]> git.uio.no Git - u/mrichter/AliRoot.git/blame - HERWIG/herwig6510.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
suppress off-line finders ( vertex etc.)
[u/mrichter/AliRoot.git] / HERWIG / herwig6510.f
CommitLineData
65767955 1C HERWIG---AliRoot/HERWIG
2C-----------------------------------------------------------------------
3C H E R W I G
4C
5C a Monte Carlo event generator for simulating
6C +---------------------------------------------------+
7C | Hadron Emission Reactions With Interfering Gluons |
8C +---------------------------------------------------+
9C I.G. Knowles(*), G. Marchesini(+), M.H.Seymour($,&) and B.R. Webber(#)
10C-----------------------------------------------------------------------
11C with Minimal Supersymmetric Standard Model Matrix Elements by
12C S. Moretti(") and K. Odagiri(^)
13C-----------------------------------------------------------------------
14C R parity violating Supersymmetric Decays and Matrix Elements by
15C P. Richardson(X)
16C-----------------------------------------------------------------------
17C matrix element corrections to top decay and Drell-Yan type processes
18C by G. Corcella(&)
19C-----------------------------------------------------------------------
20C Deep Inelastic Scattering and Heavy Flavour Electroproduction by
21C G. Abbiendi(@) and L. Stanco(%)
22C-----------------------------------------------------------------------
23C and Jet Photoproduction in Lepton-Hadron Collisions by J. Chyla(~)
24C-----------------------------------------------------------------------
25C(*) Department of Physics & Astronomy, University of Edinburgh
26C(+) Dipartimento di Fisica, Universita di Milano-Bicocca
27C($) School of Physics & Astronomy, University of Manchester
28C(&) Theory Physics Group, CERN
29C(#) Cavendish Laboratory, Cambridge
30C(") School of Physics & Astronomy, Southampton
31C(^) Academia Sinica, Taiwan
32C(X) Institute of Particle Physics Phenomenology, University of Durham
33C(@) Dipartimento di Fisica, Universita di Bologna
34C(%) Dipartimento di Fisica, Universita di Padova
35C(~) Institute of Physics, Prague
36C-----------------------------------------------------------------------
37C Version 6.510 - 31st October 2005
38C-----------------------------------------------------------------------
39C Main references:
40C
41C G.Corcella, I.G.Knowles, G.Marchesini, S.Moretti, K.Odagiri,
42C P.Richardson, M.H.Seymour and B.R.Webber, JHEP 0101 (2001) 010
43C
44C G.Marchesini, B.R.Webber, G.Abbiendi, I.G.Knowles, M.H.Seymour,
45C and L.Stanco, Computer Physics Communications 67 (1992) 465.
46C-----------------------------------------------------------------------
47C Please see the official HERWIG information page:
48C http://hepwww.rl.ac.uk/theory/seymour/herwig/
49C-----------------------------------------------------------------------
50CDECK ID>, CIRCEE.
51*CMZ :- -03/07/01 17.07.47 by Bryan Webber
52*-- Author : Bryan Webber
53C-----------------------------------------------------------------------
54 FUNCTION CIRCEE (X1, X2)
55C-----------------------------------------------------------------------
56C DUMMY FUNCTION: DELETE AND SET CIRCOP NON-ZERO
57C IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE
58C-----------------------------------------------------------------------
59 IMPLICIT NONE
60 DOUBLE PRECISION CIRCEE, X1, X2
61 WRITE (6,10)
62 10 FORMAT(/10X,'CIRCEE CALLED BUT NOT LINKED')
63 CIRCEE = 0.0D0
64 STOP
65 END
66CDECK ID>, CIRCES.
67*CMZ :- -03/07/01 17.07.47 by Bryan Webber
68*-- Author : Bryan Webber
69C-----------------------------------------------------------------------
70 SUBROUTINE CIRCES (XX1M, XX2M, XROOTS, XACC, XVER, XREV, XCHAT)
71C-----------------------------------------------------------------------
72C DUMMY SUBROUTINE: DELETE AND SET CIRCOP NON-ZERO
73C IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE
74C-----------------------------------------------------------------------
75 IMPLICIT NONE
76 DOUBLE PRECISION XX1M, XX2M, XROOTS
77 INTEGER XACC, XVER, XREV, XCHAT
78 WRITE (6,10)
79 10 FORMAT(/10X,'CIRCES CALLED BUT NOT LINKED')
80 STOP
81 END
82CDECK ID>, CIRCGG.
83*CMZ :- -03/07/01 17.07.47 by Bryan Webber
84*-- Author : Bryan Webber
85C-----------------------------------------------------------------------
86 FUNCTION CIRCGG (X1, X2)
87C-----------------------------------------------------------------------
88C DUMMY FUNCTION: DELETE AND SET CIRCOP NON-ZERO
89C IN MAIN PROGRAM IF YOU USE CIRCE BEAM SPECTRUM PACKAGE
90C-----------------------------------------------------------------------
91 IMPLICIT NONE
92 DOUBLE PRECISION CIRCGG, X1, X2
93 WRITE (6,10)
94 10 FORMAT(/10X,'CIRCGG CALLED BUT NOT LINKED')
95 CIRCGG = 0.0D0
96 STOP
97 END
98CDECK ID>, DECADD.
99*CMZ :- -28/01/92 12.34.44 by Mike Seymour
100*-- Author : Luca Stanco
101C-----------------------------------------------------------------------
102 SUBROUTINE DECADD(LOGI)
103C-----------------------------------------------------------------------
104C DUMMY SUBROUTINE: DELETE AND SET BDECAY='CLEO'
105C IN MAIN PROGRAM IF YOU USE CLEO DECAY PACKAGE
106C-----------------------------------------------------------------------
107 IMPLICIT NONE
108 LOGICAL LOGI
109 WRITE (6,10)
110 10 FORMAT(/10X,'DECADD CALLED BUT NOT LINKED')
111 STOP
112 END
113CDECK ID>, DEXAY.
114*CMZ :- -17/10/01 10.03.37 by Peter Richardson
115*-- Author : Peter Richardson
116C-----------------------------------------------------------------------
117 SUBROUTINE DEXAY(IMODE,POL)
118C-----------------------------------------------------------------------
119C DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
120C IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
121C-----------------------------------------------------------------------
122 IMPLICIT NONE
123 INTEGER IMODE
124 REAL POL(4)
125 WRITE (6,10)
126 10 FORMAT(/10X,'DEXAY CALLED BUT NOT LINKED')
127 STOP
128 END
129CDECK ID>, EUDINI.
130*CMZ :- -28/01/92 12.34.44 by Mike Seymour
131*-- Author : Luca Stanco
132C-----------------------------------------------------------------------
133 SUBROUTINE EUDINI
134C-----------------------------------------------------------------------
135C DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
136C IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
137C-----------------------------------------------------------------------
138 IMPLICIT NONE
139 WRITE (6,10)
140 10 FORMAT(/10X,'EUDINI CALLED BUT NOT LINKED')
141 STOP
142 END
143CDECK ID>, FILHEP.
144*CMZ :- -17/10/01 09:42:21 by Peter Richardson
145*-- Author : Martin W. Gruenewald
146C-----------------------------------------------------------------------
147 SUBROUTINE FILHEP(N,IST,ID,JMO1,JMO2,JDA1,JDA2,P4,PINV,PHFLAG)
148C ----------------------------------------------------------------------
149C this subroutine fills one entry into the HEPEVT common
150C and updates the information for affected mother entries
151C used by TAUOLA
152C
153C written by Martin W. Gruenewald (91/01/28)
154C ----------------------------------------------------------------------
c63d70bc 155 INCLUDE 'herwig65.inc'
65767955 156 LOGICAL QEDRAD
157 COMMON /PHORAD/ QEDRAD(NMXHEP)
158 INTEGER N,IHEP,IST,ID,JMO1,JMO2,JDA1,JDA2,I,IP
159 REAL PINV
160 LOGICAL PHFLAG
161 REAL*4 P4(4)
162C
163C check address mode
164 IF (N.EQ.0) THEN
165C append mode
166 IHEP=NHEP+1
167 ELSE IF (N.GT.0) THEN
168C absolute position
169 IHEP=N
170 ELSE
171C relative position
172 IHEP=NHEP+N
173 END IF
174C check on IHEP
175 IF ((IHEP.LE.0).OR.(IHEP.GT.NMXHEP)) RETURN
176C add entry
177 NHEP=IHEP
178 ISTHEP(IHEP)=IST
179 IDHEP(IHEP)=ID
180 JMOHEP(1,IHEP)=JMO1
181 IF(JMO1.LT.0)JMOHEP(1,IHEP)=JMOHEP(1,IHEP)+IHEP
182 JMOHEP(2,IHEP)=JMO2
183 IF(JMO2.LT.0)JMOHEP(2,IHEP)=JMOHEP(2,IHEP)+IHEP
184 JDAHEP(1,IHEP)=JDA1
185 JDAHEP(2,IHEP)=JDA2
186 DO I=1,4
187 PHEP(I,IHEP)=P4(I)
188C KORAL-B and KORAL-Z do not provide vertex and/or lifetime informations
189 VHEP(I,IHEP)=0.0
190 END DO
191 PHEP(5,IHEP)=PINV
192C FLAG FOR PHOTOS...
193 QEDRAD(IHEP)=PHFLAG
194C update process:
195 DO IP=JMOHEP(1,IHEP),JMOHEP(2,IHEP)
196 IF(IP.GT.0)THEN
197C if there is a daughter at IHEP, mother entry at IP has decayed
198 IF(ISTHEP(IP).EQ.1)ISTHEP(IP)=2
199C and daughter pointers of mother entry must be updated
200 IF(JDAHEP(1,IP).EQ.0)THEN
201 JDAHEP(1,IP)=IHEP
202 JDAHEP(2,IP)=IHEP
203 ELSE
204 JDAHEP(2,IP)=MAX(IHEP,JDAHEP(2,IP))
205 END IF
206 END IF
207 END DO
208 END
209CDECK ID>, FRAGMT.
210*CMZ :- -28/01/92 12.34.44 by Mike Seymour
211*-- Author : Luca Stanco
212C-----------------------------------------------------------------------
213 SUBROUTINE FRAGMT(I,J,K)
214C-----------------------------------------------------------------------
215C DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
216C IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
217C-----------------------------------------------------------------------
218 IMPLICIT NONE
219 INTEGER I,J,K
220 WRITE (6,10)
221 10 FORMAT(/10X,'FRAGMT CALLED BUT NOT LINKED')
222 STOP
223 END
224CDECK ID>, HVCBVI.
225*CMZ :- -28/01/92 12.34.44 by Mike Seymour
226*-- Author : Mike Seymour
227C-----------------------------------------------------------------------
228 SUBROUTINE HVCBVI
229C-----------------------------------------------------------------------
230C DUMMY ROUTINE: DELETE IF YOU LINK TO BARYON NUMBER VIOLATN PACKAGE
231C-----------------------------------------------------------------------
232 IMPLICIT NONE
233 WRITE (6,10)
234 10 FORMAT(/10X,'HVCBVI CALLED BUT NOT LINKED')
235 STOP
236 END
237CDECK ID>, HVHBVI.
238*CMZ :- -28/01/92 12.34.44 by Mike Seymour
239*-- Author : Mike Seymour
240C-----------------------------------------------------------------------
241 SUBROUTINE HVHBVI
242C-----------------------------------------------------------------------
243C DUMMY ROUTINE: DELETE IF YOU LINK TO BARYON NUMBER VIOLATN PACKAGE
244C-----------------------------------------------------------------------
245 IMPLICIT NONE
246 WRITE (6,10)
247 10 FORMAT(/10X,'HERBVI CALLED BUT NOT LINKED')
248 STOP
249 END
250CDECK ID>, HWBAZF.
251*CMZ :- -26/04/91 11.11.54 by Bryan Webber
252*-- Author : Ian Knowles
253C-----------------------------------------------------------------------
254 SUBROUTINE HWBAZF(IPAR,JPAR,VEC1,VEC2,VEC3,VEC)
255C-----------------------------------------------------------------------
256C Azimuthal correlation functions for Collins' algorithm,
257C see I.G.Knowles, Comp. Phys. Comm. 58 (90) 271 for notation.
258C-----------------------------------------------------------------------
c63d70bc 259 INCLUDE 'herwig65.inc'
65767955 260 DOUBLE PRECISION Z1,Z2,DOT12,DOT23,DOT31,TR,FN(7),VEC1(2),VEC2(2),
261 & VEC3(2),VEC(2)
262 INTEGER IPAR,JPAR
263 LOGICAL GLUI,GLUJ
264 IF (.NOT.AZSPIN) RETURN
265 Z1=PPAR(4,JPAR)/PPAR(4,IPAR)
266 Z2=1.-Z1
267 GLUI=IDPAR(IPAR).EQ.13
268 GLUJ=IDPAR(JPAR).EQ.13
269 IF (GLUI) THEN
270 IF (GLUJ) THEN
271C Branching: g--->gg
272 FN(2)=Z2/Z1
273 FN(3)=1./FN(2)
274 FN(4)=Z1*Z2
275 FN(1)=FN(2)+FN(3)+FN(4)
276 FN(5)=FN(2)+2.*Z1
277 FN(6)=FN(3)+2.*Z2
278 FN(7)=FN(4)-2.
279 ELSE
280C Branching: g--->qqbar
281 FN(1)=(Z1*Z1+Z2*Z2)/2.
282 FN(2)=0.
283 FN(3)=0.
284 FN(4)=-Z1*Z2
285 FN(5)=-(2.*Z1-1.)/2.
286 FN(6)=-FN(5)
287 FN(7)=FN(1)
288 ENDIF
289 ELSE
290 IF (GLUJ) THEN
291C Branching: q--->gq
292 FN(1)=(1.+Z2*Z2)/(2.*Z1)
293 FN(2)=Z2/Z1
294 FN(3)=0.
295 FN(4)=0.
296 FN(5)=FN(1)
297 FN(6)=(1.+Z2)/2.
298 FN(7)=-FN(6)
299 ELSE
300C Branching: q--->qg
301 FN(1)=(1.+Z1*Z1)/(2.*Z2)
302 FN(2)=0.
303 FN(3)=Z1/Z2
304 FN(4)=0.
305 FN(5)=(1.+Z1)/2.
306 FN(6)=FN(1)
307 FN(7)=-FN(5)
308 ENDIF
309 ENDIF
310 DOT12=VEC1(1)*VEC2(1)+VEC1(2)*VEC2(2)
311 DOT23=VEC2(1)*VEC3(1)+VEC2(2)*VEC3(2)
312 DOT31=VEC3(1)*VEC1(1)+VEC3(2)*VEC1(2)
313 TR=1./(FN(1)+FN(2)*DOT23+FN(3)*DOT31+FN(4)*DOT12)
314 VEC(1)=((FN(2)+FN(5)*DOT23)*VEC1(1)
315 & +(FN(3)+FN(6)*DOT31)*VEC2(1)
316 & +(FN(4)+FN(7)*DOT12)*VEC3(1))*TR
317 VEC(2)=((FN(2)+FN(5)*DOT23)*VEC1(2)
318 & +(FN(3)+FN(6)*DOT31)*VEC2(2)
319 & +(FN(4)+FN(7)*DOT12)*VEC3(2))*TR
320 END
321CDECK ID>, HWBCON.
322*CMZ :- -11/10/01 12.01.52 by Peter Richardson
323*-- Author : Bryan Webber
324C-----------------------------------------------------------------------
325 SUBROUTINE HWBCON
326C-----------------------------------------------------------------------
327C MAKES COLOUR CONNECTIONS BETWEEN JETS
328C MODIFIED 12/10/97 BY BRW FOR SUSY PROCESSES
329C MODIFIED 11/01/01 BY PR FOR SPIN CORRELATIONS(PROBLEM WITH ORDER
330C OF DECAYS)
331C NEW VARAIBLE BACK TO ALLOW CODE TO SEARCH DOWN CHAIN
332C-----------------------------------------------------------------------
c63d70bc 333 INCLUDE 'herwig65.inc'
65767955 334 INTEGER IHEP,IST,ID,JC,KC,JD,JHEP,LHEP,ID2,NTRY,KHEP
335 LOGICAL BACK
336 IF (IERROR.NE.0) RETURN
337 IF(.NOT.RPARTY) THEN
338 CALL HWBRCN
339 RETURN
340 ENDIF
341 DO 20 IHEP=1,NHEP
342 BACK = .FALSE.
343 IST=ISTHEP(IHEP)
344C---LOOK FOR PARTONS WITHOUT COLOUR MOTHERS
345 IF (IST.LT.145.OR.IST.GT.152) GOTO 20
346 51 IF (JMOHEP(2,IHEP).EQ.0.OR.BACK.OR.
347 & ISTHEP(JMOHEP(2,IHEP)).EQ.155) THEN
348C---FIND COLOUR-CONNECTED PARTON
349 IF(BACK) GOTO 52
350 IF(JMOHEP(2,IHEP).EQ.0) THEN
351 JC=JMOHEP(1,IHEP)
352 IF (IST.NE.152) JC=JMOHEP(1,JC)
353 JC =JMOHEP(2,JC)
354 ELSE
355 JC = JMOHEP(2,IHEP)
356 JHEP = JC
357 ENDIF
358 IF (JC.EQ.0) THEN
359 CALL HWWARN('HWBCON',51)
360 GOTO 20
361 ENDIF
362C---FIND SPECTATOR WHEN JC IS DECAYED HEAVY QUARK OR SUSY PARTICLE
363 52 IF (ISTHEP(JC).EQ.155.OR.BACK) THEN
364 IF (IDHEP(JMOHEP(1,JC)).EQ.94.OR.BACK) THEN
365C---DECAYED BEFORE HADRONIZING
366 IF(BACK.OR.(JMOHEP(2,IHEP).NE.0.AND.
367 & ISTHEP(JMOHEP(2,IHEP)).EQ.155)) GOTO 53
368 JHEP=JMOHEP(2,JC)
369C--new bit to try and fix the problems for spin correlations
370C--move one step further up the tree and hope this helps
371 IF (JHEP.EQ.0) THEN
372 NTRY = 0
373 1 NTRY = NTRY+1
374 JC = JMOHEP(1,JC)
375 JHEP = JMOHEP(2,JC)
376 IF(JHEP.NE.0.AND.ISTHEP(JHEP).EQ.155)
377 & JHEP = JMOHEP(2,JHEP)
378 IF(JHEP.EQ.0.AND.NTRY.LT.NHEP) GOTO 1
379 IF(NHEP.EQ.NTRY) GOTO 20
380 ENDIF
381 53 ID=IDHW(JHEP)
382 IF (ISTHEP(JHEP).EQ.155) THEN
383C---SPECIAL FOR GLUINO DECAYS
384 IF (ID.EQ.449) THEN
385 ID=IDHW(JC)
386C---N.B. WILL NEED MODS WHEN SUSY PARTICLES CAN SHOWER
387 IF (ID.EQ.449.OR.ID.EQ.13.OR.
388 & (ID.GE.401.AND.ID.LE.406).OR.
389 & (ID.GE.413.AND.ID.LE.418).OR.
390 & ID.LE.6.OR.(ID.GE.115.AND.ID.LE.120)) THEN
391C---LOOK FOR ANTI(S)QUARK OR GLUON
392 DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
393 ID=IDHW(KC)
394 IF ((ID.GE. 7.AND.ID.LE. 13).OR.
395 & (ID.GE.407.AND.ID.LE.412).OR.
396 & (ID.GE.419.AND.ID.LE.424)) GOTO 5
397 ENDDO
398 ELSE
399C---LOOK FOR (S)QUARK OR GLUON
400 DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
401 ID=IDHW(KC)
402 IF (ID.LE. 6.OR. ID.EQ. 13.OR.
403 & (ID.GE.401.AND.ID.LE.406).OR.
404 & (ID.GE.413.AND.ID.LE.418)) GOTO 5
405 ENDDO
406 ENDIF
407C---COULDNT FIND ONE
408 CALL HWWARN('HWBCON',101)
409 GOTO 999
410 5 JC=KC
411 ELSE
412C--PR MOD 30/6/99 should fix HWCFOR 104 errors
413 ID2 = IDHW(IHEP)
414 IF(IDHW(JDAHEP(1,JHEP)).EQ.449.AND.
415 & (ID2.LE.6.OR.(ID2.GE.115.AND.ID2.LE.120).OR.
416 & (ID2.GE.401.AND.ID2.LE.406).OR.ID2.EQ.13.OR.
417 & (ID2.GE.413.AND.ID2.LE.418).OR.ID2.EQ.449)) THEN
418 JC = JDAHEP(1,JHEP)
419 ELSE
420C--modifcation for top ME correction (modified for additional photon radiation)
421 IF(IDHW(JHEP).EQ.6) THEN
422 JC = JDAHEP(1,JHEP)+1
423 ELSE
424 JC = JDAHEP(1,JHEP)+1
425 IF(IDHW(JDAHEP(1,JHEP)+2).EQ.13) JC=JC+1
426 ENDIF
427 ENDIF
428 ENDIF
429 ELSEIF (ID.EQ.6.OR.ID.EQ.12.OR.
430 & (ID.GE.209.AND.ID.LE.218).OR.
431 & (ID.GE.401.AND.ID.LE.424).OR.ID.EQ.449) THEN
432C Wait for partner heavy quark to decay
433C RETURN
434C---N.B. MAY BE A PROBLEM HERE
435 GOTO 20
436 ELSE
437 JMOHEP(2,IHEP)=JHEP
438 JDAHEP(2,JHEP)=IHEP
439 GOTO 20
440 ENDIF
441 ELSE
442 JC=JMOHEP(2,JC)
443 ENDIF
444 ENDIF
445 JC=JDAHEP(1,JC)
446 JD=JDAHEP(2,JC)
447C---SEARCH IN CORRESPONDING JET
448 IF (JD.LT.JC) JD=JC
449 LHEP=0
450 DO 10 JHEP=JC,JD
451 IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 10
452 IF (JDAHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
453 IF (JDAHEP(2,JHEP).NE.0) GOTO 10
454C---JOIN IHEP AND JHEP
455 ID=IDHW(JHEP)
456 JMOHEP(2,IHEP)=JHEP
457 JDAHEP(2,JHEP)=IHEP
458 GOTO 20
459 10 CONTINUE
460 IF (LHEP.NE.0) THEN
461 JMOHEP(2,IHEP)=LHEP
462 ELSE
463C--search down the tree
464 DO 50 KHEP=JC,JD
465 IF(ISTHEP(KHEP).EQ.3.AND.ISTHEP(JDAHEP(1,KHEP)).EQ.155) THEN
466 JHEP = JDAHEP(1,KHEP)
467 BACK = .TRUE.
468 GOTO 51
469 ENDIF
470 50 CONTINUE
471C---DIDN'T FIND PARTNER OF IHEP YET
472C CALL HWWARN('HWBCON',52)
473C GOTO 20
474 ENDIF
475 ENDIF
476 20 CONTINUE
477C---BREAK COLOUR CONNECTIONS WITH PHOTONS
478 IHEP=1
479 30 IF (IHEP.LE.NHEP) THEN
480 IF (IDHW(IHEP).EQ.59 .AND. ISTHEP(IHEP).EQ.149) THEN
481C BRW FIX 13/03/99
482 IF (JMOHEP(2,IHEP).NE.0) THEN
483 IF (JDAHEP(2,JMOHEP(2,IHEP)).EQ.IHEP)
484 & JDAHEP(2,JMOHEP(2,IHEP))=JDAHEP(2,IHEP)
485 ENDIF
486C END FIX
487 IF (JDAHEP(2,IHEP).NE.0) THEN
488 IF (JMOHEP(2,JDAHEP(2,IHEP)).EQ.IHEP)
489 & JMOHEP(2,JDAHEP(2,IHEP))=JMOHEP(2,IHEP)
490 ENDIF
491 JMOHEP(2,IHEP)=IHEP
492 JDAHEP(2,IHEP)=IHEP
493 ENDIF
494 IHEP=IHEP+1
495 GOTO 30
496 ENDIF
497 999 RETURN
498 END
499CDECK ID>, HWBDED.
500*CMZ :- -22/04/96 13.54.08 by Mike Seymour
501*-- Author : Mike Seymour
502C-----------------------------------------------------------------------
503 SUBROUTINE HWBDED(IOPT)
504C FILL MISSING AREA OF DALITZ PLOT WITH 3-JET AND 2-JET+GAMMA EVENTS
505C IF (IOPT.EQ.1) SET UP EVENT RECORD
506C IF (IOPT.EQ.2) CLEAN UP EVENT RECORD AFTER SHOWERING
507C
508C********MODIFIED 13/11/00 BY BRW TO ALLOW MULTIPLE APPLICATION IN
509C*******SAME EVENT (FOR WW AND ZZ) N.B. NO CLEANUP CALLS FOR THESE!
510C-----------------------------------------------------------------------
c63d70bc 511 INCLUDE 'herwig65.inc'
65767955 512 DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,X(3),W,WMAX,WSUM,
513 & X1MIN,X1MAX,X2MIN,X2MAX,QSCALE,GAMFAC,GLUFAC,R(3,3),CS,SN,M(3),
514 & E(3),LAMBDA,A,B,C,PTSQ,EM,P1(5),P2(5),PVRT(4),EPS,MASDEP
515 INTEGER ID,ID3,EMIT,NOEMIT,IEVT,IHEP,JHEP,KHEP,ICMF,IOPT,IEDT(3),
516 & I,NDEL,LHEP,IP,JP,KP,IDUN
517 EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUSQR
518 SAVE X,WMAX,P1,P2
519 SAVE WSUM, X1MIN,X1MAX,EMIT,ICMF,IEVT
520 DATA WSUM,WMAX,X1MIN,X1MAX,EMIT,ICMF,IEVT
521 & /0.994651D0,1.84096D0,0.0D0,0.773459D0,3*0.0D0/
522 LAMBDA(A,B,C)=(A**2+B**2+C**2-2*A*B-2*B*C-2*C*A)/(4*A)
523 IF (IOPT.EQ.1) THEN
524C---FIND AN UNTREATED CMF
525 IF (IEVT.EQ.NEVHEP+NWGTS) RETURN
526 IEVT=0
527 ICMF=0
528 5 IDUN=ICMF
529 DO 10 IHEP=IDUN+1,NHEP
530 10 IF (ICMF.EQ.IDUN .AND. ISTHEP(IHEP).EQ.110 .AND.
531 & JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
532 IF (ICMF.EQ.IDUN) RETURN
533 EM=PHEP(5,ICMF)
534 IF (EM.LT.2*HWBVMC(1)) GOTO 5
535C---ONLY APPLY THE CORRECTION TO HADRONIC DECAYS
536 IF (IDHW(JDAHEP(1,ICMF)).GT.12) GOTO 5
537C---GENERATE X1,X2 ACCORDING TO 1/((1-X1)*(1-X2))
538 100 CONTINUE
539C---CHOOSE X1
540 X(1)=1-(1-X1MAX)*((1-X1MIN)/(1-X1MAX))**HWRGEN(0)
541C---CHOOSE X2
542 X2MIN=MAX(X(1),1-X(1))
543 X2MAX=(4*X(1)-3+2*DREAL( DCMPLX( X(1)**3+135*(X(1)-1)**3,
544 & 3*HWUSQR(3*(128*X(1)**4-368*X(1)**3+405*X(1)**2-216*X(1)+54))*
545 & (X(1)-1) )**(1./3) ))/3
546 IF (X2MAX.GE.ONE.OR.X2MIN.GE.ONE.OR.X2MAX.LE.X2MIN) GOTO 100
547 X(2)=1-(1-X2MAX)*((1-X2MIN)/(1-X2MAX))**HWRGEN(1)
548C---CALCULATE WEIGHT
549 W=2 * LOG((1-X1MIN)/(1-X1MAX))*LOG((1-X2MIN)/(1-X2MAX)) *
550 & (X(1)**2+X(2)**2)
551C---GENERATE UNWEIGHTED (X1,X2) PAIRS (EFFICIENCY IS ~50%)
552 IF (WMAX*HWRGEN(2).GT.W) GOTO 100
553C---SYMMETRIZE X1,X2
554 X(3)=2-X(1)-X(2)
555 IF (HWRGEN(5).GT.HALF) THEN
556 X(1)=X(2)
557 X(2)=2-X(3)-X(1)
558 ENDIF
559C---CHOOSE WHICH PARTON WILL EMIT
560 EMIT=1
561 IF (HWRGEN(6).LT.X(1)**2/(X(1)**2+X(2)**2)) EMIT=2
562 NOEMIT=3-EMIT
563 IHEP=JDAHEP( EMIT,ICMF)
564 JHEP=JDAHEP(NOEMIT,ICMF)
565C---PREFACTORS FOR GAMMA AND GLUON CASES
566 QSCALE=HWUSQR((1-X(1))*(1-X(2))*(1-X(3)))*EM/X(NOEMIT)
567 ID=IDHW(JDAHEP(1,ICMF))
568 GAMFAC=ALPFAC*ALPHEM*ICHRG(ID)**2/(18*PIFAC)
569 GLUFAC=0
570 IF (QSCALE.GT.HWBVMC(13))
571 & GLUFAC=CFFAC/(2*PIFAC)*HWUALF(1,QSCALE)
572C---SWITCH OFF PHOTON EMISSION IN W DECAYS (THE M-E DOES NOT FACTORIZE)
573 IF (ICHRG(IDHW(ICMF)).NE.0) GAMFAC=0
574C---IN FRACTION FAC*WSUM OF EVENTS ADD A GAMMA/GLUON
575 IF (GAMFAC*WSUM .GT. HWRGEN(3)) THEN
576 ID3=59
577 ELSEIF (GLUFAC*WSUM .GT. HWRGEN(4)) THEN
578 ID3=13
579 ELSE
580 EMIT=0
581 GOTO 5
582 ENDIF
583C---CHECK INFRA-RED CUT-OFF FOR GAMMA/GLUON
584 M(EMIT)=PHEP(5,IHEP)+VQCUT
585 M(NOEMIT)=PHEP(5,JHEP)+VQCUT
586 M(3)=HWBVMC(ID3)
587 E(1)=HALF*EM*(X(1)+(M(1)**2-M(2)**2-M(3)**2)/EM**2)
588 E(2)=HALF*EM*(X(2)+(M(2)**2-M(3)**2-M(1)**2)/EM**2)
589 E(3)=EM-E(1)-E(2)
590 PTSQ=-LAMBDA(E(NOEMIT)**2-M(NOEMIT)**2,E(3)**2-M(3)**2,
591 & E(EMIT)**2-M(EMIT)**2)
592 IF (PTSQ.LE.ZERO .OR.
593 $ E(1).LE.M(1).OR.E(2).LE.M(2).OR.E(3).LE.M(3)) THEN
594 EMIT=0
595 GOTO 5
596 ENDIF
597C---CALCULATE MASS-DEPENDENT SUPRESSION
598 IF (MOD(IPROC,10).GT.0) THEN
599 EPS=(RMASS(ID)/EM)**2
600 MASDEP=X(1)**2+X(2)**2
601 $ -4*EPS*X(3)-2*EPS*((1-X(2))/(1-X(1))+(1-X(1))/(1-X(2)))
602 $ -4*EPS**2*X(3)**2/((1-X(1))*(1-X(2)))
603 IF (MASDEP.LT.HWRGEN(7)*(X(1)**2+X(2)**2)) THEN
604 EMIT=0
605 GOTO 5
606 ENDIF
607 ENDIF
608C---STORE OLD MOMENTA
609 CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),P1)
610 CALL HWVEQU(5,PHEP(1,JDAHEP(2,ICMF)),P2)
611C---GET THE NON-EMITTING PARTON'S CMF DIRECTION
612 CALL HWULOF(PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,JHEP))
613 CALL HWRAZM(ONE,CS,SN)
614 CALL HWUROT(PHEP(1,JHEP),CS,SN,R)
615 M(EMIT)=PHEP(5,IHEP)
616 M(NOEMIT)=PHEP(5,JHEP)
617 M(3)=RMASS(ID3)
618 KHEP=JDAHEP(2,ICMF)
619 LHEP=KHEP+1
620 IF (NHEP.GT.KHEP) THEN
621C---MOVE UP REST OF EVENT
622 DO IP=NHEP,LHEP,-1
623 JP=IP+1
624 ISTHEP(JP)= ISTHEP(IP)
625 IDHW(JP)=IDHW(IP)
626 IDHEP(JP)=IDHEP(IP)
627 KP=JMOHEP(1,IP)
628 IF (KP.GT.KHEP) THEN
629 KP=KP+1
630 ELSE
631 IF (JDAHEP(1,KP).EQ.IP) JDAHEP(1,KP)=JP
632 IF (JDAHEP(2,KP).EQ.IP) JDAHEP(2,KP)=JP
633 ENDIF
634 JMOHEP(1,JP)=KP
635 KP=JMOHEP(2,IP)
636 IF (KP.GT.KHEP) KP=KP+1
637 JMOHEP(2,JP)=KP
638 KP=JDAHEP(1,IP)
639 IF (KP.GT.KHEP) KP=KP+1
640 JDAHEP(1,JP)=KP
641 KP=JDAHEP(2,IP)
642 IF (KP.GT.KHEP) KP=KP+1
643 JDAHEP(2,JP)=KP
644 CALL HWVEQU(5,PHEP(1,IP),PHEP(1,JP))
645 CALL HWVEQU(4,VHEP(1,IP),VHEP(1,JP))
646 ENDDO
647 ENDIF
648C---REORDER ENTRIES: IHEP=EMITTER, JHEP=NON-EMITTER, KHEP=EMITTED
649 NHEP=NHEP+1
650 IF (IDHW(IHEP).LT.IDHW(JHEP)) THEN
651 IHEP=JDAHEP(1,ICMF)
652 JHEP=LHEP
653 ELSE
654 IHEP=LHEP
655 JHEP=JDAHEP(1,ICMF)
656 ENDIF
657C---SET UP MOMENTA
658 PHEP(5,JHEP)=M(NOEMIT)
659 PHEP(5,IHEP)=M(EMIT)
660 PHEP(5,KHEP)=M(3)
661 PHEP(4,JHEP)=HALF*EM*(X(NOEMIT)+
662 & (M(NOEMIT)**2-M(EMIT)**2-M(3)**2)/EM**2)
663 PHEP(4,IHEP)=HALF*EM*(X(EMIT)+
664 & (M(EMIT)**2-M(NOEMIT)**2-M(3)**2)/EM**2)
665 PHEP(4,KHEP)=EM-PHEP(4,IHEP)-PHEP(4,JHEP)
666 PHEP(3,JHEP)=HWUSQR(PHEP(4,JHEP)**2-PHEP(5,JHEP)**2)
667 PHEP(3,IHEP)=( (PHEP(4,KHEP)**2-PHEP(5,KHEP)**2) -
668 & (PHEP(4,IHEP)**2-PHEP(5,IHEP)**2) -
669 & (PHEP(3,JHEP)**2) )*HALF/PHEP(3,JHEP)
670 PHEP(3,KHEP)=-PHEP(3,IHEP)-PHEP(3,JHEP)
671 PHEP(2,JHEP)=0
672 PHEP(2,IHEP)=0
673 PHEP(2,KHEP)=0
674 PHEP(1,JHEP)=0
675 PHEP(1,IHEP)=HWUSQR(PHEP(4,IHEP)**2-
676 & PHEP(3,IHEP)**2-PHEP(5,IHEP)**2)
677 PHEP(1,KHEP)=-PHEP(1,IHEP)
678C---ORIENT IN CMF, THEN BOOST TO LAB
679 CALL HWUROB(R,PHEP(1,IHEP),PHEP(1,IHEP))
680 CALL HWUROB(R,PHEP(1,JHEP),PHEP(1,JHEP))
681 CALL HWUROB(R,PHEP(1,KHEP),PHEP(1,KHEP))
682 CALL HWULOB(PHEP(1,ICMF),PHEP(1,IHEP),PHEP(1,IHEP))
683 CALL HWULOB(PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,JHEP))
684 CALL HWULOB(PHEP(1,ICMF),PHEP(1,KHEP),PHEP(1,KHEP))
685C---CALCULATE PRODUCTION VERTICES
686 CALL HWVZRO(4,VHEP(1,JHEP))
687 CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PVRT)
688 CALL HWUDKL(ID,PVRT,VHEP(1,KHEP))
689 CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,IHEP))
690C---REORDER ENTRIES: IHEP=QUARK, JHEP=ANTI-QUARK, KHEP=EMITTED
691 IF (IHEP.EQ.LHEP) THEN
692 IHEP=JHEP
693 JHEP=LHEP
694 ENDIF
695C---STATUS, ID AND POINTERS
696 ISTHEP(JHEP)=114
697 IDHW(JHEP)=IDHW(KHEP)
698 IDHEP(JHEP)=IDHEP(KHEP)
699 IDHW(KHEP)=ID3
700 IDHEP(KHEP)=IDPDG(ID3)
701 JDAHEP(2,ICMF)=JHEP
702 JMOHEP(1,JHEP)=ICMF
703 JDAHEP(1,JHEP)=0
704C---COLOUR CONNECTIONS AND GLUON POLARIZATION
705 JMOHEP(2,JHEP)=IHEP
706 JDAHEP(2,IHEP)=JHEP
707 IF (ID3.EQ.13) THEN
708 JMOHEP(2,IHEP)=KHEP
709 JMOHEP(2,KHEP)=JHEP
710 JDAHEP(2,JHEP)=KHEP
711 JDAHEP(2,KHEP)=IHEP
712 GPOLN=((1-X(1))**2+(1-X(2))**2)/(4*(1-X(3)))
713 GPOLN=1/(1+GPOLN)
714 ELSE
715 JMOHEP(2,IHEP)=JHEP
716 JMOHEP(2,KHEP)=KHEP
717 JDAHEP(2,JHEP)=IHEP
718 JDAHEP(2,KHEP)=KHEP
719 ENDIF
720 IEVT=NEVHEP+NWGTS
721 GOTO 5
722 ELSEIF (IOPT.EQ.2) THEN
723C---MAKE THREE-JET EVENTS FROM THE `DEAD-ZONE' LOOK LIKE TWO-JET EVENTS
724 IF (EMIT.EQ.0.OR.IEVT.NE.NEVHEP+NWGTS) THEN
725 RETURN
726 ELSEIF (EMIT.EQ.1) THEN
727 IHEP=JDAHEP(1,JDAHEP(1,ICMF)+1)
728 JHEP=JDAHEP(1,JDAHEP(1,ICMF))
729 ELSE
730 IHEP=JDAHEP(1,JDAHEP(2,ICMF))
731 JHEP=JDAHEP(1,JDAHEP(1,ICMF)+1)
732 JDAHEP(1,JDAHEP(2,ICMF))=JHEP
733 IDHW(JHEP)=IDHW(IHEP)
734 IF (ISTHEP(IHEP+1).EQ.100 .AND. ISTHEP(JHEP+1).EQ.100)
735 & CALL HWVEQU(5,PHEP(1,IHEP+1),PHEP(1,JHEP+1))
736 ENDIF
737 JMOHEP(2,JDAHEP(1,ICMF))=JDAHEP(2,ICMF)
738 JDAHEP(2,JDAHEP(1,ICMF))=JDAHEP(2,ICMF)
739 JMOHEP(2,JDAHEP(2,ICMF))=JDAHEP(1,ICMF)
740 JDAHEP(2,JDAHEP(2,ICMF))=JDAHEP(1,ICMF)
741 CALL HWVEQU(5,P1,PHEP(1,JDAHEP(1,ICMF)))
742 CALL HWVEQU(5,P2,PHEP(1,JDAHEP(2,ICMF)))
743 CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,JHEP))
744 CALL HWUMAS(PHEP(1,JHEP))
745 JDAHEP(2,JHEP)=JDAHEP(2,IHEP)
746 IEDT(1)=JDAHEP(1,ICMF)+1
747 IEDT(2)=IHEP
748 IEDT(3)=IHEP+1
749 NDEL=3
750 IF (ISTHEP(IHEP+1).NE.100) NDEL=2
751 CALL HWUEDT(NDEL,IEDT)
752 DO 410 I=1,2
753 IHEP=JDAHEP(1,JDAHEP(I,ICMF))
754 JMOHEP(1,IHEP)=JDAHEP(I,ICMF)
755 IF (ISTHEP(IHEP+1).EQ.100) THEN
756 JMOHEP(1,IHEP+1)=JMOHEP(1,IHEP)
757 JMOHEP(2,IHEP+1)=JMOHEP(2,JMOHEP(1,IHEP))
758 ENDIF
759 DO 400 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
760 JMOHEP(1,JHEP)=IHEP
761 400 CONTINUE
762 CALL HWVZRO(4,VHEP(1,JDAHEP(I,ICMF)))
763 CALL HWVZRO(4,VHEP(1,IHEP))
764 IF (ISTHEP(IHEP+1).EQ.100) CALL HWVZRO(4,VHEP(1,IHEP+1))
765 410 CONTINUE
766 EMIT=0
767 IEVT=0
768 ELSE
769 CALL HWWARN('HWBDED',500)
770 ENDIF
771 END
772CDECK ID>, HWBDIS.
773*CMZ :- -17/05/94 09.33.08 by Mike Seymour
774*-- Author : Mike Seymour
775C-----------------------------------------------------------------------
776 SUBROUTINE HWBDIS(IOPT)
777C-----------------------------------------------------------------------
778C FILL MISSING AREA OF DIS PHASE-SPACE WITH 2+1-JET EVENTS
779C IF (IOPT.EQ.1) SET UP EVENT RECORD
780C IF (IOPT.EQ.2) CLEAN UP EVENT RECORD AFTER SHOWERING
781C-----------------------------------------------------------------------
c63d70bc 782 INCLUDE 'herwig65.inc'
65767955 783 DOUBLE PRECISION HWRGEN,HWBVMC,HWUALF,HWULDO,P1(5),P2(5),P3(5),
784 & PCMF(5),L(5),R(3,3),Q,XBJ,RN,XPMIN,XPMAX,XP,ZPMIN,ZPMAX,ZP,FAC,
785 & X1,X2,XTSQ,XT,PTSQ,SIN1,SIN2,W1,W2,CFAC,PDFOLD(13),PDFNEW(13),
786 & PHI,SCALE,Q1(5),Q2(5),DIR1,DIR2,DIR,PM(5),POLD,PNEW,COMINT,
787 & BGFINT,COMWGT,C1,C2,CM,B1,B2,BM,PVRT(4)
788 INTEGER IOPT,EMIT,ICMF,IHEP,JHEP,IIN,IOUT,ILEP,IHAD,ID,IDNEW,
789 & IEDT(3),NDEL,NTRY,ITEMP
790 LOGICAL BGF
791 EXTERNAL HWRGEN,HWBVMC,HWUALF,HWULDO
792 SAVE BGF,IIN,IOUT,ICMF,ID,Q1,Q2,XP,XBJ
793 SAVE EMIT,COMINT,BGFINT,COMWGT,C1,C2,CM,B1,B2,BM
794 DATA EMIT,COMINT,BGFINT,COMWGT/0D0,3.9827D0,1.2462D0,0.3D0/
795 DATA C1,C2,CM,B1,B2,BM/0.56D0,0.20D0,10D0,0.667D0,0.167D0,3D0/
796 IF (IERROR.NE.0) RETURN
797 IF (IOPT.EQ.1) THEN
798C---FIND AN UNTREATED CMF
799 IF (EMIT.EQ.NEVHEP+NWGTS) RETURN
800 ICMF=0
801 DO 10 IHEP=1,NHEP
802 10 IF (ICMF.EQ.0 .AND. ISTHEP(IHEP).EQ.110 .AND.
803 & JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
804 IF (ICMF.EQ.0) RETURN
805 IIN=JMOHEP(2,ICMF)
806 IOUT=JDAHEP(2,ICMF)
807 ILEP=JMOHEP(1,ICMF)
808 CALL HWVEQU(5,PHEP(1,IIN),P1)
809 CALL HWVEQU(5,PHEP(1,IOUT),P2)
810 CALL HWVEQU(5,PHEP(1,ILEP),L)
811 IHAD=2
812 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
813 ID=IDHW(IIN)
814C---STORE OLD MOMENTA
815 CALL HWVEQU(5,P1,Q1)
816 CALL HWVEQU(5,P2,Q2)
817C---BOOST AND ROTATE THE MOMENTA TO THE BREIT FRAME
818 CALL HWVDIF(4,P2,P1,PCMF)
819 CALL HWUMAS(PCMF)
820 CALL HWVEQU(5,PHEP(1,IHAD),PM)
821 Q=-PCMF(5)
822 XBJ=HALF*Q**2/HWULDO(PM,PCMF)
823 CALL HWVSCA(4,HALF/XBJ,PCMF,PCMF)
824 CALL HWVSUM(4,PM,PCMF,PCMF)
825 CALL HWUMAS(PCMF)
826 CALL HWULOF(PCMF,L,L)
827 CALL HWULOF(PCMF,PM,PM)
828 CALL HWUROT(PM,ONE,ZERO,R)
829 CALL HWUROF(R,L,L)
830 PHI=ATAN2(L(2),L(1))
831 CALL HWUROT(PM,COS(PHI),SIN(PHI),R)
832C---CHOOSE THE HADRONIC-PLANE CONFIGURATION, XP,ZP
833 IF (HWRGEN(0).LT.COMWGT) THEN
834C-----CONSIDER GENERATING A QCD COMPTON EVENT
835 BGF=.FALSE.
836 P3(5)=RMASS(13)
837 100 RN=HWRGEN(1)
838 IF (RN.LT.C1) THEN
839 ZP=HWRGEN(2)
840 XPMAX=MIN(ZP,1-ZP)
841 XP=HWRGEN(3)*XPMAX
842 FAC=1/C1*2*XPMAX/((1-XP)*(1-ZP))*
843 $ (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
844 IF (HWRGEN(4).LT.HALF) THEN
845 ZPMAX=ZP
846 ZP=XP
847 XP=ZPMAX
848 ENDIF
849 ELSEIF (RN.LT.C1+C2) THEN
850 XPMAX=0.83
851 XP=XPMAX*HWRGEN(2)
852 ZPMIN=MAX(XP,1-XP)
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 ZP=1-((1-ZPMIN)/(1-ZPMAX))**HWRGEN(4)*(1-ZPMAX)
857 FAC=1/C2*XPMAX*LOG((1-ZPMIN)/(1-ZPMAX))/(1-XP)*
858 $ (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
859 ELSE
860 ZPMAX=0.85
861 ZP=ZPMAX*HWRGEN(2)
862 XPMIN=MAX(ZP,1-ZP)
863 XPMAX=(1+4*ZP*(1-ZP))/(1+6*ZP*(1-ZP))
864 XP=1-((1-XPMIN)/(1-XPMAX))**HWRGEN(4)*(1-XPMAX)
865 FAC=1/(1-C1-C2)*ZPMAX*LOG((1-XPMIN)/(1-XPMAX))/(1-ZP)*
866 $ (1+(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
867 ENDIF
868 XPMAX=(1+4*ZP*(1-ZP))/(1+6*ZP*(1-ZP))
869 ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
870 $ 3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
871 $ **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
872 IF (XP.GT.XPMAX.OR.ZP.GT.ZPMAX.OR.CM*HWRGEN(4).GT.FAC)
873 $ GOTO 100
874 ELSE
875C-----CONSIDER GENERATING A BGF EVENT
876 BGF=.TRUE.
877 P3(5)=P1(5)
878 P1(5)=RMASS(13)
879 110 RN=HWRGEN(1)
880 IF (RN.LT.B1) THEN
881 ZP=HWRGEN(2)
882 XPMAX=MIN(ZP,1-ZP)
883 XP=HWRGEN(3)*XPMAX
884 FAC=1/B1*2*XPMAX/(1-ZP)*
885 $ (( XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP
886 $ +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
887 IF (HWRGEN(4).LT.HALF) XP=1-XP
888 ELSEIF (RN.LT.B1+B2) THEN
889 XPMAX=0.83
890 XP=XPMAX*HWRGEN(2)
891 ZPMIN=MAX(XP,1-XP)
892 ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
893 $ 3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
894 $ **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
895 ZP=1-((1-ZPMIN)/(1-ZPMAX))**HWRGEN(4)*(1-ZPMAX)
896 FAC=1/B2*XPMAX*LOG((1-ZPMIN)/(1-ZPMAX))*
897 $ (( XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP
898 $ +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
899 ELSE
900 XPMAX=0.83
901 XP=XPMAX*HWRGEN(2)
902 ZPMAX=MIN(XP,1-XP)
903 ZPMIN=2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
904 $ 3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
905 $ **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
906 ZP=(ZPMAX-ZPMIN)*HWRGEN(4)+ZPMIN
907 FAC=1/(1-B1-B2)*XPMAX*(ZPMAX-ZPMIN)/(1-ZP)*
908 $ (( XP+ZP-2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP
909 $ +(1-XP-ZP+2*XP*ZP)**2+2*(1-XP)*(1-ZP)*XP*ZP)
910 ENDIF
911 ZPMAX=1-2./3.*XP*(1+DREAL( DCMPLX(10-45*XP+18*XP**2,3*SQRT(
912 $ 3*(9+66*XP-93*XP**2+12*XP**3-8*XP**4+24*XP**5-8*XP**6)))
913 $ **(1./3.) * DCMPLX(0.5D0,0.86602540378444D0) ))
914 IF (ZP.GT.ZPMAX.OR.ZP.LT.ONE-ZPMAX.OR.BM*HWRGEN(4).GT.FAC)
915 $ GOTO 110
916 ENDIF
917C---CALCULATE THE ADDITIONAL FACTORS IN THE WEIGHT
918 IF (BGF) THEN
919 IDNEW=13
920 CFAC=1./2
921 FAC=BGFINT/(1-COMWGT)
922 ELSE
923 IDNEW=ID
924 CFAC=4./3
925 FAC=COMINT/COMWGT
926 ENDIF
927 SCALE=Q*SQRT((1-XP)*(1-ZP)*ZP/XP+1)
928 ITEMP=ISTAT
929 ISTAT=7
930 CALL HWSFUN(XBJ,Q,IDHW(IHAD),NSTRU,PDFOLD,2)
931 ISTAT=ITEMP
932 IF (PDFOLD(ID).LE.ZERO) THEN
933 CALL HWWARN('HWBDIS',100)
934 GOTO 999
935 ENDIF
936 IF (XP.GT.XBJ) THEN
937 CALL HWSFUN(XBJ/XP,SCALE,IDHW(IHAD),NSTRU,PDFNEW,2)
938 FAC=CFAC/(2*PIFAC) * HWUALF(1,SCALE) * FAC *
939 $ PDFNEW(IDNEW)/PDFOLD(ID)
940 ELSE
941 FAC=0
942 ENDIF
943C---FOR PHOTON BEAMS, INCLUDE DIRECT PHOTON COUPLING
944 IF (IDHW(IHAD).EQ.59) THEN
945 ZPMIN=2./3.*XBJ*(1+DREAL( DCMPLX(10-45*XBJ+18*XBJ**2,3*SQRT(
946 $ 3*(9+66*XBJ-93*XBJ**2+12*XBJ**3-8*XBJ**4+24*XBJ**5
947 $ -8*XBJ**6)))**(1./3.)*DCMPLX(0.5D0,0.86602540378444D0) ))
948 ZPMAX=1-ZPMIN
949 DIR1=(XBJ**2+(1-XBJ)**2)*(LOG(ZPMAX/ZPMIN)-(ZPMAX-ZPMIN))
950 DIR2=4*XBJ*(1-XBJ)*(ZPMAX-ZPMIN)
951 DIR=QFCH(MOD(ID-1,6)+1)**2*ALPHEM/(2*PIFAC*PDFOLD(ID))*XBJ
952 $ *(DIR1+DIR2)
953 ELSE
954 DIR=0
955 ENDIF
956C---DECIDE WHETHER TO MAKE AN EVENT HERE
957 IF (HWRGEN(4).GT.FAC+DIR) RETURN
958C---FOR DIRECT COUPLING, CHOOSE ZP VALUE
959 IF ((FAC+DIR)*HWRGEN(8).GT.FAC) THEN
960 IF ((DIR1+DIR2)*HWRGEN(9).LT.DIR1) THEN
961 NTRY=0
962 120 NTRY=NTRY+2
963 ZP=1-(ZPMAX/ZPMIN)**HWRGEN(NTRY+1)*ZPMIN
964 IF ((ZPMIN**2+(1-ZPMIN)**2)*HWRGEN(NTRY).GT.ZP**2+(1-ZP)**2)
965 $ GOTO 120
966 ELSE
967 ZP=SQRT((ZPMAX-ZPMIN)*HWRGEN(10)+ZPMIN**2)
968 ENDIF
969 XP=XBJ
970 BGF=.TRUE.
971 P3(5)=P2(5)
972 P1(5)=0
973 ENDIF
974 X1=1- ZP /XP
975 X2=1-(1-ZP)/XP
976 XTSQ=4*(1-XP)*(1-ZP)*ZP/XP
977 XT=SQRT(XTSQ)
978 SIN1=XT/SQRT(X1**2+XTSQ)
979 SIN2=XT/SQRT(X2**2+XTSQ)
980C---CHOOSE THE AZIMUTH BETWEEN THE TWO PLANES
981 IF (BGF) THEN
982 W1=XP**2*(X1**2+1.5*XTSQ)
983 ELSE
984 W1=1
985 ENDIF
986 W2=XP**2*(X2**2+1.5*XTSQ)
987 IF (HWRGEN(5)*(W1+W2).GT.W2) THEN
988 IF (BGF) THEN
989C-----WEIGHTED BY (1+SIN1*COS(PHI))**2
990 200 PHI=(2*HWRGEN(6)-1)*PIFAC
991 IF (HWRGEN(7)*(1+SIN1)**2.GT.(1+SIN1*COS(PHI))**2) GOTO 200
992 ELSE
993C-----UNIFORMLY
994 PHI=(2*HWRGEN(6)-1)*PIFAC
995 ENDIF
996 ELSE
997C-----WEIGHTED BY (1-SIN2*COS(PHI))**2
998 210 PHI=(2*HWRGEN(6)-1)*PIFAC
999 IF (HWRGEN(7)*(1+SIN2)**2.GT.(1-SIN2*COS(PHI))**2) GOTO 210
1000 ENDIF
1001C---RECONSTRUCT MOMENTA AND BOOST BACK TO LAB
1002 P1(1)=0
1003 P1(2)=0
1004 P1(3)=HALF*Q/XP
1005 P1(4)=SQRT(P1(3)**2+P1(5)**2)
1006 PTSQ=((ZP*Q*(P1(4)+P1(3)-Q)-P2(5)**2)*(P1(4)-P1(3)+(1-ZP)*Q)
1007 $ -P3(5)**2*ZP*Q)/(P1(4)-P1(3)+Q)
1008C---CHECK INFRARED CUTOFF FOR THIS PARTON TYPE
1009 IF (PTSQ.LT.MAX(HWBVMC(ID),HWBVMC(IDHW(IOUT)))**2) RETURN
1010 P2(1)=SQRT(PTSQ)*COS(PHI)
1011 P2(2)=SQRT(PTSQ)*SIN(PHI)
1012 P2(3)=-0.5*(ZP*Q-(PTSQ+P2(5)**2)/(ZP*Q))
1013 P2(4)= 0.5*(ZP*Q+(PTSQ+P2(5)**2)/(ZP*Q))
1014 P3(1)=P1(1)-P2(1)
1015 P3(2)=P1(2)-P2(2)
1016 P3(3)=P1(3)-P2(3)-Q
1017 P3(4)=P1(4)-P2(4)
1018 CALL HWUROB(R,P1,P1)
1019 CALL HWUROB(R,P2,P2)
1020 CALL HWUROB(R,P3,P3)
1021 CALL HWULOB(PCMF,P1,P1)
1022 CALL HWULOB(PCMF,P2,P2)
1023 CALL HWULOB(PCMF,P3,P3)
1024C---SPECIAL CASE FOR DIRECT PHOTON - COPY THE EXACT BEAM MOMENTUM
1025C---SHARE THE MISMATCH EQUALLY BETWEEN THE OUTGOING PARTONS
1026C---AND PUT THEM BACK ON SHELL
1027 IF (XP.EQ.XBJ) THEN
1028 CALL HWVDIF(4,PHEP(1,IHAD),P1,PM)
1029 CALL HWVSCA(4,HALF,PM,PM)
1030 CALL HWVSUM(4,PM,P2,P2)
1031 CALL HWVSUM(4,PM,P3,P3)
1032 CALL HWUMAS(P2)
1033 CALL HWUMAS(P3)
1034 CALL HWVEQU(5,PHEP(1,IHAD),P1)
1035 CALL HWVSUM(4,P2,P3,PCMF)
1036 CALL HWUMAS(PCMF)
1037 POLD=HWULDO(P2,PCMF)**2/PCMF(5)**2-SIGN(P2(5)**2,P2(5))
1038 PNEW=PCMF(5)**2/4-RMASS(ID)**2
1039 IF (PCMF(5).LE.ZERO.OR.POLD.LE.ZERO.OR.PNEW.LE.ZERO) RETURN
1040 CALL HWVSCA(4,SQRT(PNEW/POLD),P2,P2)
1041 CALL HWVSCA(4,HALF-HWULDO(P2,PCMF)/PCMF(5)**2,PCMF,PM)
1042 CALL HWVSUM(4,PM,P2,P2)
1043 CALL HWUMAS(P2)
1044 CALL HWVDIF(4,PCMF,P2,P3)
1045 CALL HWUMAS(P3)
1046 ENDIF
1047 NHEP=NHEP+1
1048 CALL HWVEQU(5,P1,PHEP(1,IIN))
1049 IF (BGF.AND.ID.GT.6.OR..NOT.BGF.AND.ID.LT.7) THEN
1050 CALL HWVEQU(5,P2,PHEP(1,IOUT))
1051 CALL HWVEQU(5,P3,PHEP(1,NHEP))
1052 ELSE
1053 CALL HWVEQU(5,P3,PHEP(1,IOUT))
1054 CALL HWVEQU(5,P2,PHEP(1,NHEP))
1055 ENDIF
1056 CALL HWVSUM(4,PHEP(1,ILEP),PHEP(1,IIN),PHEP(1,ICMF))
1057 CALL HWUMAS(PHEP(1,ICMF))
1058C Decide which quark radiated and assign production vertices
1059 IF (BGF) THEN
1060C Boson-Gluon fusion case
1061 IF (1-ZP.LT.HWRGEN(0)) THEN
1062C Gluon splitting to quark
1063 CALL HWVZRO(4,VHEP(1,NHEP-1))
1064 CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
1065 CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
1066 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
1067 ELSE
1068C Gluon splitting to antiquark
1069 CALL HWVZRO(4,VHEP(1,NHEP))
1070 CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP-1),PVRT)
1071 CALL HWUDKL(ID,PVRT,VHEP(1,NHEP-1))
1072 CALL HWVEQU(4,VHEP(1,NHEP-1),VHEP(1,NHEP-4))
1073 ENDIF
1074 ELSE
1075C QCD Compton case
1076 IF (1.LT.HWRGEN(0)*(1+(1-XP-ZP)**2+6*XP*(1-XP)*ZP*(1-ZP)))THEN
1077C Incoming quark radiated the gluon
1078 CALL HWVZRO(4,VHEP(1,NHEP-1))
1079 CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
1080 CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
1081 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
1082 ELSE
1083C Outgoing quark radiated the gluon
1084 CALL HWVZRO(4,VHEP(1,NHEP-4))
1085 CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PVRT)
1086 CALL HWUDKL(ID,PVRT,VHEP(1,NHEP))
1087 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
1088 ENDIF
1089 ENDIF
1090C---STATUS, ID AND POINTERS
1091 ISTHEP(NHEP)=114
1092 IF (BGF) THEN
1093 IF (XP.EQ.XBJ) THEN
1094 IDHW(IIN)=59
1095 IDHEP(IIN)=IDPDG(59)
1096 ELSE
1097 IDHW(IIN)=13
1098 IDHEP(IIN)=IDPDG(13)
1099 ENDIF
1100 IF (ID.LT.7) THEN
1101 IDHW(NHEP)=IDHW(IOUT)
1102 IDHEP(NHEP)=IDHEP(IOUT)
1103 IDHW(IOUT)=MOD(ID,6)+6
1104 IDHEP(IOUT)=IDPDG(IDHW(IOUT))
1105 ELSE
1106 IDHW(NHEP)=MOD(ID,6)
1107 IDHEP(NHEP)=IDPDG(IDHW(NHEP))
1108 ENDIF
1109 ELSEIF (ID.LT.7) THEN
1110 IDHW(NHEP)=13
1111 IDHEP(NHEP)=IDPDG(13)
1112 ELSE
1113 IDHW(NHEP)=IDHW(IOUT)
1114 IDHEP(NHEP)=IDHEP(IOUT)
1115 IDHW(IOUT)=13
1116 IDHEP(IOUT)=IDPDG(13)
1117 ENDIF
1118 JDAHEP(2,ICMF)=NHEP
1119 JMOHEP(1,NHEP)=ICMF
1120C---COLOUR CONNECTIONS
1121 IF (XP.EQ.XBJ) THEN
1122 JMOHEP(2,IIN)=IIN
1123 JDAHEP(2,IIN)=IIN
1124 JMOHEP(2,IOUT)=NHEP
1125 JDAHEP(2,IOUT)=NHEP
1126 JMOHEP(2,NHEP)=IOUT
1127 JDAHEP(2,NHEP)=IOUT
1128 ELSE
1129 JDAHEP(2,IIN)=NHEP
1130 JDAHEP(2,NHEP)=IOUT
1131 JMOHEP(2,IOUT)=NHEP
1132 JMOHEP(2,NHEP)=IIN
1133 ENDIF
1134C---FACTORISATION SCALE
1135 EMSCA=SCALE
1136 EMIT=NEVHEP+NWGTS
1137 ELSEIF (IOPT.EQ.2) THEN
1138C---MAKE TWO-JET EVENTS LOOK LIKE ONE-JET EVENTS
1139 IF (EMIT.NE.NEVHEP+NWGTS .OR. XP.EQ.XBJ) RETURN
1140 IF (.NOT.BGF) THEN
1141 CALL HWVEQU(5,Q1,PHEP(1,IIN))
1142 CALL HWVEQU(5,Q2,PHEP(1,IOUT))
1143 JMOHEP(2,IIN)=IOUT
1144 JDAHEP(2,IIN)=IOUT
1145 JMOHEP(2,IOUT)=IIN
1146 JDAHEP(2,IOUT)=IIN
1147 JDAHEP(2,ICMF)=IOUT
1148 IHEP=JDAHEP(1,IOUT)
1149 JHEP=JDAHEP(1,IOUT+1)
1150 CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
1151 CALL HWUMAS(PHEP(1,IHEP))
1152 JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
1153 IEDT(1)=IOUT+1
1154 IEDT(2)=JHEP
1155 IEDT(3)=JHEP+1
1156 NDEL=3
1157 IF (ISTHEP(JHEP+1).NE.100) NDEL=2
1158 IHEP=JDAHEP(1,IOUT)
1159 JMOHEP(1,IHEP)=IOUT
1160 IF (ISTHEP(IHEP+1).EQ.100) THEN
1161 JMOHEP(1,IHEP+1)=IOUT
1162 JMOHEP(2,IHEP+1)=IIN
1163 ENDIF
1164 DO 300 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
1165 JMOHEP(1,JHEP)=IHEP
1166 300 CONTINUE
1167 IF (IDHW(IOUT).EQ.13) IDHW(IOUT)=IDHW(IOUT+1)
1168 IDHEP(IOUT)=IDPDG(IDHW(IOUT))
1169 IDHW(IHEP)=IDHW(IOUT)
1170 CALL HWUEDT(NDEL,IEDT)
1171 ELSEIF (ID.LT.7) THEN
1172 CALL HWVEQU(5,Q1,PHEP(1,IIN))
1173 CALL HWVEQU(5,Q2,PHEP(1,IOUT+1))
1174 JMOHEP(2,IIN)=IOUT+1
1175 JDAHEP(2,IIN)=IOUT+1
1176 JMOHEP(2,IOUT+1)=IIN
1177 JDAHEP(2,IOUT+1)=IIN
1178 JDAHEP(2,ICMF)=IOUT+1
1179 IHEP=JDAHEP(1,IIN)
1180 JHEP=JDAHEP(1,IOUT)
1181 CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
1182 CALL HWUMAS(PHEP(1,IHEP))
1183 CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,ICMF))
1184 CALL HWUMAS(PHEP(1,ICMF))
1185 CALL HWUEMV(JDAHEP(2,JHEP)-JDAHEP(1,JHEP)+1,
1186 $ JDAHEP(1,JHEP),JDAHEP(2,IHEP))
1187 JHEP=JDAHEP(1,IOUT)
1188 JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
1189 IEDT(1)=IOUT
1190 IEDT(2)=JHEP
1191 IEDT(3)=JHEP+1
1192 NDEL=3
1193 IF (ISTHEP(JHEP+1).NE.100) NDEL=2
1194 CALL HWUEDT(NDEL,IEDT)
1195 IHEP=JDAHEP(1,IIN)
1196 DO 400 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
1197 JMOHEP(1,JHEP)=IHEP
1198 400 CONTINUE
1199 IDHW(IIN)=ID
1200 IDHEP(IIN)=IDPDG(ID)
1201 IDHW(IHEP)=ID
1202 ELSE
1203 CALL HWVEQU(5,Q1,PHEP(1,IIN))
1204 CALL HWVEQU(5,Q2,PHEP(1,IOUT))
1205 JMOHEP(2,IIN)=IOUT
1206 JDAHEP(2,IIN)=IOUT
1207 JMOHEP(2,IOUT)=IIN
1208 JDAHEP(2,IOUT)=IIN
1209 JDAHEP(2,ICMF)=IOUT
1210 IHEP=JDAHEP(1,IIN)
1211 JHEP=JDAHEP(1,IOUT+1)
1212 CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,IHEP))
1213 CALL HWUMAS(PHEP(1,IHEP))
1214 CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,JHEP),PHEP(1,ICMF))
1215 CALL HWUMAS(PHEP(1,ICMF))
1216 CALL HWUEMV(JDAHEP(2,JHEP)-JDAHEP(1,JHEP)+1,
1217 $ JDAHEP(1,JHEP),JDAHEP(1,IHEP)-1)
1218 JHEP=JDAHEP(1,IOUT+1)
1219 JDAHEP(1,IHEP)=JDAHEP(1,JHEP)
1220 IEDT(1)=IOUT+1
1221 IEDT(2)=JHEP
1222 IEDT(3)=JHEP+1
1223 NDEL=3
1224 IF (ISTHEP(JHEP+1).NE.100.OR.JHEP.EQ.NHEP) NDEL=2
1225 CALL HWUEDT(NDEL,IEDT)
1226 IHEP=JDAHEP(1,IIN)
1227 DO 500 JHEP=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
1228 JMOHEP(1,JHEP)=IHEP
1229 500 CONTINUE
1230 IDHW(IIN)=ID
1231 IDHEP(IIN)=IDPDG(ID)
1232 IDHW(IHEP)=ID
1233 ENDIF
1234 CALL HWVZRO(4,VHEP(1,IIN))
1235 CALL HWVZRO(4,VHEP(1,JDAHEP(1,IIN)))
1236 IF (ISTHEP(JDAHEP(1,IIN)+1).EQ.100)
1237 $ CALL HWVZRO(4,VHEP(1,JDAHEP(1,IIN)+1))
1238 CALL HWVZRO(4,VHEP(1,IOUT))
1239 CALL HWVZRO(4,VHEP(1,JDAHEP(1,IOUT)))
1240 IF (ISTHEP(JDAHEP(1,IOUT)+1).EQ.100)
1241 $ CALL HWVZRO(4,VHEP(1,JDAHEP(1,IOUT)+1))
1242 EMIT=0
1243 ELSE
1244 CALL HWWARN('HWBDIS',500)
1245 ENDIF
1246 999 RETURN
1247 END
1248CDECK ID>, HWBDYP.
1249*CMZ :- -26/10/99 17.46.56 by Mike Seymour
1250*-- Author : Gennaro Corcella
1251C-----------------------------------------------------------------------
1252 SUBROUTINE HWBDYP(IOPT)
1253C MATRIX ELEMENT CORRECTIONS TO DRELL-YAN PROCESSES
1254C-----------------------------------------------------------------------
c63d70bc 1255 INCLUDE 'herwig65.inc'
65767955 1256 DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,PMODK,AZ,CZ,
1257 & T,U,S,EM,TMIN,TMAX,PMOD2,GLUFAC,SMIN,SMAX,SZ,TEST,
1258 & JAC,M(3),W1,W,PMOD3,SCAPR,CPHI,SPHI,SCALE,XI1,XI2,
1259 & PDFOLD1(13),PDFOLD2(13),PDFNEW1(13),PDFNEW2(13),ETA1,ETA2,Y,
1260 & COMWGT1,COMWGT2,WW,COS3,MODP,RN,BETA1,SIN3,R3(3,3),CTH,STH,M1,
1261 & M2,M3,GAMMA1,R5(3,3),CW,SW,R4(3,3),SCALE1,X1,X2,X3,MM,
1262 & PHAD1(5),PHAD2(5),P1(5),P2(5),P3(5),P4(5),PF(5),PV(5),PK(5),
1263 & PR(5),PNE(5),PE(5),PP1(5),PP2(5),PZ(5),PS(5),PD(5),P2N(5),
1264 & PBOS(5),PLAB(5),PTOT(5),P3N(5),SVNTN
1265 LOGICAL GLUIN,GP
1266 INTEGER EMIT,NOEMIT,IHEP,JHEP,KHEP,ICMF,IOPT,CHEP,
1267 & ID2,ID1,K,ID4,ID5,IDBOS,IHAD1,IHAD2,NTMP
1268 EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUSQR
1269 SAVE PS,PF,ICMF,ID4,ID5
1270 SAVE EMIT,NTMP
1271 DATA EMIT,NTMP/2*0/
1272 IF (IOPT.EQ.1) THEN
1273 EMIT=0
1274 NTMP=0
1275C-----CHOOSE WEIGHTS
1276 COMWGT1=0.1
1277 COMWGT2=0.55
1278C---FIND AN UNTREATED CMF
1279 ICMF=0
1280 DO 10 IHEP=1,NHEP
1281 10 IF (ICMF.EQ.0 .AND. ISTHEP(IHEP).EQ.110.AND.
1282 & JDAHEP(2,IHEP).EQ.JDAHEP(1,IHEP)+1) ICMF=IHEP
1283 IF (ICMF.EQ.0) RETURN
1284 EM=PHEP(5,ICMF)
1285C-----SET THE VECTOR BOSON RAPIDITY
1286 Y=HALF*LOG((PHEP(4,ICMF)+PHEP(3,ICMF))/
1287 & (PHEP(4,ICMF)-PHEP(3,ICMF)))
1288C------SET PARTICLE IDENTIES
1289c------ID1=QUARK, ID2=ANTIQUARK, IDBOS=VECTOR BOSON, ID4-5 BOSON DECAY
1290 IDBOS=IDHW(ICMF)
1291 ID1=IDHW(JMOHEP(1,ICMF))
1292 ID2=IDHW(JMOHEP(2,ICMF))
1293 ID4=IDHW(JDAHEP(1,ICMF))
1294 ID5=IDHW(JDAHEP(2,ICMF))
1295 M1=RMASS(ID1)
1296 M2=RMASS(ID2)
1297 M3=RMASS(13)
1298C---STORE OLD MOMENTA
1299C------VECTOR BOSON MOMENTUM
1300 CALL HWVEQU(5,PHEP(1,ICMF),PBOS)
1301C----QUARK MOMENTUM
1302 CALL HWVEQU(5,PHEP(1,JMOHEP(1,ICMF)),P1)
1303C------ANTIQUARK MOMENTUM
1304 CALL HWVEQU(5,PHEP(1,JMOHEP(2,ICMF)),P2)
1305C-------VECTOR DECAY (LEPTON) PRODUCT MOMENTA
1306 CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),P3)
1307 CALL HWVEQU(5,PHEP(1,JDAHEP(2,ICMF)),P4)
1308C------LEPTON MOMENTA IN THE BOSON REST FRAME
1309 CALL HWULOF(PHEP(1,ICMF),P2,P2N)
1310 CALL HWULOF(PHEP(1,ICMF),P3,P3N)
1311C------AZ=AZIMUTHAL ANGLE OF P3N
1312 AZ=ATAN2(P3N(2),P3N(1))
1313 CZ=COS(AZ)
1314 SZ=SIN(AZ)
1315C------PHI=ANGLE BETWEEN P2N AND P3N
1316 SCAPR=P2N(1)*P3N(1)+P2N(2)*P3N(2)+P2N(3)*P3N(3)
1317 PMOD2=SQRT(P2N(1)**2+P2N(2)**2+P2N(3)**2)
1318 PMOD3=SQRT(P3N(1)**2+P3N(2)**2+P3N(3)**2)
1319 CPHI=SCAPR/(PMOD3*PMOD2)
1320 SPHI=SQRT(1-CPHI**2)
1321C------HADRON MOMENTA
1322 IHAD1=1
1323 IHAD2=2
1324 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
1325 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
1326 CALL HWVEQU(5,PHEP(1,IHAD1),PHAD1)
1327 CALL HWVEQU(5,PHEP(1,IHAD2),PHAD2)
1328 CALL HWVSUM(4,PHAD1,PHAD2,PTOT)
1329 CALL HWUMAS(PTOT)
1330C------ Q - QBAR ENERGY FRACTIONS (BORN PROCESS)
1331c---minorimprovement---mhs---4/8/04---include mass effects correctly
1332 ETA1=(P1(4)+P1(3))/(PHAD1(4)+PHAD1(3))
1333 ETA2=(P2(4)-P2(3))/(PHAD2(4)-PHAD2(3))
1334C------ PDFs FOR THE BORN PROCESS
1335 CALL HWSFUN(ETA1,EM,IDHW(IHAD1),NSTRU,PDFOLD1,1)
1336 CALL HWSFUN(ETA2,EM,IDHW(IHAD2),NSTRU,PDFOLD2,2)
1337C-------CONSIDER Q(QBAR) IN THE INITIAL STATE
1338 RN=HWRGEN(9)
1339 IF (RN.LT.COMWGT1) THEN
1340C-------NO GLUON IN THE INITIAL STATE
1341 GLUIN=.FALSE.
1342C---CHOOSE S ACCORDING TO 1/S**2
1343 SVNTN=17
1344 SMIN=HALF*EM**2*(7-SQRT(SVNTN))
1345 SMAX=PTOT(5)**2
1346 IF (SMAX.LE.SMIN) RETURN
1347 S=SMIN*SMAX/(SMIN+HWRGEN(0)*(SMAX-SMIN))
1348 JAC=S**2*(1/SMIN-1/SMAX)
1349C---CHOOSE T ACCORDING TO (S-EM**2)/(T*U)=1/T+1/U
1350 TMAX=-HALF*EM**2*(3-HWUSQR(1+8*EM**2/S))
1351 TMIN=EM**2-S-TMAX
1352 IF (TMAX.LE.TMIN) RETURN
1353 T=TMAX*(TMIN/TMAX)**HWRGEN(1)
1354 IF (HWRGEN(2).GT.HALF) T=EM**2-S-T
1355 U=EM**2-S-T
1356 JAC=JAC*2*T*U/(S-EM**2)*LOG(TMIN/TMAX)
1357 SCALE=SQRT(U*T/S)
1358 SCALE1=SQRT(U*T/S+EM**2)
1359 GLUFAC=0
1360 IF (SCALE1.GT.HWBVMC(13)) GLUFAC=HWUALF(1,SCALE1)/(2*PIFAC)
1361C----Q-QBAR ENERGY FRACTIONS FOR Q QBAR-> VG
1362 XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+T)/(S+U))
1363 XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
1364c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x
1365 IF ((1-XI1)*SCALE.LT.HWBVMC(ID1)) RETURN
1366 IF ((1-XI2)*SCALE.LT.HWBVMC(ID2)) RETURN
1367C-----PDFs WITH AN EMITTED GLUON
1368 CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
1369 CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
1370C------CALCULATE WEIGHT
1371 W=JAC*((EM**2-T)**2+(EM**2-U)**2)/(S**2*T*U)
1372 W1=(GLUFAC/COMWGT1)*W*PDFNEW1(ID1)*PDFNEW2(ID2)/(PDFOLD1(ID1)*
1373 & PDFOLD2(ID2))*(CFFAC*ETA1*ETA2/(XI1*XI2))
1374C-------CHOOSE WHICH PARTON WILL EMIT
1375 EMIT=1
1376 IF (HWRGEN(6).LT.(EM**2-U)**2/((EM**2-U)**2+(EM**2-T)**2))
1377 & EMIT=2
1378 NOEMIT=3-EMIT
1379 ELSE
1380C--------GLUON IN THE INITIAL STATE
1381 GLUIN=.TRUE.
1382C---CHOOSE S ACCORDING TO 1/S**2
1383 SMIN=EM**2
1384 SMAX=PTOT(5)**2
1385 IF (SMAX.LE.SMIN) RETURN
1386 S=SMIN*SMAX/(SMIN+HWRGEN(0)*(SMAX-SMIN))
1387 JAC=S**2*(1/SMIN-1/SMAX)
1388C---CHOOSE T ACCORDING TO 1/T
1389 TMAX=-HALF*EM**2*(3-HWUSQR(1+8*EM**2/S))
1390 TMIN=EM**2-S
1391 IF (TMAX.LE.TMIN) RETURN
1392 T=TMAX*(TMIN/TMAX)**HWRGEN(1)
1393 JAC=JAC*T*LOG(TMAX/TMIN)
1394 U=EM**2-S-T
1395 SCALE=SQRT(U*T/S)
1396 SCALE1=SQRT(U*T/S+EM**2)
1397 GLUFAC=0
1398 IF (SCALE1.GT.HWBVMC(13)) GLUFAC=HWUALF(1,SCALE1)/(2*PIFAC)
1399C--------INITIAL STATE GLUON COMING FROM HADRON 1
1400 IF (RN.LE.COMWGT2) THEN
1401 GP=.TRUE.
1402C--------ENERGY FRACTIONS and PDFs
1403c---bug fix---mhs---4/8/04---swap u and t in mtm frac definitions
1404 XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+T)/(S+U))
1405 XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
1406c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x
1407 IF ((1-XI1)*SCALE.LT.HWBVMC(13)) RETURN
1408 IF ((1-XI2)*SCALE.LT.HWBVMC(ID2)) RETURN
1409 CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
1410 CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
1411 WW=PDFNEW1(13)*PDFNEW2(ID2)/((COMWGT2-COMWGT1)*
1412 & PDFOLD1(ID1)*PDFOLD2(ID2))
1413 ELSE
1414C-------INITIAL STATE GLUON COMING FROM HADRON 2
1415 GP=.FALSE.
1416C-------ENERGY FRACTIONS AND PDFs
1417c---bug fix---mhs---4/8/04---swap u and t in mtm frac definitions
1418 XI1=(HALF/PHAD1(4))*EXP(Y)*SQRT(S*(S+U)/(S+T))
1419 XI2=S/(4*XI1*PHAD1(4)*PHAD2(4))
1420c---minorimprovement---mhs---4/8/04---apply infrared cutoff for large x
1421 IF ((1-XI1)*SCALE.LT.HWBVMC(ID1)) RETURN
1422 IF ((1-XI2)*SCALE.LT.HWBVMC(13)) RETURN
1423 CALL HWSFUN(XI1,SCALE,IDHW(IHAD1),NSTRU,PDFNEW1,1)
1424 CALL HWSFUN(XI2,SCALE,IDHW(IHAD2),NSTRU,PDFNEW2,2)
1425 WW=PDFNEW1(ID1)*PDFNEW2(13)/((1-COMWGT2)*
1426 & PDFOLD1(ID1)*PDFOLD2(ID2))
1427 ENDIF
1428 W=-HALF*JAC*((EM**2-T)**2+(EM**2-S)**2)/(S**3*T)
1429C-------CHOOSE WHICH PARTON WILL EMIT
1430c---bug fix---mhs---4/8/04---swap emitter and nonemitter
1431 EMIT=2
1432 IF (HWRGEN(10).LT.(EM**2-S)**2/((EM**2-S)**2+(EM**2-T)**2))
1433 & EMIT=1
1434 NOEMIT=3-EMIT
1435C-------FINAL WEIGHT FOR ALL THE CONSIDERED OPTIONS
1436 W1=GLUFAC*W*WW*ETA1*ETA2/(XI1*XI2)
1437 ENDIF
1438C--------ADD ONE MORE GLUON
1439 IF (W1.GT.HWRGEN(4)) THEN
1440 NTMP=NEVHEP+NWGTS
1441 ELSE
1442 RETURN
1443 ENDIF
1444C---------INCLUDE MASSES
1445 S=S+M1**2+M2**2+M3**2
1446 IF (.NOT.GLUIN) THEN
1447 TEST=((S+M1**2-M2**2)*(S+M3**2-EM**2)-2*S*(M1**2+M3**2-T))**2
1448 $ -((S-M1**2-M2**2)**2-4*M1**2*M2**2)*
1449 $ ((S-M3**2-EM**2)**2-4*M3**2*EM**2)
1450 ELSEIF (GP) THEN
1451 TEST=((S+M3**2-M2**2)*(S+M1**2-EM**2)-2*S*(M3**2+M1**2-T))**2
1452 $ -((S-M3**2-M2**2)**2-4*M3**2*M2**2)*
1453 $ ((S-M1**2-EM**2)**2-4*M1**2*EM**2)
1454 ELSE
1455 TEST=((S+M3**2-M1**2)*(S+M2**2-EM**2)-2*S*(M3**2+M2**2-T))**2
1456 $ -((S-M3**2-M1**2)**2-4*M3**2*M1**2)*
1457 $ ((S-M2**2-EM**2)**2-4*M2**2*EM**2)
1458 ENDIF
1459 IF (TEST.GE.0) THEN
1460 EMIT=0
1461 RETURN
1462 ENDIF
1463 M(1)=M1
1464 M(2)=M2
1465 M(3)=M3
1466C----MOMENTA IN THE V-REST FRAME WITH NON EMITTER ALONG THE Z AXIS
1467C----V=BOSON,K=GLUON,E=EMITTER,NE=NON-EMITTER
1468 PV(1)=0
1469 PV(2)=0
1470 PV(3)=0
1471 PV(4)=EM
1472 PV(5)=EM
1473 PNE(2)=0
1474 PNE(1)=0
1475 IF (.NOT.GLUIN) THEN
1476 PK(4)=(S-M(3)**2-EM**2)/(2*EM)
1477 PMODK=SQRT(PK(4)**2-M(3)**2)
1478 IF (EMIT.EQ.1) THEN
1479 MM=M(1)
1480 X1=T
1481 X2=U
1482 X3=-1
1483 ELSE
1484 MM=M(2)
1485 X1=U
1486 X2=T
1487 X3=+1
1488 ENDIF
1489 PNE(4)=(EM**2+MM**2-X1)/(2*EM)
1490 PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
1491 COS3=HALF*(X2-MM**2-M(3)**2+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
1492 ELSE
1493 PK(4)=(EM**2+M(3)**2-U)/(2*EM)
1494 PMODK=SQRT(PK(4)**2-M(3)**2)
1495 IF (EMIT.EQ.1) THEN
1496 IF (GP) THEN
1497 MM=M(1)
1498 X3=+1
1499 ELSE
1500 MM=M(2)
1501 X3=-1
1502 ENDIF
1503 PNE(4)=(S-MM**2-EM**2)/(2*EM)
1504 PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
1505 COS3=HALF*(T-MM**2-M(3)**2+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
1506 ELSE
1507 IF (GP) THEN
1508 MM=M(2)
1509 X3=-1
1510 ELSE
1511 MM=M(1)
1512 X3=+1
1513 ENDIF
1514 PNE(4)=(EM**2+MM**2-T)/(2*EM)
1515 PNE(3)=X3*SQRT(PNE(4)**2-MM**2)
1516 COS3=HALF*(MM**2+M(3)**2-S+2*PNE(4)*PK(4))/(PNE(3)*PMODK)
1517 ENDIF
1518 ENDIF
1519 CALL HWUMAS(PNE)
1520 SIN3=SQRT(1-COS3**2)
1521C---------DEFINE A RANDOM ROTATION AROUND THE Z-AXIS
1522 CALL HWRAZM(PMODK*SIN3,PK(1),PK(2))
1523 PK(3)=PMODK*COS3
1524 CALL HWUMAS(PK)
1525 DO K=1,4
1526 IF (.NOT.GLUIN) THEN
1527 PE(K)=PV(K)+PK(K)-PNE(K)
1528 ELSE
1529 IF (EMIT.EQ.1) THEN
1530 PE(K)=PV(K)+PNE(K)-PK(K)
1531 ELSE
1532 PE(K)=PNE(K)+PK(K)-PV(K)
1533 ENDIF
1534 ENDIF
1535 ENDDO
1536 CALL HWUMAS(PE)
1537c------LEPTON MOMENTA IN THE BOSON REST FRAME, WITH THE DIRECTION
1538C------TAKEN FROM THE BORN PROCESS
1539 PS(5)=P3(5)
1540 PS(4)=(EM**2+P3(5)**2-P4(5)**2)/(2*EM)
1541 PS(3)=-SQRT(PS(4)**2-P3(5)**2)*CPHI
1542 PS(2)=SQRT(PS(4)**2-P3(5)**2)*SPHI*SZ
1543 PS(1)=SQRT(PS(4)**2-P3(5)**2)*SPHI*CZ
1544 PF(5)=P4(5)
1545 PF(4)=(EM**2+P4(5)**2-P3(5)**2)/(2*EM)
1546 PF(3)=-PS(3)
1547 PF(2)=-PS(2)
1548 PF(1)=-PS(1)
1549C----FIND A STATIONARY VECTOR PLAB IN THE LAB FRAME
1550 IF (.NOT.GLUIN) THEN
1551 IF (EMIT.EQ.1) THEN
1552 CALL HWVEQU(5,PE,PP1)
1553 CALL HWVEQU(5,PNE,PP2)
1554 ELSE
1555 CALL HWVEQU(5,PNE,PP1)
1556 CALL HWVEQU(5,PE,PP2)
1557 ENDIF
1558 ELSE
1559 IF (GP) THEN
1560 CALL HWVEQU(5,PK,PP1)
1561 IF (EMIT.EQ.1) THEN
1562 CALL HWVEQU(5,PE,PP2)
1563 ELSE
1564 CALL HWVEQU(5,PNE,PP2)
1565 ENDIF
1566 ELSE
1567 CALL HWVEQU(5,PK,PP2)
1568 IF (EMIT.EQ.1) THEN
1569 CALL HWVEQU(5,PE,PP1)
1570 ELSE
1571 CALL HWVEQU(5,PNE,PP1)
1572 ENDIF
1573 ENDIF
1574 ENDIF
1575 CALL HWVSCA(4,1/XI1,PP1,PP1)
1576 CALL HWVSCA(4,1/XI2,PP2,PP2)
1577 CALL HWVSUM(4,PP1,PP2,PLAB)
1578 CALL HWUMAS(PLAB)
1579C------BOOST TO PLAB REST FRAME
1580 CALL HWULOF(PLAB,PE,PE)
1581 CALL HWULOF(PLAB,PNE,PNE)
1582 CALL HWULOF(PLAB,PK,PK)
1583 CALL HWULOF(PLAB,PS,PS)
1584 CALL HWULOF(PLAB,PF,PF)
1585 CALL HWULOF(PLAB,PV,PV)
1586C----PUT THE INITIAL PARTON BELONGING TO HADRON 1 ON THE Z-AXIS
1587 IF (.NOT.GLUIN) THEN
1588 IF (EMIT.EQ.1) THEN
1589 CALL HWVEQU(5,PE,PZ)
1590 ELSE
1591 CALL HWVEQU(5,PNE,PZ)
1592 ENDIF
1593 ELSE
1594 IF (GP) THEN
1595 CALL HWVEQU(5,PK,PZ)
1596 ELSE
1597 IF (EMIT.EQ.1) THEN
1598 CALL HWVEQU(5,PE,PZ)
1599 ELSE
1600 CALL HWVEQU(5,PNE,PZ)
1601 ENDIF
1602 ENDIF
1603 ENDIF
1604 MODP=SQRT(PZ(1)**2+PZ(2)**2)
1605 CTH=PZ(1)/MODP
1606 STH=PZ(2)/MODP
1607 CALL HWUROT(PZ,CTH,STH,R3)
1608C-----ROTATE EVERYTHING BY R3
1609 CALL HWUROF(R3,PE,PE)
1610 CALL HWUROF(R3,PNE,PNE)
1611 CALL HWUROF(R3,PV,PV)
1612 CALL HWUROF(R3,PK,PK)
1613 CALL HWUROF(R3,PS,PS)
1614 CALL HWUROF(R3,PF,PF)
1615C--REORDER ENTRIES:--IHEP=EMITTER,JHEP=NON-EMITTER,KHEP=EMITTED
1616 IF (.NOT.GLUIN) THEN
1617 IHEP=JMOHEP(EMIT,ICMF)
1618 JHEP=JMOHEP(NOEMIT,ICMF)
1619 ENDIF
1620 CHEP=ICMF
1621 IDHW(CHEP)=15
1622 IDHEP(CHEP)=IDPDG(15)
1623 ICMF=ICMF+1
1624 IDHW(ICMF)=IDBOS
1625 IDHEP(ICMF)=IDPDG(IDBOS)
1626C-----NO GLUON IN THE INITIAL STATE: JUST ADD IT AFTER THE VECTOR BOSON
1627 IF (.NOT.GLUIN) THEN
1628 KHEP=ICMF+1
1629 ISTHEP(KHEP)=114
1630C---STATUS OF EMITTER/NON EMITTER
1631 ISTHEP(IHEP)=110+EMIT
1632 ISTHEP(JHEP)=110+NOEMIT
1633 ELSE
1634C-----GLUON COMING FROM THE 1ST HADRON
1635 IF (GP) THEN
1636 KHEP=CHEP-2
1637 ISTHEP(KHEP)=111
1638C----EMIT=1
1639 IF (EMIT.EQ.1) THEN
1640 IHEP=KHEP+1
1641 ISTHEP(IHEP)=112
1642 JHEP=ICMF+1
1643 ISTHEP(JHEP)=114
1644 IDHW(IHEP)=ID2
1645 IF (ID1.LE.6) THEN
1646 IDHW(JHEP)=ID1+6
1647 ELSE
1648 IDHW(JHEP)=ID1-6
1649 ENDIF
1650 ELSE
1651C-------EMIT=2
1652 JHEP=KHEP+1
1653 ISTHEP(JHEP)=112
1654 IDHW(JHEP)=ID2
1655 IHEP=ICMF+1
1656 ISTHEP(IHEP)=114
1657 IF (ID1.LE.6) THEN
1658 IDHW(IHEP)=ID1+6
1659 ELSE
1660 IDHW(IHEP)=ID1-6
1661 ENDIF
1662 ENDIF
1663 ENDIF
1664C------GLUON COMING FROM THE HADRON 2
1665 IF (.NOT.GP) THEN
1666 KHEP=CHEP-1
1667 ISTHEP(KHEP)=112
1668C-------EMIT=1
1669 IF (EMIT.EQ.1) THEN
1670 IHEP=KHEP-1
1671 ISTHEP(IHEP)=111
1672 IDHW(IHEP)=ID1
1673 JHEP=ICMF+1
1674 ISTHEP(JHEP)=114
1675 IF (ID2.LE.6) THEN
1676 IDHW(JHEP)=ID2+6
1677 ELSE
1678 IDHW(JHEP)=ID2-6
1679 ENDIF
1680 ELSE
1681C-------EMIT=2
1682 JHEP=KHEP-1
1683 ISTHEP(JHEP)=111
1684 IDHW(JHEP)=ID1
1685 IHEP=ICMF+1
1686 ISTHEP(IHEP)=114
1687 IF (ID2.LE.6) THEN
1688 IDHW(IHEP)=ID2+6
1689 ELSE
1690 IDHW(IHEP)=ID2-6
1691 ENDIF
1692 ENDIF
1693 ENDIF
1694 ENDIF
1695 IDHEP(IHEP)=IDPDG(IDHW(IHEP))
1696 IDHEP(JHEP)=IDPDG(IDHW(JHEP))
1697 ISTHEP(ICMF)=113
1698 ISTHEP(CHEP)=110
1699 IDHW(KHEP)=13
1700 IDHEP(KHEP)=IDPDG(13)
1701C---------DEFINE MOMENTA IN THE LAB FRAME
1702 CALL HWVEQU(5,PV,PHEP(1,ICMF))
1703 CALL HWVEQU(5,PK,PHEP(1,KHEP))
1704 CALL HWVEQU(5,PNE,PHEP(1,JHEP))
1705 CALL HWVEQU(5,PE,PHEP(1,IHEP))
1706 IF (.NOT.GLUIN) THEN
1707 CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,JHEP),PHEP(1,CHEP))
1708 ELSE
1709 IF (EMIT.EQ.1) THEN
1710 CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,CHEP))
1711 ELSE
1712 CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,JHEP),PHEP(1,CHEP))
1713 ENDIF
1714 ENDIF
1715 CALL HWUMAS(PHEP(1,CHEP))
1716 IF (.NOT.GLUIN) THEN
1717 JMOHEP(1,JHEP)=CHEP
1718 JMOHEP(1,IHEP)=CHEP
1719 JDAHEP(1,JHEP)=CHEP
1720 JDAHEP(1,IHEP)=CHEP
1721 JMOHEP(1,KHEP)=CHEP
1722 JDAHEP(1,KHEP)=0
1723 JMOHEP(1,ICMF)=CHEP
1724 JMOHEP(2,ICMF)=ICMF
1725 JDAHEP(1,ICMF)=0
1726 JDAHEP(2,ICMF)=ICMF
1727 ENDIF
1728 IF (GLUIN) THEN
1729 JMOHEP(2,ICMF)=ICMF
1730 JDAHEP(2,ICMF)=ICMF
1731 JMOHEP(1,KHEP)=CHEP
1732 JDAHEP(1,KHEP)=CHEP
1733 JMOHEP(1,IHEP)=CHEP
1734 JMOHEP(1,JHEP)=CHEP
1735 IF (EMIT.EQ.1) THEN
1736 JDAHEP(1,IHEP)=CHEP
1737 JDAHEP(1,JHEP)=0
1738 ELSE
1739 JDAHEP(1,JHEP)=CHEP
1740 JDAHEP(1,IHEP)=0
1741 ENDIF
1742 ENDIF
1743C---COLOUR CONNECTIONS
1744 IF (.NOT.GLUIN) THEN
1745 IF (IDHW(IHEP).LT.IDHW(JHEP)) THEN
1746 JMOHEP(2,KHEP)=IHEP
1747 JDAHEP(2,KHEP)=JHEP
1748 JMOHEP(2,IHEP)=JHEP
1749 JDAHEP(2,IHEP)=KHEP
1750 JDAHEP(2,JHEP)=IHEP
1751 JMOHEP(2,JHEP)=KHEP
1752 ELSE
1753 JMOHEP(2,KHEP)=JHEP
1754 JDAHEP(2,KHEP)=IHEP
1755 JMOHEP(2,JHEP)=IHEP
1756 JDAHEP(2,JHEP)=KHEP
1757 JDAHEP(2,IHEP)=JHEP
1758 JMOHEP(2,IHEP)=KHEP
1759 ENDIF
1760 ENDIF
1761 IF (GLUIN) THEN
1762 IF (EMIT.EQ.1) THEN
1763 IF (IDHEP(IHEP).GT.0) THEN
1764 JMOHEP(2,IHEP)=JHEP
1765 JDAHEP(2,IHEP)=KHEP
1766 JMOHEP(2,JHEP)=KHEP
1767 JDAHEP(2,JHEP)=IHEP
1768 JMOHEP(2,KHEP)=IHEP
1769 JDAHEP(2,KHEP)=JHEP
1770 ELSE
1771 JMOHEP(2,IHEP)=KHEP
1772 JDAHEP(2,IHEP)=JHEP
1773 JMOHEP(2,JHEP)=IHEP
1774 JDAHEP(2,JHEP)=KHEP
1775 JMOHEP(2,KHEP)=JHEP
1776 JDAHEP(2,KHEP)=IHEP
1777 ENDIF
1778 ELSE
1779 IF (IDHEP(JHEP).GT.0) THEN
1780 JMOHEP(2,JHEP)=IHEP
1781 JDAHEP(2,JHEP)=KHEP
1782 JMOHEP(2,IHEP)=KHEP
1783 JDAHEP(2,IHEP)=JHEP
1784 JMOHEP(2,KHEP)=JHEP
1785 JDAHEP(2,KHEP)=IHEP
1786 ELSE
1787 JMOHEP(2,JHEP)=KHEP
1788 JDAHEP(2,JHEP)=IHEP
1789 JMOHEP(2,IHEP)=JHEP
1790 JDAHEP(2,IHEP)=KHEP
1791 JMOHEP(2,KHEP)=IHEP
1792 JDAHEP(2,KHEP)=JHEP
1793 ENDIF
1794 ENDIF
1795 ENDIF
1796 EMSCA=SQRT(EM**2+PHEP(1,ICMF)**2+PHEP(2,ICMF)**2)
1797C--------SET STATUS AND LEPTON MOMENTA AFTER THE PARTON SHOWER
1798 ELSEIF (IOPT.EQ.2) THEN
1799 IF (EMIT.EQ.0.OR.NEVHEP+NWGTS.NE.NTMP) RETURN
1800 ISTHEP(JDAHEP(1,ICMF))=195
1801 IDHW(NHEP+1)=ID4
1802 IDHW(NHEP+2)=ID5
1803 IDHEP(NHEP+1)=IDPDG(ID4)
1804 IDHEP(NHEP+2)=IDPDG(ID5)
1805 ISTHEP(NHEP+1)=113
1806 ISTHEP(NHEP+2)=114
1807 CW=PHEP(3,ICMF)/SQRT(PHEP(1,ICMF)**2+PHEP(2,ICMF)**2+
1808 & PHEP(3,ICMF)**2)
1809 SW=SQRT(1-CW**2)
1810 CALL HWUROT(PHEP(1,ICMF),CW,SW,R4)
1811 CALL HWUROF(R4,PHEP(1,ICMF),PR)
1812 PR(4)=PHEP(4,ICMF)
1813 CALL HWUMAS(PR)
1814 CALL HWUROF(R4,PS,PS)
1815 CALL HWUROF(R4,PF,PF)
1816 CALL HWUMAS(PS)
1817 CALL HWUMAS(PF)
1818 CALL HWUROT(PHEP(1,JDAHEP(1,ICMF)),CW,SW,R5)
1819 CALL HWUROF(R5,PHEP(1,JDAHEP(1,ICMF)),PD)
1820 PD(4)=PHEP(4,JDAHEP(1,ICMF))
1821 CALL HWUMAS(PD)
1822 BETA1=(PR(4)*PR(3)-SQRT(PR(4)**2*PD(3)**2-PR(3)**2*PD(3)**2+
1823 & PD(3)**4))/(PD(3)**2+PR(4)**2)
1824 GAMMA1=1/SQRT(1-BETA1**2)
1825 PHEP(4,NHEP+1)=GAMMA1*PS(4)-BETA1*GAMMA1*PS(3)
1826 PHEP(3,NHEP+1)=-BETA1*GAMMA1*PS(4)+GAMMA1*PS(3)
1827 PHEP(4,NHEP+2)=GAMMA1*PF(4)-BETA1*GAMMA1*PF(3)
1828 PHEP(3,NHEP+2)=-BETA1*GAMMA1*PF(4)+GAMMA1*PF(3)
1829 PHEP(1,NHEP+1)=PS(1)
1830 PHEP(2,NHEP+1)=PS(2)
1831 PHEP(1,NHEP+2)=PF(1)
1832 PHEP(2,NHEP+2)=PF(2)
1833 CALL HWUMAS(PHEP(1,NHEP+1))
1834 CALL HWUMAS(PHEP(1,NHEP+2))
1835 CALL HWUROB(R5,PHEP(1,NHEP+1),PHEP(1,NHEP+1))
1836 CALL HWUROB(R5,PHEP(1,NHEP+2),PHEP(1,NHEP+2))
1837 JDAHEP(1,JDAHEP(1,ICMF))=NHEP+1
1838 JDAHEP(2,JDAHEP(1,ICMF))=NHEP+2
1839 JMOHEP(1,NHEP+1)=JDAHEP(1,ICMF)
1840 JMOHEP(1,NHEP+2)=JDAHEP(1,ICMF)
1841 JMOHEP(2,NHEP+1)=NHEP+2
1842 JDAHEP(2,NHEP+1)=NHEP+2
1843 JMOHEP(2,NHEP+2)=NHEP+1
1844 JDAHEP(2,NHEP+2)=NHEP+1
1845C--special for spin correlations(relabel in spin common block)
1846 IF(SYSPIN.AND.NSPN.NE.0) THEN
1847 IDSPN(2) = NHEP+1
1848 IDSPN(3) = NHEP+2
1849 ISNHEP(NHEP+1) = 2
1850 ISNHEP(NHEP+2) = 3
1851 ENDIF
1852 NHEP=NHEP+2
1853 EMIT=0
1854 ENDIF
1855 END
1856CDECK ID>, HWBFIN.
1857*CMZ :- -26/04/91 10.18.56 by Bryan Webber
1858*-- Author : Bryan Webber
1859C-----------------------------------------------------------------------
1860 SUBROUTINE HWBFIN(IHEP)
1861C-----------------------------------------------------------------------
1862C DELETES INTERNAL LINES FROM SHOWER, MAKES COLOUR CONNECTION INDEX
1863C AND COPIES INTO /HEPEVT/ IN COLOUR ORDER.
1864C-----------------------------------------------------------------------
c63d70bc 1865 INCLUDE 'herwig65.inc'
65767955 1866 INTEGER IHEP,ID,IJET,KHEP,IPAR,JPAR,NXPAR,IP,JP
1867 IF (IERROR.NE.0) RETURN
1868C---SAVE VIRTUAL PARTON DATA
1869 NHEP=NHEP+1
1870 IF(NHEP.GT.NMXHEP) THEN
1871 CALL HWWARN('HWBFIN',100)
1872 GOTO 999
1873 ENDIF
1874 ID=IDPAR(2)
1875 IDHW(NHEP)=ID
1876 IDHEP(NHEP)=IDPDG(ID)
1877 ISTHEP(NHEP)=ISTHEP(IHEP)+20
1878 JMOHEP(1,NHEP)=IHEP
1879 JMOHEP(2,NHEP)=JMOHEP(1,IHEP)
1880 JDAHEP(1,IHEP)=NHEP
1881 JDAHEP(1,NHEP)=0
1882 JDAHEP(2,NHEP)=0
1883 CALL HWVEQU(5,PPAR(1,2),PHEP(1,NHEP))
1884 CALL HWVEQU(4,VPAR(1,2),VHEP(1,NHEP))
1885C---FINISHED FOR SPECTATOR OR NON-PARTON JETS
1886 IF (ISTHEP(NHEP).GT.136) RETURN
1887 IF (ID.GT.13.AND.ID.LT.209 .AND. ID.NE.59) RETURN
1888 IF (ID.GT.220.AND.ABS(IDPDG(ID)).LT.1000000) RETURN
1889 IF (ID.GT.424.AND.ID.NE.449) RETURN
1890 IF (.NOT.TMPAR(2).AND.ID.EQ.59) RETURN
1891 IDHEP(NHEP)=94
1892 IJET=NHEP
1893 IF (NPAR.GT.2) THEN
1894C---SAVE CONE DATA
1895 NHEP=NHEP+1
1896 IF(NHEP.GT.NMXHEP) THEN
1897 CALL HWWARN('HWBFIN',101)
1898 GOTO 999
1899 ENDIF
1900 IDHW(NHEP)=IDPAR(1)
1901 IDHEP(NHEP)=0
1902 ISTHEP(NHEP)=100
1903 JMOHEP(1,NHEP)=IHEP
1904 JMOHEP(2,NHEP)=JCOPAR(1,1)
1905 JDAHEP(1,NHEP)=0
1906 JDAHEP(2,NHEP)=0
1907 CALL HWVEQU(5,PPAR,PHEP(1,NHEP))
1908 CALL HWVEQU(4,VPAR(1,2),VHEP(1,NHEP))
1909 ENDIF
1910 KHEP=NHEP
1911C---START WITH ANTICOLOUR DAUGHTER OF HARDEST PARTON
1912 IPAR=2
1913 JPAR=JCOPAR(4,IPAR)
1914 NXPAR=NPAR/2
1915 DO 20 IP=1,NXPAR
1916 DO 10 JP=1,NXPAR
1917 IF (JPAR.EQ.0) GOTO 15
1918 IF (JCOPAR(2,JPAR).EQ.IPAR) THEN
1919 IPAR=JPAR
1920 JPAR=JCOPAR(4,IPAR)
1921 ELSE
1922 IPAR=JPAR
1923 JPAR=JCOPAR(1,IPAR)
1924 ENDIF
1925 10 CONTINUE
1926C---COULDN'T FIND COLOUR PARTNER
1927 CALL HWWARN('HWBFIN',1)
1928 15 JPAR=JCOPAR(1,IPAR)
1929 KHEP=KHEP+1
1930 IF(KHEP.GT.NMXHEP) THEN
1931 CALL HWWARN('HWBFIN',102)
1932 GOTO 999
1933 ENDIF
1934 ID=IDPAR(IPAR)
1935 IF (TMPAR(IPAR)) THEN
1936 IF (ID.LT.14) THEN
1937 ISTHEP(KHEP)=139
1938 ELSEIF (ID.EQ.59) THEN
1939 ISTHEP(KHEP)=139
1940 ELSEIF (ID.LT.109) THEN
1941 ISTHEP(KHEP)=130
1942 ELSEIF (ID.LT.120) THEN
1943 ISTHEP(KHEP)=139
1944 ELSEIF (ABS(IDPDG(ID)).LT.1000000) THEN
1945 ISTHEP(KHEP)=130
1946 ELSEIF (ID.LT.425) THEN
1947 ISTHEP(KHEP)=139
1948 ELSEIF (ID.EQ.449) THEN
1949 ISTHEP(KHEP)=139
1950 ELSE
1951 ISTHEP(KHEP)=130
1952 ENDIF
1953 ELSE
1954 ISTHEP(KHEP)=ISTHEP(IHEP)+24
1955 ENDIF
1956 IDHW(KHEP)=ID
1957 IDHEP(KHEP)=IDPDG(ID)
1958 CALL HWVEQU(5,PPAR(1,IPAR),PHEP(1,KHEP))
1959 CALL HWVEQU(4,VPAR(1,IPAR),VHEP(1,KHEP))
1960 JMOHEP(1,KHEP)=IJET
1961 JMOHEP(2,KHEP)=KHEP+1
1962 JDAHEP(1,KHEP)=0
1963 JDAHEP(2,KHEP)=KHEP-1
1964 20 CONTINUE
1965 JMOHEP(2,KHEP)=0
1966 JDAHEP(2,NHEP+1)=0
1967 JDAHEP(1,IJET)=NHEP+1
1968 JDAHEP(2,IJET)=KHEP
1969 NHEP=KHEP
1970 999 RETURN
1971 END
1972CDECK ID>, HWBGEN.
1973*CMZ :- -14/10/99 18.04.56 by Mike Seymour
1974*-- Author : Bryan Webber
1975C-----------------------------------------------------------------------
1976 SUBROUTINE HWBGEN
1977C-----------------------------------------------------------------------
1978C BRANCHING GENERATOR WITH INTERFERING GLUONS
1979C HWBGEN EVOLVES QCD JETS ACCORDING TO THE METHOD OF
1980C G.MARCHESINI & B.R.WEBBER, NUCL. PHYS. B238(1984)1
1981C-----------------------------------------------------------------------
c63d70bc 1982 INCLUDE 'herwig65.inc'
65767955 1983 DOUBLE PRECISION HWULDO,HWRGAU,EINHEP,ERTXI,RTXI,XF
1984 INTEGER NTRY,LASHEP,IHEP,NRHEP,ID,IST,JHEP,KPAR,I,J,IRHEP(NMXJET),
1985 & IRST(NMXJET),JPR
1986 LOGICAL HWRLOG
1987 EXTERNAL HWULDO,HWRGAU
1988 IF (IERROR.NE.0) RETURN
1989 IF (IPRO.EQ.80) RETURN
1990C---CHECK THAT EMSCA IS SET
1991 IF (EMSCA.LE.ZERO) CALL HWWARN('HWBGEN',200)
1992 IF (HARDME) THEN
1993C---FORCE A BRANCH INTO THE `DEAD ZONE' IN E+E-
1994 JPR=IPROC/10
1995C**********13/11/00 BRW FIX TO ALLOW ALSO WW AND ZZ
1996 IF (JPR.EQ.10.OR.JPR.EQ.20.OR.JPR.EQ.25) CALL HWBDED(1)
1997C**********END FIX
1998C---FORCE A BRANCH INTO THE `DEAD ZONE' IN DIS
1999 IF (IPRO.EQ.90) CALL HWBDIS(1)
2000C---FORCE A BRANCH INTO THE `DEAD ZONE' IN DRELL-YAN PROCESSES
2001 IF (IPRO.EQ.13.OR.IPRO.EQ.14) CALL HWBDYP(1)
2002C---FORCE A BRANCH INTO THE `DEAD ZONE' IN TOP DECAYS
2003 CALL HWBTOP
2004 ENDIF
2005C---GENERATE INTRINSIC PT ONCE AND FOR ALL
2006 DO 5 JNHAD=1,2
2007 IF (PTRMS.NE.0.) THEN
2008 PTINT(1,JNHAD)=HWRGAU(1,ZERO,PXRMS)
2009 PTINT(2,JNHAD)=HWRGAU(2,ZERO,PXRMS)
2010 PTINT(3,JNHAD)=PTINT(1,JNHAD)**2+PTINT(2,JNHAD)**2
2011 ELSE
2012 CALL HWVZRO(3,PTINT(1,JNHAD))
2013 ENDIF
2014 5 CONTINUE
2015 NTRY=0
2016 LASHEP=NHEP
2017 10 NTRY=NTRY+1
2018 IF (NTRY.GT.NETRY) THEN
2019 CALL HWWARN('HWBGEN',ISLENT*100)
2020 GOTO 999
2021 ENDIF
2022 NRHEP=0
2023 NHEP=LASHEP
2024 FROST=.FALSE.
2025 DO 100 IHEP=1,LASHEP
2026 IST=ISTHEP(IHEP)
2027 IF (IST.GE.111.AND.IST.LE.115) THEN
2028 NRHEP=NRHEP+1
2029 IRHEP(NRHEP)=IHEP
2030 IRST(NRHEP)=IST
2031 ID=IDHW(IHEP)
2032 IF (IST.NE.115) THEN
2033C---FOUND A PARTON TO EVOLVE
2034 NEVPAR=IHEP
2035 NPAR=2
2036 IDPAR(1)=17
2037 IDPAR(2)=ID
2038 TMPAR(1)=.TRUE.
2039 PPAR(2,1)=0.
2040 PPAR(4,1)=1.
2041 DO 15 J=1,2
2042 DO 15 I=1,2
2043 JMOPAR(I,J)=0
2044 15 JCOPAR(I,J)=0
2045C---SET UP EVOLUTION SCALE AND FRAME
2046 JHEP=JMOHEP(2,IHEP)
2047 IF (ID.EQ.13) THEN
2048 IF (HWRLOG(HALF)) JHEP=JDAHEP(2,IHEP)
2049 ELSEIF (IST.GT.112) THEN
2050 IF ((ID.GT.6.AND.ID.LT.13).OR.
2051 & (ID.GT.214.AND.ID.LT.221)) JHEP=JDAHEP(2,IHEP)
2052 ELSE
2053 IF (ID.LT.7.OR.(ID.GT.208.AND.ID.LT.215)) JHEP=JDAHEP(2,IHEP)
2054 ENDIF
2055 IF (JHEP.LE.0.OR.JHEP.GT.NHEP) THEN
2056 CALL HWWARN('HWBGEN',1)
2057 JHEP=IHEP
2058 ENDIF
2059 JCOPAR(1,1)=JHEP
2060 EINHEP=PHEP(4,IHEP)
2061 ERTXI=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))
2062 IF (ERTXI.LT.ZERO) ERTXI=0.
2063 IF (IST.LE.112.AND.IHEP.EQ.JHEP) ERTXI=0.
2064 IF (ISTHEP(JHEP).EQ.155) THEN
2065 ERTXI=ERTXI/PHEP(5,JHEP)
2066 RTXI=1.
2067 ELSE
2068 ERTXI=SQRT(ERTXI)
2069 RTXI=ERTXI/EINHEP
2070 ENDIF
2071 IF (RTXI.EQ.ZERO) THEN
2072 XF=1.
2073 PPAR(1,1)=0.
2074 PPAR(3,1)=1.
2075 PPAR(1,2)=EINHEP
2076 PPAR(2,2)=0.
2077 PPAR(4,2)=EINHEP
2078 ELSE
2079 XF=1./RTXI
2080 PPAR(1,1)=1.
2081 PPAR(3,1)=0.
2082 PPAR(1,2)=ERTXI
2083 PPAR(2,2)=1.
2084 PPAR(4,2)=ERTXI
2085 ENDIF
2086 IF (PPAR(4,2).LT.PHEP(5,IHEP)) PPAR(4,2)=PHEP(5,IHEP)
2087C---STORE MASS
2088 PPAR(5,2)=PHEP(5,IHEP)
2089 CALL HWVZRO(4,VPAR(1,1))
2090 CALL HWVZRO(4,VPAR(1,2))
2091 IF (IST.GT.112) THEN
2092 TMPAR(2)=.TRUE.
2093 INHAD=0
2094 JNHAD=0
2095 XFACT=0.
2096 ELSE
2097 TMPAR(2)=.FALSE.
2098 JNHAD=IST-110
2099 INHAD=JNHAD
2100 IF (JDAHEP(1,JNHAD).NE.0) INHAD=JDAHEP(1,JNHAD)
2101 XFACT=XF/PHEP(4,INHAD)
2102 ANOMSC(1,JNHAD)=ZERO
2103 ANOMSC(2,JNHAD)=ZERO
2104 ENDIF
2105C---FOR QUARKS IN A COLOUR SINGLET, ALLOW SOFT MATRIX-ELEMENT CORRECTION
2106 HARDST=PPAR(4,2)
2107 IF (SOFTME.AND.IDHW(IHEP).LT.13.AND.
2108 $ ((JMOHEP(2,JHEP).EQ.IHEP.AND.JDAHEP(2,JHEP).EQ.IHEP).OR.
2109 $ ISTHEP(JHEP).EQ.155)) HARDST=0
2110C---CREATE BRANCHES AND COMPUTE ENERGIES
2111 DO 20 KPAR=2,NMXPAR
2112 IF (TMPAR(KPAR)) THEN
2113 CALL HWBRAN(KPAR)
2114 ELSE
2115 CALL HWSBRN(KPAR)
2116 ENDIF
2117 IF (IERROR.NE.0) RETURN
2118 IF (FROST) GOTO 100
2119 IF (KPAR.EQ.NPAR) GOTO 30
2120 20 CONTINUE
2121C---COMPUTE MASSES AND 3-MOMENTA
2122 30 CONTINUE
2123 CALL HWBMAS
2124 IF (AZSPIN) CALL HWBSPN
2125 IF (TMPAR(2)) THEN
2126 CALL HWBTIM(2,1)
2127 ELSE
2128 CALL HWBSPA
2129 ENDIF
2130C---ENTER PARTON JET IN /HEPEVT/
2131 CALL HWBFIN(IHEP)
2132 ELSE
2133C---COPY SPECTATOR
2134 NHEP=NHEP+1
2135 IF (ID.GT.120.AND.ID.LT.133 .OR. ID.GE.198.AND.ID.LE.201) THEN
2136 ISTHEP(NHEP)=190
2137 ELSE
2138 ISTHEP(NHEP)=152
2139 ENDIF
2140 IDHW(NHEP)=ID
2141 IDHEP(NHEP)=IDPDG(ID)
2142 JMOHEP(1,NHEP)=IHEP
2143 JMOHEP(2,NHEP)=0
2144 JDAHEP(2,NHEP)=0
2145 JDAHEP(1,IHEP)=NHEP
2146 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
2147 ENDIF
2148 ISTHEP(IHEP)=ISTHEP(IHEP)+10
2149 ENDIF
2150 100 CONTINUE
2151 IF (.NOT.FROST) THEN
2152C---COMBINE JETS
2153 ISTAT=20
2154 CALL HWBJCO
2155 ENDIF
2156 IF (.NOT.FROST) THEN
2157C---ATTACH SPECTATORS
2158 ISTAT=30
2159 CALL HWSSPC
2160 ENDIF
2161 IF (FROST) THEN
2162C---BAD JET: RESTORE PARTONS AND RE-EVOLVE
2163 DO 120 I=1,NRHEP
2164 120 ISTHEP(IRHEP(I))=IRST(I)
2165 GOTO 10
2166 ENDIF
2167C---CONNECT COLOURS
2168 CALL HWBCON
2169 ISTAT=40
2170 LASHEP=NHEP
2171 IF (HARDME) THEN
2172C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN E+E-
2173 IF (IPROC/10.EQ.10) CALL HWBDED(2)
2174C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN DIS
2175 IF (IPRO.EQ.90) CALL HWBDIS(2)
2176C---CLEAN UP IF THERE WAS A BRANCH IN THE `DEAD ZONE' IN DRELL-YAN PROC
2177 IF (IPRO.EQ.13.OR.IPRO.EQ.14) CALL HWBDYP(2)
2178 ENDIF
2179C---IF THE CLEAN-UP OPERATION ADDED ANY PARTONS TO THE EVENT RECORD
2180C IT MIGHT NEED RESHOWERING
2181 IF (NHEP.GT.LASHEP) THEN
2182 LASHEP=NHEP
2183 GOTO 10
2184 ENDIF
2185 999 RETURN
2186 END
2187CDECK ID>, HWBGUP.
2188*CMZ :- -16/07/02 09.40.25 by Peter Richardson
2189*-- Author : Peter Richardson
2190C----------------------------------------------------------------------
2191 SUBROUTINE HWBGUP(ISTART,ICMF)
2192C----------------------------------------------------------------------
2193C Makes the colour connections and performs the parton shower
2194C for events read in from the GUPI (Generic User Process Interface)
2195C event common block
2196C----------------------------------------------------------------------
c63d70bc 2197 INCLUDE 'herwig65.inc'
65767955 2198 INTEGER MAXNUP
2199 PARAMETER (MAXNUP=500)
2200 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
2201 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
2202 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
2203 & IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
2204 & ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
2205 & SPINUP(MAXNUP)
2206C--Local variables
2207 INTEGER ISTART,ICMF,J,K,I,JCOL,ICOL
2208 LOGICAL FOUND
2209 COMMON /HWGUP/ILOC(NMXHEP),JLOC(MAXNUP)
2210 INTEGER ILOC,JLOC
2211C--now we need to do the colour connections
2212 20 ISTART = ISTART+1
2213 IF(ISTART.GT.NHEP) GOTO 30
2214 IF(ISTART.EQ.ICMF) ISTART = ISTART+1
2215 IF(JMOHEP(2,ISTART).NE.0.AND.JDAHEP(2,ISTART).NE.0) GOTO 20
2216 K = ISTART
2217 J = ILOC(K)
2218 IF(ICOLUP(1,J).NE.0) THEN
2219 JCOL = 1
2220 ICOL = ICOLUP(1,J)
2221 ELSE
2222 JCOL = 2
2223 ICOL = ICOLUP(2,J)
2224 ENDIF
2225 IF(ICOL.EQ.0) THEN
2226 JMOHEP(2,K) = K
2227 JDAHEP(2,K) = K
2228 GOTO 20
2229 ENDIF
2230C--now search for the partner
2231C--first search for the flavour partner if not looking for colour partner
2232C--search for the flavour partner of the particle
2233C--this must be set or HERWIG won't work
2234 10 IF(JDAHEP(2,K).NE.0.AND.JMOHEP(2,K).NE.0) GOTO 20
2235 IF(ICOL.EQ.0) THEN
2236 FOUND = .FALSE.
2237C--look for unpaired particle
2238 DO 15 I=1,NUP
2239 IF(JLOC(I).EQ.0) GOTO 15
2240 IF(IDUP(I).EQ.21.OR.IDUP(I).EQ.9) GOTO 15
2241 IF(JLOC(I).EQ.ISTART) GOTO 15
2242 IF(ICOLUP(1,I).EQ.0.AND.ICOLUP(2,I).EQ.0) GOTO 15
2243C--antiflavour partner
2244 IF(JDAHEP(2,JLOC(I)).EQ.0) THEN
2245C--pair incoming particle with outgoing particle
2246C-- or outgoing antiparticle with outgoing particle
2247 IF(ISTUP(I).GT.0.AND.IDUP(I).GT.0.AND.
2248 & ((IDUP(J).GT.0.AND.ISTUP(J).EQ.-1).OR.
2249 & (IDUP(J).LT.0.AND.ISTUP(J).GT.0 ))) THEN
2250 FOUND = .TRUE.
2251 JCOL = 1
2252C--pair incoming particle with incoming antiparticle
2253C-- or outgoing antiparticle with incoming antiparticle
2254 ELSEIF(IDUP(I).LT.0.AND.ISTUP(I).EQ.-1.AND.
2255 & ((IDUP(J).GT.0.AND.ISTUP(J).EQ.-1).OR.
2256 & (IDUP(J).LT.0.AND.ISTUP(J).GT.0 ))) THEN
2257 FOUND = .TRUE.
2258 JCOL = 2
2259 ENDIF
2260C--make the connection
2261 IF(FOUND) THEN
2262 JMOHEP(2,K) = JLOC(I)
2263 JDAHEP(2,JLOC(I)) = K
2264 ENDIF
2265 ENDIF
2266C--flavour partner
2267 IF(JMOHEP(2,JLOC(I)).EQ.0.AND.(.NOT.FOUND)) THEN
2268C--pair incoming antiparticle with outgoing antiparticle
2269C-- or outgoing particle with outgoing antiparticle
2270 IF(IDUP(I).LT.0.AND.ISTUP(I).GT.0.AND.
2271 & ((IDUP(J).LT.0.AND.ISTUP(J).EQ.-1).OR.
2272 & (IDUP(J).GT.0.AND.ISTUP(J).GT.0 ))) THEN
2273 FOUND = .TRUE.
2274 JCOL = 2
2275C--pair incoming antiparticle with incoming particle
2276C-- or outgoing particle with incoming particle
2277 ELSEIF(IDUP(I).GT.0.AND.ISTUP(I).EQ.-1.AND.
2278 & ((IDUP(J).LT.0.AND.ISTUP(J).EQ.-1).OR.
2279 & (IDUP(J).GT.0.AND.ISTUP(J).GT.0 ))) THEN
2280 FOUND = .TRUE.
2281 JCOL = 1
2282 ENDIF
2283C--make the connection
2284 IF(FOUND) THEN
2285 JDAHEP(2,K) = JLOC(I)
2286 JMOHEP(2,JLOC(I)) = K
2287 ENDIF
2288 ENDIF
2289C--set up the search for the next partner
2290 IF(FOUND) THEN
2291 FOUND = .FALSE.
2292 ICOL = ICOLUP(JCOL,I)
2293 K = JLOC(I)
2294 J = I
2295 GOTO 10
2296 ENDIF
2297 15 CONTINUE
2298C--if no other choice then connect to the first particle in the loop
2299 IF(JDAHEP(2,K).EQ.0.AND.JMOHEP(2,ISTART).EQ.0) THEN
2300 JDAHEP(2,K) = ISTART
2301 JMOHEP(2,ISTART) = K
2302 ELSEIF(JDAHEP(2,ISTART).EQ.0.AND.JMOHEP(2,K).EQ.0) THEN
2303 JMOHEP(2,K) = ISTART
2304 JDAHEP(2,ISTART) = K
2305 ELSE
2306 CALL HWWARN('HWBGUP',100)
2307 GOTO 999
2308 ENDIF
2309 GOTO 20
2310 ENDIF
2311C--now the bit to find colour partners
2312 FOUND = .FALSE.
2313C--special for particle from a decaying coloured particle
2314 IF(MOTHUP(1,J).NE.0) THEN
2315 IF(ISTUP(MOTHUP(1,J)).EQ.2.OR.ISTUP(MOTHUP(1,J)).EQ.3) THEN
2316 IF(IDUP(J).LT.0.AND.ICOL.EQ.ICOLUP(2,MOTHUP(1,J))) THEN
2317 JDAHEP(2,K) = JLOC(MOTHUP(1,J))
2318 JMOHEP(2,K) = JLOC(MOTHUP(1,J))
2319 GOTO 20
2320 ELSEIF(IDUP(J).GT.0.AND.ICOL.EQ.ICOLUP(1,MOTHUP(1,J))) THEN
2321 JDAHEP(2,K) = JLOC(MOTHUP(1,J))
2322 JMOHEP(2,K) = JLOC(MOTHUP(1,J))
2323 GOTO 20
2324 ENDIF
2325 ENDIF
2326 ENDIF
2327C--search for the partner
2328 DO I=1,NUP
2329 IF(ICOLUP(1,I).EQ.ICOL.AND.I.NE.J) THEN
2330 IF((JCOL.EQ.1.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).GT.0).OR.
2331 & (JCOL.EQ.2.AND.ISTUP(J).GT.0.AND.ISTUP(I).GE.0)) THEN
2332 JDAHEP(2,K) = JLOC(I)
2333 JMOHEP(2,JLOC(I)) = K
2334 FOUND = .TRUE.
2335 ELSEIF((JCOL.EQ.1.AND.ISTUP(J).GT.0.AND.ISTUP(I).EQ.-1).OR.
2336 & (JCOL.EQ.2.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).EQ.-1)) THEN
2337 JMOHEP(2,K) = JLOC(I)
2338 JDAHEP(2,JLOC(I)) = K
2339 FOUND = .TRUE.
2340 ENDIF
2341 IF(FOUND) JCOL = 2
2342 ELSEIF(ICOLUP(2,I).EQ.ICOL.AND.I.NE.J) THEN
2343 IF((JCOL.EQ.1.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).EQ.-1).OR.
2344 & (JCOL.EQ.2.AND.ISTUP(J).GT.0.AND.ISTUP(I).EQ.-1)) THEN
2345 JDAHEP(2,K) = JLOC(I)
2346 JMOHEP(2,JLOC(I)) = K
2347 FOUND = .TRUE.
2348 ELSEIF((JCOL.EQ.1.AND.ISTUP(J).GE.0.AND.ISTUP(I).GE.0).OR.
2349 & (JCOL.EQ.2.AND.ISTUP(J).EQ.-1.AND.ISTUP(I).GE.0)) THEN
2350 JMOHEP(2,K) = JLOC(I)
2351 JDAHEP(2,JLOC(I)) = K
2352 FOUND = .TRUE.
2353 ENDIF
2354 IF(FOUND) JCOL = 1
2355 ENDIF
2356 IF(FOUND) THEN
2357 K = JLOC(I)
2358 J = I
2359 ICOL = ICOLUP(JCOL,I)
2360 GOTO 10
2361 ENDIF
2362 ENDDO
2363C--special for self connected gluons
2364 IF(IDUP(J).EQ.21.OR.IDUP(J).EQ.9.AND.
2365 & ICOLUP(1,J).EQ.ICOLUP(2,J)) THEN
2366 JMOHEP(2,K) = K
2367 JDAHEP(2,K) = K
2368C--options for self connected gluons
2369 IF(LHGLSF) THEN
2370 CALL HWWARN('HWBGUP',1)
2371 ELSE
2372 CALL HWWARN('HWBGUP',101)
2373 GOTO 999
2374 ENDIF
2375 GOTO 20
2376 ENDIF
2377C--perform the shower
2378 30 CALL HWBGEN
2379 999 RETURN
2380 END
2381CDECK ID>, HWBJCO.
2382*CMZ :- -30/09/02 09.19.58 by Peter Richardson
2383*-- Author : Bryan Webber
2384C-----------------------------------------------------------------------
2385 SUBROUTINE HWBJCO
2386C-----------------------------------------------------------------------
2387C COMBINES JETS WITH REQUIRED KINEMATICS
2388C-----------------------------------------------------------------------
c63d70bc 2389 INCLUDE 'herwig65.inc'
65767955 2390 DOUBLE PRECISION HWULDO,EPS,PTX,PTY,PF,PTINF,PTCON,CN,CP,SP,PP0,
2391 & PM0,ET0,DET,ECM,EMJ,EMP,EMS,DMS,ES,DPF,ALF,AL(2),ET(2),PP(2),
2392 & PT(3),PA(5),PB(5),PC(5),PQ(5),PR(5),PS(5),RR(3,3),RS(3,3),ETC,
2393 & PJ(NMXJET),PM(NMXJET),PBR(5),RBR(3,3),DISP(4),PLAB(5)
2394 INTEGER LJET,IJ1,IST,IP,ICM,IP1,IP2,NP,IHEP,MHEP,JP,KP,LP,KHEP,
2395 & JHEP,NE,IJT,IEND(2),IJET(NMXJET),IPAR(NMXJET)
2396 LOGICAL AZCOR,JETRAD,DISPRO,DISLOW
2397 EXTERNAL HWULDO
2398 PARAMETER (EPS=1.D-4)
2399 IF (IERROR.NE.0) RETURN
2400 AZCOR=AZSOFT.OR.AZSPIN
2401 LJET=131
2402 10 IJET(1)=1
2403 20 IJ1=IJET(1)
2404 DO 40 IHEP=IJ1,NHEP
2405 IST=ISTHEP(IHEP)
2406 IF (IST.EQ.137.OR.IST.EQ.138) IST=133
2407 IF (IST.EQ.LJET) THEN
2408C---FOUND AN UNBOOSTED JET - FIND PARTNERS
2409 IP=JMOHEP(1,IHEP)
2410 ICM=JMOHEP(1,IP)
2411 DISPRO=IPRO/10.EQ.9.AND.IDHW(ICM).EQ.15
2412 DISLOW=DISPRO.AND.JDAHEP(1,ICM).EQ.JDAHEP(2,ICM)-1
2413 IF (IST.EQ.131) THEN
2414 IP1=JMOHEP(1,ICM)
2415 IP2=JMOHEP(2,ICM)
2416 ELSE
2417 IP1=JDAHEP(1,ICM)
2418 IP2=JDAHEP(2,ICM)
2419 ENDIF
2420 IF (IP1.NE.IP) THEN
2421 CALL HWWARN('HWBJCO',100)
2422 GOTO 999
2423 ENDIF
2424 NP=0
2425 DO 30 JHEP=IP1,IP2
2426 NP=NP+1
2427 IPAR(NP)=JHEP
2428 30 IJET(NP)=JDAHEP(1,JHEP)
2429 GOTO 50
2430 ENDIF
2431 40 CONTINUE
2432C---NO MORE JETS?
2433 IF (LJET.EQ.131) THEN
2434 LJET=133
2435 GOTO 10
2436 ENDIF
2437 RETURN
2438 50 IF (LJET.EQ.131) THEN
2439C---SPACELIKE JETS: FIND SPACELIKE PARTONS
2440 IF (NP.NE.2) THEN
2441 CALL HWWARN('HWBJCO',103)
2442 GOTO 999
2443 ENDIF
2444C---special for DIS: FIND BOOST AND ROTATION FROM LAB TO BREIT FRAME
2445 IF (DISPRO.AND.BREIT) THEN
2446 IP=2
2447 IF (JDAHEP(1,IP).NE.0) IP=JDAHEP(1,IP)
2448 CALL HWVDIF(4,PHEP(1,JMOHEP(1,ICM)),PHEP(1,JDAHEP(1,ICM)),PB)
2449 CALL HWUMAS(PB)
2450C---IF Q**2<10**-2, SOMETHING MUST HAVE ALREADY GONE WRONG
2451 IF (PB(5)**2.LT.1.D-2) THEN
2452 CALL HWWARN('HWBJCO',102)
2453 GOTO 999
2454 ENDIF
2455 CALL HWVSCA(4,PB(5)**2/HWULDO(PHEP(1,IP),PB),PHEP(1,IP),PBR)
2456 CALL HWVSUM(4,PB,PBR,PBR)
2457 CALL HWUMAS(PBR)
2458 CALL HWULOF(PBR,PB,PB)
2459 CALL HWUROT(PB,ONE,ZERO,RBR)
2460 ENDIF
2461 PTX=0.
2462 PTY=0.
2463 PF=1.D0
2464 DO 90 IP=1,2
2465 MHEP=IJET(IP)
2466 IF (JDAHEP(1,MHEP).EQ.0) THEN
2467C---SPECIAL FOR NON-PARTON JETS
2468 IHEP=MHEP
2469 GOTO 70
2470 ELSE
2471 IST=134+IP
2472 DO 60 IHEP=MHEP,NHEP
2473 60 IF (ISTHEP(IHEP).EQ.IST) GOTO 70
2474C---COULDN'T FIND SPACELIKE PARTON
2475 CALL HWWARN('HWBJCO',101)
2476 GOTO 999
2477 ENDIF
2478 70 CALL HWVSCA(3,PF,PHEP(1,IHEP),PS)
2479 IF (PTINT(3,IP).GT.ZERO) THEN
2480C---ADD INTRINSIC PT
2481 PT(1)=PTINT(1,IP)
2482 PT(2)=PTINT(2,IP)
2483 PT(3)=0.
2484 CALL HWUROT(PS, ONE,ZERO,RS)
2485 CALL HWUROB(RS,PT,PT)
2486 CALL HWVSUM(3,PS,PT,PS)
2487 ENDIF
2488 JP=IJET(IP)+1
2489 IF (AZCOR.AND.JP.LE.NHEP.AND.IDHW(JP).EQ.17) THEN
2490C---ALIGN CONE WITH INTERFERING PARTON
2491 CALL HWUROT(PS, ONE,ZERO,RS)
2492 CALL HWUROF(RS,PHEP(1,JP),PR)
2493 PTCON=PR(1)**2+PR(2)**2
2494 KP=JMOHEP(2,JP)
2495 IF (KP.EQ.0) THEN
2496 CALL HWWARN('HWBJCO',1)
2497 PTINF=0.
2498 ELSE
2499 CALL HWVEQU(4,PHEP(1,KP),PB)
2500 IF (DISPRO.AND.BREIT) THEN
2501 CALL HWULOF(PBR,PB,PB)
2502 CALL HWUROF(RBR,PB,PB)
2503 ENDIF
2504 PTINF=PB(1)**2+PB(2)**2
2505 IF (PTINF.LT.EPS) THEN
2506C---COLLINEAR JETS: ALIGN CONES
2507 KP=JDAHEP(1,KP)+1
2508C---BUG FIX BY MHS 17/03/05: RETURNED TO VERSION 6.500!
2509 IF (ISTHEP(KP).EQ.100.AND.ISTHEP(KP-1).GE.141
2510 $ .AND.ISTHEP(KP-1).LE.144) THEN
2511C---END FIX
2512 CALL HWVEQU(4,PHEP(1,KP),PB)
2513 IF (DISPRO.AND.BREIT) THEN
2514 CALL HWULOF(PBR,PB,PB)
2515 CALL HWUROF(RBR,PB,PB)
2516 ENDIF
2517 PTINF=PB(1)**2+PB(2)**2
2518 ELSE
2519 PTINF=0.
2520 ENDIF
2521 ENDIF
2522 ENDIF
2523 IF (PTCON.NE.ZERO.AND.PTINF.NE.ZERO) THEN
2524 CN=1./SQRT(PTINF*PTCON)
2525 CP=CN*(PR(1)*PB(1)+PR(2)*PB(2))
2526 SP=CN*(PR(1)*PB(2)-PR(2)*PB(1))
2527 ELSE
2528 CALL HWRAZM( ONE,CP,SP)
2529 ENDIF
2530 ELSE
2531 CALL HWRAZM( ONE,CP,SP)
2532 ENDIF
2533C---ROTATE SO SPACELIKE IS ALONG AXIS (APART FROM INTRINSIC PT)
2534 CALL HWUROT(PS,CP,SP,RS)
2535 IHEP=IJET(IP)
2536 KHEP=JDAHEP(2,IHEP)
2537 IF (KHEP.LT.IHEP) KHEP=IHEP
2538 IEND(IP)=KHEP
2539 DO 80 JHEP=IHEP,KHEP
2540 CALL HWUROF(RS,PHEP(1,JHEP),PHEP(1,JHEP))
2541 80 CALL HWUROF(RS,VHEP(1,JHEP),VHEP(1,JHEP))
2542 PP(IP)=PHEP(4,IHEP)+PF*PHEP(3,IHEP)
2543 ET(IP)=PHEP(1,IHEP)**2+PHEP(2,IHEP)**2-PHEP(5,IHEP)**2
2544C---REDEFINE HARD CM
2545 PTX=PTX+PHEP(1,IHEP)
2546 PTY=PTY+PHEP(2,IHEP)
2547 90 PF=-PF
2548 PHEP(1,ICM)=PTX
2549 PHEP(2,ICM)=PTY
2550C---special for DIS: keep lepton momenta fixed
2551 IF (DISPRO) THEN
2552 IP1=JMOHEP(1,ICM)
2553 IP2=JDAHEP(1,ICM)
2554 IJT=IJET(1)
2555C---IJT will be used to store lepton momentum transfer
2556 CALL HWVDIF(4,PHEP(1,IP1),PHEP(1,IP2),PHEP(1,IJT))
2557 CALL HWUMAS(PHEP(1,IJT))
2558 IF (IDHEP(IP1).EQ.IDHEP(IP2)) THEN
2559 IDHW(IJT)=200
2560 ELSEIF (IDHEP(IP1).LT.IDHEP(IP2)) THEN
2561 IDHW(IJT)=199
2562 ELSE
2563 IDHW(IJT)=198
2564 ENDIF
2565 IDHEP(IJT)=IDPDG(IDHW(IJT))
2566 ISTHEP(IJT)=3
2567C---calculate boost for struck parton
2568C PC is momentum of outgoing parton(s)
2569 IP2=JDAHEP(2,ICM)
2570 IF (.NOT.DISLOW) THEN
2571C---FOR heavy QQbar PQ and PC are old and new QQbar momenta
2572 CALL HWVSUM(4,PHEP(1,IP2-1),PHEP(1,IP2),PQ)
2573 CALL HWUMAS(PQ)
2574 PC(5)=PQ(5)
2575 ELSE
2576 PC(5)=PHEP(5,JDAHEP(1,IP2))
2577 ENDIF
2578 CALL HWVSUM(2,PHEP(1,IJT),PHEP(1,IJET(2)),PC)
2579 ET(1)=ET(2)
2580C---USE BREIT FRAME BOSON MOMENTUM IF NECESSARY
2581 IF (BREIT) THEN
2582 ET(2)=ET(1)+PC(5)**2+PHEP(5,IJET(2))**2
2583 PM0=PHEP(5,IJT)
2584 PP0=-PM0
2585 ELSE
2586 ET(2)=PC(1)**2+PC(2)**2+PC(5)**2
2587 PP0=PHEP(4,IJT)+PHEP(3,IJT)
2588 PM0=PHEP(4,IJT)-PHEP(3,IJT)
2589 ENDIF
2590 ET0=(PP0*PM0)+ET(1)-ET(2)
2591 DET=ET0**2-4.*(PP0*PM0)*ET(1)
2592 IF (DET.LT.ZERO) THEN
2593 FROST=.TRUE.
2594 RETURN
2595 ENDIF
2596 ALF=(SQRT(DET)-ET0)/(2.*PP0*PP(2))
2597 PB(1)=0.
2598 PB(2)=0.
2599 PB(5)=2.D0
2600 PB(3)=ALF-(1./ALF)
2601 PB(4)=ALF+(1./ALF)
2602 DO 100 IHEP=IJET(2),IEND(2)
2603 CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
2604 CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
2605C---BOOST FROM BREIT FRAME IF NECESSARY
2606 IF (BREIT) THEN
2607 CALL HWUROB(RBR,PHEP(1,IHEP),PHEP(1,IHEP))
2608 CALL HWULOB(PBR,PHEP(1,IHEP),PHEP(1,IHEP))
2609 CALL HWUROB(RBR,VHEP(1,IHEP),VHEP(1,IHEP))
2610 CALL HWULB4(PBR,VHEP(1,IHEP),VHEP(1,IHEP))
2611 ENDIF
2612 100 ISTHEP(IHEP)=ISTHEP(IHEP)+10
2613 CALL HWVDIF(4,VHEP(1,IPAR(2)),VHEP(1,IJET(2)),DISP)
2614 DO 110 IHEP=IJET(2),IEND(2)
2615 110 CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
2616 IF (IEND(2).GT.IJET(2)+1) ISTHEP(IJET(2)+1)=100
2617 CALL HWVSUM(4,PHEP(1,IJT),PHEP(1,IJET(2)),PC)
2618 CALL HWVSUM(4,PHEP(1,IP1),PHEP(1,IJET(2)),PHEP(1,ICM))
2619 CALL HWUMAS(PHEP(1,ICM))
2620 ELSEIF (IPRO/10.EQ.5) THEN
2621C Special to preserve photon momentum
2622 ETC=PTX**2+PTY**2+PHEP(5,ICM)**2
2623 ET0=ETC+ET(1)-ET(2)
2624 DET=ET0**2-4.*ETC*ET(1)
2625 IF (DET.LT.ZERO) THEN
2626 FROST=.TRUE.
2627 RETURN
2628 ENDIF
2629 ALF=(SQRT(DET)+ET0-2.*ET(1))/(2.*PP(1)*PP(2))
2630 PB(1)=0.
2631 PB(2)=0.
2632 PB(3)=ALF-1./ALF
2633 PB(4)=ALF+1./ALF
2634 PB(5)=2.
2635 IJT=IJET(2)
2636 DO 120 IHEP=IJT,IEND(2)
2637 CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
2638 CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
2639 120 ISTHEP(IHEP)=ISTHEP(IHEP)+10
2640 CALL HWVDIF(4,VHEP(1,IPAR(2)),VHEP(1,IJT),DISP)
2641 DO 130 IHEP=IJT,IEND(2)
2642 130 CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
2643 IF (IEND(2).GT.IJT+1) ISTHEP(IJT+1)=100
2644 ISTHEP(IJET(1))=ISTHEP(IJET(1))+10
2645 CALL HWVSUM(2,PHEP(3,IPAR(1)),PHEP(3,IJT),PHEP(3,ICM))
2646 ELSE
2647C--change to preserve either long mom or rapidity rather than long mom
2648C--by PR and BRW 30/9/02
2649 IF (PRESPL) THEN
2650C--PRESERVE LONG MOM OF CMF
2651 PHEP(4,ICM)=
2652 & SQRT(PTX**2+PTY**2+PHEP(3,ICM)**2+PHEP(5,ICM)**2)
2653 ELSE
2654C--PRESERVE RAPIDITY OF CMF
2655 DET=SQRT(ONE+(PTX**2+PTY**2)/(PHEP(4,ICM)**2
2656 & -PHEP(3,ICM)**2))
2657 CALL HWVSCA(2,DET,PHEP(3,ICM),PHEP(3,ICM))
2658 ENDIF
2659C---NOW BOOST TO REQUIRED Q**2 AND X-F
2660 PP0=PHEP(4,ICM)+PHEP(3,ICM)
2661 PM0=PHEP(4,ICM)-PHEP(3,ICM)
2662 ET0=(PP0*PM0)+ET(1)-ET(2)
2663 DET=ET0**2-4.*(PP0*PM0)*ET(1)
2664 IF (DET.LT.ZERO) THEN
2665 FROST=.TRUE.
2666 RETURN
2667 ENDIF
2668 DET=SQRT(DET)+ET0
2669 AL(1)= 2.*PM0*PP(1)/DET
2670 AL(2)=(PM0/PP(2))*(1.-2.*ET(1)/DET)
2671 PB(1)=0.
2672 PB(2)=0.
2673 PB(5)=2.
2674 DO 160 IP=1,2
2675 PB(3)=AL(IP)-(1./AL(IP))
2676 PB(4)=AL(IP)+(1./AL(IP))
2677 IJT=IJET(IP)
2678 DO 140 IHEP=IJT,IEND(IP)
2679 CALL HWULOF(PB,PHEP(1,IHEP),PHEP(1,IHEP))
2680 CALL HWULF4(PB,VHEP(1,IHEP),VHEP(1,IHEP))
2681 140 ISTHEP(IHEP)=ISTHEP(IHEP)+10
2682 CALL HWVDIF(4,VHEP(1,IPAR(IP)),VHEP(1,IJT),DISP)
2683 DO 150 IHEP=IJT,IEND(IP)
2684 150 CALL HWVSUM(4,DISP,VHEP(1,IHEP),VHEP(1,IHEP))
2685 IF (IEND(IP).GT.IJT+1) THEN
2686 ISTHEP(IJT+1)=100
2687 ELSEIF (IEND(IP).EQ.IJT) THEN
2688C---NON-PARTON JET
2689 ISTHEP(IJT)=3
2690 ENDIF
2691 160 CONTINUE
2692 ENDIF
2693 ISTHEP(ICM)=120
2694 ELSE
2695C---TIMELIKE JETS
2696C---SPECIAL CASE: IF HARD PROCESS IS W/Z DECAY, PERFORM KINEMATIC
2697C RECONSTRUCTION IN ITS REST FRAME INSTEAD OF THE LAB FRAME
2698 IF (IDHW(ICM).GE.198.AND.IDHW(ICM).LE.200.AND.WZRFR) THEN
2699 CALL HWVEQU(5,PHEP(1,ICM),PLAB)
2700 CALL HWULOF(PLAB,PHEP(1,ICM),PHEP(1,ICM))
2701 CALL HWULF4(PLAB,VHEP(1,ICM),VHEP(1,ICM))
2702 DO 165 IP=1,NP
2703 CALL HWULOF(PLAB,PHEP(1,IPAR(IP)),PHEP(1,IPAR(IP)))
2704 CALL HWULF4(PLAB,VHEP(1,IPAR(IP)),VHEP(1,IPAR(IP)))
2705 165 CONTINUE
2706 ENDIF
2707C special for DIS: preserve outgoing lepton momentum
2708 IF (DISPRO) THEN
2709 CALL HWVEQU(5,PHEP(1,IPAR(1)),PHEP(1,IJET(1)))
2710 ISTHEP(IJET(1))=1
2711 LP=2
2712 ELSE
2713 CALL HWVEQU(5,PHEP(1,ICM),PC)
2714C--- PQ AND PC ARE OLD AND NEW PARTON CM
2715 CALL HWVSUM(4,PHEP(1,IPAR(1)),PHEP(1,IPAR(2)),PQ)
2716 PQ(5)=PHEP(5,ICM)
2717 IF (NP.GT.2) THEN
2718 DO 170 KP=3,NP
2719 170 CALL HWVSUM(4,PHEP(1,IPAR(KP)),PQ,PQ)
2720 ENDIF
2721 LP=1
2722 ENDIF
2723 IF (.NOT.DISLOW) THEN
2724C---FIND JET CM MOMENTA
2725 ECM=PQ(5)
2726 EMS=0.
2727 JETRAD=.FALSE.
2728 DO 180 KP=LP,NP
2729 EMJ=PHEP(5,IJET(KP))
2730 EMP=PHEP(5,IPAR(KP))
2731 JETRAD=JETRAD.OR.EMJ.NE.EMP
2732 EMS=EMS+EMJ
2733 PM(KP)= EMJ**2
2734C---N.B. ROUNDING ERRORS HERE AT HIGH ENERGIES
2735 PJ(KP)=(HWULDO(PHEP(1,IPAR(KP)),PQ)/ECM)**2-EMP**2
2736 IF (PJ(KP).LE.ZERO) THEN
2737 CALL HWWARN('HWBJCO',104)
2738 GOTO 999
2739 ENDIF
2740 180 CONTINUE
2741 PF=1.
2742 IF (JETRAD) THEN
2743C---JETS DID RADIATE
2744 IF (EMS.GE.ECM) THEN
2745 FROST=.TRUE.
2746 GOTO 240
2747 ENDIF
2748 DO 200 NE=1,NETRY
2749 EMS=-ECM
2750 DMS=0.
2751 DO 190 KP=LP,NP
2752 ES=SQRT(PF*PJ(KP)+PM(KP))
2753 EMS=EMS+ES
2754 190 DMS=DMS+PJ(KP)/ES
2755 DPF=2.*EMS/DMS
2756 IF (DPF.GT.PF) DPF=0.9*PF
2757 PF=PF-DPF
2758 200 IF (ABS(DPF).LT.EPS) GOTO 210
2759 CALL HWWARN('HWBJCO',105)
2760 GOTO 999
2761 ENDIF
2762 210 CONTINUE
2763 ENDIF
2764C---BOOST PC AND PQ TO BREIT FRAME IF NECESSARY
2765 IF (DISPRO.AND.BREIT) THEN
2766 CALL HWULOF(PBR,PC,PC)
2767 CALL HWUROF(RBR,PC,PC)
2768 IF (.NOT.DISLOW) THEN
2769 CALL HWULOF(PBR,PQ,PQ)
2770 CALL HWUROF(RBR,PQ,PQ)
2771 ENDIF
2772 ENDIF
2773 DO 230 IP=LP,NP
2774C---FIND CM ROTATION FOR JET IP
2775 IF (.NOT.DISLOW) THEN
2776 CALL HWVEQU(4,PHEP(1,IPAR(IP)),PR)
2777 IF (DISPRO.AND.BREIT) THEN
2778 CALL HWULOF(PBR,PR,PR)
2779 CALL HWUROF(RBR,PR,PR)
2780 ENDIF
2781C--Modified by MHS 17/08/05 to do unboost in 2 stages (trans,long)
2782 PA(1)=PQ(1)
2783 PA(2)=PQ(2)
2784 PA(3)=ZERO
2785 PA(5)=SQRT(PQ(3)**2+PQ(5)**2)
2786 PA(4)=PQ(4)
2787 CALL HWULOF(PA,PR,PR)
2788 PA(1)=ZERO
2789 PA(2)=ZERO
2790 PA(3)=PQ(3)
2791 PA(4)=PA(5)
2792 PA(5)=PQ(5)
2793 CALL HWULOF(PA,PR,PR)
2794C--End mod
2795 CALL HWUROT(PR, ONE,ZERO,RR)
2796 PR(1)=ZERO
2797 PR(2)=ZERO
2798 PR(3)=SQRT(PF*PJ(IP))
2799 PR(4)=SQRT(PF*PJ(IP)+PM(IP))
2800 PR(5)=PHEP(5,IJET(IP))
2801 CALL HWUROB(RR,PR,PR)
2802C--Modified by BRW 25/10/02 to do boost in 2 stages (long,trans)
2803 PA(1)=ZERO
2804 PA(2)=ZERO
2805 PA(3)=PC(3)
2806 PA(5)=PC(5)
2807 PA(4)=SQRT(PA(3)**2+PA(5)**2)
2808 CALL HWULOB(PA,PR,PR)
2809 PA(1)=PC(1)
2810 PA(2)=PC(2)
2811 PA(3)=ZERO
2812 PA(5)=PA(4)
2813 PA(4)=PC(4)
2814 CALL HWULOB(PA,PR,PR)
2815C--End mod
2816 ELSE
2817 CALL HWVEQU(5,PC,PR)
2818 ENDIF
2819C---NOW PR IS LAB/BREIT MOMENTUM OF JET IP
2820 KP=IJET(IP)+1
2821 IF (AZCOR.AND.KP.LE.NHEP.AND.IDHW(KP).EQ.17) THEN
2822C---ALIGN CONE WITH INTERFERING PARTON
2823 CALL HWUROT(PR, ONE,ZERO,RS)
2824 JP=JMOHEP(2,KP)
2825 IF (JP.EQ.0) THEN
2826 CALL HWWARN('HWBJCO',2)
2827 PTINF=0.
2828 ELSE
2829 CALL HWVEQU(4,PHEP(1,JP),PS)
2830 IF (DISPRO.AND.BREIT) THEN
2831 CALL HWULOF(PBR,PS,PS)
2832 CALL HWUROF(RBR,PS,PS)
2833 ENDIF
2834 CALL HWUROF(RS,PS,PS)
2835 PTINF=PS(1)**2+PS(2)**2
2836 IF (PTINF.LT.EPS) THEN
2837C---COLLINEAR JETS: ALIGN CONES
2838 JP=JDAHEP(1,JP)+1
2839C---BUG FIX BY MHS 17/03/05: RETURNED TO VERSION 6.500!
2840 IF (ISTHEP(JP).EQ.100.AND.ISTHEP(JP-1).GE.141
2841 $ .AND.ISTHEP(JP-1).LE.144) THEN
2842C---END FIX
2843 CALL HWVEQU(4,PHEP(1,JP),PS)
2844 IF (DISPRO.AND.BREIT) THEN
2845 CALL HWULOF(PBR,PS,PS)
2846 CALL HWUROF(RBR,PS,PS)
2847 ENDIF
2848 CALL HWUROF(RS,PS,PS)
2849 PTINF=PS(1)**2+PS(2)**2
2850 ELSE
2851 PTINF=0.
2852 ENDIF
2853 ENDIF
2854 ENDIF
2855 CALL HWVEQU(4,PHEP(1,KP),PB)
2856 IF (DISPRO.AND.BREIT) THEN
2857 CALL HWULOF(PBR,PB,PB)
2858 CALL HWUROF(RBR,PB,PB)
2859 ENDIF
2860 PTCON=PB(1)**2+PB(2)**2
2861 IF (PTCON.NE.ZERO.AND.PTINF.NE.ZERO) THEN
2862 CN=1./SQRT(PTINF*PTCON)
2863 CP=CN*(PS(1)*PB(1)+PS(2)*PB(2))
2864 SP=CN*(PS(1)*PB(2)-PS(2)*PB(1))
2865 ELSE
2866 CALL HWRAZM( ONE,CP,SP)
2867 ENDIF
2868 ELSE
2869 CALL HWRAZM( ONE,CP,SP)
2870 ENDIF
2871 CALL HWUROT(PR,CP,SP,RS)
2872C---FIND BOOST FOR JET IP
2873 ALF=(PHEP(3,IJET(IP))+PHEP(4,IJET(IP)))/
2874 & (PR(4)+SQRT((PR(4)+PR(5))*(PR(4)-PR(5))))
2875 PB(1)=0.
2876 PB(2)=0.
2877 PB(3)=ALF-(1./ALF)
2878 PB(4)=ALF+(1./ALF)
2879 PB(5)=2.
2880 IHEP=IJET(IP)
2881 KHEP=JDAHEP(2,IHEP)
2882 IF (KHEP.LT.IHEP) KHEP=IHEP
2883 DO 220 JHEP=IHEP,KHEP
2884 CALL HWULOF(PB,PHEP(1,JHEP),PHEP(1,JHEP))
2885 CALL HWUROB(RS,PHEP(1,JHEP),PHEP(1,JHEP))
2886 CALL HWULF4(PB,VHEP(1,JHEP),VHEP(1,JHEP))
2887 CALL HWUROB(RS,VHEP(1,JHEP),VHEP(1,JHEP))
2888C---BOOST FROM BREIT FRAME IF NECESSARY
2889 IF (DISPRO.AND.BREIT) THEN
2890 CALL HWUROB(RBR,PHEP(1,JHEP),PHEP(1,JHEP))
2891 CALL HWULOB(PBR,PHEP(1,JHEP),PHEP(1,JHEP))
2892 CALL HWUROB(RBR,VHEP(1,JHEP),VHEP(1,JHEP))
2893 CALL HWULB4(PBR,VHEP(1,JHEP),VHEP(1,JHEP))
2894 ENDIF
2895 CALL HWVSUM(4,VHEP(1,JHEP),VHEP(1,IPAR(IP)),VHEP(1,JHEP))
2896C--MHS FIX 07/03/05 FOR VERTEX POSITION OF LONG LIVED NON-PARTON JETS
2897 IF (KHEP.EQ.IHEP.AND.(IDHW(JHEP).GE.121.AND.IDHW(JHEP).LE.132
2898 $ .OR.IDHW(JHEP).EQ.59))
2899 $ CALL HWVSUM(4,VTXPIP,VHEP(1,JHEP),VHEP(1,JHEP))
2900C--END FIX
2901 220 ISTHEP(JHEP)=ISTHEP(JHEP)+10
2902 IF (KHEP.GT.IHEP+1) THEN
2903 ISTHEP(IHEP+1)=100
2904 ELSEIF (KHEP.EQ.IHEP) THEN
2905C---NON-PARTON JET
2906 ISTHEP(IHEP)=190
2907 ENDIF
2908 230 CONTINUE
2909 IF (ISTHEP(ICM).EQ.110) ISTHEP(ICM)=120
2910C---SPECIAL CASE: FOR W/Z DECAY BOOST BACK TO THE LAB FRAME
2911 240 IF (IDHW(ICM).GE.198.AND.IDHW(ICM).LE.200.AND.WZRFR) THEN
2912 CALL HWULOB(PLAB,PHEP(1,ICM),PHEP(1,ICM))
2913 CALL HWULB4(PLAB,VHEP(1,ICM),VHEP(1,ICM))
2914 DO 260 IP=1,NP
2915 CALL HWULOB(PLAB,PHEP(1,IPAR(IP)),PHEP(1,IPAR(IP)))
2916 CALL HWULB4(PLAB,VHEP(1,IPAR(IP)),VHEP(1,IPAR(IP)))
2917 CALL HWULOB(PLAB,PHEP(1,IJET(IP)),PHEP(1,IJET(IP)))
2918C--MHS FIX 07/03/05 - DO NOT REBOOST PRIMARY VERTEX
2919 IF (ISTHEP(IJET(IP)).EQ.190)
2920 $ CALL HWVDIF(4,VHEP(1,IJET(IP)),VTXPIP,VHEP(1,IJET(IP)))
2921 CALL HWULB4(PLAB,VHEP(1,IJET(IP)),VHEP(1,IJET(IP)))
2922 IF (ISTHEP(IJET(IP)).EQ.190)
2923 $ CALL HWVSUM(4,VHEP(1,IJET(IP)),VTXPIP,VHEP(1,IJET(IP)))
2924C---END FIX
2925 IF (JDAHEP(1,IJET(IP)).GT.0) THEN
2926 IF (JDAHEP(2,IJET(IP)).GT.JDAHEP(1,IJET(IP))) THEN
2927 CALL HWULOB(PLAB,PHEP(1,IJET(IP)+1),PHEP(1,IJET(IP)+1))
2928 CALL HWULB4(PLAB,VHEP(1,IJET(IP)+1),VHEP(1,IJET(IP)+1))
2929 ENDIF
2930 DO 250 IHEP=JDAHEP(1,IJET(IP)),JDAHEP(2,IJET(IP))
2931 CALL HWULOB(PLAB,PHEP(1,IHEP),PHEP(1,IHEP))
2932 CALL HWULB4(PLAB,VHEP(1,IHEP),VHEP(1,IHEP))
2933 250 CONTINUE
2934 ENDIF
2935 260 CONTINUE
2936 ENDIF
2937 IF (FROST) RETURN
2938 ENDIF
2939 GOTO 20
2940 999 RETURN
2941 END
2942CDECK ID>, HWBMAS.
2943*CMZ :- -26/04/91 11.11.54 by Bryan Webber
2944*-- Author : Bryan Webber
2945C-----------------------------------------------------------------------
2946 SUBROUTINE HWBMAS
2947C-----------------------------------------------------------------------
2948C Passes backwards through a jet cascade calculating the masses
2949C and magnitudes of the longitudinal and transverse three momenta.
2950C Components given relative to direction of parent for a time-like
2951C vertex and with respect to z-axis for space-like vertices.
2952C
2953C On input PPAR(1-5,*) contains:
2954C (E*sqrt(Xi),Xi,3-mom (if external),E,M-sq (if external))
2955C
2956C On output PPAR(1-5,*) (if TMPAR(*)), containts:
2957C (P-trans,Xi or Xilast,P-long,E,M)
2958C-----------------------------------------------------------------------
c63d70bc 2959 INCLUDE 'herwig65.inc'
65767955 2960 DOUBLE PRECISION HWUSQR,EXI,PISQ,PJPK,EJEK,PTSQ,Z,ZMIN,ZMAX,
2961 $ EMI,EMJ,EMK,C,NQ,HWBVMC,RHO,POLD,PNEW,EOLD,ENEW,A,B
2962 INTEGER IPAR,JPAR,KPAR,MPAR,I,J,K
2963 EXTERNAL HWUSQR
2964 IF (IERROR.NE.0) RETURN
2965 IF (NPAR.GT.2) THEN
2966 DO 30 MPAR=NPAR-1,3,-2
2967 JPAR=MPAR
2968C Find parent and partner of this branch
2969 IPAR=JMOPAR(1,JPAR)
2970 KPAR=JPAR+1
2971C Determine type of branching
2972 IF (TMPAR(IPAR)) THEN
2973C Time-like branching
2974C Compute mass of parent
2975 EXI=PPAR(1,JPAR)*PPAR(1,KPAR)
2976 PPAR(5,IPAR)=PPAR(5,JPAR)+PPAR(5,KPAR)+2.*EXI
2977C Compute three momentum of parent
2978 PISQ=PPAR(4,IPAR)*PPAR(4,IPAR)-PPAR(5,IPAR)
2979 PPAR(3,IPAR)=HWUSQR(PISQ)
2980C---SPECIAL FOR G-->QQBAR: READJUST ANGULAR DISTRIBUTION
2981 IF (IDPAR(IPAR).EQ.13 .AND. IDPAR(JPAR).LT.13) THEN
2982 Z=PPAR(4,JPAR)/PPAR(4,IPAR)
2983 ZMIN=HWBVMC(IDPAR(JPAR))/PPAR(1,JPAR)*Z
2984 RHO=(Z*(3-Z*(3-2*Z))-ZMIN*(3-ZMIN*(3-2*ZMIN)))
2985 $ /(2*(1-2*ZMIN)*(1-ZMIN*(1-ZMIN)))
2986 NQ=PPAR(3,IPAR)*(PPAR(3,IPAR)+PPAR(4,IPAR))
2987 EMI=PPAR(5,IPAR)
2988 EMJ=PPAR(5,JPAR)
2989 EMK=PPAR(5,KPAR)
2990 ZMIN=MAX((EMI+EMJ-EMK)/(2*(EMI+NQ)),
2991 $ (EMI+EMJ-EMK-SQRT(ABS((EMI-EMJ-EMK)**2-4*EMJ*EMK)))/(2*EMI))
2992 ZMAX=1-MAX((EMI-EMJ+EMK)/(2*(EMI+NQ)),
2993 $ (EMI-EMJ+EMK-SQRT(ABS((EMI-EMJ-EMK)**2-4*EMJ*EMK)))/(2*EMI))
2994 C=2*RMASS(IDPAR(JPAR))**2/EMI
2995 Z=(4*ZMIN*(1.5*(1+C-ZMIN)+ZMIN**2)*(1-RHO)
2996 $ +4*ZMAX*(1.5*(1+C-ZMAX)+ZMAX**2)*RHO-2-3*C)/(1+2*C)**1.5
2997 Z=SQRT(1+2*C)*SINH(LOG(Z+SQRT(Z**2+1))/3)+0.5
2998 Z=(Z*NQ+(EMI+EMJ-EMK)/2)/(NQ+EMI)
2999 PPAR(4,JPAR)=Z*PPAR(4,IPAR)
3000 PPAR(4,KPAR)=PPAR(4,IPAR)-PPAR(4,JPAR)
3001 PPAR(3,JPAR)=HWUSQR(PPAR(4,JPAR)**2-EMJ)
3002 PPAR(3,KPAR)=HWUSQR(PPAR(4,KPAR)**2-EMK)
3003 PPAR(2,JPAR)=EXI/(PPAR(4,JPAR)*PPAR(4,KPAR))
3004 IF(JDAPAR(2,JPAR).NE.0)PPAR(2,JDAPAR(2,JPAR))=PPAR(2,JPAR)
3005 IF(JDAPAR(2,KPAR).NE.0)PPAR(2,JDAPAR(2,KPAR))=PPAR(2,JPAR)
3006C---FIND DESCENDENTS OF THIS SPLITTING AND READJUST THEIR MOMENTA TOO
3007 DO 20 J=JPAR+2,NPAR-1,2
3008 I=J
3009 10 I=JMOPAR(1,I)
3010 IF (I.GT.IPAR) GOTO 10
3011 IF (I.EQ.IPAR) THEN
3012 I=JMOPAR(1,J)
3013 K=J+1
3014 POLD=PPAR(3,J)+PPAR(3,K)
3015 EOLD=PPAR(4,J)+PPAR(4,K)
3016 PNEW=HWUSQR(PPAR(4,I)**2-PPAR(5,I))
3017 ENEW=PPAR(4,I)
3018 A=(ENEW*EOLD-PNEW*POLD)/PPAR(5,I)
3019 B=(PNEW*EOLD-ENEW*POLD)/PPAR(5,I)
3020 PPAR(3,J)=A*PPAR(3,J)+B*PPAR(4,J)
3021 PPAR(4,J)=(PPAR(4,J)+B*PPAR(3,J))/A
3022 PPAR(3,K)=PNEW-PPAR(3,J)
3023 PPAR(4,K)=ENEW-PPAR(4,J)
3024 PPAR(2,J)=1-(PPAR(3,J)*PPAR(3,K)+PPAR(1,J)*PPAR(1,K))
3025 $ /(PPAR(4,J)*PPAR(4,K))
3026 IF (JDAPAR(2,J).NE.0) PPAR(2,JDAPAR(2,J))=PPAR(2,J)
3027 IF (JDAPAR(2,K).NE.0) PPAR(2,JDAPAR(2,K))=PPAR(2,J)
3028 ENDIF
3029 20 CONTINUE
3030 ENDIF
3031C Compute daughter' transverse and longitudinal momenta
3032 PJPK=PPAR(3,JPAR)*PPAR(3,KPAR)
3033 EJEK=PPAR(4,JPAR)*PPAR(4,KPAR)-EXI
3034 PTSQ=(PJPK+EJEK)*(PJPK-EJEK)/PISQ
3035 PPAR(1,JPAR)=HWUSQR(PTSQ)
3036 PPAR(3,JPAR)=HWUSQR(PPAR(3,JPAR)*PPAR(3,JPAR)-PTSQ)
3037 PPAR(1,KPAR)=-PPAR(1,JPAR)
3038 PPAR(3,KPAR)= PPAR(3,IPAR)-PPAR(3,JPAR)
3039 ELSE
3040C Space-like branching
3041C Re-arrange such that JPAR is time-like
3042 IF (TMPAR(KPAR)) THEN
3043 KPAR=JPAR
3044 JPAR=JPAR+1
3045 ENDIF
3046C Compute time-like branch
3047 PTSQ=(2.-PPAR(2,JPAR))*PPAR(1,JPAR)*PPAR(1,JPAR)
3048 & -PPAR(5,JPAR)
3049 PPAR(1,JPAR)=HWUSQR(PTSQ)
3050 PPAR(3,JPAR)=(1.-PPAR(2,JPAR))*PPAR(4,JPAR)
3051 PPAR(3,IPAR)=PPAR(3,KPAR)-PPAR(3,JPAR)
3052 PPAR(5,IPAR)=0.
3053 PPAR(1,KPAR)=0.
3054 ENDIF
3055C Reset Xi to Xilast
3056 PPAR(2,KPAR)=PPAR(2,IPAR)
3057 30 CONTINUE
3058 ENDIF
3059 DO 40 IPAR=2,NPAR
3060 40 PPAR(5,IPAR)=HWUSQR(PPAR(5,IPAR))
3061 PPAR(1,2)=0.
3062 PPAR(2,2)=0.
3063 END
3064CDECK ID>, HWBRAN.
3065*CMZ :- -14/10/99 18.04.56 by Mike Seymour
3066*-- Author : Bryan Webber & Mike Seymour
3067C-----------------------------------------------------------------------
3068 SUBROUTINE HWBRAN(KPAR)
3069C-----------------------------------------------------------------------
3070C BRANCHES TIMELIKE PARTON KPAR INTO TWO, PUTS PRODUCTS
3071C INTO NPAR+1 AND NPAR+2, AND INCREASES NPAR BY TWO
3072C-----------------------------------------------------------------------
c63d70bc 3073 INCLUDE 'herwig65.inc'
65767955 3074 DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUTAB,HWRUNI,HWULDO,PMOM,
3075 & QNOW,QLST,QKTHR,RN,QQBAR,DQQ,QGTHR,SNOW,QSUD,ZMIN,ZMAX,ZRAT,WMIN,
3076 & QLAM,Z1,Z2,ETEST,ZTEST,ENOW,XI,XIPREV,EPREV,QMAX,QGAM,SLST,SFNL,
3077 & TARG,ALF,BETA0(3:6),BETAP(3:6),SQRK(4:6,5),REJFAC,Z,X1,X2,OTHXI,
3078 & OTHZ,X3,FF,AW,XCUT,CC,JJ,HWUSQR
3079 INTEGER HWRINT,KPAR,ID,JD,IS,NTRY,N,ID1,ID2,MPAR,ISUD(13),IHEP,
3080 & JHEP,M,NF,NN,IREJ,NREJ,ITOP
3081 EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUTAB,HWRUNI,HWULDO,HWRINT,HWUSQR
3082 SAVE BETA0,BETAP,SQRK
3083 SAVE ISUD
3084 DATA ISUD,BETA0/2,2,3,4,5,6,2,2,3,4,5,6,1,4*ZERO/
3085 IF (IERROR.NE.0) RETURN
3086C---SET SQRK(M,N) TO THE PROBABILITY THAT A GLUON WILL NOT PRODUCE A
3087C QUARK-ANTIQUARK PAIR BETWEEN SCALES RMASS(M) AND 2*HWBVMC(N)
3088 IF (SUDORD.NE.1.AND.BETA0(3).EQ.ZERO) THEN
3089 DO 100 M=3,6
3090 BETA0(M)=(11.*CAFAC-2.*M)*0.5
3091 100 BETAP(M)=(17.*CAFAC**2-(5.*CAFAC+3.*CFFAC)*M)
3092 & /BETA0(M)*0.25/PIFAC
3093 DO 120 N=1,5
3094 DO 110 M=4,6
3095 IF (M.LE.N) THEN
3096 SQRK(M,N)=ONE
3097 ELSEIF (M.EQ.4.OR.M.EQ.N+1) THEN
3098 NF=M
3099 IF (2*HWBVMC(N).GT.RMASS(M)) NF=M+1
3100 SQRK(M,N)=((BETAP(NF-1)+1/HWUALF(1,2*HWBVMC(N)))/
3101 $ (BETAP(NF-1)+1/HWUALF(1,RMASS(M))))**(1/BETA0(NF-1))
3102 ELSE
3103 SQRK(M,N)=SQRK(M-1,N)*
3104 $ ((BETAP(M-1)+1/HWUALF(1,RMASS(M-1)))/
3105 $ (BETAP(M-1)+1/HWUALF(1,RMASS(M))))**(1/BETA0(M-1))
3106 ENDIF
3107 110 CONTINUE
3108 120 CONTINUE
3109 ENDIF
3110 ID=IDPAR(KPAR)
3111C--TEST FOR PARTON TYPE
3112 IF (ID.LE.13) THEN
3113 JD=ID
3114 IS=ISUD(ID)
3115 ELSEIF (ID.GE.209.AND.ID.LE.220) THEN
3116 JD=ID-208
3117 IS=7
3118 ELSE
3119 IS=0
3120 END IF
3121 QNOW=-1.
3122 IF (IS.NE.0) THEN
3123C--TIMELIKE PARTON BRANCHING
3124 ENOW=PPAR(4,KPAR)
3125 XIPREV=PPAR(2,KPAR)
3126 IF (JMOPAR(1,KPAR).EQ.0) THEN
3127 EPREV=PPAR(4,KPAR)
3128 ELSE
3129 EPREV=PPAR(4,JMOPAR(1,KPAR))
3130 ENDIF
3131C--IF THIS IS CHARGED & PHOTONS ARE ALLOWED, ANGLES MIGHT NOT BE ORDERED
3132 QMAX=0
3133 QLST=PPAR(1,KPAR)
3134 IF (ICHRG(ID).NE.0 .AND. VPCUT.LT.PPAR(1,2)) THEN
3135C--LOOK FOR A PREVIOUS G->QQBAR, IF ANY
3136 MPAR=KPAR
3137 1 IF (JMOPAR(1,MPAR).NE.0) THEN
3138 IF (IDPAR(JMOPAR(1,MPAR)).EQ.ID) THEN
3139 MPAR=JMOPAR(1,MPAR)
3140 GOTO 1
3141 ENDIF
3142 ENDIF
3143C--IF CLIMBED TO THE TOP OF THE LIST, FIND QED INTERFERENCE PARTNER
3144 IF (MPAR.EQ.2) THEN
3145 JHEP=0
3146 IF (ID.LT.7) THEN
3147 IHEP=JDAHEP(2,JCOPAR(1,1))
3148 IF (IHEP.GT.0) JHEP=JDAHEP(2,IHEP)
3149 ELSE
3150 IHEP=JMOHEP(2,JCOPAR(1,1))
3151 IF (IHEP.GT.0) JHEP=JMOHEP(2,IHEP)
3152 ENDIF
3153 IF (IHEP.GT.0.AND.JHEP.GT.0) THEN
3154 QMAX=HWULDO(PHEP(1,IHEP),PHEP(1,JHEP))
3155 & *(ENOW/PPAR(4,2))**2
3156 ELSE
3157C--FIX AT HARD PROCESS SCALE IF POINTER NOT YET SET
3158C (CAN HAPPEN IN SUSY EVENTS)
3159 QMAX=EMSCA**2
3160 ENDIF
3161 ELSE
3162 QMAX=ENOW**2*PPAR(2,MPAR)
3163 ENDIF
3164C--IF PREVIOUS BRANCHING WAS Q->QGAMMA, LOOK FOR A QCD BRANCHING
3165 MPAR=KPAR
3166 2 IF (JMOPAR(1,MPAR).NE.0) THEN
3167 IF (IDPAR(JDAPAR(1,JMOPAR(1,MPAR))).EQ.59 .OR.
3168 & IDPAR(JDAPAR(2,JMOPAR(1,MPAR))).EQ.59) THEN
3169 MPAR=JMOPAR(1,MPAR)
3170 GOTO 2
3171 ENDIF
3172 ENDIF
3173 QLST=ENOW**2*PPAR(2,MPAR)
3174 QMAX=SQRT(MAX(ZERO,MIN(
3175 & QMAX , EPREV**2*XIPREV , ENOW**2*XIPREV*(2-XIPREV))))
3176 QLST=SQRT(MIN(
3177 & QLST , EPREV**2*XIPREV , ENOW**2*XIPREV*(2-XIPREV)))
3178 ENDIF
3179 NTRY=0
3180 5 NTRY=NTRY+1
3181 IF (NTRY.GT.NBTRY) THEN
3182 CALL HWWARN('HWBRAN',100)
3183 GOTO 999
3184 ENDIF
3185 IF (ID.EQ.13) THEN
3186C--GLUON -> QUARK+ANTIQUARK OPTION
3187 IF (QLST.GT.QCDL3) THEN
3188 DO 8 N=1,NFLAV
3189 QKTHR=2.*HWBVMC(N)
3190 IF (QLST.GT.QKTHR) THEN
3191 RN=HWRGEN(N)
3192 IF (SUDORD.NE.1) THEN
3193C---FIND IN WHICH FLAVOUR INTERVAL THE UPPER LIMIT LIES
3194 NF=3
3195 DO 200 M=MAX(3,N),NFLAV
3196 200 IF (QLST.GT.RMASS(M)) NF=M
3197C---CALCULATE THE FORM FACTOR
3198 IF (NF.EQ.MAX(3,N)) THEN
3199 SFNL=((BETAP(NF)+1/HWUALF(1,QKTHR))/
3200 $ (BETAP(NF)+1/HWUALF(1,QLST)))**(1/BETA0(NF))
3201 SLST=SFNL
3202 ELSE
3203 SFNL=((BETAP(NF)+1/HWUALF(1,RMASS(NF)))/
3204 $ (BETAP(NF)+1/HWUALF(1,QLST)))**(1/BETA0(NF))
3205 SLST=SFNL*SQRK(NF,N)
3206 ENDIF
3207 ENDIF
3208 IF (RN.GT.1.E-3) THEN
3209 QQBAR=QCDL3*(QLST/QCDL3)**(RN**BETAF)
3210 ELSE
3211 QQBAR=QCDL3
3212 ENDIF
3213 IF (SUDORD.NE.1) THEN
3214C---FIND IN WHICH FLAVOUR INTERVAL THE SOLUTION LIES
3215 IF (RN.GE.SFNL) THEN
3216 NN=NF
3217 ELSEIF (RN.GE.SLST) THEN
3218 NN=MAX(3,N)
3219 DO 210 M=MAX(3,N)+1,NF-1
3220 210 IF (RN.GE.SLST/SQRK(M,N)) NN=M
3221 ELSE
3222 NN=0
3223 QQBAR=QCDL3
3224 ENDIF
3225 IF (NN.GT.0) THEN
3226 IF (NN.EQ.NF) THEN
3227 TARG=HWUALF(1,QLST)
3228 ELSE
3229 TARG=HWUALF(1,RMASS(NN+1))
3230 RN=RN/SLST*SQRK(NN+1,N)
3231 ENDIF
3232 TARG=1/((BETAP(NN)+1/TARG)*RN**BETA0(NN)-BETAP(NN))
3233C---NOW SOLVE HWUALF(1,QQBAR)=TARG FOR QQBAR ITERATIVELY
3234 7 QQBAR=MAX(QQBAR,HALF*QKTHR)
3235 ALF=HWUALF(1,QQBAR)
3236 IF (ABS(ALF-TARG).GT.ACCUR) THEN
3237 NTRY=NTRY+1
3238 IF (NTRY.GT.NBTRY) THEN
3239 CALL HWWARN('HWBRAN',101)
3240 GOTO 999
3241 ENDIF
3242 QQBAR=QQBAR*(1+3*PIFAC*(ALF-TARG)
3243 $ /(BETA0(NN)*ALF**2*(1+BETAP(NN)*ALF)))
3244 GOTO 7
3245 ENDIF
3246 ENDIF
3247 ENDIF
3248 IF (QQBAR.GT.QNOW.AND.QQBAR.GT.QKTHR) THEN
3249 QNOW=QQBAR
3250 ID2=N
3251 ENDIF
3252 ELSE
3253 GOTO 9
3254 ENDIF
3255 8 CONTINUE
3256 ENDIF
3257C--GLUON->DIQUARKS OPTION
3258 9 IF (QLST.LT.QDIQK) THEN
3259 IF (PDIQK.NE.ZERO) THEN
3260 RN=HWRGEN(0)
3261 DQQ=QLST*EXP(-RN/PDIQK)
3262 IF (DQQ.GT.QNOW) THEN
3263 IF (DQQ.GT.2.*RMASS(115)) THEN
3264 QNOW=DQQ
3265 ID2=115
3266 ENDIF
3267 ENDIF
3268 ENDIF
3269 ENDIF
3270 ENDIF
3271C--ENHANCE GLUON AND PHOTON EMISSION BY A FACTOR OF TWO IF THIS BRANCH
3272C IS CAPABLE OF BEING THE HARDEST SO FAR
3273 NREJ=1
3274 IF (TMPAR(2).AND.0.25*MAX(QLST,QMAX).GT.HARDST) NREJ=2
3275C--BRANCHING ID->ID+GLUON
3276 QGTHR=HWBVMC(ID)+HWBVMC(13)
3277 IF (QLST.GT.QGTHR) THEN
3278 DO 300 IREJ=1,NREJ
3279 RN=HWRGEN(1)
3280 SLST=HWUTAB(SUD(1,IS),QEV(1,IS),NQEV,QLST,INTER)
3281 IF (RN.EQ.ZERO) THEN
3282 SNOW=2.
3283 ELSE
3284 SNOW=SLST/RN
3285 ENDIF
3286 IF (SNOW.LT.ONE) THEN
3287 QSUD=HWUTAB(QEV(1,IS),SUD(1,IS),NQEV,SNOW,INTER)
3288C---IF FORM FACTOR DID NOT GET INVERTED CORRECTLY TRY LINEAR INSTEAD
3289 IF (QSUD.GT.QLST) THEN
3290 SNOW=HWUTAB(SUD(1,IS),QEV(1,IS),NQEV,QLST,1)/RN
3291 QSUD=HWUTAB(QEV(1,IS),SUD(1,IS),NQEV,SNOW,1)
3292 IF (QSUD.GT.QLST) THEN
3293 CALL HWWARN('HWBRAN',1)
3294 QSUD=-1
3295 ENDIF
3296 ENDIF
3297 IF (QSUD.GT.QGTHR.AND.QSUD.GT.QNOW) THEN
3298 ID2=13
3299 QNOW=QSUD
3300 ENDIF
3301 ENDIF
3302 300 CONTINUE
3303 ENDIF
3304C--BRANCHING ID->ID+PHOTON
3305 IF (ICHRG(ID).NE.0) THEN
3306 QGTHR=MAX(HWBVMC(ID)+HWBVMC(59),HWBVMC(59)*EXP(0.75))
3307 IF (QMAX.GT.QGTHR) THEN
3308 DO 400 IREJ=1,NREJ
3309 RN=HWRGEN(2)
3310 IF (RN.EQ.ZERO) THEN
3311 QGAM=0
3312 ELSE
3313 QGAM=(LOG(QMAX/HWBVMC(59))-0.75)**2
3314 & +PIFAC*9/(ICHRG(ID)**2*ALPFAC*ALPHEM)*LOG(RN)
3315 IF (QGAM.GT.ZERO) THEN
3316 QGAM=HWBVMC(59)*EXP(0.75+SQRT(QGAM))
3317 ELSE
3318 QGAM=0
3319 ENDIF
3320 ENDIF
3321 IF (QGAM.GT.QGTHR.AND.QGAM.GT.QNOW) THEN
3322 ID2=59
3323 QNOW=QGAM
3324 ENDIF
3325 400 CONTINUE
3326 ENDIF
3327 ENDIF
3328 IF (QNOW.GT.ZERO) THEN
3329C--BRANCHING HAS OCCURRED
3330 ZMIN=HWBVMC(ID2)/QNOW
3331 ZMAX=1.-ZMIN
3332 IF (ID.EQ.13) THEN
3333 IF (ID2.EQ.13) THEN
3334C--GLUON -> GLUON + GLUON
3335 ID1=13
3336 WMIN=ZMIN*ZMAX
3337 ETEST=(1.-WMIN)**2*HWUALF(5-SUDORD*2,QNOW*WMIN)
3338 ZRAT=(ZMAX*(1-ZMIN))/(ZMIN*(1-ZMAX))
3339C--CHOOSE Z1 DISTRIBUTED ON (ZMIN,ZMAX)
3340C ACCORDING TO GLUON BRANCHING FUNCTION
3341 10 Z1=ZMAX/(ZMAX+(1-ZMAX)*ZRAT**HWRGEN(0))
3342 Z2=1.-Z1
3343 ZTEST=(1.-(Z1*Z2))**2*HWUALF(5-SUDORD*2,QNOW*(Z1*Z2))
3344 IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 10
3345 Z=Z1
3346 ELSEIF (ID2.NE.115) THEN
3347C--GLUON -> QUARKS
3348 ID1=ID2+6
3349 ETEST=ZMIN**2+ZMAX**2
3350 20 Z1=HWRUNI(0,ZMIN,ZMAX)
3351 Z2=1.-Z1
3352 ZTEST=Z1*Z1+Z2*Z2
3353 IF (ZTEST.LT.ETEST*HWRGEN(0)) GOTO 20
3354 ELSE
3355C--GLUON -> DIQUARKS
3356 ID2=HWRINT(115,117)
3357 ID1=ID2-6
3358 Z1=HWRUNI(0,ZMIN,ZMAX)
3359 Z2=1.-Z1
3360 ENDIF
3361 ELSE
3362C--QUARK OR ANTIQUARK BRANCHING
3363 IF (ID2.EQ.13) THEN
3364C--TO GLUON
3365 ZMAX=1.-HWBVMC(ID)/QNOW
3366 WMIN=MIN(ZMIN*(1.-ZMIN),ZMAX*(1.-ZMAX))
3367 ETEST=(1.+ZMAX**2)*HWUALF(5-SUDORD*2,QNOW*WMIN)
3368 ZRAT=ZMAX/ZMIN
3369 30 Z1=ZMIN*ZRAT**HWRGEN(0)
3370 Z2=1.-Z1
3371 ZTEST=(1.+Z2*Z2)*HWUALF(5-SUDORD*2,QNOW*Z1*Z2)
3372 IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 30
3373 ELSE
3374C--TO PHOTON
3375 ZMIN= HWBVMC(59)/QNOW
3376 ZMAX=1-HWBVMC(ID)/QNOW
3377 ZRAT=ZMAX/ZMIN
3378 ETEST=1+(1-ZMIN)**2
3379 40 Z1=ZMIN*ZRAT**HWRGEN(0)
3380 Z2=1-Z1
3381 ZTEST=1+Z2*Z2
3382 IF (ZTEST.LT.ETEST*HWRGEN(1)) GOTO 40
3383 ENDIF
3384C--QUARKS EMIT ON LOWER SIDE, ANTIQUARKS ON UPPER SIDE
3385 Z=Z1
3386 IF (JD.LE.6) THEN
3387 Z1=Z2
3388 Z2=1.-Z2
3389 ID1=ID
3390 ELSE
3391 ID1=ID2
3392 ID2=ID
3393 ENDIF
3394 ENDIF
3395C--UPDATE THIS BRANCH AND CREATE NEW BRANCHES
3396 XI=(QNOW/ENOW)**2
3397 IF (ID1.NE.59.AND.ID2.NE.59) THEN
3398 IF (ID.EQ.13.AND.ID1.NE.13) THEN
3399 QLAM=QNOW
3400 ELSE
3401 QLAM=QNOW*Z1*Z2
3402 ENDIF
3403 IF (SUDORD.EQ.1.AND.HWUALF(2,QLAM).LT.HWRGEN(0) .OR.
3404 & (2.-XI)*(QNOW*Z1*Z2)**2.GT.EMSCA**2) THEN
3405C--BRANCHING REJECTED: REDUCE Q AND REPEAT
3406 QMAX=QNOW
3407 QLST=QNOW
3408 QNOW=-1.
3409 GOTO 5
3410 ENDIF
3411 ENDIF
3412C--IF THIS IS HARDEST EMISSION SO FAR, APPLY MATRIX-ELEMENT CORRECTION
3413 IF (ID.NE.13.OR.ID1.EQ.13) THEN
3414 QLAM=QNOW*Z1*Z2
3415 REJFAC=1
3416 IF (TMPAR(2).AND.QLAM.GT.HARDST) THEN
3417C----SOFT MATRIX-ELEMENT CORRECTION TO TOP DECAYS
3418 ITOP=JCOPAR(1,1)
3419 IF (ISTHEP(ITOP).EQ.155.AND.(IDHW(ITOP).EQ.6
3420 $ .OR.IDHW(ITOP).EQ.12)) THEN
3421 AW=(PHEP(5,JDAHEP(1,ITOP))/PHEP(5,ITOP))**2
3422 FF=0.5*(1-AW)*(1-2*AW+1/AW)
3423 CC=0.25*(1-AW)**2
3424 X1=1-2*CC*Z*(1-Z)*XI
3425 X3=0.5*(1-AW+2*CC*Z*(1-Z)*XI-(1-2*Z)
3426 & *HWUSQR(((1+AW-2*CC*Z*(1-Z)*XI)**2-4*AW)
3427 & /(1-2*Z*(1-Z)*XI)))
3428C-----JACOBIAN FACTOR
3429 JJ=(1-X1)*(2-AW-X1-2*X3)*(1-2*Z*(1-Z)*XI)/(
3430 $ 4*CC**2*((X1+AW)**2-4*AW)*Z**2*(1-Z)**2*(1-2*Z)*XI)
3431C-----REJECTION FACTOR
3432 XCUT=2*GCUTME/PHEP(5,ITOP)
3433 IF (X3.GT.XCUT) REJFAC=FF*JJ
3434 & *X3**2*(1-X1)*(1+(1-Z)**2)/(Z*XI)
3435 & /((1+1/AW-2*AW)*((1-AW)*X3-(1-X1)
3436 & *(1-X3)-X3**2)+(1+1/(2*AW))*X3*(X1+X3-1)**2
3437 & +2*X3**2*(1-X1))
3438 ELSEIF (MOD(ISTHEP(JCOPAR(1,1)),10).GE.3) THEN
3439C---COLOUR PARTNER IS ALSO OUTGOING
3440 X1=1-Z*(1-Z)*XI
3441 X2=0.5*(1+Z*(1-Z)*XI +
3442 $ (1-Z*(1-Z)*XI)*(1-2*Z)/SQRT(1-2*Z*(1-Z)*XI))
3443 REJFAC=SQRT(2*X1-1)/(X1*Z*(1-Z))
3444 $ *(1+(1-Z)**2)/(Z*XI)
3445 $ *(1-X1)*(1-X2)/(X1**2+X2**2)
3446C---CHECK WHETHER IT IS IN THE OVERLAP REGION
3447 OTHXI=4*(1-X2)*X2**2/(X2**2-(2*X2-1)*(2*X1+X2-2)**2)
3448 IF (OTHXI.LT.ONE) THEN
3449 OTHZ=0.5*(1-SQRT(2*X2-1)/X2*(2*X1+X2-2))
3450 REJFAC=REJFAC+SQRT(2*X2-1)/(X2*OTHZ*(1-OTHZ))
3451 $ *(1+(1-OTHZ)**2)/(OTHZ*OTHXI)
3452 $ *(1-X2)*(1-X1)/(X2**2+X1**2)
3453 ENDIF
3454 ELSE
3455C---COLOUR PARTNER IS INCOMING (X1=XP, X2=ZP)
3456 X1=1/(1+Z*(1-Z)*XI)
3457 X2=0.5*(1+(1-2*Z)/SQRT(1-2*Z*(1-Z)*XI))
3458 REJFAC=SQRT(3-2/X1)/(X1**2*Z*(1-Z))
3459 $ *(1+(1-Z)**2)/(Z*XI)
3460 $ *(1-X1)*(1-X2)/
3461 $ (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
3462C---CHECK WHETHER IT IS IN THE OVERLAP REGION
3463 OTHXI=(SQRT(X1+2*(1-X2)*(1-X2+X1*X2))-SQRT(X1))**2/
3464 $ (1+X1-X2-SQRT(X1*(X1+2*(1-X2)*(1-X2+X1*X2))))
3465 OTHZ=(SQRT(X1*(X1+2*(1-X2)*(1-X2+X1*X2)))-X1)/(1-X2)
3466 IF (OTHXI.LT.OTHZ**2) THEN
3467 REJFAC=REJFAC+OTHZ**3*(1-X1-X2+2*X1*X2)
3468 $ /(X1**2*(1-OTHZ)*(OTHZ+OTHXI*(1-OTHZ)))
3469 $ *(1+OTHZ**2)/((1-OTHZ)*OTHXI)
3470 $ *(1-X1)*(1-X2)/
3471 $ (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
3472 ENDIF
3473 ENDIF
3474 ENDIF
3475 IF (NREJ*REJFAC*HWRGEN(NREJ).GT.ONE) THEN
3476 QMAX=QNOW
3477 QLST=QNOW
3478 QNOW=-1.
3479 GOTO 5
3480 ENDIF
3481 IF (QLAM.GT.HARDST) HARDST=QLAM
3482 ENDIF
3483 MPAR=NPAR+1
3484 IDPAR(MPAR)=ID1
3485 TMPAR(MPAR)=.TRUE.
3486 PPAR(1,MPAR)=QNOW*Z1
3487 PPAR(2,MPAR)=XI
3488 PPAR(4,MPAR)=ENOW*Z1
3489 NPAR=NPAR+2
3490 IDPAR(NPAR)=ID2
3491 TMPAR(NPAR)=.TRUE.
3492 PPAR(1,NPAR)=QNOW*Z2
3493 PPAR(2,NPAR)=XI
3494 PPAR(4,NPAR)=ENOW*Z2
3495C---NEW MOTHER-DAUGHTER RELATIONS
3496 JDAPAR(1,KPAR)=MPAR
3497 JDAPAR(2,KPAR)=NPAR
3498 JMOPAR(1,MPAR)=KPAR
3499 JMOPAR(1,NPAR)=KPAR
3500C---NEW COLOUR CONNECTIONS
3501 JCOPAR(3,KPAR)=NPAR
3502 JCOPAR(4,KPAR)=MPAR
3503 JCOPAR(1,MPAR)=NPAR
3504 JCOPAR(2,MPAR)=KPAR
3505 JCOPAR(1,NPAR)=KPAR
3506 JCOPAR(2,NPAR)=MPAR
3507C
3508 ENDIF
3509 ENDIF
3510 IF (QNOW.LT.ZERO) THEN
3511C--BRANCHING STOPS
3512 IF (ID.EQ.IDPAR(2).AND.PPAR(5,2).GT.1D-6) THEN
3513 PPAR(5,KPAR)=PPAR(5,2)**2
3514 ELSE
3515 PPAR(5,KPAR)=RMASS(ID)**2
3516 ENDIF
3517 PMOM=PPAR(4,KPAR)**2-PPAR(5,KPAR)
3518 IF (PMOM.LT.-1E-6) THEN
3519 CALL HWWARN('HWBRAN',104)
3520 GOTO 999
3521 ENDIF
3522 IF (PMOM.LT.ZERO) PMOM=ZERO
3523 PPAR(3,KPAR)=SQRT(PMOM)
3524 JDAPAR(1,KPAR)=0
3525 JDAPAR(2,KPAR)=0
3526 JCOPAR(3,KPAR)=0
3527 JCOPAR(4,KPAR)=0
3528 ENDIF
3529 999 RETURN
3530 END
3531CDECK ID>, HWBRCN.
3532*CMZ :- -31/03/00 17:54:05 by Peter Richardson
3533*-- Author : Peter Richardson
3534C-----------------------------------------------------------------------
3535 SUBROUTINE HWBRCN
3536C-----------------------------------------------------------------------
3537C SUBROUTINE TO REPLACE HWBCON IN RPARITY VIOLATING SUSY
3538C BASED ON HWBCON BY BRW
3539C-----------------------------------------------------------------------
c63d70bc 3540 INCLUDE 'herwig65.inc'
65767955 3541 INTEGER IHEP,IST,ID,JC,JD,JHEP,IDP,IDM,IDM2,
3542 & RHEP,IST2,ANTC,XHEP,IP,COLP
3543 LOGICAL BVVUSE,BVVHRD,BVDEC1,BVDEC2,COLRD,ACOLRD,BVHRD,BVHRD2,
3544 & BVDEC3
3545 LOGICAL IFGO
3546C--logical functions to decide if baryon number violating
3547C--BVDEC1 DELTAB=+1
3548 BVDEC1(IP) = ((IDHW(IP).GE.419.AND.IDHW(IP).LE.424).OR.
3549 & IDHW(IP).EQ.411.OR.IDHW(IP).EQ.412.OR.
3550 & IDHW(IP).EQ.449).AND.IDHW(JDAHEP(1,IP)).LE.6.
3551 & AND.IDHW(JDAHEP(1,IP)+1).LE.6.AND.
3552 & IDHW(JDAHEP(2,IP)).LE.6
3553C--BVDEC2 DELTAB=-1
3554 BVDEC2(IP) = ((IDHW(IP).GE.413.AND.IDHW(IP).LE.418).OR.
3555 & IDHW(IP).EQ.405.OR.IDHW(IP).EQ.406.OR.
3556 & IDHW(IP).EQ.449).AND.
3557 & IDHW(JDAHEP(1,IP)).GE.7.AND.IDHW(JDAHEP(1,IP)).LE.12.AND.
3558 & IDHW(JDAHEP(1,IP)+1).GE.7.AND.IDHW(JDAHEP(1,IP)+1).LE.12.AND.
3559 & IDHW(JDAHEP(2,IP)).GE.7.AND.IDHW(JDAHEP(2,IP)).LE.12
3560C--Neutralino and Chargino Decays
3561 BVDEC3(IP) = ((IDHW(IP).GE.450.AND.IDHW(IP).LE.457).AND.
3562 & (IDHW(JDAHEP(1,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)+1).LE.12.
3563 & .AND.IDHW(JDAHEP(2,IP)).LE.12))
3564C--Now the hard vertices
3565 BVHRD(IP) = IDHW(IP).EQ.15.AND.IDHW(JMOHEP(1,IP)).LE.12.
3566 & AND.IDHW(JMOHEP(2,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)).LE.12.
3567 & AND.IDHW(JDAHEP(2,IP)).GE.449.AND.IDHW(JDAHEP(2,IP)).LE.457
3568 BVHRD2(IP) = IDHW(IP).EQ.15.AND.IDHW(JMOHEP(1,IP)).LE.12.
3569 & AND.IDHW(JMOHEP(2,IP)).LE.12.AND.IDHW(JDAHEP(1,IP)).GE.198.
3570 & AND.IDHW(JDAHEP(1,IP)).LE.207.
3571 & AND.ABS(IDHEP(JDAHEP(2,IP))).GT.1000000
3572C--Those particles which are coloured
3573 COLRD(IP) = IP.LE.6.OR.IP.EQ.13.OR.IP.EQ.449.OR.
3574 & (IP.GE.401.AND.IP.LE.406).OR.(IP.GE.413.AND.IP.LE.418).OR.
3575 & (IP.GE.115.AND.IP.LE.120).OR.IP.EQ.59
3576C--Those particles which are anticoloured
3577 ACOLRD(IP) = (IP.GE.7.AND.IP.LE.12).OR.IP.EQ.13.OR.IP.EQ.449.OR.
3578 & (IP.GE.407.AND.IP.LE.412).OR.(IP.GE.419.AND.IP.LE.424).OR.
3579 & (IP.GE.109.AND.IP.LE.114).OR.IP.EQ.59
3580 IF (IERROR.NE.0) RETURN
3581C--Added 31/03/00 PR
3582 IF(NHEP.GT.NMXHEP) THEN
3583 CALL HWWARN('HWBRCN',101)
3584 GOTO 999
3585 ENDIF
3586 COLP = 0
3587 IF(COLUPD.AND.HRDCOL(1,3).NE.0) THEN
3588 JD = 0
3589 DO IHEP = HRDCOL(1,3),HRDCOL(1,3)+4
3590 JD = JD+1
3591 IF(JD.NE.3) THEN
3592 JMOHEP(2,IHEP) = HRDCOL(1,JD)
3593 JDAHEP(2,IHEP) = HRDCOL(2,JD)
3594 ENDIF
3595 ENDDO
3596 COLUPD=.FALSE.
3597 DO IHEP=1,5
3598 DO JHEP=1,2
3599 HRDCOL(JHEP,IHEP)=0
3600 ENDDO
3601 ENDDO
3602 ELSEIF(COLUPD) THEN
3603 RETURN
3604 ENDIF
3605 DO 110 IHEP=1,NHEP
3606 IST=ISTHEP(IHEP)
3607 JD =0
3608 BVVUSE = .FALSE.
3609 BVVHRD = .FALSE.
3610C---LOOK FOR PARTONS WITHOUT COLOUR MOTHERS
3611 IF ((IST.LT.145.OR.IST.GT.152).AND.IST.NE.155) GOTO 110
3612 IF (JMOHEP(2,IHEP).EQ.0) THEN
3613C---FIND COLOUR-CONNECTED PARTON
3614 IF(IST.EQ.155.AND.ABS(IDHEP(IHEP)).EQ.6) THEN
3615 JC = JMOHEP(1,IHEP)
3616 ELSEIF(IST.EQ.155) THEN
3617 GOTO 110
3618 ELSE
3619 JC=JMOHEP(1,IHEP)
3620 ENDIF
3621 IF (IST.NE.152) JC=JMOHEP(1,JC)
3622C--Correction for BV
3623 IF(HRDCOL(1,1).NE.0) THEN
3624 IDP = IDHW(HRDCOL(1,1))
3625 ELSE
3626 IDP = 0
3627 ENDIF
3628 IDM = JMOHEP(1,JC)
3629 IF(BVDEC1(IDM).OR.BVDEC2(IDM)) THEN
3630 IF(IDHW(IDM).EQ.449.AND.JDAHEP(1,IDM).EQ.JC) THEN
3631 JC=JMOHEP(2,JC)
3632 ELSE
3633 JD = JMOHEP(2,JC)
3634 JC = IDM
3635 IF(JC.EQ.JD) JD= JDAHEP(2,JC-1)
3636 BVVUSE = .TRUE.
3637 ENDIF
3638C--NEW FOR BV HARD PROCESS
3639 ELSEIF(BVHRD(IDM)) THEN
3640 IF(IDHW(JDAHEP(2,JMOHEP(1,JC))).EQ.449) THEN
3641 JD = JMOHEP(2,JC)
3642 IDM2 = JDAHEP(2,HRDCOL(1,2))
3643 IF(JD.EQ.IDM2) JD = HRDCOL(1,1)
3644 IF(JC.EQ.JDAHEP(2,IDM2).AND.COLRD(IDHW(IHEP))) THEN
3645 JC = JMOHEP(2,JC)
3646 ELSEIF(JC.EQ.IDM2) THEN
3647 IF(JDAHEP(2,JMOHEP(2,JC)).EQ.JC) THEN
3648 JC = JMOHEP(2,JC)
3649 ELSE
3650 JMOHEP(2,IHEP)=JMOHEP(2,JC)
3651 GOTO 110
3652 ENDIF
3653 ELSE
3654 JC = HRDCOL(1,1)
3655 BVVUSE = .TRUE.
3656 BVVHRD = .TRUE.
3657 IF(ACOLRD(IDHW(IHEP))) JC = JD
3658 IF(JC.EQ.IDM2) GOTO 110
3659 ENDIF
3660 ELSE
3661 JC =JMOHEP(2,JC)
3662 BVVUSE = .TRUE.
3663 BVVHRD = .TRUE.
3664 ENDIF
3665 ELSEIF(BVHRD2(IDM)) THEN
3666 JD = JMOHEP(2,JC)
3667 IF(JC.EQ.JDAHEP(2,HRDCOL(1,2))) THEN
3668 JMOHEP(2,IHEP)=JMOHEP(2,JC)
3669 GOTO 110
3670 ENDIF
3671 IF(JD.EQ.JDAHEP(2,HRDCOL(1,2))) JD = HRDCOL(1,1)
3672 BVVUSE=.TRUE.
3673 BVVHRD = .TRUE.
3674 IF(JC.EQ.JDAHEP(2,HRDCOL(1,2))) THEN
3675 JC = JMOHEP(2,JC)
3676 ELSE
3677 JC = HRDCOL(1,1)
3678 ENDIF
3679 ELSE
3680 JC =JMOHEP(2,JC)
3681 ENDIF
3682 IF (JC.EQ.0) THEN
3683 CALL HWWARN('HWBCON',51)
3684 GOTO 110
3685 ENDIF
3686C---FIND SPECTATOR WHEN JC IS DECAYED HEAVY QUARK OR SUSY PARTICLE
3687 IF (ISTHEP(JC).EQ.155) THEN
3688 IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN
3689C---DECAYED BEFORE HADRONIZING
3690 IF(BVVHRD) THEN
3691 JHEP = JC
3692 ELSEIF(BVVUSE) THEN
3693 JHEP=JDAHEP(2,JC-1)
3694 ELSE
3695 JHEP=JMOHEP(2,JC)
3696 ENDIF
3697 IF(JHEP.EQ.0.AND.ABS(IDHEP(JC)).EQ.6) THEN
3698 JHEP = JMOHEP(1,JMOHEP(1,JC))
3699 IF(BVDEC1(JMOHEP(1,JHEP)).OR.BVDEC2(JMOHEP(1,JHEP))) THEN
3700 JC = JHEP
3701 JHEP = JDAHEP(2,JC-1)
3702 ELSE
3703 JHEP = 0
3704 ENDIF
3705 ENDIF
3706 IF(BVVUSE.AND.ABS(IDHEP(JHEP)).GT.1000000.AND.
3707 & ISTHEP(JHEP).NE.155.OR.JHEP.EQ.0) GOTO 110
3708 ID=IDHW(JHEP)
3709 IF (ISTHEP(JHEP).EQ.155) THEN
3710C---SPECIAL FOR GLUINO DECAYS
3711 IF (ID.EQ.449) THEN
3712 ID=IDHW(JC)
3713 IF(BVVUSE) THEN
3714 ID=IDHW(IHEP)
3715 IF(ID.LE.6.OR.ID.EQ.13.OR.
3716 & (ID.GE.115.AND.ID.LE.120)) THEN
3717 ID = 7
3718 ELSE
3719 ID = 1
3720 ENDIF
3721 ENDIF
3722 CALL HWBRC1(JC,ID,JHEP,.TRUE.,IFGO)
3723 IF(IFGO) GOTO 999
3724 IF(BVVUSE.AND.JMOHEP(1,JC).EQ.JMOHEP(1,JD)) JC =JD
3725 ELSE
3726 JC=JDAHEP(2,JHEP)
3727 IF(COLRD(IDHW(IHEP)).AND.IDHW(JDAHEP(1,JHEP)).EQ.449)
3728 & JC=JDAHEP(1,JHEP)
3729 IF(BVVUSE.AND.JMOHEP(1,JC).EQ.JMOHEP(1,JD)) JC =JD
3730 ENDIF
3731 ELSE
3732 IF(BVVUSE) THEN
3733 IF(BVDEC2(JMOHEP(1,JHEP)).OR.JD.NE.JHEP.OR.
3734 & BVHRD(JMOHEP(1,JHEP)).OR.BVHRD2(JMOHEP(1,JHEP))) THEN
3735 JC = JD
3736 GOTO 100
3737 ELSE
3738 JMOHEP(2,IHEP)=JHEP
3739 ID = IDHW(JHEP)
3740 IF((ID.GE.7.AND.ID.LE.12).OR.
3741 & (ID.GE.109.AND.ID.LE.114)) JMOHEP(2,JHEP)=IHEP
3742 ENDIF
3743 ELSE
3744C--new for particles connected to BV
3745 IDM = JMOHEP(1,JHEP)
3746 IF(BVDEC1(IDM).OR.BVHRD(IDM).OR.BVHRD2(IDM)) THEN
3747 JC = JHEP
3748 IF(ABS(IDHEP(IHEP)).LT.1000000) GOTO 100
3749 JMOHEP(2,IHEP)=JHEP
3750 GOTO 110
3751 ENDIF
3752C--new for top's from BV
3753 ID = IDHW(JC)
3754 IDP = JMOHEP(1,JMOHEP(1,JMOHEP(1,JC)))
3755 IF((ID.EQ.6.AND.(BVDEC1(IDP))).
3756 & OR.(ID.EQ.12.AND.BVDEC2(IDP)).
3757 & OR.((ID.EQ.12.OR.ID.EQ.449).AND.BVHRD(IDP))) THEN
3758 JMOHEP(2,IHEP)=JHEP
3759 IF(JDAHEP(2,JHEP).EQ.JC) JDAHEP(2,JHEP)=IHEP
3760 ELSE
3761 IF((IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12.
3762 & AND.IDHW(JHEP).GE.7.AND.IDHW(JHEP).LE.12).OR.
3763 & (IDHW(IHEP).LE.6.AND.IDHW(JHEP).LE.6)) THEN
3764 JMOHEP(2,IHEP)=JHEP
3765 ELSE
3766 JMOHEP(2,IHEP)=JHEP
3767 IF((COLRD(IDHW(IHEP)).AND.ACOLRD(IDHW(JHEP))).OR.
3768 & (.NOT.COLRD(IDHW(IHEP)).AND.
3769 & .NOT.ACOLRD(IDHW(JHEP)))) THEN
3770 IF(JDAHEP(2,JHEP).EQ.0) THEN
3771 JDAHEP(2,JHEP)=IHEP
3772 ELSEIF(JMOHEP(2,JDAHEP(2,JHEP)).NE.JHEP) THEN
3773 JDAHEP(2,JHEP)=IHEP
3774 ENDIF
3775 ELSE
3776 IF(JMOHEP(2,JHEP).EQ.JC) JMOHEP(2,JHEP)=IHEP
3777 ENDIF
3778 ENDIF
3779 ENDIF
3780 ENDIF
3781 GOTO 110
3782 ENDIF
3783 ELSE
3784 JC=JMOHEP(2,JC)
3785 ENDIF
3786 ENDIF
3787 100 CONTINUE
3788 IF(BVVUSE.AND.ABS(IDHEP(JC)).LT.1000000.AND.JC.NE.JD
3789 & .AND.JD.NE.0.AND.JD.NE.JMOHEP(1,JC)) JC = JD
3790 IF(BVVUSE.AND.ABS(IDHEP(JC)).GT.1000000) THEN
3791 IF(COLRD(IDHW(IHEP)).AND..NOT.BVVHRD) GOTO 110
3792 ENDIF
3793 IF(BVVUSE.AND.ISTHEP(JC).EQ.149) JC=JMOHEP(1,JMOHEP(1,JC))
3794C--SEARCH IN THE JET
3795 IF((ISTHEP(JC).GT.145.AND.ISTHEP(JC).LT.152).AND.
3796 & ISTHEP(IHEP).EQ.155) THEN
3797 JMOHEP(2,IHEP) = JC
3798 GOTO 110
3799 ENDIF
3800 CALL HWBRC2(COLP,IHEP,JC,.TRUE.,BVVUSE,BVVHRD)
3801 IF(COLP.NE.0) THEN
3802 JMOHEP(2,IHEP) = COLP
3803 IF(COLRD(IDHW(IHEP)).AND.ACOLRD(IDHW(COLP)).
3804 & AND.JDAHEP(2,COLP).EQ.0)
3805 & JDAHEP(2,COLP) = IHEP
3806 IF((IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12).AND.
3807 & (IDHW(COLP).GE.7.AND.IDHW(COLP).LE.12)) THEN
3808 IF(JMOHEP(2,COLP).EQ.0) JMOHEP(2,COLP) = IHEP
3809 ENDIF
3810 ENDIF
3811 ENDIF
3812 110 CONTINUE
3813C---BREAK COLOUR CONNECTIONS WITH PHOTONS modified for Rslash
3814 IHEP=1
3815 130 IF (IHEP.LE.NHEP) THEN
3816 IF (IDHW(IHEP).EQ.59 .AND. ISTHEP(IHEP).EQ.149.AND.
3817 & (JMOHEP(2,IHEP).NE.IHEP.OR.JDAHEP(2,IHEP).NE.IHEP)) THEN
3818 IF(JMOHEP(2,IHEP).NE.0) THEN
3819 IF (JDAHEP(2,JMOHEP(2,IHEP)).EQ.IHEP)
3820 & JDAHEP(2,JMOHEP(2,IHEP))=JDAHEP(2,IHEP)
3821 ENDIF
3822 IF (JDAHEP(2,IHEP).NE.0) THEN
3823 IF (JMOHEP(2,JDAHEP(2,IHEP)).EQ.IHEP)
3824 & JMOHEP(2,JDAHEP(2,IHEP))=JMOHEP(2,IHEP)
3825 ENDIF
3826 DO RHEP=1,NHEP
3827 IST=ISTHEP(RHEP)
3828 IF((IST.GE.147.AND.IST.LE.149).AND.JDAHEP(2,RHEP).EQ.IHEP)
3829 & JDAHEP(2,RHEP)=JMOHEP(2,IHEP)
3830 ENDDO
3831 DO RHEP=1,NHEP
3832 IST=ISTHEP(RHEP)
3833 IF((IST.GE.147.AND.IST.LE.149).AND.JMOHEP(2,RHEP).EQ.IHEP)
3834 & JMOHEP(2,RHEP) = JDAHEP(2,IHEP)
3835 ENDDO
3836 JMOHEP(2,IHEP)=IHEP
3837 JDAHEP(2,IHEP)=IHEP
3838 ENDIF
3839 IHEP=IHEP+1
3840 GOTO 130
3841 ENDIF
3842C--Update the BV anticolour corrections
3843 DO 210 IHEP=1,NHEP+1
3844 IF(IHEP.EQ.1) GOTO 210
3845 IST2 = 0
3846 IF(IHEP.EQ.NHEP+1) THEN
3847 ANTC = HRDCOL(1,1)
3848 IF(ANTC.EQ.0.OR.(IDHW(JMOHEP(1,HRDCOL(1,2))).LE.6)) GOTO 210
3849 IST=155
3850 XHEP=HRDCOL(1,2)
3851 IF(ANTC.EQ.JDAHEP(2,XHEP)) ANTC=JDAHEP(1,JDAHEP(1,ANTC))
3852 IF(ANTC.NE.0.AND.JDAHEP(1,ANTC).NE.0) IST2=ISTHEP(ANTC)
3853 ELSE
3854 ANTC = JDAHEP(2,IHEP-1)
3855 IF(ANTC.NE.0) IST2=ISTHEP(ANTC)
3856 IST=ISTHEP(IHEP)
3857 IDM = IDHW(IHEP)
3858 XHEP=IHEP
3859 ENDIF
3860 JC = 0
3861 JHEP = 0
3862 JD = 0
3863 IF(IST.EQ.155.AND.IST2.EQ.155) THEN
3864 IDM = IDHW(XHEP)
3865 IF(BVDEC1(XHEP).OR.BVDEC2(XHEP).OR.BVHRD(XHEP).OR.
3866 & BVHRD2(XHEP)) THEN
3867 JC=ANTC
3868 ID = IDHW(JC)
3869 JHEP = JC
3870 IF(BVDEC1(JC).OR.BVDEC2(JC)) THEN
3871 IF(IHEP.EQ.(NHEP+1)) ANTC=JDAHEP(1,JC)
3872 GOTO 200
3873 ENDIF
3874 IF (ID.EQ.449) THEN
3875C--SPECIAL FOR GLUINO DECAYS
3876 ID=IDHW(XHEP)
3877 IF(IHEP.EQ.NHEP+1) ID = 407
3878 CALL HWBRC1(JC,ID,JHEP,.FALSE.,IFGO)
3879 IF(IFGO) GOTO 999
3880 ELSE
3881 IF(IDHW(JDAHEP(1,JHEP)).EQ.449) THEN
3882 JC=JDAHEP(1,JHEP)
3883 ELSE
3884 JC=JDAHEP(2,JHEP)
3885 ENDIF
3886 ENDIF
3887C--SEARCH IN JET
3888 CALL HWBRC2(COLP,XHEP,JC,.FALSE.,BVVUSE,.FALSE.)
3889 ANTC = COLP
3890 IF(IHEP.LE.NHEP.AND.ACOLRD(IDHW(IHEP)).AND.
3891 & COLRD(IDHW(COLP)).AND.JMOHEP(2,COLP).EQ.0) THEN
3892 JMOHEP(2,COLP) = IHEP
3893 ELSEIF(IHEP.LE.NHEP.AND.IDHW(IHEP).LE.6.AND.
3894 & IDHW(COLP).LE.6.AND.JDAHEP(2,COLP).EQ.0) THEN
3895 JDAHEP(2,COLP) = IHEP
3896 ELSEIF(IHEP.GT.NHEP.AND.
3897 & ((BVHRD(XHEP).AND.COLRD(JDAHEP(1,XHEP))).
3898 & OR.(BVHRD2(XHEP).AND.ACOLRD(JDAHEP(2,XHEP)))).AND.
3899 & ACOLRD(IDHW(COLP)).AND.JDAHEP(2,COLP).EQ.0) THEN
3900 JDAHEP(2,COLP) = IHEP
3901 ENDIF
3902 ENDIF
3903 ENDIF
3904 200 CONTINUE
3905 IF(IHEP.EQ.NHEP+1) THEN
3906 IF(HRDCOL(1,1).NE.ANTC.AND.ANTC.NE.0) THEN
3907 HRDCOL(1,1)=ANTC
3908 IF(JDAHEP(2,ANTC).EQ.IHEP) THEN
3909 IF(JDAHEP(2,JMOHEP(1,HRDCOL(1,2))).EQ.JDAHEP(2,HRDCOL(1,2)).
3910 & AND.JMOHEP(2,JDAHEP(2,HRDCOL(1,2))).EQ.JMOHEP(1,HRDCOL(1,2)))
3911 & THEN
3912 JDAHEP(2,ANTC) = JMOHEP(2,HRDCOL(1,2))
3913 ELSE
3914 JDAHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
3915 ENDIF
3916 ELSEIF(JMOHEP(2,ANTC).EQ.IHEP) THEN
3917 JMOHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
3918 ENDIF
3919 ENDIF
3920 ELSEIF(IHEP.NE.1) THEN
3921 IF(JDAHEP(2,IHEP-1).NE.ANTC.AND.ANTC.NE.0) JDAHEP(2,IHEP-1)=ANTC
3922 ENDIF
3923 210 CONTINUE
3924C--Update BV decaying particles connections
3925 DO 310 IHEP=1,NHEP+1
3926 IF(IHEP.EQ.1) GOTO 310
3927 IF(IHEP.EQ.NHEP+1) THEN
3928 ANTC=HRDCOL(1,1)
3929 IF(ANTC.EQ.0.OR.IDHW(JDAHEP(1,HRDCOL(1,2))).LE.6) GOTO 310
3930 IST=155
3931 XHEP=HRDCOL(1,2)
3932 IF(ANTC.EQ.JDAHEP(2,XHEP)) ANTC=JDAHEP(1,JDAHEP(1,ANTC))
3933 ELSE
3934 ANTC=JMOHEP(2,IHEP)
3935 IST=ISTHEP(IHEP)
3936 IDM = IDHW(IHEP)
3937 XHEP=IHEP
3938 ENDIF
3939 IST2 = 0
3940 JC = 0
3941 JD = 0
3942 IF(ANTC.NE.0.AND.IHEP.NE.NHEP+1) THEN
3943 IF(JDAHEP(1,ANTC).NE.0) IST2 = ISTHEP(ANTC)
3944 ELSEIF(ANTC.NE.0.AND.IHEP.EQ.NHEP+1) THEN
3945 IST2=ISTHEP(ANTC)
3946 ENDIF
3947 IF(IST.EQ.155.AND.IST2.EQ.155) THEN
3948 IF(BVDEC2(XHEP).OR.BVHRD(XHEP).OR.BVHRD2(XHEP)) THEN
3949C--FIND COLOUR CONNECTED PARTON
3950 JC = ANTC
3951 ID=IDHW(JC)
3952 JHEP = JC
3953 IF(BVDEC2(JHEP)) THEN
3954 ANTC=JC
3955 GOTO 300
3956 ENDIF
3957 IF (ID.EQ.449) THEN
3958 ID=IDHW(XHEP)
3959 IF(IHEP.EQ.NHEP+1) ID = 401
3960C--SPECIAL FOR GLUINO DECAYS
3961 CALL HWBRC1(JC,ID,JHEP,.TRUE.,IFGO)
3962 IF(IFGO) GOTO 999
3963 ELSE
3964 IF(IDHW(JDAHEP(1,JHEP)).EQ.449) THEN
3965 JC=JDAHEP(1,JHEP)
3966 ELSE
3967 JC=JDAHEP(2,JHEP)
3968 ENDIF
3969 ENDIF
3970C--SEARCH IN JET
3971 CALL HWBRC2(COLP,XHEP,JC,.TRUE.,BVVUSE,.FALSE.)
3972 ANTC = COLP
3973 IF(COLP.EQ.0) GOTO 300
3974 IF(IHEP.LE.NHEP) THEN
3975 IF(JDAHEP(2,COLP).EQ.0) THEN
3976 JDAHEP(2,COLP) = JDAHEP(2,IHEP)
3977 ELSEIF(JMOHEP(2,JDAHEP(2,COLP)).NE.COLP) THEN
3978 JDAHEP(2,COLP) = JDAHEP(2,IHEP)
3979 ENDIF
3980 ELSEIF(IHEP.GT.NHEP.AND.
3981 & ((BVHRD(XHEP).AND.ACOLRD(JDAHEP(1,XHEP)).AND.
3982 & IDHW(JDAHEP(2,XHEP)).EQ.449).
3983 & OR.(BVHRD2(XHEP).AND.ACOLRD(JDAHEP(2,XHEP)))).AND.
3984 & ACOLRD(IDHW(COLP)).AND.JDAHEP(2,COLP).EQ.0) THEN
3985 JDAHEP(2,COLP) = IHEP
3986 ENDIF
3987 ENDIF
3988 ENDIF
3989 300 CONTINUE
3990 IF(IHEP.NE.NHEP+1.AND.IHEP.NE.1) THEN
3991 IF(JMOHEP(2,IHEP).NE.ANTC.AND.ANTC.NE.0) JMOHEP(2,IHEP)=ANTC
3992 ELSEIF(IHEP.GT.NHEP) THEN
3993 IF(HRDCOL(1,1).NE.ANTC.AND.ANTC.NE.0) HRDCOL(1,1)=ANTC
3994 IF(ANTC.EQ.0) GOTO 310
3995 IF(JDAHEP(2,ANTC).EQ.IHEP) THEN
3996 IF(JDAHEP(2,JMOHEP(1,HRDCOL(1,2))).EQ.JDAHEP(2,HRDCOL(1,2)).
3997 & AND.JMOHEP(2,JDAHEP(2,HRDCOL(1,2))).EQ.JMOHEP(1,HRDCOL(1,2)))
3998 & THEN
3999 JDAHEP(2,ANTC) = JMOHEP(2,HRDCOL(1,2))
4000 ELSE
4001 JDAHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
4002 ENDIF
4003 ELSEIF(JMOHEP(2,ANTC).EQ.IHEP) THEN
4004 JMOHEP(2,ANTC) = JMOHEP(1,HRDCOL(1,2))
4005 ENDIF
4006 ENDIF
4007 310 CONTINUE
4008C--Update partons connected to decaying SUSY particle
4009 DO 400 IHEP=1,NHEP
4010 IST=ISTHEP(IHEP)
4011C--LOOK FOR PARTONS CONNECTED TO A DECAYING SUSY PARTICLE
4012 IF (IST.LT.145.OR.IST.GT.152) GOTO 400
4013 IF(JMOHEP(2,IHEP).EQ.0) GOTO 400
4014 IF(ISTHEP(JMOHEP(2,IHEP)).EQ.155) THEN
4015C--FIND THE COLOUR CONNECTED PARTON
4016 JC=JMOHEP(2,IHEP)
4017 ID=IDHW(JC)
4018 JHEP = JC
4019 IF(BVDEC2(JC).AND.IDHW(JC).NE.449) THEN
4020 IF(IDHW(IHEP).GE.7.AND.IDHW(IHEP).LE.12)
4021 & JMOHEP(2,IHEP)=JDAHEP(1,JC)
4022 GOTO 400
4023 ENDIF
4024 IF (ID.EQ.449) THEN
4025C--SPECIAL FOR GLUINO DECAYS
4026 ID=IDHW(IHEP)
4027 CALL HWBRC1(JC,ID,JHEP,.TRUE.,IFGO)
4028 IF(IFGO) GOTO 999
4029 ELSE
4030 ID=IDHW(IHEP)
4031 IF(COLRD(ID).AND.IDHW(JDAHEP(1,JC)).EQ.449) THEN
4032 JC=JDAHEP(1,JHEP)
4033 ELSE
4034 JC=JDAHEP(2,JHEP)
4035 IF(IDHW(JHEP).EQ.6.AND.IDHW(JC).EQ.13) JC=JC-1
4036 ENDIF
4037 ENDIF
4038C--SEARCH IN JET
4039 CALL HWBRC2(COLP,IHEP,JC,.TRUE.,BVVUSE,.FALSE.)
4040 JMOHEP(2,IHEP) = COLP
4041 ENDIF
4042 400 CONTINUE
4043C--Update partons connected to decaying SUSY particle
4044 DO 500 IHEP=1,NHEP
4045 IST=ISTHEP(IHEP)
4046C--LOOK FOR PARTONS CONNECTED TO A DECAYING SUSY PARTICLE
4047 IF (IST.LT.145.OR.IST.GT.152) GOTO 500
4048 IF(JDAHEP(2,IHEP).EQ.0) GOTO 500
4049 IF(ISTHEP(JDAHEP(2,IHEP)).EQ.155) THEN
4050C--FIND THE COLOUR CONNECTED PARTON
4051 JC=JDAHEP(2,IHEP)
4052 ID=IDHW(JC)
4053 ID=IDHW(JC)
4054 IF (ID.EQ.449) THEN
4055 ID=IDHW(IHEP)
4056C--SPECIAL FOR GLUINO DECAYS
4057 JHEP = JC
4058 CALL HWBRC1(JC,ID,JHEP,.FALSE.,IFGO)
4059 IF(IFGO) GOTO 999
4060 ELSE
4061 IF(ACOLRD(IDHW(IHEP)).AND.IDHW(JDAHEP(1,JC)).EQ.449) THEN
4062 JC = JDAHEP(1,JC)
4063 ELSE
4064 JC=JDAHEP(2,JC)
4065 ENDIF
4066 ENDIF
4067C--SEARCH IN THE JET
4068 CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
4069 IF(COLP.NE.0) JDAHEP(2,IHEP) = COLP
4070 ENDIF
4071 500 CONTINUE
4072C--Flavour and anticolour connections in Rslash
4073 DO 610 IHEP=1,NHEP
4074 IST=ISTHEP(IHEP)
4075 IF(IST.LT.145.OR.IST.GT.152.OR.JDAHEP(2,IHEP).NE.0) GOTO 610
4076 JD = 0
4077 BVVUSE = .FALSE.
4078 JC = JMOHEP(1,IHEP)
4079 IF(IST.NE.152) JC = JMOHEP(1,JC)
4080 IF(JC.EQ.0) THEN
4081 CALL HWWARN('HWBRCN',51)
4082 GOTO 610
4083 ENDIF
4084C--For particles which came from a top decay
4085 IF(ABS(IDHEP(JMOHEP(1,JC))).EQ.6) THEN
4086 JD = JMOHEP(1,JMOHEP(1,JMOHEP(1,JC)))
4087C--flavour connect to self if needed
4088 IF(JDAHEP(2,JMOHEP(1,JC)-1).EQ.JMOHEP(1,JC)) THEN
4089 JDAHEP(2,IHEP) = IHEP
4090 GOTO 610
4091 ELSEIF(JDAHEP(2,JMOHEP(1,JC)-1).NE.0) THEN
4092 JDAHEP(2,IHEP) = JDAHEP(2,JMOHEP(1,JC)-1)
4093 GOTO 610
4094 ELSE
4095 JC = JD
4096 ENDIF
4097 ENDIF
4098C--Decide if this came from a BV decay
4099 IDM = JMOHEP(1,JC)
4100 IF(BVDEC1(IDM).OR.BVDEC2(IDM).OR.BVDEC3(IDM).
4101 & OR.BVHRD(IDM).OR.BVHRD2(IDM)) THEN
4102C--Do BV piece
4103 IF(JDAHEP(2,JC).EQ.JMOHEP(1,JC)) THEN
4104 IF(IDHW(JMOHEP(1,JC)).EQ.449.AND.
4105 & JDAHEP(1,JMOHEP(1,JC)).EQ.JC) THEN
4106 JC = JDAHEP(2,JMOHEP(1,JC)-1)
4107 ELSE
4108 JC = JMOHEP(2,JMOHEP(1,JC))
4109 ENDIF
4110 IF(ABS(IDHEP(JC)).LT.1000000) THEN
4111 IF(JDAHEP(1,JC).EQ.0) THEN
4112 JDAHEP(2,IHEP) = JC
4113 GOTO 610
4114 ELSE
4115 GOTO 600
4116 ENDIF
4117 ELSEIF(ABS(IDHEP(JC)).GT.1000000
4118 & .AND.ISTHEP(JC).NE.155) THEN
4119 GOTO 610
4120 ENDIF
4121 IF(ISTHEP(JC).EQ.155.AND.ACOLRD(IDHW(IHEP))) THEN
4122 JC = JDAHEP(1,JC)
4123 ELSE
4124 IF(ISTHEP(JC).EQ.155.AND.IDHW(JDAHEP(1,JC)).NE.449) THEN
4125 JC = JDAHEP(1,JC)
4126 ELSE
4127 JC = JDAHEP(2,JC)
4128 ENDIF
4129 ENDIF
4130 ELSE
4131C--For the hard process
4132 IF(IDHW(IDM).EQ.15.AND.JC.EQ.JDAHEP(2,JMOHEP(1,JC))) THEN
4133 JDAHEP(2,IHEP) = JDAHEP(2,JC)
4134 GOTO 610
4135 ELSEIF(IDHW(IDM).EQ.15.AND.IDHW(IHEP).NE.449) THEN
4136 JD=HRDCOL(1,1)
4137 IF(BVHRD(IDM).AND.IDHW(JDAHEP(2,IDM)).NE.449) THEN
4138 JC = JDAHEP(2,JC)
4139 GOTO 600
4140 ELSEIF(JMOHEP(1,JDAHEP(2,JC)).EQ.JD) THEN
4141 JC=JDAHEP(2,JC)
4142 GOTO 600
4143 ENDIF
4144 IF(JDAHEP(2,JC).EQ.8) JC = JD
4145 ELSE
4146 JD=JMOHEP(2,JMOHEP(1,JC))
4147 ENDIF
4148 IF(COLRD(IDHW(IHEP)).AND..NOT.ACOLRD(IDHW(IHEP)).AND.
4149 & ABS(IDHEP(JD)).GT.1000000.AND.ISTHEP(JD).NE.155) THEN
4150 JDAHEP(2,IHEP) = JD
4151 IF(JDAHEP(2,JD).EQ.0) JDAHEP(2,JD) = IHEP
4152 ENDIF
4153 IF(ABS(IDHEP(JD)).GT.1000000
4154 & .AND.ISTHEP(JD).NE.155) GOTO 610
4155 IF(ISTHEP(JC).EQ.149) THEN
4156 JDAHEP(2,IHEP)=JC
4157 GOTO 610
4158 ENDIF
4159 IF(ACOLRD(IDHW(IHEP)).AND.IDHW(JC).EQ.449.AND.BVDEC2(JC)) THEN
4160 JC = JDAHEP(1,JC)
4161 ELSE
4162 JC = JDAHEP(2,JC)
4163 ENDIF
4164 ENDIF
4165C--SEARCH IN THE JET
4166 600 CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
4167 IF(COLP.NE.0) THEN
4168 IF(ABS(IDHEP(COLP)).EQ.6.AND.JDAHEP(1,COLP).NE.0) THEN
4169 IF(ISTHEP(COLP).EQ.155) THEN
4170 JC = JDAHEP(2,COLP)
4171 ELSE
4172 JC = JDAHEP(2,JDAHEP(2,COLP))
4173 ENDIF
4174 GOTO 600
4175 ENDIF
4176 JDAHEP(2,IHEP) = COLP
4177 ENDIF
4178 ELSE
4179C--check if it came from a top
4180 IF(ABS(IDHEP(JC)).EQ.6) THEN
4181C--start the analysis again
4182 JC = JMOHEP(1,IHEP)
4183 IF(IST.NE.152) JC = JMOHEP(1,JC)
4184 JC = JDAHEP(2,JC)
4185 IF(JC.EQ.0) THEN
4186 CALL HWWARN('HWBRCN',52)
4187 GOTO 610
4188 ENDIF
4189 IF(ISTHEP(JC).EQ.155) THEN
4190 IF (IDHEP(JMOHEP(1,JC)).EQ.94) THEN
4191C---DECAYED BEFORE HADRONIZING
4192 JHEP=JDAHEP(2,JC-1)
4193 IF (JHEP.EQ.0) GO TO 610
4194 ID=IDHW(JHEP)
4195 IF (ISTHEP(JHEP).EQ.155) THEN
4196C---SPECIAL FOR GLUINO DECAYS
4197 IF (ID.EQ.449) THEN
4198 CALL HWBRC1(JC,ID,JHEP,.TRUE.,IFGO)
4199 IF(IFGO) GOTO 999
4200 ELSE
4201 JC=JDAHEP(2,JHEP)
4202 ENDIF
4203 ELSE
4204 IF(JMOHEP(2,JHEP).EQ.JC) JMOHEP(2,JHEP)=IHEP
4205 JDAHEP(2,IHEP) = JHEP
4206 GOTO 610
4207 ENDIF
4208 ELSE
4209 JC=JDAHEP(2,JC-1)
4210 ENDIF
4211 ENDIF
4212C--SEARCH IN JET
4213 CALL HWBRC2(COLP,IHEP,JC,.FALSE.,BVVUSE,.FALSE.)
4214 IF(COLP.NE.0) JDAHEP(2,IHEP) = COLP
4215 ELSE
4216 IF(ISTHEP(JMOHEP(1,JC)).EQ.155
4217 & .AND.IDHW(JC).LE.6) THEN
4218 JDAHEP(2,IHEP) = JDAHEP(2,JMOHEP(1,JC)-1)
4219 IF(JDAHEP(2,IHEP).NE.0) GOTO 610
4220 ENDIF
4221 CALL HWWARN('HWBRCN',100)
4222 GOTO 610
4223 ENDIF
4224 ENDIF
4225 610 CONTINUE
4226 999 RETURN
4227 END
4228CDECK ID>, HWBRC1.
4229*CMZ :- -20/07/99 10:56:12 by Peter Richardson
4230*-- Author : PeterRichardson
4231C-----------------------------------------------------------------------
4232 SUBROUTINE HWBRC1(JC,ID,JHEP,COL,IFGO)
4233C-----------------------------------------------------------------------
4234C--Function to find the right daugther of a decaying gluino
4235C-----------------------------------------------------------------------
c63d70bc 4236 INCLUDE 'herwig65.inc'
65767955 4237 INTEGER ID,JHEP,KC,JC
4238 LOGICAL COL,IFGO
4239C---N.B. WILL NEED MODS WHEN SUSY PARTICLES CAN SHOWER
4240C--Rparity take the first daughther
4241 IFGO = .FALSE.
4242 IF(IDHW(JDAHEP(1,JHEP)).LE.12.AND.IDHW(JDAHEP(1,JHEP)+1).LE.12
4243 & .AND.IDHW(JDAHEP(2,JHEP)).LE.12) THEN
4244 KC = JDAHEP(1,JHEP)
4245 GOTO 20
4246 ELSEIF ((COL.AND.(ID.EQ.449.OR.ID.EQ.13)).OR.
4247 & (ID.GE.401.AND.ID.LE.406).OR.
4248 & (ID.GE.413.AND.ID.LE.418).OR.ID.LE.6.OR.
4249 & (ID.GE.115.AND.ID.LE.120)) THEN
4250C---LOOK FOR ANTI(S)QUARK OR GLUON
4251 DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
4252 ID=IDHW(KC)
4253 IF ((ID.GE.7.AND.ID.LE.13).OR.(ID.GE.407.AND.ID.LE.412).OR.
4254 & (ID.GE.419.AND.ID.LE.424)) GOTO 20
4255 ENDDO
4256 ELSE
4257C---LOOK FOR (S)QUARK OR GLUON
4258 DO KC=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
4259 ID=IDHW(KC)
4260 IF (ID.LE. 6.OR. ID.EQ. 13.OR.(ID.GE.401.AND.ID.LE.406).OR.
4261 & (ID.GE.413.AND.ID.LE.418)) GOTO 20
4262 ENDDO
4263 ENDIF
4264C---COULDNT FIND ONE
4265 CALL HWWARN('HWBRC1',100)
4266 IFGO = .TRUE.
4267 RETURN
4268 20 JC=KC
4269 END
4270CDECK ID>, HWBRC2.
4271*CMZ :- -20/07/99 10:56:12 by Peter Richardson
4272*-- Author : Peter Richardson
4273C-----------------------------------------------------------------------
4274 SUBROUTINE HWBRC2(COLP,IHEP,JC,CON,BVVUSE,BVVHRD)
4275C-----------------------------------------------------------------------
4276C--Function to search in the jet for the particle
4277C-----------------------------------------------------------------------
c63d70bc 4278 INCLUDE 'herwig65.inc'
65767955 4279 INTEGER JC,JD,QHEP,LHEP,IHEP,JHEP,IDM,NCOUNT,ID,IP,IDM2,COLP
4280 LOGICAL CON,BVVUSE,FLA,AFLA,BVVHRD
4281 FLA(IP) = (IP.LE.6.OR.(IP.GE.115.AND.IP.LE.120).
4282 & OR.(IP.GE.401.AND.IP.LE.406).
4283 & OR.(IP.GE.413.AND.IP.LE.418))
4284 AFLA(IP) = ((IP.LE.12.AND.IP.GE.7).OR.(IP.GE.109.AND.IP.LE.114).
4285 & OR.(IP.GE.407.AND.IP.LE.412).
4286 & OR.(IP.GE.419.AND.IP.LE.424))
4287 ID = IDHW(IHEP)
4288 COLP = 0
4289C--begining and end of jet
4290 IF(JDAHEP(1,JC).NE.0) THEN
4291 JC=JDAHEP(1,JC)
4292 JD=JDAHEP(2,JC)
4293 ELSE
4294 COLP = JC
4295 RETURN
4296 ENDIF
4297 IF (JD.LT.JC) JD=JC
4298 LHEP=0
4299 IF(CON) THEN
4300C--SEARCH FOR A COLOUR PARTNER
4301 DO 110 JHEP=JC,JD
4302 IDM = IDHW(JHEP)
4303 IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 110
4304 IF(AFLA(ID).AND.IDM.EQ.13) GOTO 110
4305 IF (JDAHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
4306 IF ((BVVUSE.AND.JMOHEP(2,JHEP).NE.0).OR.
4307 & (.NOT.BVVUSE.AND.JDAHEP(2,JHEP).NE.0)) GOTO 110
4308 IF(BVVUSE.AND.ABS(IDHEP(JHEP)).GT.1000000) THEN
4309 IF(BVVHRD.AND.AFLA(ID)) THEN
4310 CONTINUE
4311 ELSE
4312 RETURN
4313 ENDIF
4314 ENDIF
4315 IF(BVVUSE.AND.(
4316 & ((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449).AND.AFLA(IDM)).
4317 & OR.(AFLA(ID).AND.(FLA(IDM).OR.IDM.EQ.13.OR.IDM.EQ.449))))
4318 & GOTO 110
4319 IF(AFLA(ID).AND.(IDM.EQ.59.OR.IDM.EQ.449.OR.IDM.EQ.13)) GOTO 110
4320C---JOIN IHEP AND JHEP
4321 COLP=JHEP
4322 IF(BVVUSE.OR.(ID.GE.7.AND.ID.LE.12.
4323 & AND.((IDM.GE.7.AND.IDM.LE.12)))) RETURN
4324 IF(IHEP.NE.HRDCOL(1,2).AND.
4325 & (((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.59)
4326 & .AND.(AFLA(IDM).OR.IDM.EQ.13.OR.IDM.EQ.449.OR.IDM.EQ.59))
4327 & .OR.(AFLA(ID).AND.(FLA(IDM).OR.IDM.EQ.59))))
4328 & JDAHEP(2,JHEP)=IHEP
4329 RETURN
4330 110 CONTINUE
4331 IF (LHEP.NE.0) COLP=LHEP
4332C--Additional Baryon number violating piece
4333 IF(COLP.EQ.0) THEN
4334 IDM2= IDHW(JC)
4335 IF(JMOHEP(1,JC).LT.6) THEN
4336 IF(IDM2.LE.6) THEN
4337 IDM2= IDM2+6
4338 ELSEIF(IDM2.GT.6) THEN
4339 IDM2=IDM2-6
4340 ENDIF
4341 ENDIF
4342 IF(IHEP.EQ.HRDCOL(1,2).OR.
4343 & ((FLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.15.OR.ID.EQ.59)
4344 & .AND.(AFLA(IDM2).OR.IDM2.EQ.13.OR.IDM2.EQ.13))) THEN
4345 QHEP = JD+1
4346 12 QHEP = QHEP-1
4347 IF(IDHEP(QHEP).EQ.0) GOTO 12
4348 IF(IDHW(QHEP).EQ.59) THEN
4349 IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4350 COLP = IHEP
4351 RETURN
4352 ELSE
4353 GOTO 12
4354 ENDIF
4355 ENDIF
4356 NCOUNT = 0
4357 11 IF(JDAHEP(2,QHEP).NE.0) THEN
4358 IF(JMOHEP(2,JDAHEP(2,QHEP)).EQ.QHEP.AND.
4359 & JDAHEP(2,QHEP).NE.QHEP) THEN
4360 IF(JDAHEP(2,QHEP).GE.JC.AND.JDAHEP(2,QHEP).LE.JD) THEN
4361 QHEP = JDAHEP(2,QHEP)
4362 NCOUNT = NCOUNT+1
4363 IF(NCOUNT.LT.NHEP) GOTO 11
4364 ENDIF
4365 ENDIF
4366 ENDIF
4367 ELSE
4368 QHEP = JC
4369 13 QHEP = QHEP+1
4370 IF(IDHEP(QHEP).EQ.0) GOTO 13
4371 IF(IDHW(QHEP).EQ.59) THEN
4372 IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4373 COLP = IHEP
4374 RETURN
4375 ELSE
4376 GOTO 13
4377 ENDIF
4378 ENDIF
4379 NCOUNT = 0
4380 9 IF(JMOHEP(2,QHEP).NE.0) THEN
4381 IF(JDAHEP(2,JMOHEP(2,QHEP)).EQ.QHEP.AND.
4382 & JMOHEP(2,QHEP).NE.QHEP) THEN
4383 IF(JMOHEP(2,QHEP).GE.JC.AND.JMOHEP(2,QHEP).LE.JD) THEN
4384 QHEP = JMOHEP(2,QHEP)
4385 NCOUNT = NCOUNT+1
4386 IF(NCOUNT.LT.NHEP) GOTO 9
4387 ENDIF
4388 ENDIF
4389 ENDIF
4390 ENDIF
4391 IF(ABS(IDHEP(QHEP)).LT.1000000) COLP=QHEP
4392 ENDIF
4393 ELSE
4394C--Search for an anticolour partner
4395 DO 210 JHEP=JC,JD
4396 IF (ISTHEP(JHEP).LT.145.OR.ISTHEP(JHEP).GT.152) GOTO 210
4397 IF (JMOHEP(2,JHEP).EQ.IHEP) LHEP=JHEP
4398 IF (JMOHEP(2,JHEP).NE.0) GOTO 210
4399C---JOIN IHEP AND JHEP
4400 COLP=JHEP
4401 RETURN
4402 210 CONTINUE
4403 IF (LHEP.NE.0) COLP=LHEP
4404C--New piece
4405 IF(COLP.EQ.0) THEN
4406 IDM2=IDHW(JC)
4407 IF(JMOHEP(1,JC).LT.6) THEN
4408 IF(IDM2.LE.6) THEN
4409 IDM2= IDM2+6
4410 ELSEIF(IDM2.GT.6) THEN
4411 IDM2=IDM2-6
4412 ENDIF
4413 ENDIF
4414C--Additional Baryon number violating piece
4415 IF((FLA(ID).AND.AFLA(IDM2)).OR.
4416 & ((AFLA(ID).OR.ID.EQ.13.OR.ID.EQ.449.OR.ID.EQ.15.OR.ID.EQ.59)
4417 & .AND.(FLA(IDM2).OR.IDM2.EQ.13.OR.IDM2.EQ.449)
4418 & .AND..NOT.(IDHW(JMOHEP(1,JC)).EQ.13.AND.
4419 & IDHW(JMOHEP(1,JMOHEP(1,JC))).EQ.12.AND.
4420 & ISTHEP(JMOHEP(1,JMOHEP(1,JC))).EQ.155)
4421 & )) THEN
4422C--special for gluino decay to gluon
4423 IF(ID.EQ.449.AND.IDHW(JMOHEP(1,JMOHEP(1,JC))).EQ.449.AND.
4424 & IDHW(JMOHEP(1,JC)).EQ.13) RETURN
4425 QHEP = JC
4426 211 QHEP = QHEP+1
4427 IF(IDHEP(QHEP).EQ.0) GOTO 211
4428 IF(IDHW(QHEP).EQ.59) THEN
4429 IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4430 COLP = IHEP
4431 RETURN
4432 ELSE
4433 GOTO 211
4434 ENDIF
4435 ENDIF
4436 NCOUNT = 0
4437 209 IF(JMOHEP(2,QHEP).NE.0) THEN
4438 IF(JDAHEP(2,JMOHEP(2,QHEP)).EQ.QHEP.AND.
4439 & JMOHEP(2,QHEP).NE.QHEP) THEN
4440 IF(JMOHEP(2,QHEP).GE.JC.AND.JMOHEP(2,QHEP).LE.JD) THEN
4441 QHEP = JMOHEP(2,QHEP)
4442 NCOUNT = NCOUNT+1
4443 IF(NCOUNT.LT.NHEP) GOTO 209
4444 ENDIF
4445 ENDIF
4446 ENDIF
4447 IF(QHEP.NE.0) COLP=QHEP
4448 IF(JDAHEP(2,QHEP).EQ.0.AND.IHEP.NE.6) THEN
4449 IDM2= IDHW(QHEP)
4450 IF(FLA(IHEP).AND.FLA(QHEP).OR.
4451 & ((AFLA(IHEP).OR.ID.EQ.13.OR.ID.EQ.449).AND.
4452 & (AFLA(QHEP).OR.IDM2.EQ.13.OR.IDM2.EQ.449)))
4453 & JDAHEP(2,QHEP)=IHEP
4454 ENDIF
4455 ELSE
4456 QHEP = JD+1
4457 220 QHEP = QHEP-1
4458 IF(IDHEP(QHEP).EQ.0) GOTO 220
4459 IF(IDHW(QHEP).EQ.59) THEN
4460 IF(JC.EQ.JD.AND.IDHW(JMOHEP(1,QHEP)).EQ.59) THEN
4461 COLP = IHEP
4462 RETURN
4463 ELSE
4464 GOTO 220
4465 ENDIF
4466 ENDIF
4467 NCOUNT = 0
4468 219 IF(JDAHEP(2,QHEP).NE.0) THEN
4469 IF(JMOHEP(2,JDAHEP(2,QHEP)).EQ.QHEP) THEN
4470 IF(JDAHEP(2,QHEP).GE.JC.AND.JDAHEP(2,QHEP).LE.JD) THEN
4471 QHEP = JDAHEP(2,QHEP)
4472 NCOUNT = NCOUNT+1
4473 IF(NCOUNT.LT.200) GOTO 219
4474 ENDIF
4475 ENDIF
4476 ENDIF
4477 IF(QHEP.NE.0) COLP=QHEP
4478 IDM2 = IDHW(QHEP)
4479 IF(JDAHEP(2,QHEP).EQ.0.AND.
4480 & (((AFLA(ID).OR.ID.EQ.13).AND.(AFLA(IDM2).OR.IDM2.EQ.13)).OR.
4481 & (FLA(ID).AND.FLA(IDM2)))) JDAHEP(2,QHEP)=IHEP
4482 ENDIF
4483 ENDIF
4484 ENDIF
4485 END
4486CDECK ID>, HWBSPA.
4487*CMZ :- -26/04/91 14.26.44 by Federico Carminati
4488*-- Author : Ian Knowles
4489C-----------------------------------------------------------------------
4490 SUBROUTINE HWBSPA
4491C-----------------------------------------------------------------------
4492C Constructs time-like 4-momenta & production vertices in space-like
4493C jet started by parton no.2 interference partner 1 and spin density
4494C DECPAR(2). RHOPAR(2) gives the jet spin density matrix.
4495C See I.G. Knowles, Comp. Phys. Comm. 58 (90) 271.
4496C-----------------------------------------------------------------------
c63d70bc 4497 INCLUDE 'herwig65.inc'
65767955 4498 DOUBLE PRECISION HWRGEN,DMIN,PT,EIKON,EISCR,EINUM,EIDEN1,EIDEN2,
4499 & WT,SPIN,Z1,Z2,TR,PRMAX,CX,SX,CAZ,ROHEP(3),RMAT(3,3),ZERO2(2)
4500 INTEGER IPAR,JPAR,KPAR,LPAR,MPAR,JSTR,LSTR,MSTR
4501 LOGICAL EICOR
4502 EXTERNAL HWRGEN
4503 SAVE ZERO2,DMIN
4504 DATA ZERO2,DMIN/2*0D0,1D-15/
4505 IF (IERROR.NE.0) RETURN
4506 JPAR=2
4507 KPAR=1
4508 IF (NPAR.EQ.2) THEN
4509 CALL HWVZRO(2,RHOPAR(1,2))
4510 RETURN
4511 ENDIF
4512C Generate azimuthal angle of JPAR's branching using an M-function
4513C Find the daughters of JPAR, with LPAR time-like
4514 10 LPAR=JDAPAR(1,JPAR)
4515 IF (TMPAR(LPAR)) THEN
4516 MPAR=LPAR+1
4517 ELSE
4518 MPAR=LPAR
4519 LPAR=MPAR+1
4520 ENDIF
4521C Soft correlations
4522 CALL HWUROT(PPAR(1,JPAR), ONE,ZERO,RMAT)
4523 CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
4524 PT=MAX(SQRT(ROHEP(1)*ROHEP(1)+ROHEP(2)*ROHEP(2)),DMIN)
4525 EIKON=1.
4526 EICOR=AZSOFT.AND.IDPAR(LPAR).EQ.13
4527 IF (EICOR) THEN
4528 IF (ABS(PPAR(5,MPAR)).LT.DMIN) THEN
4529 EISCR=ONE
4530 ELSE
4531 EISCR=ONE-(PPAR(5,MPAR)/PPAR(4,MPAR))**2
4532 & /MIN(PPAR(2,LPAR),PPAR(2,MPAR))
4533 ENDIF
4534 EINUM=PPAR(4,KPAR)*PPAR(4,LPAR)*ABS(PPAR(2,LPAR)-PPAR(2,MPAR))
4535 EIDEN1=PPAR(4,KPAR)*PPAR(4,LPAR)-ROHEP(3)*PPAR(3,LPAR)
4536 EIDEN2=PT*ABS(PPAR(1,LPAR))
4537 EIKON=MAX(EISCR+EINUM/MAX(EIDEN1-EIDEN2,DMIN),ZERO)
4538 ENDIF
4539C Spin correlations
4540 WT=ZERO
4541 SPIN=ONE
4542 IF (AZSPIN.AND.IDPAR(JPAR).EQ.13) THEN
4543 Z1=PPAR(4,JPAR)/PPAR(4,MPAR)
4544 Z2=ONE-Z1
4545 IF (IDPAR(MPAR).EQ.13) THEN
4546 TR=Z1/Z2+Z2/Z1+Z1*Z2
4547 ELSEIF (IDPAR(MPAR).LT.13) THEN
4548 TR=(ONE+Z2**2)/(TWO*Z1)
4549 ENDIF
4550 WT=Z2/(Z1*TR)
4551 ENDIF
4552C Assign the azimuthal angle
4553 PRMAX=(1.+ABS(WT))*EIKON
4554 50 CALL HWRAZM( ONE,CX,SX)
4555 CALL HWUROT(PPAR(1,JPAR),CX,SX,RMAT)
4556C Determine the angle between the branching planes
4557 CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
4558 CAZ=ROHEP(1)/PT
4559 PHIPAR(1,JPAR)=2.*CAZ*CAZ-1.
4560 PHIPAR(2,JPAR)=2.*CAZ*ROHEP(2)/PT
4561 IF (EICOR) EIKON=MAX(EISCR+EINUM/MAX(EIDEN1-EIDEN2*CAZ,DMIN),ZERO)
4562 IF (AZSPIN) SPIN=1.+WT*(DECPAR(1,JPAR)*PHIPAR(1,JPAR)
4563 & +DECPAR(2,JPAR)*PHIPAR(2,JPAR))
4564 IF (SPIN*EIKON.LT.HWRGEN(0)*PRMAX) GOTO 50
4565C Construct full 4-momentum of LPAR, sum P-trans of MPAR
4566 PPAR(2,LPAR)=ZERO
4567 PPAR(2,MPAR)=ZERO
4568 CALL HWUROB(RMAT,PPAR(1,LPAR),PPAR(1,LPAR))
4569 CALL HWVDIF(2,PPAR(1,2),PPAR(1,LPAR),PPAR(1,2))
4570C Test for end of space-like branches
4571 IF (JDAPAR(1,MPAR).EQ.0) GOTO 60
4572C Generate new Decay matrix
4573 CALL HWBAZF(MPAR,JPAR,ZERO2,DECPAR(1,JPAR),
4574 & PHIPAR(1,JPAR),DECPAR(1,MPAR))
4575C Advance along the space-like branch
4576 JPAR=MPAR
4577 KPAR=LPAR
4578 GOTO 10
4579C Retreat along space-like line
4580C Assign initial spin density matrix
4581 60 CONTINUE
4582 CALL HWVEQU(2,ZERO2,RHOPAR(1,MPAR))
4583 CALL HWUMAS(PPAR(1,2))
4584 CALL HWVZRO(4,VPAR(1,MPAR))
4585 JSTR=JPAR
4586 LSTR=LPAR
4587 MSTR=MPAR
4588 70 JPAR=JSTR
4589 LPAR=LSTR
4590 MPAR=MSTR
4591 CALL HWVEQU(4,VPAR(1,MPAR),VPAR(1,LPAR))
4592 IF (MPAR.EQ.2) RETURN
4593C Construct spin density matrix for time-like branch
4594 CALL HWBAZF(MPAR,JPAR,RHOPAR(1,MPAR),PHIPAR(1,JPAR),
4595 & DECPAR(1,JPAR),RHOPAR(1,LPAR))
4596C Evolve time-like side branch
4597 CALL HWBTIM(LPAR,MPAR)
4598C Construct spin density matrix for space-like branch
4599 CALL HWBAZF(MPAR,JPAR,PHIPAR(1,JPAR),RHOPAR(1,MPAR),
4600 & DECPAR(1,LPAR),RHOPAR(1,JPAR))
4601C Assign production vertex to J
4602 CALL HWVDIF(4,PPAR(1,MPAR),PPAR(1,LPAR),PPAR(1,JPAR))
4603 CALL HWUDKL(IDPAR(JPAR),PPAR(1,JPAR),VPAR(1,JPAR))
4604 CALL HWVSUM(4,VPAR(1,MPAR),VPAR(1,JPAR),VPAR(1,JPAR))
4605C Find parent and partner of MPAR
4606 MPAR=JPAR
4607 JPAR=JMOPAR(1,MPAR)
4608C BRW modified here 19/06/01 to avoid compiler-dependent bug
4609C (overwriting of JPAR etc.)
4610 IPAR=MPAR+1
4611 KPAR=JMOPAR(1,IPAR)
4612 IF (JPAR.EQ.KPAR) THEN
4613 LPAR=MPAR+1
4614 ELSE
4615 LPAR=MPAR-1
4616 ENDIF
4617 JSTR=JPAR
4618 LSTR=LPAR
4619 MSTR=MPAR
4620 GOTO 70
4621 END
4622CDECK ID>, HWBSPN.
4623*CMZ :- -26/04/91 11.11.54 by Bryan Webber
4624*-- Author : Ian Knowles
4625C-----------------------------------------------------------------------
4626 SUBROUTINE HWBSPN
4627C-----------------------------------------------------------------------
4628C Constructs appropriate spin density/decay matrix for parton
4629C in hard subprocess, otherwise zero. Assignments based upon
4630C Comp. Phys. Comm. 58 (1990) 271.
4631C-----------------------------------------------------------------------
c63d70bc 4632 INCLUDE 'herwig65.inc'
65767955 4633 DOUBLE PRECISION C,V12,V23,V13,TR,C1,C2,C3,R1(2),R2(2)
4634 INTEGER IST
4635 SAVE R1,R2,V12
4636 IF (IERROR.NE.0) RETURN
4637 IST=MOD(ISTHEP(NEVPAR),10)
4638C Assumed partons processed in the order IST=1,2,3,4
4639 IF (IPROC.GE.100.AND.IPROC.LE.116) THEN
4640C An e+e- ---> qqbar g event
4641 IF (IDPAR(2).EQ.13) THEN
4642 RHOPAR(1,2)=GPOLN
4643 RHOPAR(2,2)=0.
4644 RETURN
4645 ENDIF
4646 ELSEIF (IPRO.EQ.15.OR.IPRO.EQ.17) THEN
4647 IF (IHPRO.EQ. 7.OR.IHPRO.EQ. 8.OR.
4648 & IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
4649 & IHPRO.EQ.15.OR.IHPRO.EQ.16.OR.
4650 & (IHPRO.GE.21.AND.IHPRO.LE.31)) THEN
4651C A hard 2 --- > 2 QCD subprocess involving gluons
4652 IF (IST.EQ.2) THEN
4653 CALL HWVEQU(2,RHOPAR(1,2),R1(1))
4654 C=GCOEF(2)/GCOEF(1)
4655 DECPAR(1,2)=C*R1(1)
4656 DECPAR(2,2)=C*R1(2)
4657 RETURN
4658 ELSEIF (IST.EQ.3) THEN
4659 CALL HWVEQU(2,RHOPAR(1,2),R2(1))
4660 V12=R1(1)*R2(1)+R1(2)*R2(2)
4661 TR=1./(GCOEF(1)+GCOEF(2)*V12)
4662 RHOPAR(1,2)= (GCOEF(3)*R1(1)+GCOEF(4)*R2(1))*TR
4663 RHOPAR(2,2)=-(GCOEF(3)*R1(2)+GCOEF(4)*R2(2))*TR
4664 RETURN
4665 ELSEIF (IST.EQ.4) THEN
4666 V13=R1(1)*DECPAR(1,2)+R1(2)*DECPAR(2,2)
4667 V23=R2(1)*DECPAR(1,2)+R2(2)*DECPAR(2,2)
4668 TR=1./(GCOEF(1)+GCOEF(2)*V12+GCOEF(3)*V13+GCOEF(4)*V23)
4669 C1=(GCOEF(2)+GCOEF(5))*TR
4670 C2=(GCOEF(3)+GCOEF(6))*TR
4671 C3=(GCOEF(4)+GCOEF(6))*TR
4672 RHOPAR(1,2)=C1*DECPAR(1,2)+C2*R2(1)+C3*R1(1)
4673 RHOPAR(2,2)=C1*DECPAR(2,2)-C2*R1(2)-C3*R2(2)
4674 RETURN
4675 ENDIF
4676 ENDIF
4677 ELSEIF ((IPRO.EQ.16).OR.(IPRO.EQ.36)) THEN
4678C A gluon fusion ---> Higgs event
4679 IF (IST.EQ.2) THEN
4680 IF (IHIGGS.NE.4) THEN
4681 DECPAR(1,2)=RHOPAR(1,2)
4682 DECPAR(2,2)=-RHOPAR(2,2)
4683 ELSE
4684 DECPAR(1,2)=-RHOPAR(1,2)
4685 DECPAR(2,2)=RHOPAR(2,2)
4686 END IF
4687 RETURN
4688 ENDIF
4689 ELSEIF (IPRO.EQ.42) THEN
4690C A gluon fusion (or qq-bar annihilation) ---> graviton production event
4691 IF (IST.EQ.2) THEN
4692 DECPAR(1,2)=RHOPAR(1,2)
4693 DECPAR(2,2)=RHOPAR(2,2)
4694 RETURN
4695 ENDIF
4696 ENDIF
4697 CALL HWVZRO(2,RHOPAR(1,2))
4698 CALL HWVZRO(2,DECPAR(1,2))
4699 END
4700CDECK ID>, HWBSU1.
4701*CMZ :- -13/07/92 20.15.54 by Mike Seymour
4702*-- Author : Bryan Webber, modified by Mike Seymour
4703C-----------------------------------------------------------------------
4704 FUNCTION HWBSU1(ZLOG)
4705C-----------------------------------------------------------------------
4706C Z TIMES THE INTEGRAND IN EXPONENT OF QUARK SUDAKOV FORM FACTOR.
4707C HWBSU1 IS FOR UPPER PART OF Z INTEGRATION REGION
4708C-----------------------------------------------------------------------
4709 IMPLICIT NONE
4710 DOUBLE PRECISION HWBSU1,HWBSUL,Z,ZLOG,U
4711 EXTERNAL HWBSUL
4712 Z=EXP(ZLOG)
4713 U=1.-Z
4714 HWBSU1=HWBSUL(Z)*(1.+U*U)
4715 END
4716CDECK ID>, HWBSU2.
4717*CMZ :- -13/07/92 20.15.54 by Mike Seymour
4718*-- Author : Bryan Webber, modified by Mike Seymour
4719C-----------------------------------------------------------------------
4720 FUNCTION HWBSU2(Z)
4721C-----------------------------------------------------------------------
4722C INTEGRAND IN EXPONENT OF QUARK SUDAKOV FORM FACTOR.
4723C HWBSU2 IS FOR LOWER PART OF Z INTEGRATION REGION
4724C-----------------------------------------------------------------------
4725 IMPLICIT NONE
4726 DOUBLE PRECISION HWBSU2,HWBSUL,Z,U
4727 EXTERNAL HWBSUL
4728 U=1.-Z
4729 HWBSU2=HWBSUL(Z)*(1.+Z*Z)/U
4730 END
4731CDECK ID>, HWBSUD.
4732*CMZ :- -14/07/92 13.28.23 by Mike Seymour
4733*-- Author : Bryan Webber
4734C-----------------------------------------------------------------------
4735 SUBROUTINE HWBSUD
4736C-----------------------------------------------------------------------
4737C COMPUTES (OR READS) TABLES OF SUDAKOV FORM FACTORS
4738C-----------------------------------------------------------------------
c63d70bc 4739 INCLUDE 'herwig65.inc'
65767955 4740 DOUBLE PRECISION HWUGAU,HWBVMC,HWBSUG,HWBSU1,HWBSU2,G1,G2,QRAT,
4741 & QLAM,POWER,AFAC,QMIN,QFAC,QNOW,ZMIN,ZMAX,Q1,QCOLD,VGOLD,VQOLD,
4742 & RMOLD(6),ACOLD,ZLO,ZHI
4743 INTEGER IQ,IS,L1,L2,L,LL,I,INOLD,NQOLD,NSOLD,NCOLD,NFOLD,SDOLD
4744 EXTERNAL HWUGAU,HWBVMC,HWBSUG,HWBSU1,HWBSU2
4745 SAVE NQOLD,NSOLD,NCOLD,NFOLD,SDOLD,QCOLD,VGOLD,VQOLD,RMOLD,ACOLD,
4746 & INOLD
4747 COMMON/HWSINT/QRAT,QLAM
4748 IF (LRSUD.EQ.0) THEN
4749 POWER=1./FLOAT(NQEV-1)
4750 AFAC=6.*CAFAC/BETAF
4751 QMIN=QG+QG
4752 QFAC=(1.1*QLIM/QMIN)**POWER
4753 SUD(1,1)=1.
4754 QEV(1,1)=QMIN
4755C--IS=1 FOR GLUON->GLUON+GLUON FORM FACTOR
4756 DO 10 IQ=2,NQEV
4757 QNOW=QFAC*QEV(IQ-1,1)
4758 QLAM=QNOW/QCDL3
4759 ZMIN=QG/QNOW
4760 QRAT=1./ZMIN
4761 G1=0
4762 DO 5 I=3,6
4763 ZLO=ZMIN
4764 ZHI=HALF
4765 IF (I.NE.6) ZLO=MAX(ZLO,QG/RMASS(I+1))
4766 IF (I.NE.3) ZHI=MIN(ZHI,QG/RMASS(I))
4767 IF (ZHI.GT.ZLO) G1=G1+HWUGAU(HWBSUG,LOG(ZLO),LOG(ZHI),ACCUR)
4768 5 CONTINUE
4769 SUD(IQ,1)=EXP(AFAC*G1)
4770 10 QEV(IQ,1)=QNOW
4771 AFAC=3.*CFFAC/BETAF
4772C--QUARK FORM FACTORS.
4773C--IS=2,3,4,5,6,7 FOR U/D,S,C,B,T,V
4774 DO 15 IS=2,NSUD
4775 Q1=HWBVMC(IS)
4776 IF (IS.EQ.7) Q1=HWBVMC(209)
4777 QMIN=Q1+QG
4778 IF (QMIN.GT.QLIM) GOTO 15
4779 QFAC=(1.1*QLIM/QMIN)**POWER
4780 SUD(1,IS)=1.
4781 QEV(1,IS)=QMIN
4782 DO 14 IQ=2,NQEV
4783 QNOW=QFAC*QEV(IQ-1,IS)
4784 QLAM=QNOW/QCDL3
4785 ZMIN=QG/QNOW
4786 QRAT=1./ZMIN
4787 ZMAX=QG/QMIN
4788 G1=0
4789 DO 12 I=3,6
4790 ZLO=ZMIN
4791 ZHI=ZMAX
4792 IF (I.NE.6) ZLO=MAX(ZLO,QG/RMASS(I+1))
4793 IF (I.NE.3) ZHI=MIN(ZHI,QG/RMASS(I))
4794 IF (ZHI.GT.ZLO) G1=G1+HWUGAU(HWBSU1,LOG(ZLO),LOG(ZHI),ACCUR)
4795 12 CONTINUE
4796 ZMIN=Q1/QNOW
4797 QRAT=1./ZMIN
4798 ZMAX=Q1/QMIN
4799 G2=0
4800 DO 13 I=3,6
4801 ZLO=ZMIN
4802 ZHI=ZMAX
4803 IF (I.NE.6) ZLO=MAX(ZLO,Q1/RMASS(I+1))
4804 IF (I.NE.3) ZHI=MIN(ZHI,Q1/RMASS(I))
4805 IF (ZHI.GT.ZLO) G2=G2+HWUGAU(HWBSU2,ZLO,ZHI,ACCUR)
4806 13 CONTINUE
4807 SUD(IQ,IS)=EXP(AFAC*(G1+G2))
4808 14 QEV(IQ,IS)=QNOW
4809 15 CONTINUE
4810 QCOLD=QCDLAM
4811 VGOLD=VGCUT
4812 VQOLD=VQCUT
4813 ACOLD=ACCUR
4814 INOLD=INTER
4815 NQOLD=NQEV
4816 NSOLD=NSUD
4817 NCOLD=NCOLO
4818 NFOLD=NFLAV
4819 SDOLD=SUDORD
4820 DO 16 IS=1,NSUD
4821 16 RMOLD(IS)=RMASS(IS)
4822 ELSE
4823 IF (LRSUD.GT.0) THEN
4824 IF (IPRINT.NE.0) WRITE (6,17) LRSUD
4825 17 FORMAT(/10X,'READING SUDAKOV TABLE ON UNIT',I4)
4826 OPEN(UNIT=LRSUD,FORM='UNFORMATTED',STATUS='UNKNOWN')
4827 READ(UNIT=LRSUD) QCOLD,VGOLD,VQOLD,RMOLD,
4828 & ACOLD,QEV,SUD,INOLD,NQOLD,NSOLD,NCOLD,NFOLD,SDOLD
4829 CLOSE(UNIT=LRSUD)
4830 ENDIF
4831C---CHECK THAT RELEVANT PARAMETERS ARE UNCHANGED
4832 IF (QCDLAM.NE.QCOLD) CALL HWWARN('HWBSUD',501)
4833 IF (VGCUT .NE.VGOLD) CALL HWWARN('HWBSUD',502)
4834 IF (VQCUT .NE.VQOLD) CALL HWWARN('HWBSUD',503)
4835 IF (ACCUR .NE.ACOLD) CALL HWWARN('HWBSUD',504)
4836 IF (INTER .NE.INOLD) CALL HWWARN('HWBSUD',505)
4837 IF (NQEV .NE.NQOLD) CALL HWWARN('HWBSUD',506)
4838 IF (NSUD .NE.NSOLD) CALL HWWARN('HWBSUD',507)
4839 IF (NCOLO .NE.NCOLD) CALL HWWARN('HWBSUD',508)
4840 IF (NFLAV .NE.NFOLD) CALL HWWARN('HWBSUD',509)
4841 IF (SUDORD.NE.SDOLD) CALL HWWARN('HWBSUD',510)
4842C---CHECK MASSES AND THAT TABLES ARE BIG ENOUGH FOR THIS RUN
4843 DO 18 IS=1,NSUD
4844 IF (RMASS(IS).NE.RMOLD(IS))
4845 & CALL HWWARN('HWBSUD',510+IS)
4846 IF (QEV(NQEV,IS).LT.QLIM.AND.HWBVMC(IS)+QG.LT.QLIM)
4847 & CALL HWWARN('HWBSUD',500)
4848 18 CONTINUE
4849 ENDIF
4850 IF (LWSUD.GT.0) THEN
4851 IF (IPRINT.NE.0) WRITE (6,19) LWSUD
4852 19 FORMAT(/10X,'WRITING SUDAKOV TABLE ON UNIT',I4)
4853 OPEN (UNIT=LWSUD,FORM='UNFORMATTED',STATUS='UNKNOWN')
4854 WRITE(UNIT=LWSUD) QCDLAM,VGCUT,VQCUT,(RMASS(I),I=1,6),
4855 & ACCUR,QEV,SUD,INTER,NQEV,NSUD,NCOLO,NFLAV,SUDORD
4856 CLOSE(UNIT=LWSUD)
4857 ENDIF
4858 IF (IPRINT.GT.2) THEN
4859C--PRINT EXTRACTS FROM TABLES OF FORM FACTORS
4860 DO 40 IS=1,NSUD
4861 WRITE(6,20) IS,NQEV
4862 20 FORMAT(1H1//10X,'EXTRACT FROM TABLE OF SUDAKOV FORM FACTOR NO.',
4863 & I2,' (',I5,' ACTUAL ENTRIES)'//10X,'SUD IS PROBABILITY THAT',
4864 & ' PARTON WITH GIVEN UPPER LIMIT ON Q WILL REACH THRESHOLD',
4865 & ' WITHOUT BRANCHING'///2X,8(' Q SUD ')/)
4866 L2=NQEV/8
4867 L1=L2/32
4868 IF (L1.LT.1) L1=1
4869 DO 40 L=L1,L2,L1
4870 LL=L+7*L2
4871 WRITE(6,30) (QEV(I,IS),SUD(I,IS),I=L,LL,L2)
4872 30 FORMAT(2X,8(F9.2,F7.4))
4873 40 CONTINUE
4874 WRITE(6,50)
4875 50 FORMAT(1H1)
4876 ENDIF
4877 END
4878CDECK ID>, HWBSUG.
4879*CMZ :- -13/07/92 20.15.54 by Mike Seymour
4880*-- Author : Bryan Webber, modified by Mike Seymour
4881C-----------------------------------------------------------------------
4882 FUNCTION HWBSUG(ZLOG)
4883C-----------------------------------------------------------------------
4884C Z TIMES INTEGRAND IN EXPONENT OF GLUON SUDAKOV FORM FACTOR
4885C-----------------------------------------------------------------------
4886 IMPLICIT NONE
4887 DOUBLE PRECISION HWBSUG,HWBSUL,Z,ZLOG,W
4888 EXTERNAL HWBSUL
4889 Z=EXP(ZLOG)
4890 W=Z*(1.-Z)
4891 HWBSUG=HWBSUL(Z)*(W-2.+1./W)*Z
4892 END
4893CDECK ID>, HWBSUL.
4894*CMZ :- -13/07/92 20.15.54 by Mike Seymour
4895*-- Author : Mike Seymour
4896C-----------------------------------------------------------------------
4897 FUNCTION HWBSUL(Z)
4898C-----------------------------------------------------------------------
4899C LOGARITHMIC PART OF INTEGRAND IN EXPONENT OF SUDAKOV FORM FACTOR.
4900C THE SECOND ORDER ALPHAS CASE COMES FROM CONVERTING INTEGRAL OVER
4901C Q^2 INTO ONE OVER ALPHAS, WITH FLAVOUR THRESHOLDS.
4902C-----------------------------------------------------------------------
c63d70bc 4903 INCLUDE 'herwig65.inc'
65767955 4904 DOUBLE PRECISION HWBSUL,HWUALF,Z,QRAT,QLAM,U,AL,BL,QNOW,QMIN,
4905 & BET(6),BEP(6),MUMI(6),MUMA(6),ALMI(6),ALMA(6),FINT(6),ALFINT,
4906 & MUMIN,MUMAX,ALMIN,ALMAX
4907 INTEGER NF
4908 LOGICAL FIRST
4909 EXTERNAL HWUALF
4910 SAVE FIRST,BET,BEP,MUMI,MUMA
4911 COMMON/HWSINT/QRAT,QLAM
4912 DATA FIRST/.TRUE./
4913 ALFINT(AL,BL)=1/BET(NF)*
4914 & LOG(BL/(AL*(1+BEP(NF)*BL))*(1+BEP(NF)*AL))
4915 HWBSUL=0
4916 U=1.-Z
4917 IF (SUDORD.EQ.1) THEN
4918 AL=LOG(QRAT*Z)
4919 BL=LOG(QLAM*U*Z)
4920 HWBSUL=LOG(1.-AL/BL)
4921 ELSE
4922 IF (FIRST) THEN
4923 DO 10 NF=3,6
4924 BET(NF)=(11*CAFAC-2*NF)/(12*PIFAC)
4925 BEP(NF)=(17*CAFAC**2-(5*CAFAC+3*CFFAC)*NF)/(24*PIFAC**2)
4926 & /BET(NF)
4927 IF (NF.EQ.3) THEN
4928 MUMI(3)=0
4929 ALMI(3)=1D30
4930 ELSE
4931 MUMI(NF)=RMASS(NF)
4932 ALMI(NF)=HWUALF(1,MUMI(NF))
4933 ENDIF
4934 IF (NF.EQ.6) THEN
4935 MUMA(NF)=1D30
4936 ALMA(NF)=0
4937 ELSE
4938 MUMA(NF)=RMASS(NF+1)
4939 ALMA(NF)=HWUALF(1,MUMA(NF))
4940 ENDIF
4941 IF (NF.NE.3.AND.NF.NE.6) FINT(NF)=ALFINT(ALMI(NF),ALMA(NF))
4942 10 CONTINUE
4943 FIRST=.FALSE.
4944 ENDIF
4945 QNOW=QLAM*QCDL3
4946 QMIN=QNOW/QRAT
4947 MUMIN= U*QMIN
4948 MUMAX=Z*U*QNOW
4949 IF (MUMAX.LE.MUMIN) RETURN
4950 ALMIN=HWUALF(1,MUMIN)
4951 ALMAX=HWUALF(1,MUMAX)
4952 NF=3
4953 20 IF (MUMIN.GT.MUMA(NF)) THEN
4954 NF=NF+1
4955 GOTO 20
4956 ENDIF
4957 IF (MUMAX.LT.MUMA(NF)) THEN
4958 HWBSUL=ALFINT(ALMIN,ALMAX)
4959 ELSE
4960 HWBSUL=ALFINT(ALMIN,ALMA(NF))
4961 NF=NF+1
4962 30 IF (MUMAX.GT.MUMA(NF)) THEN
4963 HWBSUL=HWBSUL+FINT(NF)
4964 NF=NF+1
4965 GOTO 30
4966 ENDIF
4967 HWBSUL=HWBSUL+ALFINT(ALMI(NF),ALMAX)
4968 ENDIF
4969 HWBSUL=HWBSUL*BET(5)
4970 ENDIF
4971 END
4972CDECK ID>, HWBTIM.
4973*CMZ :- -26/04/91 14.27.17 by Federico Carminati
4974*-- Author : Ian Knowles
4975C-----------------------------------------------------------------------
4976 SUBROUTINE HWBTIM(INITBR,INTERF)
4977C-----------------------------------------------------------------------
4978C Constructs full 4-momentum & production vertices in time-like jet
4979C initiated by INITBR, interference partner INTERF and spin density
4980C RHOPAR(INITBR). DECPAR(INITBR) returns jet's spin density matrix.
4981C Includes azimuthal angular correlations between branching planes
4982C due to spin (if AZSPIN) using the algorithm of Knowles & Collins.
4983C Ses Nucl. Phys. B304 (1988) 794 & Comp. Phys. Comm. 58 (1990) 271.
4984C-----------------------------------------------------------------------
c63d70bc 4985 INCLUDE 'herwig65.inc'
65767955 4986 DOUBLE PRECISION HWRGEN,DMIN,PT,EIKON,EINUM,EIDEN1,EIDEN2,EISCR,
4987 & WT,SPIN,Z1,Z2,PRMAX,CAZ,CX,SX,ROHEP(3),RMAT(3,3),ZERO2(2)
4988 INTEGER INITBR,INTERF,IPAR,JPAR,KPAR,LPAR,MPAR,NTRY,JOLD
4989 LOGICAL EICOR,SWAP
4990 EXTERNAL HWRGEN
4991 SAVE ZERO2,DMIN
4992 DATA ZERO2,DMIN/ZERO,ZERO,1.D-15/
4993 IF (IERROR.NE.0) RETURN
4994 JPAR=INITBR
4995 KPAR=INTERF
4996 IF ((JDAPAR(1,JPAR).NE.0).OR.(IDPAR(JPAR).EQ.13)) GOTO 30
4997C No branching, assign decay matrix
4998 CALL HWVZRO(2,DECPAR(1,JPAR))
4999 RETURN
5000C Advance up the leader
5001C Find the parent and partner of J
5002 10 IPAR=JMOPAR(1,JPAR)
5003 KPAR=JPAR+1
5004C Generate new Rho
5005 IF (JMOPAR(1,KPAR).EQ.IPAR) THEN
5006C Generate Rho'
5007 CALL HWBAZF(IPAR,JPAR,PHIPAR(1,IPAR),RHOPAR(1,IPAR),
5008 & ZERO2,RHOPAR(1,JPAR))
5009 ELSE
5010 KPAR=JPAR-1
5011 IF (JMOPAR(1,KPAR).NE.IPAR) THEN
5012 CALL HWWARN('HWBTIM',100)
5013 GOTO 999
5014 ENDIF
5015C Generate Rho''
5016 CALL HWBAZF(IPAR,KPAR,RHOPAR(1,IPAR),PHIPAR(1,IPAR),
5017 & DECPAR(1,KPAR),RHOPAR(1,JPAR))
5018 ENDIF
5019C Generate azimuthal angle of J's branching
5020 30 IF (JDAPAR(1,JPAR).EQ.0) THEN
5021C Final state gluon
5022 CALL HWVZRO(2,DECPAR(1,JPAR))
5023 IF (JPAR.EQ.INITBR) RETURN
5024 GOTO 70
5025 ELSE
5026C Assign an angle to a branching using an M-function
5027C Find the daughters of J
5028 LPAR=JDAPAR(1,JPAR)
5029 MPAR=JDAPAR(2,JPAR)
5030C Soft correlations
5031 CALL HWUROT(PPAR(1,JPAR), ONE,ZERO,RMAT)
5032 CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
5033 PT=MAX(SQRT(ROHEP(1)*ROHEP(1)+ROHEP(2)*ROHEP(2)),DMIN)
5034 EIKON=1.
5035 SWAP=.FALSE.
5036 EICOR=AZSOFT.AND.((IDPAR(LPAR).EQ.13).OR.(IDPAR(MPAR).EQ.13))
5037 IF (EICOR) THEN
5038C Rearrange s.t. LPAR is the (softest) gluon
5039 IF (IDPAR(MPAR).EQ.13) THEN
5040 IF (IDPAR(LPAR).NE.13.OR.
5041 & PPAR(4,MPAR).LT.PPAR(4,LPAR)) THEN
5042 SWAP=.TRUE.
5043 LPAR=MPAR
5044 MPAR=LPAR-1
5045 ENDIF
5046 ENDIF
5047 EINUM=(PPAR(4,KPAR)*PPAR(4,LPAR))
5048 & *ABS(PPAR(2,LPAR)-PPAR(2,MPAR))
5049 EIDEN1=(PPAR(4,KPAR)*PPAR(4,LPAR))-ROHEP(3)*PPAR(3,LPAR)
5050 EIDEN2=PT*ABS(PPAR(1,LPAR))
5051 IF (ABS(PPAR(2,MPAR)).LT.DMIN) THEN
5052 IF (ABS(PPAR(5,MPAR)).LT.DMIN) THEN
5053 EISCR=ONE
5054 ELSE
5055 CALL HWWARN('HWBTIM',102)
5056 GOTO 999
5057 ENDIF
5058 ELSE
5059 EISCR=ONE-(PPAR(5,MPAR)/PPAR(4,MPAR))**2
5060 & /MIN(PPAR(2,LPAR),PPAR(2,MPAR))
5061 ENDIF
5062 EIKON=EISCR+EINUM/MAX(EIDEN1-EIDEN2,DMIN)
5063 ENDIF
5064C Spin correlations
5065 WT=0.
5066 SPIN=1.
5067 IF (AZSPIN) THEN
5068 Z1=PPAR(4,LPAR)/PPAR(4,JPAR)
5069 Z2=1.-Z1
5070 IF (IDPAR(JPAR).EQ.13.AND.IDPAR(LPAR).EQ.13) THEN
5071 WT=Z1*Z2/(Z1/Z2+Z2/Z1+Z1*Z2)
5072 ELSEIF (IDPAR(JPAR).EQ.13.AND.IDPAR(LPAR).LT.13) THEN
5073 WT=-2.*Z1*Z2/(Z1*Z1+Z2*Z2)
5074 ENDIF
5075 ENDIF
5076C Assign the azimuthal angle
5077 PRMAX=(1.+ABS(WT))*EIKON
5078 NTRY=0
5079 50 NTRY=NTRY+1
5080 IF (NTRY.GT.NBTRY) THEN
5081 CALL HWWARN('HWBTIM',101)
5082 GOTO 999
5083 ENDIF
5084 CALL HWRAZM( ONE,CX,SX)
5085 CALL HWUROT(PPAR(1,JPAR),CX,SX,RMAT)
5086C Determine the angle between the branching planes
5087 CALL HWUROF(RMAT,PPAR(1,KPAR),ROHEP)
5088 CAZ=ROHEP(1)/PT
5089 PHIPAR(1,JPAR)=2.*CAZ*CAZ-1.
5090 PHIPAR(2,JPAR)=2.*CAZ*ROHEP(2)/PT
5091 IF (EICOR) EIKON=EISCR+EINUM/MAX(EIDEN1-EIDEN2*CAZ,DMIN)
5092 IF (AZSPIN) SPIN=1.+WT*(RHOPAR(1,JPAR)*PHIPAR(1,JPAR)
5093 & +RHOPAR(2,JPAR)*PHIPAR(2,JPAR))
5094 IF (SPIN*EIKON.LT.HWRGEN(0)*PRMAX) GOTO 50
5095C Construct full 4-momentum of L and M
5096 JOLD=JPAR
5097 IF (SWAP) THEN
5098 PPAR(1,LPAR)=-PPAR(1,LPAR)
5099 PPAR(1,MPAR)=-PPAR(1,MPAR)
5100 JPAR=MPAR
5101 ELSE
5102 JPAR=LPAR
5103 ENDIF
5104 PPAR(2,LPAR)=0.
5105 CALL HWUROB(RMAT,PPAR(1,LPAR),PPAR(1,LPAR))
5106 PPAR(2,MPAR)=0.
5107 CALL HWUROB(RMAT,PPAR(1,MPAR),PPAR(1,MPAR))
5108C Assign production vertex to L and M
5109 CALL HWUDKL(IDPAR(JOLD),PPAR(1,JOLD),VPAR(1,LPAR))
5110 CALL HWVSUM(4,VPAR(1,JOLD),VPAR(1,LPAR),VPAR(1,LPAR))
5111 CALL HWVEQU(4,VPAR(1,LPAR),VPAR(1,MPAR))
5112 ENDIF
5113 60 IF (JDAPAR(1,JPAR).NE.0) GOTO 10
5114C Assign decay matrix
5115 CALL HWVZRO(2,DECPAR(1,JPAR))
5116C Backtrack down the leader
5117 70 IPAR=JMOPAR(1,JPAR)
5118 KPAR=JDAPAR(1,IPAR)
5119 IF (KPAR.EQ.JPAR) THEN
5120C Develop the side branch
5121 JPAR=JDAPAR(2,IPAR)
5122 GOTO 60
5123 ELSE
5124C Construct decay matrix
5125 CALL HWBAZF(IPAR,KPAR,DECPAR(1,JPAR),DECPAR(1,KPAR),
5126 & PHIPAR(1,IPAR),DECPAR(1,IPAR))
5127 ENDIF
5128 IF (IPAR.EQ.INITBR) RETURN
5129 JPAR=IPAR
5130 GOTO 70
5131 999 RETURN
5132 END
5133CDECK ID>, HWBTOP.
5134*CMZ :- -31/03/00 17:54:05 by Peter Richardson
5135*-- Author : Gennaro Corcella
5136C-----------------------------------------------------------------------
5137 SUBROUTINE HWBTOP
5138C-----------------------------------------------------------------------
c63d70bc 5139 INCLUDE 'herwig65.inc'
65767955 5140 DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUSQR,X(3),W,
5141 & X3MIN,X3MAX,X1MIN,X1MAX,QSCALE,GLUFAC,R(3,3),M(3),
5142 & E(3),AW,PTSQ,EM,EPS,MASDEP,A,B,C,GAMDEP,LAMBDA,
5143 & PW(5),PT(5),PW1(5),CS,SN,EPG,QQ,RR,CC
5144 INTEGER ID,ID3,IHEP,KHEP,WHEP,ICMF,K
5145 EXTERNAL HWBVMC,HWUALF,HWUSQR,HWRGEN
5146 LAMBDA(A,B,C)=(A**2+B**2+C**2-2*A*B-2*B*C-2*C*A)/(4*A)
5147C---FIND AN UNTREATED CMF
5148 ICMF=0
5149 DO 10 IHEP=1,NHEP
5150C----FIND A DECAYING TOP QUARK
5151 10 IF (ISTHEP(IHEP).EQ.155.AND.ISTHEP(JDAHEP(1,IHEP)).EQ.113
5152 & .AND.(IDHW(IHEP).EQ.6.OR.IDHW(IHEP).EQ.12))
5153 & ICMF=IHEP
5154 IF (ICMF.EQ.0) RETURN
5155 EM=PHEP(5,ICMF)
5156 X3MIN=2*GCUTME/EM
5157C---GENERATE X(1),X(3) ACCORDING TO 1/((1-X(1))*X(3)**2)
5158 100 CONTINUE
5159C-----AW=(MW/MT)**2
5160 AW=(PHEP(5,JDAHEP(1,ICMF))/EM)**2
5161C---CHOOSE X3
5162 X3MAX=1-AW
5163 X(3)=X3MIN*X3MAX/(X3MIN+(X3MAX-X3MIN)*HWRGEN(0))
5164C--CC, QQ AND RR ARE THE VARIABLE DEFINED IN OUR PAPER
5165C--IN ORDER TO SOLVE THE CUBIC EQUATION
5166 CC=(1-AW)**2/4
5167 QQ=(AW**2-4*(1-X(3))*(2-CC-X(3))-2*AW*(3+2*X(3)))/3
5168 & -((3+2*AW-4*X(3))**2)/9
5169 RR=((3+2*AW-4*X(3))*(AW**2-4*(1-X(3))*(2-CC-X(3))
5170 & -2*AW*(3+2*X(3)))-3*(AW*(4-AW)*(2-CC)+(1-CC)
5171 & *(2*(1-X(3))-AW)**2))/6-(ONE/27)*(3+2*AW-4*X(3))**3
5172C---CHOOSE X1
5173 X1MAX=2*(-QQ**3)**(ONE/6)*COS(ACOS(RR/SQRT(-QQ**3))/3)
5174 & -(3+2*AW-4*X(3))/3
5175 X1MIN=1-X(3)+(AW*X(3))/(1-X(3))
5176 IF (X1MAX.GE.1.OR.X1MIN.GE.1.OR.X1MAX.LE.X1MIN) GOTO 100
5177 X(1)=1-(1-X1MAX)*((1-X1MIN)/(1-X1MAX))**HWRGEN(1)
5178C---CALCULATE WEIGHT
5179 W=((1+1/AW-2*AW)*((1-AW)*X(3)-(1-X(1))*(1-X(3))-X(3)**2)
5180 & +(1+1/(2*AW))*X(3)*(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1)))
5181 & *(1/X3MIN-1/X3MAX)*LOG((1-X1MIN)/(1-X1MAX))
5182C---QSCALE=DURHAM-LIKE TRANSVERSE MOMENTUM OF THE GLUON
5183 QSCALE=EM*HWUSQR(X(3)*(1-X(1))/(2-X(1)-X(3)-AW))
5184C---FACTOR FOR GLUON EMISSION
5185 ID=IDHW(JDAHEP(2,ICMF))
5186 GLUFAC=0
5187 IF (QSCALE.GT.HWBVMC(13)) GLUFAC=CFFAC*HWUALF(1,QSCALE)
5188 & /(PIFAC*(1-AW)*(1-2*AW+1/AW))
5189C---IN FRACTION GLUFAC*W OF EVENTS ADD A GLUON
5190 IF (GLUFAC*W.GT.HWRGEN(4)) THEN
5191 ID3=13
5192 ELSE
5193 GOTO 1000
5194 ENDIF
5195C---CHECK INFRA-RED CUT-OFF FOR GLUON
5196 M(1)=PHEP(5,JDAHEP(1,ICMF))
5197 M(2)=HWBVMC(ID)
5198 M(3)=HWBVMC(ID3)
5199 E(1)=HALF*EM*(X(1)+AW+(-M(2)**2-M(3)**2)/EM**2)
5200 E(3)=HALF*EM*X(3)
5201 E(2)=EM-E(1)-E(3)
5202 PTSQ=-LAMBDA(E(1)**2-M(1)**2,E(3)**2-M(3)**2,
5203 & E(2)**2-M(2)**2)
5204 IF (PTSQ.LE.0.OR.E(1).LE.M(1).OR.E(2).LE.M(2).OR.E(3).LE.M(3))
5205 $ GOTO 1000
5206C---CALCULATE MASS-DEPENDENT SUPPRESSION
5207 EPS=(RMASS(ID)/EM)**2
5208 EPG=(RMASS(ID3)/EM)**2
5209 GAMDEP=(1-AW)*(1+1/AW-2*AW)/(SQRT(1+AW**2+EPS**2
5210 & -2*AW-2*EPS-2*AW*EPS)*(1+EPS+(1-EPS)**2/AW-2*AW))
5211 MASDEP=GAMDEP/(1-X(1))*((1+EPS+(1-EPS)**2/AW-2*AW)
5212 & *((1-AW+EPS)*X(3)*(1-X(1))-(1-X(1))**2*(1-X(3))
5213 & -X(3)**2*(1-X(1)+EPS))+(1+(1+EPS)/(2*AW))*X(3)
5214 & *(1-X(1))*(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1))**2)
5215 IF (MASDEP.LT.HWRGEN(7)*((1+1/AW-2*AW)*((1-AW)*X(3)
5216 & -(1-X(1))*(1-X(3))-X(3)**2)+(1+1/(2*AW))*X(3)
5217 & *(X(1)+X(3)-1)**2+2*X(3)**2*(1-X(1)))) GOTO 1000
5218C---STORE OLD MOMENTA
5219c---PT = TOP MOMENTUM, PW= W MOMENTUM
5220 CALL HWVEQU(5,PHEP(1,ICMF),PT)
5221 CALL HWVEQU(5,PHEP(1,JDAHEP(1,ICMF)),PW)
5222C--------GET THE NON-EMITTING PARTON CMF DIRECTION
5223 CALL HWULOF(PHEP(1,ICMF),PW,PW)
5224 CALL HWRAZM(ONE,CS,SN)
5225 CALL HWUROT(PW,CS,SN,R)
5226 CALL HWUROF(R,PW,PW)
5227 CALL HWUMAS(PW)
5228C---REORDER ENTRIES: IHEP=EMITTER, KHEP=EMITTED
5229 NHEP=NHEP+1
5230 IHEP=JDAHEP(2,ICMF)
5231 WHEP=JDAHEP(1,ICMF)
5232 KHEP=NHEP
5233C---SET UP MOMENTA IN TOP REST FRAME
5234 PHEP(1,ICMF)=0
5235 PHEP(2,ICMF)=0
5236 PHEP(3,ICMF)=0
5237 PHEP(4,ICMF)=EM
5238 PHEP(5,ICMF)=EM
5239 PHEP(4,IHEP)=HALF*EM*(2-X(1)-X(3)+EPS-AW+EPG)
5240 PHEP(4,KHEP)=HALF*EM*X(3)
5241 PHEP(5,IHEP)=RMASS(ID)
5242 PHEP(5,KHEP)=RMASS(ID3)
5243 PHEP(3,KHEP)=HALF*EM*((X(1)+AW-EPS-EPG)*X(3)-2*(1+EPS-AW
5244 $ -EPG-(2+EPS+EPG-AW-X(1)-X(3))))/HWUSQR((X(1)+AW
5245 $ -EPS-EPG)**2-4*AW)
5246 PHEP(3,IHEP)=-PHEP(3,KHEP)-HALF*EM
5247 $ *HWUSQR((X(1)+AW-EPS-EPG)**2-4*AW)
5248 PHEP(2,IHEP)=0
5249 PHEP(1,KHEP)=HWUSQR(PHEP(4,KHEP)**2-PHEP(5,KHEP)**2
5250 $ -PHEP(3,KHEP)**2)
5251 PHEP(1,IHEP)=-PHEP(1,KHEP)
5252 PHEP(2,KHEP)=0
5253 CALL HWVSUM(4,PHEP(1,IHEP),PHEP(1,KHEP),PW1)
5254 CALL HWVDIF(4,PHEP(1,ICMF),PW1,PW1)
5255 CALL HWUMAS(PW1)
5256 DO K=1,5
5257 PHEP(K,WHEP)=PW1(K)
5258 ENDDO
5259C---ORIENT IN CMF, THEN BOOST TO LAB
5260 CALL HWUROB(R,PHEP(1,ICMF),PHEP(1,ICMF))
5261 CALL HWUROB(R,PHEP(1,IHEP),PHEP(1,IHEP))
5262 CALL HWUROB(R,PHEP(1,WHEP),PHEP(1,WHEP))
5263 CALL HWUROB(R,PHEP(1,KHEP),PHEP(1,KHEP))
5264 CALL HWULOB(PT,PHEP(1,IHEP),PHEP(1,IHEP))
5265 CALL HWULOB(PT,PHEP(1,KHEP),PHEP(1,KHEP))
5266 CALL HWULOB(PT,PHEP(1,ICMF),PHEP(1,ICMF))
5267 CALL HWULOB(PT,PHEP(1,WHEP),PHEP(1,WHEP))
5268C---STATUS AND COLOUR CONNECTION
5269C--Bug fix 31/03/00 PR
5270 ISTHEP(KHEP)=114
5271 IDHW(KHEP)=ID3
5272 IDHEP(KHEP)=IDPDG(ID3)
5273 JMOHEP(1,KHEP)=ICMF
5274 JMOHEP(1,IHEP)=ICMF
5275 JDAHEP(1,KHEP)=0
5276 JDAHEP(2,ICMF)=KHEP
5277 IF(IDHW(ICMF).EQ.6) THEN
5278 JDAHEP(2,IHEP)=ICMF
5279 JDAHEP(2,KHEP)=IHEP
5280 JMOHEP(2,IHEP)=KHEP
5281 JMOHEP(2,KHEP)=ICMF
5282 ELSE
5283 JDAHEP(2,IHEP) = KHEP
5284 JDAHEP(2,KHEP) = ICMF
5285 JMOHEP(2,IHEP) = ICMF
5286 JMOHEP(2,KHEP) = IHEP
5287 ENDIF
5288C--End of Fix
5289C--modification to allow photon radiation via photos in top decay
5290 1000 IF(ITOPRD.EQ.1) CALL HWPHTP(ICMF)
5291 END
5292CDECK ID>, HWBVMC.
5293*CMZ :- -26/04/91 11.11.54 by Bryan Webber
5294*-- Author : Bryan Webber
5295C-----------------------------------------------------------------------
5296 FUNCTION HWBVMC(ID)
5297C-----------------------------------------------------------------------
5298C VIRTUAL MASS CUTOFF FOR PARTON TYPE ID
5299C-----------------------------------------------------------------------
c63d70bc 5300 INCLUDE 'herwig65.inc'
65767955 5301 DOUBLE PRECISION HWBVMC
5302 INTEGER ID
5303 IF (ID.EQ.13) THEN
5304 HWBVMC=RMASS(ID)+VGCUT
5305 ELSEIF (ID.LT.13) THEN
5306 HWBVMC=RMASS(ID)+VQCUT
5307 ELSEIF (ID.EQ.59) THEN
5308 HWBVMC=RMASS(ID)+VPCUT
5309 ELSE
5310 HWBVMC=RMASS(ID)
5311 ENDIF
5312 END
5313CDECK ID>, HWCBCT.
5314*CMZ :- -20/07/99 10:56:12 by Peter Richardson
5315*-- Author : Peter Richardson
5316C-----------------------------------------------------------------------
5317 SUBROUTINE HWCBCT(JHEP,KHEP,THEP,PCL,SPLIT)
5318C-----------------------------------------------------------------------
5319C Subroutine to split a baryonic cluster containing two heavy quarks
5320C Based on HWCCUT
5321C-----------------------------------------------------------------------
c63d70bc 5322 INCLUDE 'herwig65.inc'
65767955 5323 DOUBLE PRECISION HWUPCM,HWRGEN,HWVDOT,EMC,QM1,QM2,QM3,QM4,
5324 & PXY,PCX,PCY,RCM,PCL(5),AX(5),PA(5),PB(5),PC(5),
5325 & VCLUS(4),DQM,EMX,EMY,SKAPPA,RKAPPA,VTMP(4),
5326 & DELTM,PDIQUK(5),AY(5)
5327 INTEGER HWRINT,JHEP,KHEP,LHEP,MHEP,THEP,ID1,ID2,ID3,ID4,NTRY,
5328 & NTRYMX,J,IB
5329 LOGICAL SPLIT
5330 EXTERNAL HWUPCM,HWRGEN,HWVDOT
5331 PARAMETER(SKAPPA=1.,NTRYMX=100)
5332 IF(IERROR.NE.0) RETURN
5333 EMC=PCL(5)
5334 ID1=IDHW(JHEP)
5335 ID2=IDHW(KHEP)
5336 ID3=IDHW(THEP)
5337 QM1=RMASS(ID1)
5338 QM2=RMASS(ID2)
5339 QM3=RMASS(ID3)
5340 SPLIT = .FALSE.
5341 NTRY = 0
5342C Decide if cluster contains a b-(anti)quark
5343 IF (ID1.EQ.5.OR.ID1.EQ.11.OR.ID2.EQ.5.OR.ID2.EQ.11.OR.
5344 & ID3.EQ.5.OR.ID3.EQ.11) THEN
5345 IB=2
5346 ELSE
5347 IB=1
5348 ENDIF
5349C-- Set the positon of the cluster to be that of the heavy quark
5350 CALL HWVEQU(4,VHEP(1,THEP),VCLUS)
5351C--SPLIT THE BARYONIC CLUSTER INTO A HEAVY FLAVOUR MESON AND A HEAVY
5352C--FLAVOUR BARYON
5353 PXY=EMC-QM1-QM2-QM3
5354 20 NTRY=NTRY+1
5355 IF(NTRY.GT.NTRYMX) RETURN
5356 30 EMX=QM1+QM2+PXY*HWRGEN(0)**PSPLT(IB)
5357 EMY= QM3+PXY*HWRGEN(1)**PSPLT(IB)
5358 IF(EMX+EMY.GE.EMC) GOTO 30
5359C--PULL A LIGHT QUARK PAIR OUT OF THE VACUUM
5360 40 ID4=HWRINT(1,3)
5361 IF(QWT(ID4).LT.HWRGEN(3)) GOTO 40
5362 QM4=RMASS(ID4)
5363C--Now combine particles 3 & 4 into a diquark
5364C--If three also heavy this diquark doesn't exist in HERWIG
5365C--just assume mass is sum of quark masses,as for other diquarks
5366 DQM=QM3+QM4
5367C--Now obtain the masses for the cluster splitting
5368 PCX=HWUPCM(EMX,QM1,DQM)
5369 IF(PCX.LT.ZERO) GOTO 20
5370 PCY=HWUPCM(EMY,QM2,QM4)
5371 IF(PCY.LT.ZERO) GOTO 20
5372 SPLIT=.TRUE.
5373C--Now we've decided which light quark to pull out of the vacuum
5374C--Find the direction of the second heavy quark
5375 CALL HWULOF(PCL,PHEP(1,THEP),AX)
5376 RCM=1./SQRT(HWVDOT(3,AX,AX))
5377 CALL HWVSCA(3,RCM,AX,AX)
5378C--Construct the new CoM momenta(collinear)
5379 PXY=HWUPCM(EMC,EMX,EMY)
5380 CALL HWVSCA(3,PXY,AX,PC)
5381C--pc is momenta of Y cluster along 2nd quark dirn in cluster frame
5382 PC(4)=SQRT(PXY**2+EMY**2)
5383 PC(5)=EMY
5384C--pa is momenta of 2nd quark in Y frame
5385 CALL HWVSCA(3,PCY,AX,PA)
5386 PA(4)=SQRT(PCY**2+QM3**2)
5387 PA(5)=QM3
5388C--pb is momenta of 2nd quark in cluster frame,pa now momenta of antiquark
5389 CALL HWULOB(PC,PA,PB)
5390 CALL HWVDIF(4,PC,PB,PA)
5391 PA(5)=QM4
5392 LHEP=NHEP+1
5393 MHEP=NHEP+2
5394C--boost these momenta back to lab frame
5395 CALL HWULOB(PCL,PB,PHEP(1,THEP))
5396 CALL HWULOB(PCL,PA,PHEP(1,MHEP))
5397C--pc now becomes momenta of X cluster in cluster frame
5398 CALL HWVSCA(3,-ONE,PC,PC)
5399 PC(4)=EMC-PC(4)
5400 PC(5)=EMX
5401C--find the dirn of the 1st heavy quark in the X frame
5402C--transform to cluster frame
5403 CALL HWULOF(PCL,PHEP(1,JHEP),AY)
5404C--transform to X-frame
5405 CALL HWULOF(PC,AY,AY)
5406 RCM=1./SQRT(HWVDOT(3,AY,AY))
5407 CALL HWVSCA(3,RCM,AY,AY)
5408C--pa now momenta of 1st havy quark along this dirn
5409 CALL HWVSCA(3,PCX,AY,PA)
5410 PA(4)=SQRT(PCX**2+QM1**2)
5411 PA(5)=QM1
5412C--pb now momenta of 1st heavy quark in cluster frame then to lab
5413 CALL HWULOB(PC,PA,PB)
5414 CALL HWULOB(PCL,PB,PHEP(1,JHEP))
5415C--now find the diquark momenta by momentum conservation
5416 DO 50 J=1,4
5417 50 PDIQUK(J)=PCL(J)-PHEP(J,THEP)-PHEP(J,MHEP)-PHEP(J,JHEP)
5418 PDIQUK(5)=DQM
5419C--Now obtain the quark momenta from the diquark
5420 DO 60 J=1,3
5421 60 PA(J) = 0
5422 PA(4) = QM2
5423 PA(5) = QM2
5424 CALL HWULOB(PDIQUK,PA,PHEP(1,KHEP))
5425 CALL HWVDIF(4,PDIQUK,PHEP(1,KHEP),PHEP(1,LHEP))
5426C--Construct new vertex positions
5427 RKAPPA=GEV2MM/SKAPPA
5428 CALL HWVSCA(3,RKAPPA,AX,AX)
5429 DELTM=(EMX-EMY)*(EMX+EMY)/(TWO*EMC)
5430 CALL HWVSCA(3,DELTM,AX,VTMP)
5431 VTMP(4)=(HALF*EMC-PXY)*RKAPPA
5432 CALL HWULB4(PCL,VTMP,VTMP)
5433 CALL HWVSUM(4,VTMP,VCLUS,VHEP(1,LHEP))
5434 CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
5435C--Relabel the colours of the quarks
5436 IDHEP(LHEP) = IDPDG(ID4)
5437 IDHEP(MHEP) = IDPDG(ID4)
5438 IF(IDHEP(JHEP).GT.0) THEN
5439 IDHW(LHEP) = ID4+6
5440 IDHEP(LHEP) = -IDHEP(LHEP)
5441 IDHW(MHEP) = ID4
5442 JDAHEP(2,LHEP) = JHEP
5443 JMOHEP(2,LHEP) = MHEP
5444 JMOHEP(2,MHEP) = JMOHEP(2,JHEP)
5445 JDAHEP(2,MHEP) = LHEP
5446 JMOHEP(2,JHEP) = LHEP
5447 ELSE
5448 IDHW(LHEP) = ID4
5449 IDHW(MHEP) = ID4+6
5450 IDHEP(MHEP) = -IDHEP(MHEP)
5451 JMOHEP(2,LHEP) = JHEP
5452 JDAHEP(2,MHEP) = JDAHEP(2,JHEP)
5453 JDAHEP(2,LHEP) = MHEP
5454 JMOHEP(2,MHEP) = LHEP
5455 JDAHEP(2,JHEP) = LHEP
5456 ENDIF
5457 ISTHEP(LHEP) = 151
5458 ISTHEP(MHEP) = 151
5459 JMOHEP(1,LHEP) = JMOHEP(1,KHEP)
5460 JDAHEP(1,LHEP) = 0
5461 JMOHEP(1,MHEP) = JMOHEP(1,JHEP)
5462 JDAHEP(1,MHEP) = 0
5463 NHEP = NHEP+2
5464 END
5465CDECK ID>, HWCBVI.
5466*CMZ :- -12/12/01 14:59:58 by Peter Richardson
5467*-- Author : Mark Gibbs, modified by Peter Richardson
5468C-----------------------------------------------------------------------
5469 SUBROUTINE HWCBVI
5470C-----------------------------------------------------------------------
5471C FINDS UNPAIRED PARTONS AFTER BARYON-NUMBER VIOLATION
5472C MODIFIED FOR RPARITY VIOLATING SUSY
5473C-----------------------------------------------------------------------
c63d70bc 5474 INCLUDE 'herwig65.inc'
65767955 5475 COMMON/HWBVIC/NBV,IBV(18)
5476 DOUBLE PRECISION HWRGEN,PDQ(5)
5477 INTEGER NBV,IBV,JBV,KBV,LBV,IHEP,IP1,IP2,IP3,JP1,JP2,JP3,
5478 & HWCBVT,NBR,MBV,IQ1,IQ2,IQ3,ID1,ID2,IDQ,IDIQK(3,3)
5479 LOGICAL SPLIT,DUNBV(18)
5480 SAVE IDIQK
5481 DATA IDIQK/111,110,113,110,109,112,113,112,114/
5482C---Check for errors
5483 IF (IERROR.NE.0) RETURN
5484C---Correct colour connections are gluon splitting
5485 CALL HWCCCC
5486C---Reset bvi clustering flag
5487 HVFCEN = .FALSE.
5488C---LIST PARTONS WITH WRONG COLOUR PARTNERS-QUARKS ONLY
5489 5 NBV=0
5490 DO 10 IHEP=1,NHEP
5491 IF (ISTHEP(IHEP).GT.149.AND.ISTHEP(IHEP).LT.155) THEN
5492 IF (QORQQB(IDHW(IHEP))) THEN
5493 IF (.NOT.QORQQB(IDHW(JMOHEP(2,IHEP))).
5494 & AND.JMOHEP(2,IHEP).GT.6) GOTO 10
5495 ELSE
5496C---Extra check for Gamma's
5497 IF (IDHW(IHEP).EQ.59) GO TO 10
5498C---End of bug fix.
5499 IF (QORQQB(IDHW(JDAHEP(2,IHEP)))) GO TO 10
5500 GO TO 10
5501 ENDIF
5502 IF(JMOHEP(2,IHEP).LT.6.AND.
5503 & .NOT.QBORQQ(IDHW(JMOHEP(2,IHEP)))) GOTO 10
5504C--new for hard process
5505 NBV=NBV+1
5506 IF (NBV.GT.18) THEN
5507 CALL HWWARN('HWCBVI',100)
5508 GOTO 999
5509 ENDIF
5510 IBV(NBV)=IHEP
5511 DUNBV(NBV)=.FALSE.
5512 ENDIF
5513 10 CONTINUE
5514C--NOW FIND THE ANTIQUARKS WITH WRONG COLOUR CONNECTIONS
5515 DO 11 IHEP=1,NHEP
5516 IF(ISTHEP(IHEP).GT.149.AND.ISTHEP(IHEP).LT.155) THEN
5517 IF(QBORQQ(IDHW(IHEP))) THEN
5518 IF(.NOT.QBORQQ(IDHW(JDAHEP(2,IHEP))).AND.
5519 & JDAHEP(2,IHEP).GT.6) GO TO 11
5520 ELSE
5521C--Extra check for gamma's
5522 IF(IDHW(IHEP).EQ.59) GO TO 11
5523 IF(QBORQQ(IDHW(JMOHEP(2,IHEP)))) GO TO 11
5524 GO TO 11
5525 ENDIF
5526 IF(JDAHEP(2,IHEP).LT.6.AND.
5527 & .NOT.QORQQB(IDHW(JDAHEP(2,IHEP)))) GOTO 11
5528 NBV=NBV+1
5529 IF(NBV.GT.18) THEN
5530 CALL HWWARN('HWCBVI',100)
5531 GOTO 999
5532 ENDIF
5533 IBV(NBV)=IHEP
5534 DUNBV(NBV)=.FALSE.
5535 ENDIF
5536 11 CONTINUE
5537 IF (NBV.EQ.0) RETURN
5538 IF(MOD(NBV,3).NE.0) THEN
5539 CALL HWWARN('HWCBVI',101)
5540 GOTO 999
5541 ENDIF
5542C---PROCESS FOUND PARTONS, STARTING AT RANDOM POINT IN LIST
5543 NBR=INT(NBV*HWRGEN(0))
5544 DO 100 MBV=1,NBV
5545 JBV=MBV+NBR
5546 IF (JBV.GT.NBV) JBV=JBV-NBV
5547 IF (.NOT.DUNBV(JBV)) THEN
5548 DUNBV(JBV)=.TRUE.
5549 IP1=IBV(JBV)
5550 JP1=HWCBVT(IP1)
5551C---FIND ASSOCIATED PARTONS
5552 DO 20 KBV=1,NBV
5553 IF (.NOT.DUNBV(KBV)) THEN
5554 IP2=IBV(KBV)
5555 JP2=HWCBVT(IP2)
5556 IF (JP2.EQ.JP1) THEN
5557 DUNBV(KBV)=.TRUE.
5558 DO 15 LBV=1,NBV
5559 IF (.NOT.DUNBV(LBV)) THEN
5560 IP3=IBV(LBV)
5561 JP3=HWCBVT(IP3)
5562 IF (JP3.EQ.JP2) THEN
5563 DUNBV(LBV)=.TRUE.
5564 GO TO 25
5565 ENDIF
5566 ENDIF
5567 15 CONTINUE
5568 ENDIF
5569 ENDIF
5570 20 CONTINUE
5571 CALL HWWARN('HWCBVI',102)
5572 GOTO 999
5573 25 IQ1=0
5574C---LOOK FOR DIQUARK
5575 IF (ABS(IDHEP(IP1)).GT.100) THEN
5576 IQ1=IP1
5577 IQ2=IP2
5578 IQ3=IP3
5579 ELSEIF (ABS(IDHEP(IP2)).GT.100) THEN
5580 IQ1=IP2
5581 IQ2=IP3
5582 IQ3=IP1
5583 ELSEIF (ABS(IDHEP(IP3)).GT.100) THEN
5584 IQ1=IP3
5585 IQ2=IP1
5586 IQ3=IP2
5587 ENDIF
5588 IF (IQ1.EQ.0) THEN
5589C---NO DIQUARKS: COMBINE TWO (ANTI)QUARKS
5590 IF (ABS(IDHEP(IP1)).GT.3) THEN
5591 IQ1=IP2
5592 IQ2=IP3
5593 IQ3=IP1
5594 ELSEIF (ABS(IDHEP(IP2)).GT.3) THEN
5595 IQ1=IP3
5596 IQ2=IP1
5597 IQ3=IP2
5598 ELSE
5599 IQ1=IP1
5600 IQ2=IP2
5601 IQ3=IP3
5602 ENDIF
5603 ID1=IDHEP(IQ1)
5604 ID2=IDHEP(IQ2)
5605C---CHECK FLAVOURS
5606 IF (ID1.GT.0.AND.ID1.LT.4.AND.
5607 & ID2.GT.0.AND.ID2.LT.4) THEN
5608 IDQ=IDIQK(ID1,ID2)
5609 ELSEIF (ID1.LT.0.AND.ID1.GT.-4.AND.
5610 & ID1.LT.0.AND.ID2.GT.-4) THEN
5611 IDQ=IDIQK(-ID1,-ID2)+6
5612 ELSE
5613C---CANT MAKE DIQUARKS WITH HEAVY QUARKS: TRY CLUSTER SPLITTING
5614 CALL HWVSUM(4,PHEP(1,IQ1),PHEP(1,IQ2),PDQ)
5615 CALL HWUMAS(PDQ)
5616C--Use the original splitting procedure
5617 CALL HWCCUT(IQ1,IQ2,PDQ,.FALSE.,SPLIT)
5618 IF (IERROR.NE.0) RETURN
5619 IF(SPLIT) GOTO 5
5620C--If it fails try the new procedure
5621 CALL HWVSUM(4,PDQ,PHEP(1,IQ3),PDQ)
5622 CALL HWUMAS(PDQ)
5623 IF(ABS(ID1).GT.3) THEN
5624 CALL HWCBCT(IQ3,IQ2,IQ1,PDQ,SPLIT)
5625 ELSEIF(ABS(ID2).GT.3) THEN
5626 CALL HWCBCT(IQ3,IQ1,IQ2,PDQ,SPLIT)
5627 ELSE
5628 CALL HWWARN('HWCBVI',100)
5629 GOTO 999
5630 ENDIF
5631 IF (SPLIT) GO TO 5
5632C---Unable to form cluster; dispose of event
5633 CALL HWWARN('HWCBVI',-3)
5634 GOTO 999
5635 ENDIF
5636C---OVERWRITE FIRST AND CANCEL SECOND
5637 IDHW(IQ1)=IDQ
5638 IDHEP(IQ1)=IDPDG(IDQ)
5639 CALL HWVSUM(4,PHEP(1,IQ1),PHEP(1,IQ2),PHEP(1,IQ1))
5640 CALL HWUMAS(PHEP(1,IQ1))
5641 ISTHEP(IQ2)=0
5642C---REMAKE COLOUR CONNECTIONS
5643 IF (QORQQB(IDQ)) THEN
5644 JMOHEP(2,IQ1)=IQ3
5645 JDAHEP(2,IQ3)=IQ1
5646 ELSE
5647 JDAHEP(2,IQ1)=IQ3
5648 JMOHEP(2,IQ3)=IQ1
5649 ENDIF
5650 ELSE
5651C---SPLIT A DIQUARK
5652 NHEP=NHEP+1
5653 CALL HWVSCA(5,HALF,PHEP(1,IQ1),PHEP(1,IQ1))
5654 CALL HWVEQU(5,PHEP(1,IQ1),PHEP(1,NHEP))
5655 ISTHEP(NHEP)=150
5656 JMOHEP(1,NHEP)=JMOHEP(1,IQ1)
5657 JDAHEP(1,NHEP)=0
5658C---FIND FLAVOURS
5659 IDQ=IDHW(IQ1)
5660 DO 30 ID2=1,3
5661 DO 30 ID1=1,3
5662 IF (IDIQK(ID1,ID2).EQ.IDQ) THEN
5663 IDHW(IQ1)=ID1
5664 IDHW(NHEP)=ID2
5665C---REMAKE COLOUR CONNECTIONS (DIQUARK)
5666 JMOHEP(2,IQ1)=IQ2
5667 JMOHEP(2,IQ2)=NHEP
5668 JMOHEP(2,IQ3)=IQ1
5669 JMOHEP(2,NHEP)=IQ3
5670 JDAHEP(2,IQ1)=IQ3
5671 JDAHEP(2,IQ2)=IQ1
5672 JDAHEP(2,IQ3)=NHEP
5673 JDAHEP(2,NHEP)=IQ2
5674 GO TO 35
5675 ELSEIF (IDIQK(ID1,ID2).EQ.IDQ-6) THEN
5676 IDHW(IQ1)=ID1+6
5677 IDHW(NHEP)=ID2+6
5678C---REMAKE COLOUR CONNECTIONS (ANTIDIQUARK)
5679 JMOHEP(2,IQ1)=IQ3
5680 JMOHEP(2,IQ2)=IQ1
5681 JMOHEP(2,IQ3)=NHEP
5682 JMOHEP(2,NHEP)=IQ2
5683 JDAHEP(2,IQ1)=IQ2
5684 JDAHEP(2,IQ2)=NHEP
5685 JDAHEP(2,IQ3)=IQ1
5686 JDAHEP(2,NHEP)=IQ3
5687 GO TO 35
5688 ENDIF
5689 30 CONTINUE
5690 CALL HWWARN('HWCBVI',104)
5691 GOTO 999
5692 35 IDHEP(IQ1)=IDPDG(IDHW(IQ1))
5693 IDHEP(NHEP)=IDPDG(IDHW(NHEP))
5694 ENDIF
5695 ENDIF
5696 100 CONTINUE
5697 999 RETURN
5698 END
5699CDECK ID>, HWCBVT.
5700*CMZ :-
5701*-- Author : Peter Richardson
5702C-----------------------------------------------------------------------
5703 FUNCTION HWCBVT(IP)
5704C-----------------------------------------------------------------------
5705C Function to find the baryon number violating vertex a parton came from
5706C-----------------------------------------------------------------------
c63d70bc 5707 INCLUDE 'herwig65.inc'
65767955 5708 INTEGER HWCBVT,IP,JP(2),KP,I,J,ID,TYPE,IDM,IDM2,IDM3,IDM4
5709 JP(1) = IP
5710 ID = IDHW(IP)
5711 IF(ID.LE.6.OR.(ID.GE.115.AND.ID.LE.120)) THEN
5712 JP(2) = JMOHEP(2,IP)
5713 ELSE
5714 JP(2) = JDAHEP(2,IP)
5715 ENDIF
5716 DO I=1,2
5717 IDM = JMOHEP(1,JMOHEP(1,JMOHEP(1,JMOHEP(1,JP(I)))))
5718 IF(IDHW(IDM).EQ.6.OR.IDHW(IDM).EQ.12) THEN
5719 JP(I)=IDM
5720 ENDIF
5721 ENDDO
5722 DO J=1,7
5723 DO I=1,2
5724 KP = JMOHEP(1,JP(I))
5725 IDM = IDHW(KP)
5726 IDM2 = IDHW(JDAHEP(1,KP))
5727 IDM3 = IDHW(JDAHEP(2,KP))
5728 IDM4 = IDHW(JDAHEP(1,KP)+1)
5729 IF((ISTHEP(KP).EQ.155.AND.
5730 & ((IDM.GE.449.AND.IDM.LE.457.AND.IDM2.LE.12.AND.
5731 & IDM3.LE.12.AND.IDM4.LE.12).OR.
5732 & (((IDM.GE.411.AND.IDM.LE.424).OR.IDM.EQ.405.OR.IDM.EQ.406)
5733 & .AND.IDM2.LE.12.AND.IDM3.LE.12)))
5734 & .OR.(IDM.EQ.15.AND.IDM2.LE.12.AND.
5735 & IDHW(JMOHEP(1,KP)).LE.12.AND.
5736 & IDHW(JMOHEP(2,KP)).LE.12.AND.IDM3.GE.449.AND.
5737 & IDM3.LE.457).OR.
5738 & (IDM.EQ.15.AND.IDM2.GE.198.AND.IDM2.LE.200.
5739 & AND.ABS(IDPDG(IDM3)).GT.1000000)) THEN
5740 IF(IDHW(KP).EQ.449.AND.JDAHEP(1,KP).EQ.JP(I)) THEN
5741 KP = JMOHEP(1,KP)
5742 ELSEIF(IDHW(KP).EQ.15) THEN
5743 TYPE=IDHW(JDAHEP(1,KP))
5744 IF(TYPE.GE.7.AND.TYPE.LE.12.AND.
5745 & JMOHEP(2,JDAHEP(2,KP)).EQ.JP(I)) THEN
5746 KP=IP
5747 ELSEIF(TYPE.LE.6.AND.
5748 & JDAHEP(2,JDAHEP(2,KP)).EQ.JP(I)) THEN
5749 KP=IP
5750 ELSE
5751 HWCBVT = KP
5752 RETURN
5753 ENDIF
5754 ELSE
5755 HWCBVT = KP
5756 RETURN
5757 ENDIF
5758 ENDIF
5759 JP(I) =KP
5760 ENDDO
5761 ENDDO
5762 HWCBVT = 0
5763 END
5764CDECK ID>, HWCCCC.
5765*CMZ :-
5766*-- Author : Peter Richardson
5767C-----------------------------------------------------------------------
5768 SUBROUTINE HWCCCC
5769C-----------------------------------------------------------------------
5770C Subroutine to correct colour connections after the gluon splitting
5771C-----------------------------------------------------------------------
c63d70bc 5772 INCLUDE 'herwig65.inc'
65767955 5773 INTEGER IHEP,STFSPT,LHEP,MHEP,RHEP
5774 IF(IERROR.NE.0) RETURN
5775C--Find the first particle in the event record with status 150
5776 DO IHEP=1,NHEP
5777 IF(ISTHEP(IHEP).GE.150.AND.ISTHEP(IHEP).LE.154) THEN
5778 STFSPT = IHEP
5779 GOTO 10
5780 ENDIF
5781 ENDDO
5782 10 CONTINUE
5783C--Now find any that are colour connected to earlier particles
5784C--in the event record
5785 DO IHEP=STFSPT,NHEP
5786C--First the quarks and antidiquarks
5787 IF(IDHW(IHEP).LT.6.OR.
5788 & (IDHW(IHEP).GE.115.AND.IDHW(IHEP).LE.120)) THEN
5789 IF(JMOHEP(2,IHEP).LT.STFSPT) THEN
5790 LHEP = IHEP
5791 MHEP = JMOHEP(2,IHEP)
5792 RHEP = MHEP
5793 IF(MHEP.GT.6) RHEP = JDAHEP(1,MHEP)
5794C--As from Rparity connect to particle not to antiparticle
5795 IF(IDHW(MHEP).NE.13) THEN
5796 JMOHEP(2,LHEP) = RHEP
5797 ELSE
5798 RHEP = RHEP+1
5799 JMOHEP(2,LHEP) = RHEP
5800 ENDIF
5801 ENDIF
5802 ENDIF
5803C--Now the antiquarks
5804 IF((IDHW(IHEP).GT.6.AND.IDHW(IHEP).LE.12).OR.
5805 & (IDHW(IHEP).GE.109.AND.IDHW(IHEP).LE.114)) THEN
5806 IF(JDAHEP(2,IHEP).LT.STFSPT) THEN
5807 LHEP = IHEP
5808 MHEP = JDAHEP(2,IHEP)
5809 RHEP = MHEP
5810 IF(MHEP.GT.6) RHEP = JDAHEP(1,MHEP)
5811C--As from Rparity connect to antiparticle not particle
5812 IF(IDHW(MHEP).NE.13) THEN
5813 JDAHEP(2,LHEP) = RHEP
5814 ELSE
5815 JDAHEP(2,LHEP) = RHEP
5816 ENDIF
5817 ENDIF
5818 ENDIF
5819 ENDDO
5820 END
5821CDECK ID>, HWCCUT.
5822*CMZ :- -26/04/91 14.29.39 by Federico Carminati
5823*-- Author : Bryan Webber
5824C-----------------------------------------------------------------------
5825 SUBROUTINE HWCCUT(JHEP,KHEP,PCL,BTCLUS,SPLIT)
5826C-----------------------------------------------------------------------
5827C Cuts into 2 the cluster, momentum PCL, made of partons JHEP & KHEP
5828C-----------------------------------------------------------------------
c63d70bc 5829 INCLUDE 'herwig65.inc'
65767955 5830 DOUBLE PRECISION HWREXQ,HWUPCM,HWRGEN,HWVDOT,EMC,QM1,QM2,EMX,EMY,
5831 & QM3,PXY,PCX,PCY,RCM,PCL(5),AX(5),PA(5),PB(5),PC(5),SKAPPA,DELTM,
5832 & VSCA,VTMP(4),RKAPPA,VCLUS
5833 INTEGER HWRINT,JHEP,KHEP,LHEP,MHEP,ID1,ID2,ID3,NTRY,NTRYMX,J,IB
5834 LOGICAL BTCLUS,SPLIT
5835 EXTERNAL HWREXQ,HWUPCM,HWRGEN,HWVDOT,HWRINT
5836 COMMON/HWCFRM/VCLUS(4,NMXHEP)
5837 PARAMETER (SKAPPA=1.,NTRYMX=100)
5838 IF (IERROR.NE.0) RETURN
5839 EMC=PCL(5)
5840 ID1=IDHW(JHEP)
5841 ID2=IDHW(KHEP)
5842 QM1=RMASS(ID1)
5843 QM2=RMASS(ID2)
5844 SPLIT=.FALSE.
5845 NTRY=0
5846C Decide if cluster contains a b-(anti)quark
5847 IF (ID1.EQ.5.OR.ID1.EQ.11.OR.ID2.EQ.5.OR.ID2.EQ.11) THEN
5848 IB=2
5849 ELSE
5850 IB=1
5851 ENDIF
5852 IF (BTCLUS) THEN
5853C Split beam and target clusters as soft clusters
5854C Both (remnant) children treated like soft clusters if IOPREM=0(1)
5855 10 ID3=HWRINT(1,2)
5856 QM3=RMASS(ID3)
5857 IF (EMC.LE.QM1+QM2+2.*QM3) THEN
5858 ID3=3-ID3
5859 QM3=RMASS(ID3)
5860 IF (EMC.LE.QM1+QM2+2.*QM3) RETURN
5861 ENDIF
5862 PXY=EMC-QM1-QM2-TWO*QM3
5863 IF (ISTHEP(JHEP).EQ.153.OR.ISTHEP(JHEP).EQ.154.OR.
5864 & IOPREM.EQ.0) THEN
5865 EMX=QM1+QM3+HWREXQ(BTCLM,PXY)
5866 ELSE
5867 EMX=QM1+QM3+PXY*HWRGEN(0)**PSPLT(IB)
5868 ENDIF
5869 IF (ISTHEP(KHEP).EQ.153.OR.ISTHEP(KHEP).EQ.154.OR.
5870 & IOPREM.EQ.0) THEN
5871 EMY=QM2+QM3+HWREXQ(BTCLM,PXY)
5872 ELSE
5873 EMY=QM2+QM3+PXY*HWRGEN(1)**PSPLT(IB)
5874 ENDIF
5875 IF (EMX+EMY.GE.EMC) THEN
5876 NTRY=NTRY+1
5877 IF (NTRY.GT.NTRYMX) RETURN
5878 GOTO 10
5879 ENDIF
5880 PCX=HWUPCM(EMX,QM1,QM3)
5881 PCY=HWUPCM(EMY,QM2,QM3)
5882 ELSE
5883C Choose fragment masses for ordinary cluster
5884 PXY=EMC-QM1-QM2
5885 20 NTRY=NTRY+1
5886 IF (NTRY.GT.NTRYMX) RETURN
5887 30 EMX=QM1+PXY*HWRGEN(0)**PSPLT(IB)
5888 EMY=QM2+PXY*HWRGEN(1)**PSPLT(IB)
5889 IF (EMX+EMY.GE.EMC) GOTO 30
5890C u,d,s pair production with weights QWT
5891 40 ID3=HWRINT(1,3)
5892 IF (QWT(ID3).LT.HWRGEN(3)) GOTO 40
5893 QM3=RMASS(ID3)
5894 PCX=HWUPCM(EMX,QM1,QM3)
5895 IF (PCX.LT.ZERO) GOTO 20
5896 PCY=HWUPCM(EMY,QM2,QM3)
5897 IF (PCY.LT.ZERO) GOTO 20
5898 SPLIT=.TRUE.
5899 ENDIF
5900C Boost antiquark to CoM frame to find axis
5901 CALL HWULOF(PCL,PHEP(1,KHEP),AX)
5902 RCM=1./SQRT(HWVDOT(3,AX,AX))
5903 CALL HWVSCA(3,RCM,AX,AX)
5904C Construct new CoM momenta (collinear)
5905 PXY=HWUPCM(EMC,EMX,EMY)
5906 CALL HWVSCA(3,PXY,AX,PC)
5907 PC(4)=SQRT(PXY**2+EMY**2)
5908 PC(5)=EMY
5909 CALL HWVSCA(3,PCY,AX,PA)
5910 PA(4)=SQRT(PCY**2+QM2**2)
5911 PA(5)=QM2
5912 CALL HWULOB(PC,PA,PB)
5913 CALL HWVDIF(4,PC,PB,PA)
5914 PA(5)=QM3
5915 LHEP=NHEP+1
5916 MHEP=NHEP+2
5917 IF (MHEP.GT.NMXHEP) THEN
5918 CALL HWWARN('HWCCUT',100)
5919 GOTO 999
5920 ENDIF
5921 CALL HWULOB(PCL,PB,PHEP(1,KHEP))
5922 CALL HWULOB(PCL,PA,PHEP(1,MHEP))
5923 CALL HWVSCA(3,-ONE,PC,PC)
5924 PC(4)=EMC-PC(4)
5925 PC(5)=EMX
5926 CALL HWVSCA(3,PCX,AX,PA)
5927 PA(4)=SQRT(PCX**2+QM3**2)
5928 CALL HWULOB(PC,PA,PB)
5929 CALL HWULOB(PCL,PB,PHEP(1,LHEP))
5930 DO 50 J=1,4
5931 50 PHEP(J,JHEP)=PCL(J)-PHEP(J,KHEP)-PHEP(J,LHEP)-PHEP(J,MHEP)
5932 PHEP(5,JHEP)=QM1
5933 CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
5934C Construct new vertex positions
5935 RKAPPA=GEV2MM/SKAPPA
5936 CALL HWVSCA(3,RKAPPA,AX,AX)
5937 DELTM=(EMX-EMY)*(EMX+EMY)/(TWO*EMC)
5938 CALL HWVSCA(3,DELTM,AX,VTMP)
5939 VTMP(4)=(HALF*EMC-PXY)*RKAPPA
5940 CALL HWULB4(PCL,VTMP,VTMP)
5941 CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VHEP(1,LHEP))
5942 CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
5943 VSCA=0.25*EMC+HALF*(PXY+DELTM)
5944 CALL HWVSCA(3,VSCA,AX,VTMP)
5945 VTMP(4)=(EMC-VSCA)*RKAPPA
5946 CALL HWULB4(PCL,VTMP,VTMP)
5947 CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VCLUS(1,MHEP))
5948 VSCA=-0.25*EMC+HALF*(DELTM-PXY)
5949 CALL HWVSCA(3,VSCA,AX,VTMP)
5950 VTMP(4)=(EMC+VSCA)*RKAPPA
5951 CALL HWULB4(PCL,VTMP,VTMP)
5952 CALL HWVSUM(4,VTMP,VCLUS(1,JHEP),VCLUS(1,JHEP))
5953C (Re-)label quarks
5954 IDHW(LHEP)=ID3+6
5955 IDHW(MHEP)=ID3
5956 IDHEP(MHEP)= IDPDG(ID3)
5957 IDHEP(LHEP)=-IDPDG(ID3)
5958 ISTHEP(LHEP)=151
5959 ISTHEP(MHEP)=151
5960 JMOHEP(2,JHEP)=LHEP
5961 JDAHEP(2,KHEP)=MHEP
5962 JMOHEP(1,LHEP)=JMOHEP(1,KHEP)
5963 JMOHEP(2,LHEP)=MHEP
5964 JDAHEP(1,LHEP)=0
5965 JDAHEP(2,LHEP)=JHEP
5966 JMOHEP(1,MHEP)=JMOHEP(1,JHEP)
5967 JMOHEP(2,MHEP)=KHEP
5968 JDAHEP(1,MHEP)=0
5969 JDAHEP(2,MHEP)=LHEP
5970 NHEP=NHEP+2
5971 999 RETURN
5972 END
5973CDECK ID>, HWCDEC.
5974*CMZ :- -26/04/91 10.18.56 by Bryan Webber
5975*-- Author : Bryan Webber
5976C-----------------------------------------------------------------------
5977 SUBROUTINE HWCDEC
5978C-----------------------------------------------------------------------
5979C DECAYS CLUSTERS INTO PRIMARY HADRONS
5980C-----------------------------------------------------------------------
c63d70bc 5981 INCLUDE 'herwig65.inc'
65767955 5982 INTEGER JCL,KCL,IP,JP,KP,IST,ID1,ID2,ID3
5983 IF (IERROR.NE.0) RETURN
5984 IF (IPRO/10.EQ.9.OR.IPRO/10.EQ.5) THEN
5985C---RELABEL CLUSTER CONNECTED TO REMNANT IN DIS
5986 DO 10 JCL=2,NHEP
5987 IF (ISTHEP(JCL).EQ.164) GOTO 20
5988 IF (ISTHEP(JCL).EQ.165) THEN
5989 IP=JMOHEP(1,JCL)
5990 JP=JMOHEP(2,JCL)
5991 KP=IP
5992 IF (ISTHEP(IP).EQ.162) THEN
5993 KP=JP
5994 JP=IP
5995 ENDIF
5996 IF (JMOHEP(2,KP).NE.JP) THEN
5997 IP=JMOHEP(2,KP)
5998 ELSE
5999 IP=JDAHEP(2,KP)
6000 ENDIF
6001 KCL=JDAHEP(1,IP)
6002 IF (ISTHEP(KCL)/10.NE.16) THEN
6003 CALL HWWARN('HWCDEC',100)
6004 GOTO 999
6005 ENDIF
6006 ISTHEP(KCL)=164
6007 GOTO 20
6008 ENDIF
6009 10 CONTINUE
6010 ENDIF
6011 20 CONTINUE
6012 DO 30 JCL=1,NHEP
6013 IST=ISTHEP(JCL)
6014 IF (IST.GT.162.AND.IST.LT.166) THEN
6015C---DON'T HADRONIZE BEAM/TARGET CLUSTERS
6016 IF (IST.EQ.163.OR..NOT.GENSOF) THEN
6017C---SET UP FLAVOURS FOR CLUSTER DECAY
6018 CALL HWCFLA(IDHW(JMOHEP(1,JCL)),IDHW(JMOHEP(2,JCL)),ID1,ID3)
6019 CALL HWCHAD(JCL,ID1,ID3,ID2)
6020 ENDIF
6021 ENDIF
6022 30 CONTINUE
6023 ISTAT=50
6024 999 RETURN
6025 END
6026CDECK ID>, HWCFLA.
6027*CMZ :- -26/04/91 10.18.56 by Bryan Webber
6028*-- Author : Bryan Webber
6029C-----------------------------------------------------------------------
6030 SUBROUTINE HWCFLA(JD1,JD2,ID1,ID2)
6031C-----------------------------------------------------------------------
6032C SETS UP FLAVOURS FOR CLUSTER DECAY
6033C-----------------------------------------------------------------------
6034 IMPLICIT NONE
6035 INTEGER JD1,JD2,ID1,ID2,JD,JDEC(12)
6036 SAVE JDEC
6037 DATA JDEC/1,2,3,10,11,12,4,5,6,7,8,9/
6038 JD=JD1
6039 IF (JD.GT.12) JD=JD-108
6040 ID1=JDEC(JD)
6041 JD=JD2
6042 IF (JD.GT.12) JD=JD-96
6043 ID2=JDEC(JD-6)
6044 END
6045CDECK ID>, HWCFOR.
6046*CMZ :- -26/04/91 14.15.56 by Federico Carminati
6047*-- Author : Bryan Webber
6048C-----------------------------------------------------------------------
6049 SUBROUTINE HWCFOR
6050C-----------------------------------------------------------------------
6051C Converts colour-connected quark-antiquark pairs into clusters
6052C Modified by IGK to include BRW's colour rearrangement and
6053C MHS's cluster vertices
6054C MODIFIED 16/10/97 BY BRW FOR SUSY PROCESSES
6055C-----------------------------------------------------------------------
c63d70bc 6056 INCLUDE 'herwig65.inc'
65767955 6057 DOUBLE PRECISION HWULDO,HWVDOT,HWRGEN,HWUPCM,DCL0,DCL(4),DCL1,
6058 & DFAC,DISP1(4),DISP2(4),DMAX,PCL(5),DOT1,DOT2,FAC,VCLUS,SCA1,SCA2,
6059 & EM0,EM1,EM2,PC0,PC1
6060 INTEGER HWRINT,MAP(120),IBHEP,IBCL,JBHEP,JHEP,
6061 & KHEP,LHEP,LCL,IHEP,MCL,I,ISTJ,ISTK,JCL,ID1,ID3,L
6062 LOGICAL HWRLOG,SPLIT
6063 EXTERNAL HWULDO,HWVDOT,HWRGEN,HWUPCM,HWRINT
6064 COMMON/HWCFRM/VCLUS(4,NMXHEP)
6065 SAVE MAP
6066 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,
6067 & 12/
6068 IF (IERROR.NE.0) RETURN
6069C Split gluons
6070 CALL HWCGSP
6071C Find colour partners after baryon number violating event
6072 IF (HVFCEN) THEN
6073 IF(RPARTY) THEN
6074 CALL HVCBVI
6075 ELSE
6076 CALL HWCBVI
6077 ENDIF
6078 ENDIF
6079 IF (IERROR.NE.0) RETURN
6080C Look for partons to cluster
6081 DO 10 IBHEP=1,NHEP
6082 10 IF (ISTHEP(IBHEP).GE.150.AND.ISTHEP(IBHEP).LE.154) GOTO 20
6083 IBCL=1
6084 GOTO 130
6085 20 CONTINUE
6086C--Final check for colour disconnections
6087 DO 25 JHEP=IBHEP,NHEP
6088 IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6089 & QORQQB(IDHW(JHEP))) THEN
6090 KHEP=JMOHEP(2,JHEP)
6091C BRW FIX 13/03/99
6092 IF (KHEP.EQ.0.OR..NOT.(
6093 & ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154.AND.
6094 & QBORQQ(IDHW(KHEP)))) THEN
6095 DO KHEP=IBHEP,NHEP
6096 IF (ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154
6097 & .AND.QBORQQ(IDHW(KHEP))) THEN
6098 LHEP=JDAHEP(2,KHEP)
6099 IF (LHEP.EQ.0.OR..NOT.(
6100 & ISTHEP(LHEP).GE.150.AND.ISTHEP(LHEP).LE.154.AND.
6101 & QORQQB(IDHW(LHEP)))) THEN
6102 JMOHEP(2,JHEP)=KHEP
6103 JDAHEP(2,KHEP)=JHEP
6104 GOTO 25
6105 ENDIF
6106 ENDIF
6107 ENDDO
6108C END FIX
6109 CALL HWWARN('HWCFOR',100)
6110 GOTO 999
6111 ENDIF
6112 ENDIF
6113 25 CONTINUE
6114 IF (CLRECO) THEN
6115C Allow for colour rearrangement of primary clusters
6116 NRECO=0
6117C Randomize starting point
6118 JBHEP=HWRINT(IBHEP,NHEP)
6119 JHEP=JBHEP
6120 30 JHEP=JHEP+1
6121 IF (JHEP.GT.NHEP) JHEP=IBHEP
6122 IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6123 & QORQQB(IDHW(JHEP))) THEN
6124C Find colour connected antiquark or diquark
6125 KHEP=JMOHEP(2,JHEP)
6126C Find partner antiquark or diquark
6127 LHEP=JDAHEP(2,JHEP)
6128C Find closest antiquark or diquark
6129 DCL0=1.D15
6130 LCL=0
6131 DO 40 IHEP=IBHEP,NHEP
6132 IF (ISTHEP(IHEP).GE.150.AND.ISTHEP(IHEP).LE.154.AND.
6133 & QBORQQ(IDHW(IHEP))) THEN
6134C Check whether already reconnected
6135 IF (JDAHEP(2,IHEP).GT.0.AND.IHEP.NE.LHEP) THEN
6136 CALL HWVDIF(4,VHEP(1,IHEP),VHEP(1,JHEP),DCL)
6137 DCL1=ABS(HWULDO(DCL,DCL))
6138 IF (DCL1.LT.DCL0) THEN
6139 DCL0=DCL1
6140 LCL=IHEP
6141 ENDIF
6142 ENDIF
6143 ENDIF
6144 40 CONTINUE
6145 IF (LCL.NE.0.AND.LCL.NE.KHEP) THEN
6146 MCL=JDAHEP(2,LCL)
6147 IF (JDAHEP(2,MCL).NE.KHEP) THEN
6148C Pairwise reconnection is possible
6149 CALL HWVDIF(4,VHEP(1,KHEP),VHEP(1,MCL ),DCL)
6150 DCL0=DCL0+ABS(HWULDO(DCL,DCL))
6151 CALL HWVDIF(4,VHEP(1,JHEP),VHEP(1,KHEP),DCL)
6152 DCL1=ABS(HWULDO(DCL,DCL))
6153 CALL HWVDIF(4,VHEP(1,LCL ),VHEP(1,MCL ),DCL)
6154 DCL1=DCL1+ABS(HWULDO(DCL,DCL))
6155 IF (DCL0.LT.DCL1.AND.HWRLOG(PRECO)) THEN
6156C Reconnection occurs
6157 JMOHEP(2,JHEP)= LCL
6158 JDAHEP(2,LCL )=-JHEP
6159 JMOHEP(2,MCL) = KHEP
6160 JDAHEP(2,KHEP)=-MCL
6161 NRECO=NRECO+1
6162 ENDIF
6163 ENDIF
6164 ENDIF
6165 ENDIF
6166 IF (JHEP.NE.JBHEP) GOTO 30
6167 IF (NRECO.NE.0) THEN
6168 DO 50 IHEP=IBHEP,NHEP
6169 50 JDAHEP(2,IHEP)=ABS(JDAHEP(2,IHEP))
6170 ENDIF
6171 ENDIF
6172C Find (adjusted) cluster positions using MHS prescription
6173 DFAC=ONE
6174 DMAX=1D-10
6175 DO 70 JHEP=IBHEP,NHEP
6176 IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6177 & QORQQB(IDHW(JHEP))) THEN
6178 KHEP=JMOHEP(2,JHEP)
6179 CALL HWUDKL(IDHW(JHEP),PHEP(1,JHEP),DISP1)
6180 CALL HWVSCA(4,DFAC,DISP1,DISP1)
6181 CALL HWUDKL(IDHW(KHEP),PHEP(1,KHEP),DISP2)
6182 CALL HWVSCA(4,DFAC,DISP2,DISP2)
6183C Rescale the lengths of DISP1,DISP2 if too long
6184 DOT1=HWVDOT(3,DISP1,DISP1)
6185 DOT2=HWVDOT(3,DISP2,DISP2)
6186 IF (MAX(DOT1,DOT2).GT.DMAX**2) THEN
6187 CALL HWVSCA(4,DMAX/SQRT(DOT1),DISP1,DISP1)
6188 CALL HWVSCA(4,DMAX/SQRT(DOT2),DISP2,DISP2)
6189 ENDIF
6190 CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
6191 DOT1=HWVDOT(3,DISP1,PCL)
6192 DOT2=HWVDOT(3,DISP2,PCL)
6193C If PCL > 90^o from either quark, use a vector which isn't
6194 IF (DOT1.LE.ZERO.OR. DOT2.LE.ZERO) THEN
6195 CALL HWVSUM(4,DISP1,DISP2,PCL)
6196 DOT1=HWVDOT(3,DISP1,PCL)
6197 DOT2=HWVDOT(3,DISP2,PCL)
6198 ENDIF
6199C If vectors are exactly opposite each other this method cannot work
6200 IF (DOT1.EQ.ZERO.OR.DOT2.EQ.ZERO) THEN
6201C So use midpoint of quark constituents
6202 CALL HWVSUM(4,VHEP(1,JHEP),VHEP(1,KHEP),VCLUS(1,JHEP))
6203 CALL HWVSCA(4,HALF,VCLUS(1,JHEP),VCLUS(1,JHEP))
6204 GOTO 70
6205 ENDIF
6206C Rescale DISP1 or DISP2 to give equal components in the PCL direction
6207 FAC=DOT1/DOT2
6208 IF (FAC.GT.ONE) THEN
6209 CALL HWVSCA(4, FAC,DISP2,DISP2)
6210 DOT2=DOT1
6211 ELSE
6212 CALL HWVSCA(4,ONE/FAC,DISP1,DISP1)
6213 DOT1=DOT2
6214 ENDIF
6215C Shift VHEP(1,JHEP) or VHEP(1,KHEP) s.t. their line is perp to PCL
6216 FAC=(HWVDOT(3,PCL,VHEP(1,KHEP))
6217 & -HWVDOT(3,PCL,VHEP(1,JHEP)))/DOT1
6218 SCA1=MAX(ONE,ONE+FAC)
6219 SCA2=MAX(ONE,ONE-FAC)
6220 DO 60 I=1,4
6221 60 VCLUS(I,JHEP)=.5*(VHEP(I,JHEP)+VHEP(I,KHEP)
6222 & +SCA1*DISP1(I)+SCA2*DISP2(I))
6223 ENDIF
6224 70 CONTINUE
6225C First chop up beam/target clusters
6226 DO 80 JHEP=IBHEP,NHEP
6227 KHEP=JMOHEP(2,JHEP)
6228 ISTJ=ISTHEP(JHEP)
6229 ISTK=ISTHEP(KHEP)
6230C--PR MOD here 8/7/99
6231 IF (QORQQB(IDHW(JHEP)).AND.
6232 & (((ISTJ.EQ.153.OR.ISTJ.EQ.154).AND.ISTK.NE.151.AND.ISTK.NE.0)
6233 & .OR.((ISTK.EQ.153.OR.ISTK.EQ.154).
6234 & AND.ISTJ.NE.151.AND.ISTJ.NE.0))) THEN
6235C--end
6236 CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
6237 CALL HWUMAS(PCL)
6238 CALL HWCCUT(JHEP,KHEP,PCL,.TRUE.,SPLIT)
6239 IF (IERROR.NE.0) RETURN
6240 ENDIF
6241 80 CONTINUE
6242C Second chop up massive pairs
6243 DO 100 JHEP=IBHEP,NMXHEP
6244 IF (JHEP.GT.NHEP) GOTO 110
6245 IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6246 & QORQQB(IDHW(JHEP))) THEN
6247 90 KHEP=JMOHEP(2,JHEP)
6248 CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PCL)
6249 CALL HWUMAS(PCL)
6250 IF (PCL(5).GT.CTHRPW(MAP(IDHW(JHEP)),MAP(IDHW(KHEP)))) THEN
6251 CALL HWCCUT(JHEP,KHEP,PCL,.FALSE.,SPLIT)
6252 IF (IERROR.NE.0) RETURN
6253 IF (SPLIT) GOTO 90
6254 ENDIF
6255 ENDIF
6256 100 CONTINUE
6257C Third create clusters and store production vertex
6258 110 IBCL=NHEP+1
6259 JCL=NHEP
6260 DO 120 JHEP=IBHEP,NHEP
6261 IF (ISTHEP(JHEP).GE.150.AND.ISTHEP(JHEP).LE.154.AND.
6262 & QORQQB(IDHW(JHEP))) THEN
6263 JCL=JCL+1
6264 IF(JCL.GT.NMXHEP) THEN
6265 CALL HWWARN('HWCFOR',105)
6266 GOTO 999
6267 ENDIF
6268 IDHW(JCL)=19
6269 IDHEP(JCL)=91
6270 KHEP=JMOHEP(2,JHEP)
6271 IF (KHEP.EQ.0.OR..NOT.(
6272 & ISTHEP(KHEP).GE.150.AND.ISTHEP(KHEP).LE.154.AND.
6273 & QBORQQ(IDHW(KHEP)))) THEN
6274 CALL HWWARN('HWCFOR',104)
6275 GOTO 999
6276 ENDIF
6277 CALL HWVSUM(4,PHEP(1,JHEP),PHEP(1,KHEP),PHEP(1,JCL))
6278 CALL HWUMAS(PHEP(1,JCL))
6279 IF (ISTHEP(JHEP).EQ.153.OR.ISTHEP(KHEP).EQ.153) THEN
6280 ISTHEP(JCL)=164
6281 ELSEIF (ISTHEP(JHEP).EQ.154.OR.ISTHEP(KHEP).EQ.154) THEN
6282 ISTHEP(JCL)=165
6283 ELSE
6284 ISTHEP(JCL)=163
6285 ENDIF
6286 JMOHEP(1,JCL)=JHEP
6287 JMOHEP(2,JCL)=KHEP
6288 JDAHEP(1,JCL)=0
6289 JDAHEP(2,JCL)=0
6290 JDAHEP(1,JHEP)=JCL
6291 JDAHEP(1,KHEP)=JCL
6292 ISTHEP(JHEP)=ISTHEP(JHEP)+8
6293 ISTHEP(KHEP)=ISTHEP(KHEP)+8
6294 CALL HWVEQU(4,VCLUS(1,JHEP),VHEP(1,JCL))
6295 ENDIF
6296 120 CONTINUE
6297 NHEP=JCL
6298C Fix up momenta for single-hadron clusters
6299 130 DO 150 JCL=IBCL,NHEP
6300C Don't hadronize beam/target clusters
6301 IF (ISTHEP(JCL).LT.163.OR.ISTHEP(JCL).GT.165) GOTO 150
6302 IF (ISTHEP(JCL).NE.163.AND.GENSOF) GOTO 150
6303C Set up flavours for cluster decay
6304 CALL HWCFLA(IDHW(JMOHEP(1,JCL)),IDHW(JMOHEP(2,JCL)),ID1,ID3)
6305 EM0=PHEP(5,JCL)
6306 IF ((B1LIM.EQ.ZERO).OR.(ID1.NE.11.AND.ID3.NE.11)) THEN
6307 IF (EM0.GT.MIN(RMIN(ID1,1)+RMIN(1,ID3),
6308 $ RMIN(ID1,2)+RMIN(2,ID3))) GOTO 150
6309 ELSE
6310C Special for b clusters: allow 1-hadron decay above threshold
6311 IF (B1LIM*HWRGEN(1).LT.EM0/(MIN(RMIN(ID1,1)+RMIN(1,ID3),
6312 $ RMIN(ID1,2)+RMIN(2,ID3)))-1.)
6313 & GOTO 150
6314 ENDIF
6315 EM1=RMIN(ID1,ID3)
6316 IF (ABS(EM0-EM1).LT.1.D-5) GOTO 150
6317C Decide to go backward or forward to transfer 4-momentum
6318 L=1-2*HWRINT(0,1)
6319 MCL=NHEP-IBCL+1
6320 LCL=JCL
6321 DO 140 I=1,MCL
6322 LCL=LCL+L
6323 IF (LCL.LT.IBCL) LCL=LCL+MCL
6324 IF (LCL.GT.NHEP) LCL=LCL-MCL
6325 IF (LCL.EQ.JCL) THEN
6326 IF (EM0.GE.EM1+RMIN(1,1)) GOTO 150
6327 CALL HWWARN('HWCFOR',101)
6328 GOTO 999
6329 ENDIF
6330 IF (ISTHEP(LCL).LT.163.OR.ISTHEP(LCL).GT.165) GOTO 140
6331C Rescale momenta in 2-cluster CoM
6332 CALL HWVSUM(4,PHEP(1,JCL),PHEP(1,LCL),PCL)
6333 CALL HWUMAS(PCL)
6334 EM2=PHEP(5,LCL)
6335 PC0=HWUPCM(PCL(5),EM0,EM2)
6336 PC1=HWUPCM(PCL(5),EM1,EM2)
6337 IF (PC1.LT.ZERO) THEN
6338C Need to rescale other mass as well
6339 CALL HWCFLA(IDHW(JMOHEP(1,LCL)),IDHW(JMOHEP(2,LCL)),ID1,ID3)
6340 EM2=RMIN(ID1,ID3)
6341 PC1=HWUPCM(PCL(5),EM1,EM2)
6342 IF (PC1.LT.ZERO) GOTO 140
6343 PHEP(5,LCL)=EM2
6344 ENDIF
6345 IF (PC0.GT.ZERO) THEN
6346 PC0=PC1/PC0
6347 CALL HWULOF(PCL,PHEP(1,JCL),PHEP(1,JCL))
6348 CALL HWVSCA(3,PC0,PHEP(1,JCL),PHEP(1,JCL))
6349 PHEP(4,JCL)=SQRT(PC1**2+EM1**2)
6350 PHEP(5,JCL)=EM1
6351 CALL HWULOB(PCL,PHEP(1,JCL),PHEP(1,JCL))
6352 CALL HWVDIF(4,PCL,PHEP(1,JCL),PHEP(1,LCL))
6353 GOTO 150
6354 ELSEIF (PC0.EQ.ZERO) THEN
6355 PHEP(5,JCL)=EM1
6356 CALL HWDTWO(PCL,PHEP(1,JCL),PHEP(1,LCL),PC1,TWO,.TRUE.)
6357 GOTO 150
6358 ELSE
6359 CALL HWWARN('HWCFOR',102)
6360 GOTO 999
6361 ENDIF
6362 140 CONTINUE
6363 CALL HWWARN('HWCFOR',103)
6364 GOTO 999
6365 150 CONTINUE
6366 ISTAT=60
6367C Non-partons labelled as partons (ie photons) should get copied
6368 DO 160 IHEP=1,NHEP
6369 IF (ISTHEP(IHEP).EQ.150) THEN
6370 NHEP=NHEP+1
6371 JDAHEP(1,IHEP)=NHEP
6372 ISTHEP(IHEP)=157
6373 ISTHEP(NHEP)=190
6374 IDHW(NHEP)=IDHW(IHEP)
6375 IDHEP(NHEP)=IDPDG(IDHW(IHEP))
6376 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
6377C--MHS FIX 07/03/05 - VERTEX SHOULD BE RELATIVE TO FIXED AXES
6378 CALL HWVSUM(4,VTXPIP,VHEP(1,IHEP),VHEP(1,NHEP))
6379C--END FIXES
6380 JMOHEP(1,NHEP)=IHEP
6381 JMOHEP(2,NHEP)=JMOHEP(1,IHEP)
6382 JDAHEP(1,NHEP)=0
6383 JDAHEP(2,NHEP)=0
6384 ENDIF
6385 160 CONTINUE
6386 999 RETURN
6387 END
6388CDECK ID>, HWCGSP.
6389*CMZ :- -13/07/92 20.15.54 by Mike Seymour
6390*-- Author : Bryan Webber
6391C-----------------------------------------------------------------------
6392 SUBROUTINE HWCGSP
6393C-----------------------------------------------------------------------
6394C SPLITS ANY TIMELIKE GLUONS REMAINING AFTER PERTURBATIVE
6395C BRANCHING INTO LIGHT (I.E. U OR D) Q-QBAR PAIRS
6396C-----------------------------------------------------------------------
c63d70bc 6397 INCLUDE 'herwig65.inc'
65767955 6398 DOUBLE PRECISION HWRGEN,PF
6399 INTEGER HWRINT,IHEP,JHEP,KHEP,LHEP,MHEP,ID,J,IST
6400 EXTERNAL HWRGEN,HWRINT
6401 IF (NGSPL.EQ.0) CALL HWWARN('HWCGSP',400)
6402 LHEP=NHEP-1
6403 MHEP=NHEP
6404 DO 100 IHEP=1,NHEP
6405 IF (ISTHEP(IHEP).GE.147.AND.ISTHEP(IHEP).LE.149) THEN
6406 JHEP=JMOHEP(2,IHEP)
6407C BRW FIX 12/03/99
6408 IF (JHEP.LE.0) THEN
6409 KHEP=0
6410 DO JHEP=1,NHEP
6411 IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.149
6412 & .AND.JDAHEP(2,JHEP).LE.0) THEN
6413 KHEP=KHEP+1
6414 JMOHEP(2,IHEP)=JHEP
6415 JDAHEP(2,JHEP)=IHEP
6416 ENDIF
6417 ENDDO
6418 IF (KHEP.EQ.0) THEN
6419 CALL HWWARN('HWCGSP',102)
6420 GOTO 999
6421 ENDIF
6422 IF (KHEP.NE.1) THEN
6423 CALL HWWARN('HWCGSP',103)
6424 GOTO 999
6425 ENDIF
6426 ENDIF
6427C END FIX
6428C---CHECK FOR DECAYED HEAVY ANTIQUARKS
6429 IF (ISTHEP(JHEP).EQ.155) THEN
6430 JHEP=JDAHEP(1,JDAHEP(2,JHEP))
6431 DO 10 J=JDAHEP(1,JHEP),JDAHEP(2,JHEP)
6432 10 IF (ISTHEP(J).EQ.149.AND.JDAHEP(2,J).EQ.0) GOTO 20
6433 CALL HWWARN('HWCGSP',100)
6434 GOTO 999
6435 20 JHEP=J
6436 ENDIF
6437 KHEP=JDAHEP(2,IHEP)
6438C BRW FIX 12/03/99
6439 IF (KHEP.LE.0) THEN
6440 KHEP=0
6441 DO JHEP=1,NHEP
6442 IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.149
6443 & .AND.JMOHEP(2,JHEP).LE.0) THEN
6444 KHEP=KHEP+1
6445 JDAHEP(2,IHEP)=JHEP
6446 JMOHEP(2,JHEP)=IHEP
6447 ENDIF
6448 ENDDO
6449 IF (KHEP.EQ.0) THEN
6450 CALL HWWARN('HWCGSP',104)
6451 GOTO 999
6452 ENDIF
6453 IF (KHEP.NE.1) THEN
6454 CALL HWWARN('HWCGSP',105)
6455 GOTO 999
6456 ENDIF
6457 KHEP=JDAHEP(2,IHEP)
6458 ENDIF
6459C END FIX
6460C---CHECK FOR DECAYED HEAVY QUARKS
6461 IF (ISTHEP(KHEP).EQ.155) THEN
6462 CALL HWWARN('HWCGSP',101)
6463 GOTO 999
6464 ENDIF
6465 IF (IDHW(IHEP).EQ.13) THEN
6466C---SPLIT A GLUON
6467 LHEP=LHEP+2
6468 MHEP=MHEP+2
6469 IF(MHEP.GT.NMXHEP) THEN
6470 CALL HWWARN('HWCGSP',106)
6471 GOTO 999
6472 ENDIF
6473 30 ID=HWRINT(1,NGSPL)
6474 IF (PGSPL(ID).LT.PGSMX*HWRGEN(0)) GOTO 30
6475 PHEP(5,LHEP)=RMASS(ID)
6476 PHEP(5,MHEP)=RMASS(ID)
6477C---ASSUME ISOTROPIC ANGULAR DISTRIBUTION
6478 IF (PHEP(5,IHEP).GT.PHEP(5,LHEP)+PHEP(5,MHEP)) THEN
6479 CALL HWDTWO(PHEP(1,IHEP),PHEP(1,LHEP),
6480 & PHEP(1,MHEP),PGSPL(ID),TWO,.TRUE.)
6481 ELSE
6482 PF=HWRGEN(1)
6483 CALL HWVSCA(4,PF,PHEP(1,IHEP),PHEP(1,LHEP))
6484 CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,LHEP),PHEP(1,MHEP))
6485 PHEP(5,LHEP)=PF*PHEP(5,IHEP)
6486 PHEP(5,MHEP)=PHEP(5,IHEP)-PHEP(5,LHEP)
6487 ENDIF
6488 CALL HWUDKL(13,PHEP(1,IHEP),VHEP(1,LHEP))
6489 CALL HWVSUM(4,VHEP(1,IHEP),VHEP(1,LHEP),VHEP(1,LHEP))
6490 CALL HWVEQU(4,VHEP(1,LHEP),VHEP(1,MHEP))
6491 IDHW(LHEP)=ID+6
6492 IDHW(MHEP)=ID
6493 IDHEP(MHEP)= IDPDG(ID)
6494 IDHEP(LHEP)=-IDPDG(ID)
6495 ISTHEP(IHEP)=2
6496 ISTHEP(LHEP)=150
6497 ISTHEP(MHEP)=150
6498C---NEW COLOUR CONNECTIONS
6499 IF(RPARTY.OR.JMOHEP(2,KHEP).EQ.IHEP) JMOHEP(2,KHEP)=LHEP
6500 IF(RPARTY.OR.JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=MHEP
6501 JMOHEP(1,LHEP)=JMOHEP(1,IHEP)
6502 JMOHEP(2,LHEP)=MHEP
6503 JMOHEP(1,MHEP)=JMOHEP(1,IHEP)
6504 JMOHEP(2,MHEP)=JHEP
6505 JDAHEP(1,LHEP)=0
6506 JDAHEP(2,LHEP)=KHEP
6507 JDAHEP(1,MHEP)=0
6508 JDAHEP(2,MHEP)=LHEP
6509 JDAHEP(1,IHEP)=LHEP
6510 JDAHEP(2,IHEP)=MHEP
6511 ELSE
6512C---COPY A NON-GLUON
6513 LHEP=LHEP+1
6514 MHEP=MHEP+1
6515 IF(MHEP.GT.NMXHEP) THEN
6516 CALL HWWARN('HWCGSP',107)
6517 GOTO 999
6518 ENDIF
6519 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,MHEP))
6520 CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,MHEP))
6521 IDHW(MHEP)=IDHW(IHEP)
6522 IDHEP(MHEP)=IDHEP(IHEP)
6523 IST=ISTHEP(IHEP)
6524 ISTHEP(IHEP)=2
6525 IF (IST.EQ.149) THEN
6526 ISTHEP(MHEP)=150
6527 ELSE
6528 ISTHEP(MHEP)=IST+6
6529 ENDIF
6530C---NEW COLOUR CONNECTIONS
6531 IF(RPARTY.OR.JMOHEP(2,KHEP).EQ.IHEP)
6532 & JMOHEP(2,KHEP)=MHEP
6533 IF(RPARTY.OR.(JHEP.NE.IHEP.AND.JDAHEP(2,JHEP).EQ.IHEP))
6534 & JDAHEP(2,JHEP)=MHEP
6535 JMOHEP(1,MHEP)=JMOHEP(1,IHEP)
6536 JMOHEP(2,MHEP)=JMOHEP(2,IHEP)
6537 JDAHEP(1,MHEP)=0
6538 JDAHEP(2,MHEP)=JDAHEP(2,IHEP)
6539 JDAHEP(1,IHEP)=MHEP
6540 ENDIF
6541 ENDIF
6542 100 CONTINUE
6543 NHEP=MHEP
6544 999 RETURN
6545 END
6546CDECK ID>, HWCHAD.
6547*CMZ :- -26/04/91 14.00.57 by Federico Carminati
6548*-- Author : Bryan Webber
6549C-----------------------------------------------------------------------
6550 SUBROUTINE HWCHAD(JCL,ID1,ID3,ID2)
6551C-----------------------------------------------------------------------
6552C HADRONIZES CLUSTER JCL, CONSISTING OF PARTONS ID1,ID3
6553C ID2 RETURNS PARTON-ANTIPARTON PAIR CREATED
6554C (IN SPECIAL CLUSTER CODE - SEE HWCFLA)
6555C
6556C MODIFIED 15/11/99 TO SMEAR POSITIONS OF HADRONS BY 1/(CLUSTER MASS)
6557C-----------------------------------------------------------------------
c63d70bc 6558 INCLUDE 'herwig65.inc'
65767955 6559 DOUBLE PRECISION HWRGEN,HWRGAU,HWVDOT,EM0,EM1,EM2,EMADU,EMSQ,
6560 & PCMAX,PCM,PTEST,PCQK,PP(5),EMLOW,RMAT(3,3),CT,ST,CX,SX,HPSMR
6561 INTEGER HWRINT,JCL,ID1,ID2,ID3,ID,IR1,IR2,NTRY,IDMIN,IMAX,I,MHEP,
6562 & IM,JM,KM,IB
6563 LOGICAL DIQK
6564 EXTERNAL HWRGEN,HWRINT
6565 DIQK(ID)=ID.GT.3.AND.ID.LT.10
6566 IF (IERROR.NE.0) RETURN
6567 ID2=0
6568 EM0=PHEP(5,JCL)
6569 IF (LOCN(ID1,ID3).LE.0) THEN
6570 CALL HWWARN('HWCHAD',104)
6571 GOTO 999
6572 ENDIF
6573 IR1=NCLDK(LOCN(ID1,ID3))
6574 EM1=RMIN(ID1,ID3)
6575 IF (ABS(EM0-EM1).LT.0.001) THEN
6576C---SINGLE-HADRON CLUSTER
6577 NHEP=NHEP+1
6578 IF (NHEP.GT.NMXHEP) THEN
6579 CALL HWWARN('HWCHAD',100)
6580 GOTO 999
6581 ENDIF
6582 IDHW(NHEP)=IR1
6583 IDHEP(NHEP)=IDPDG(IR1)
6584 ISTHEP(NHEP)=191
6585 JDAHEP(1,JCL)=NHEP
6586 JDAHEP(2,JCL)=NHEP
6587 CALL HWVEQU(5,PHEP(1,JCL),PHEP(1,NHEP))
6588 CALL HWVSUM(4,VHEP(1,JCL),VTXPIP,VHEP(1,NHEP))
6589 ELSE
6590 NTRY=0
6591 IDMIN=1
6592 EMLOW=RMIN(ID1,1)+RMIN(1,ID3)
6593 EMADU=RMIN(ID1,2)+RMIN(2,ID3)
6594 IF (EMADU.LT.EMLOW) THEN
6595 IDMIN=2
6596 EMLOW=EMADU
6597 ENDIF
6598 EMSQ=EM0**2
6599 PCMAX=EMSQ-EMLOW**2
6600 IF (PCMAX.GE.ZERO) THEN
6601C---SET UP TWO QUARK-ANTIQUARK PAIRS OR A
6602C QUARK-DIQUARK AND AN ANTIDIQUARK-ANTIQUARK
6603 PCMAX=PCMAX*(EMSQ-(RMIN(ID1,IDMIN)-RMIN(IDMIN,ID3))**2)
6604 IMAX=12
6605 IF (DIQK(ID1).OR.DIQK(ID3)) IMAX=3
6606 DO 10 I=3,IMAX
6607 IF (EM0.LT.RMIN(ID1,I)+RMIN(I,ID3)) GOTO 20
6608 10 CONTINUE
6609 I=IMAX+1
6610 20 ID2=HWRINT(1,I-1)
6611 IF (PWT(ID2).NE.ONE) THEN
6612 IF (PWT(ID2).LT.HWRGEN(1)) GOTO 20
6613 ENDIF
6614C---PICK TWO PARTICLES WITH THESE QUANTUM NUMBERS
6615 NTRY=NTRY+1
6616 30 IR1=LOCN(ID1,ID2)+INT(RESN(ID1,ID2)*HWRGEN(2))
6617 IF (CLDKWT(IR1).LT.HWRGEN(3)) GOTO 30
6618 IR1=NCLDK(IR1)
6619 40 IR2=LOCN(ID2,ID3)+INT(RESN(ID2,ID3)*HWRGEN(4))
6620 IF (CLDKWT(IR2).LT.HWRGEN(5)) GOTO 40
6621 IR2=NCLDK(IR2)
6622 EM1=RMASS(IR1)
6623 EM2=RMASS(IR2)
6624 PCM=EMSQ-(EM1+EM2)**2
6625 IF (PCM.GT.ZERO) GOTO 70
6626 IF (NTRY.LE.NDTRY) GOTO 20
6627C---CAN'T FIND A DECAY MODE - CHOOSE LIGHTEST
6628 60 ID2=HWRINT(1,2)
6629 IR1=NCLDK(LOCN(ID1,ID2))
6630 IR2=NCLDK(LOCN(ID2,ID3))
6631 EM1=RMASS(IR1)
6632 EM2=RMASS(IR2)
6633 PCM=EMSQ-(EM1+EM2)**2
6634 IF (PCM.GT.ZERO) GOTO 70
6635 NTRY=NTRY+1
6636 IF (NTRY.LE.NDTRY+50) GOTO 60
6637 CALL HWWARN('HWCHAD',101)
6638 GOTO 999
6639C---DECAY IS ALLOWED
6640 70 PCM=PCM*(EMSQ-(EM1-EM2)**2)
6641 IF (NTRY.GT.NCTRY) GOTO 80
6642 PTEST=PCM*SWTEF(IR1)*SWTEF(IR2)
6643 IF (PTEST.LT.PCMAX*HWRGEN(0)**2) GOTO 20
6644 ELSE
6645C---ALLOW DECAY BY PI0 EMISSION IF ONLY POSSIBILITY
6646 ID2=1
6647 IR2=NCLDK(LOCN(1,1))
6648 EM2=RMASS(IR2)
6649 PCM=(EMSQ-(EM1+EM2)**2)*(EMSQ-(EM1-EM2)**2)
6650 ENDIF
6651C---DECAY IS CHOSEN. GENERATE DECAY MOMENTA
6652C AND PUT PARTICLES IN /HEPEVT/
6653 80 IF (PCM.LT.ZERO) THEN
6654 CALL HWWARN('HWCHAD',102)
6655 GOTO 999
6656 ENDIF
6657 PCM=0.5*SQRT(PCM)/EM0
6658 MHEP=NHEP+1
6659 NHEP=NHEP+2
6660 IF (NHEP.GT.NMXHEP) THEN
6661 CALL HWWARN('HWCHAD',103)
6662 GOTO 999
6663 ENDIF
6664 PHEP(5,MHEP)=EM1
6665 PHEP(5,NHEP)=EM2
6666C Decide if cluster contains a b-(anti)quark or not
6667 IF (ID1.EQ.11.OR.ID2.EQ.11.OR.ID3.EQ.11) THEN
6668 IB=2
6669 ELSE
6670 IB=1
6671 ENDIF
6672 IF (CLDIR(IB).NE.0) THEN
6673 DO 110 IM=1,2
6674 JM=JMOHEP(IM,JCL)
6675 IF (JM.EQ.0) GOTO 110
6676 IF (ISTHEP(JM).NE.158) GOTO 110
6677C LOOK FOR PARENT PARTON
6678 DO 100 KM=JMOHEP(1,JM)+1,JM
6679 IF (ISTHEP(KM).EQ.2) THEN
6680 IF (JDAHEP(1,KM).EQ.JM) THEN
6681C FOUND PARENT PARTON
6682 IF (IDHW(KM).NE.13) THEN
6683C FIND ITS DIRECTION IN CLUSTER CMF
6684 CALL HWULOF(PHEP(1,JCL),PHEP(1,KM),PP)
6685 PCQK=PP(1)**2+PP(2)**2+PP(3)**2
6686 IF (PCQK.GT.ZERO) THEN
6687 PCQK=SQRT(PCQK)
6688 IF (CLSMR(IB).GT.ZERO) THEN
6689C DO GAUSSIAN SMEARING OF DIRECTION
6690 90 CT=ONE+CLSMR(IB)*LOG(HWRGEN(0))
6691 IF (CT.LT.-ONE) GOTO 90
6692 ST=ONE-CT*CT
6693 IF (ST.GT.ZERO) ST=SQRT(ST)
6694 CALL HWRAZM( ONE,CX,SX)
6695 CALL HWUROT(PP,CX,SX,RMAT)
6696 PP(1)=ZERO
6697 PP(2)=PCQK*ST
6698 PP(3)=PCQK*CT
6699 CALL HWUROB(RMAT,PP,PP)
6700 ENDIF
6701 PCQK=PCM/PCQK
6702 IF (IM.EQ.2) PCQK=-PCQK
6703 CALL HWVSCA(3,PCQK,PP,PHEP(1,MHEP))
6704 PHEP(4,MHEP)=SQRT(PHEP(5,MHEP)**2+PCM**2)
6705 CALL HWULOB(PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,MHEP))
6706 CALL HWVDIF(4,PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,NHEP))
6707 GOTO 130
6708 ENDIF
6709 ENDIF
6710 GOTO 120
6711 ENDIF
6712 ELSEIF (ISTHEP(KM).GT.140) THEN
6713C FINISHED THIS JET
6714 GOTO 110
6715 ENDIF
6716 100 CONTINUE
6717 110 CONTINUE
6718 ENDIF
6719 120 CALL HWDTWO(PHEP(1,JCL),PHEP(1,MHEP),PHEP(1,NHEP),
6720 & PCM,TWO,.TRUE.)
6721 130 IDHW(MHEP)=IR1
6722 IDHW(NHEP)=IR2
6723 IDHEP(MHEP)=IDPDG(IR1)
6724 IDHEP(NHEP)=IDPDG(IR2)
6725 ISTHEP(MHEP)=192
6726 ISTHEP(NHEP)=192
6727 JMOHEP(1,MHEP)=JCL
6728C---SECOND MOTHER OF HADRON IS JET
6729 JMOHEP(2,MHEP)=JMOHEP(1,JMOHEP(1,JCL))
6730 JDAHEP(1,JCL)=MHEP
6731 JDAHEP(2,JCL)=NHEP
6732C---SMEAR HADRON POSITIONS
6733 HPSMR=GEV2MM/PHEP(5,JCL)
6734 DO I=1,4
6735 VHEP(I,MHEP)=HWRGAU(I,ZERO,HPSMR)
6736 ENDDO
6737 VHEP(4,MHEP)=ABS(VHEP(4,MHEP))
6738 & +SQRT(HWVDOT(3,VHEP(1,MHEP),VHEP(1,MHEP)))
6739 CALL HWULB4(PHEP(1,JCL),VHEP(1,MHEP),VHEP(1,MHEP))
6740 CALL HWVSUM(4,VHEP(1,JCL),VHEP(1,MHEP),VHEP(1,MHEP))
6741 CALL HWVSUM(4,VTXPIP,VHEP(1,MHEP),VHEP(1,MHEP))
6742 DO I=1,4
6743 VHEP(I,NHEP)=HWRGAU(I,ZERO,HPSMR)
6744 ENDDO
6745 VHEP(4,NHEP)=ABS(VHEP(4,NHEP))
6746 & +SQRT(HWVDOT(3,VHEP(1,NHEP),VHEP(1,NHEP)))
6747 CALL HWULB4(PHEP(1,JCL),VHEP(1,NHEP),VHEP(1,NHEP))
6748 CALL HWVSUM(4,VHEP(1,JCL),VHEP(1,NHEP),VHEP(1,NHEP))
6749 CALL HWVSUM(4,VTXPIP,VHEP(1,NHEP),VHEP(1,NHEP))
6750 ENDIF
6751 ISTHEP(JCL)=180+MOD(ISTHEP(JCL),10)
6752 JMOHEP(1,NHEP)=JCL
6753 JMOHEP(2,NHEP)=JMOHEP(1,JMOHEP(1,JCL))
6754 999 RETURN
6755 END
6756CDECK ID>, HWD2ME.
6757*CMZ :- -09/04/02 13:37:38 by Peter Richardson
6758*-- Author : Peter Richardson
6759C-----------------------------------------------------------------------
6760 SUBROUTINE HWD2ME(IMODE)
6761C-----------------------------------------------------------------------
6762C Computes the width and maximum weight for a two body mode
6763C-----------------------------------------------------------------------
c63d70bc 6764 INCLUDE 'herwig65.inc'
65767955 6765 INTEGER IMODE,I
6766 DOUBLE PRECISION A(2),M(3),PCM,E1,E2,HWUPCM,PHS,WGT,MWGT,PCM2,
6767 & M2(3)
6768 EXTERNAL HWUPCM
6769C--set up the masses and couplings
6770 M(1) = RMASS(IDK(ID2PRT(IMODE)))
6771 DO 1 I=1,2
6772 A(I) = A2MODE(I,IMODE)
6773 1 M(I+1) = RMASS(IDKPRD(I,ID2PRT(IMODE)))
6774 DO 2 I=1,3
6775 2 M2(I) = M(I)**2
6776C--first compute the masses etc
6777 PCM = HWUPCM(M(1),M(2),M(3))
6778 PCM2 = PCM**2
6779 PHS = PCM/M2(1)/8.0D0/PIFAC
6780C--now compute the width and max weight
6781C--first the fermion --> fermion scalar diagrams
6782 IF(I2DRTP(IMODE).EQ.1) THEN
6783 WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(2)-M2(3))
6784 & +FOUR*A(1)*A(2)*M(1)*M(2))
6785 E1 = SQRT(M2(2)+PCM2)
6786 E2 = SQRT(M2(3)+PCM2)
6787 MWGT = HALF*M2(1)/(E1+E2)*(E1+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6788C--next the fermion --> scalar fermion diagrams
6789 ELSEIF(I2DRTP(IMODE).EQ.2) THEN
6790 WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2))
6791 & +FOUR*A(1)*A(2)*M(1)*M(3))
6792 E1 = SQRT(M2(2)+PCM2)
6793 E2 = SQRT(M2(3)+PCM2)
6794 MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6795C--next the fermion --> scalar antifermion diagrams
6796 ELSEIF(I2DRTP(IMODE).EQ.3) THEN
6797 WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2))
6798 & +FOUR*A(1)*A(2)*M(1)*M(3))
6799 E1 = SQRT(M2(2)+PCM2)
6800 E2 = SQRT(M2(3)+PCM2)
6801 MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6802C--next the fermion --> fermion gauge boson diagrams
6803 ELSEIF(I2DRTP(IMODE).EQ.4) THEN
6804 WGT = 2.0D0*(M2(1)-M2(2))**2
6805 MWGT = WGT
6806C--next the scalar --> fermion antifermion diagrams
6807 ELSEIF(I2DRTP(IMODE).EQ.5) THEN
6808 WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6809 & -FOUR*M(2)*M(3)*A(1)*A(2)
6810 MWGT = WGT
6811C--next the scalar --> fermion fermion diagrams
6812 ELSEIF(I2DRTP(IMODE).EQ.6) THEN
6813 WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6814 & -FOUR*M(2)*M(3)*A(1)*A(2)
6815 MWGT = WGT
6816C--next the fermion --> fermion pion diagrams
6817 ELSEIF(I2DRTP(IMODE).EQ.7) THEN
6818 WGT = HALF/FOUR/RMASS(198)**4*(
6819 & (A(1)**2+A(2)**2)*((M2(1)-M2(2))**2-M2(3)*(M2(1)+M2(2)))
6820 & +FOUR*M(1)*M(2)*M2(3)*A(1)*A(2))
6821 E1 = SQRT(M2(2)+PCM2)
6822 E2 = SQRT(M2(3)+PCM2)
6823 MWGT =ONE/8.0D0/RMASS(198)**4*ABS(A(1)**2-A(2)**2)*
6824 & M(1)*(M(1)*M2(3)+(M2(1)-M2(2)+M2(3))*(E2+PCM))+WGT
6825C--next scalar --> antifermion fermion diagrams
6826 ELSEIF(I2DRTP(IMODE).EQ.8) THEN
6827 WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6828 & -FOUR*M(2)*M(3)*A(1)*A(2)
6829 MWGT = WGT
6830C--next fermion --> gravitino photon
6831 ELSEIF(I2DRTP(IMODE).EQ.9) THEN
6832 WGT = 8.0D0*M2(1)**3
6833 MWGT = WGT
6834C--next fermion --> gravitino scalar
6835 ELSEIF(I2DRTP(IMODE).EQ.10) THEN
6836 WGT = HALF*(M2(1)-M2(3))**3
6837 E1 = SQRT(M2(2)+PCM2)
6838 E2 = SQRT(M2(3)+PCM2)
6839 MWGT = TWO*M2(1)/(E1+E2)*(E1+PCM)*(M2(1)-M2(3))**2 +WGT
6840C--next sfermion --> fermion gravitino
6841 ELSEIF(I2DRTP(IMODE).EQ.11) THEN
6842 WGT = (M2(1)-M2(2))**3
6843 MWGT = WGT
6844C--next antisfermion --> fermion gravitino
6845 ELSEIF(I2DRTP(IMODE).EQ.12) THEN
6846 WGT = (M2(1)-M2(2))**3
6847 MWGT = WGT
6848C--next the scalar --> antifermion antifermion diagrams
6849 ELSEIF(I2DRTP(IMODE).EQ.13) THEN
6850 WGT = (M2(1)-M2(2)-M2(3))*(A(1)**2+A(2)**2)
6851 & -FOUR*M(2)*M(3)*A(1)*A(2)
6852 MWGT = WGT
6853C--next the antifermion --> scalar antifermion diagrams
6854 ELSEIF(I2DRTP(IMODE).EQ.14) THEN
6855 WGT = HALF*((A(1)**2+A(2)**2)*(M2(1)+M2(3)-M2(2))
6856 & +FOUR*A(1)*A(2)*M(1)*M(3))
6857 E1 = SQRT(M2(2)+PCM2)
6858 E2 = SQRT(M2(3)+PCM2)
6859 MWGT = HALF*M2(1)/(E1+E2)*(E2+PCM)*ABS(A(1)**2-A(2)**2)+WGT
6860C--unrecognised issue warning
6861 ELSE
6862 CALL HWWARN('HWITWO',500)
6863 ENDIF
6864 WGT = P2MODE(IMODE)* WGT*PHS
6865 MWGT = 1.1D0*P2MODE(IMODE)*MWGT*PHS
6866C--put the information in the common block
6867 WT2MAX(IMODE) = MWGT
6868C--output the information
6869 IF(IPRINT.EQ.2) THEN
6870 WRITE(*,3010) WGT
6871 WRITE(*,3020) MWGT
6872 WRITE(*,3030) WGT/HBAR/BRFRAC(ID2PRT(IMODE))*
6873 & RLTIM(IDK(ID2PRT(IMODE)))
6874 ENDIF
6875 RETURN
6876C--format statements
6877 3010 FORMAT(' PARTIAL WIDTH = ',G12.4)
6878 3020 FORMAT(' MAXIMUM WEIGHT = ',E12.4)
6879 3030 FORMAT(' RATIO TO ISAJET VALUE = ',G12.4)
6880 END
6881CDECK ID>, HWD3ME.
6882*CMZ :- -20/10/99 09:46:43 by Peter Richardson
6883*-- Author : Peter Richardson
6884C-----------------------------------------------------------------------
6885 SUBROUTINE HWD3ME(ID,ITYPE,IMODE,RHOIN,IDSPIN)
6886C-----------------------------------------------------------------------
6887C Subroutine to perform the three body decays for spin correlations
6888C and SUSY three body modes
6889C-----------------------------------------------------------------------
c63d70bc 6890 INCLUDE 'herwig65.inc'
65767955 6891 INTEGER IMODE,I,J,ID,IDP(4+NDIAGR),ITYPE,NDIA,ID1,ID2,
6892 & DRTYPE(NDIAGR),NTRY,IDSPIN,NCTHRE,DRCF(NDIAGR)
6893 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,WGT,M342,HWRUNI,
6894 & HWUPCM,M232,M242,WMAX,WSUM,WSSUM,MR,PRE,TEMP,HWRGEN,WTMAX,
6895 & BRW(6),BRZ(12),P(5,4),PM(5,4),WGTM,CFTHRE(NCFMAX,NCFMAX)
6896 DOUBLE COMPLEX S,D,RHOIN(2,2),F0(2,2,8),F3(2,2,8),F1(2,2,8),
6897 & F2(2,2,8),F0M(2,2,8),F1M(2,2,8),F01(2,2,8,8)
6898 EXTERNAL HWRUNI,HWUPCM,HWRGEN
6899 COMMON/HWHEWS/S(8,8,2),D(8,8)
6900 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
6901 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
6902 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
6903 SAVE BRW,BRZ
6904 DATA BRW/0.321D0,0.321D0,0.000D0,0.108D0,0.108D0,0.108D0/
6905 DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
6906 & 0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
6907C--compute the masses of external particles for the decay mode
6908C--first for true three body decay modes
6909 IF(ITYPE.EQ.0) THEN
6910C--initalisation for the diagrams
6911 WTMAX = WT3MAX(IMODE)
6912 PRE = P3MODE(IMODE)
6913 NCTHRE = N3NCFL(IMODE)
6914 NDIA = NDI3BY(IMODE)
6915 IDP(1) = IDK(ID3PRT(IMODE))
6916 DO 1 I=1,3
6917 1 IDP(I+1) = IDKPRD(I,ID3PRT(IMODE))
6918 DO 2 I=1,NCTHRE
6919 DO 2 J=1,NCTHRE
6920 2 CFTHRE(I,J) = SPN3CF(I,J,IMODE)
6921C--enter the couplings for the diagrams
6922 DO 3 I=1,NDI3BY(IMODE)
6923 DRTYPE(I) = I3DRTP(I,IMODE)
6924 DRCF (I) = I3DRCF(I,IMODE)
6925 DO 3 J=1,2
6926 A(J,I) = A3MODE(J,I,IMODE)
6927 3 B(J,I) = B3MODE(J,I,IMODE)
6928C--enter the intermediate masses for the diagrams
6929 DO 4 I=1,NDI3BY(IMODE)
6930 IDP(I+4) = I3MODE(I,IMODE)
6931 MR(I) = RMASS(I3MODE(I,IMODE))
6932 MS(I) = MR(I)**2
6933 IF(I3MODE(I,IMODE).GT.200) THEN
6934 MWD(I) = RMASS(I3MODE(I,IMODE))*HBAR/RLTIM(I3MODE(I,IMODE))
6935 ELSEIF(I3MODE(I,IMODE).EQ.200) THEN
6936 MWD(I) = RMASS(200)*GAMZ
6937 ELSEIF(I3MODE(I,IMODE).EQ.198.OR.I3MODE(I,IMODE).EQ.199) THEN
6938 MWD(I) = RMASS(198)*GAMW
6939 ELSEIF(I3MODE(I,IMODE).EQ.59) THEN
6940 MWD(I) = 0.0D0
6941 ENDIF
6942 4 CONTINUE
6943C--reorder for top quark decay modes(b first then W products)
6944 IF(IDP(1).EQ.6.OR.IDP(1).EQ.12) THEN
6945 I = IDP(2)
6946 IDP(2) = IDP(4)
6947 IDP(4) = IDP(3)
6948 IDP(3) = I
6949 ENDIF
6950C--reorder if fermion not first
6951 IF(IDP(3).GT.IDP(4).AND.((IDP(1).EQ.6.OR.IDP(1).EQ.12).OR.
6952 & IDP(2).GE.400)) THEN
6953 I = IDP(3)
6954 IDP(3) = IDP(4)
6955 IDP(4) = I
6956 ENDIF
6957C--then for two body modes to gauge bosons including boson decays
6958 ELSE
6959C--initalisation for the diagram
6960 WTMAX = WTBMAX(ITYPE,IMODE)
6961 NDIA = 1
6962 PRE = PBMODE(ITYPE,IMODE)
6963 DRTYPE(1) = IBDRTP(IMODE)
6964 DRCF (1) = 1
6965 NCTHRE = 1
6966 CFTHRE(1,1) = ONE
6967C--particles in decay
6968 IDP(1) = IDK(IDBPRT(IMODE))
6969 IDP(2) = IDKPRD(1,IDBPRT(IMODE))
6970 IF(IDP(2).GE.198.AND.IDP(2).LE.200)
6971 & IDP(2) = IDKPRD(2,IDBPRT(IMODE))
6972 IDP(5) = IBMODE(IMODE)
6973C--masses of virtual particles and couplings
6974 MR(1) = RMASS(IBMODE(IMODE))
6975 MS(1) = MR(1)**2
6976 DO J=1,2
6977 A(J,1) = ABMODE(J,IMODE)
6978 B(J,1) = BBMODE(J,ITYPE,IMODE)
6979 ENDDO
6980 IF(IBMODE(IMODE).EQ.200) THEN
6981 MWD(1) = RMASS(200)*GAMZ
6982 ELSE
6983 MWD(1) = RMASS(198)*GAMW
6984 ENDIF
6985C--particles from boson decay
6986 IF(IBMODE(IMODE).EQ.200) THEN
6987 ID1 = ITYPE
6988 IF(ITYPE.GT.6) ID1 = ID1+114
6989 ID2 = ID1+6
6990 ELSE
6991 ID1 = 2*ITYPE-1
6992 IF(ITYPE.GT.3) ID1 = ID1+114
6993 ID2 = ID1+7
6994 IF(IBMODE(IMODE).EQ.198) THEN
6995 I = ID1+6
6996 ID1 = ID2-6
6997 ID2 = I
6998 ENDIF
6999 ENDIF
7000 IDP(3) = ID1
7001 IDP(4) = ID2
7002C--only do the decay if possible for an on-shell boson
7003 IF(RMASS(ID1)+RMASS(ID2).GT.MR(1)) RETURN
7004 IF(IPRINT.EQ.2.AND..NOT.GENEV)
7005 & WRITE(6,3000) RNAME(IDP(5)),RNAME(IDP(3)),RNAME(IDP(4))
7006 MA(3) = RMASS(IDP(3))
7007 MA(4) = RMASS(IDP(4))
7008 DO 5 I=1,4
7009 5 MA2(I) = MA(I)**2
7010 ENDIF
7011C--set up the masses MA OFF SHELL MB ON SHELL
7012 DO 6 I=1,4
7013 MB(I) = RMASS(IDP(I))
7014 MB2(I) = MB(I)**2
7015 IF(.NOT.GENEV) THEN
7016 MA (I) = MB (I)
7017 MA2(I) = MB2(I)
7018 ENDIF
7019 6 CONTINUE
7020 IF(MA(1).LT.MA(2)+MA(3)+MA(4)) RETURN
7021C--compute the width and maximum weight if initialising
7022 IF(.NOT.GENEV) THEN
7023C--search for maximum weight
7024 WMAX = ZERO
7025 WSUM = ZERO
7026 WSSUM = ZERO
7027 DO 7 I=1,NSEARCH
7028 CALL HWD3M0(1,NDIA,WGT,WGTM,RHOIN,IDSPIN)
7029 WGT = WGT*PRE
7030 WGTM=WGTM*PRE
7031 IF(WGTM.GT.WMAX) WMAX = WGTM
7032 WSUM = WSUM+WGT
7033 WSSUM = WSSUM+WGT**2
7034 IF(WGT.LT.ZERO) CALL HWWARN('HWD3ME',500)
7035 7 CONTINUE
7036C--compute width and maximum weight
7037 WSUM = WSUM/DBLE(NSEARCH)
7038 WSSUM = MAX(ZERO,WSSUM/DBLE(NSEARCH)-WSUM**2)
7039 WSSUM = SQRT(WSSUM/DBLE(NSEARCH))
7040C--if required output results
7041 IF(IPRINT.EQ.2) THEN
7042 WRITE(6,3010) WSUM,WSSUM
7043 WRITE(6,3020) WMAX
7044 IF(ITYPE.EQ.0) THEN
7045 TEMP = BRFRAC(ID3PRT(IMODE))*HBAR/RLTIM(IDK(ID3PRT(IMODE)))
7046 ELSE
7047 IF(IBMODE(IMODE).EQ.200) THEN
7048 TEMP = BRFRAC(IDBPRT(IMODE))*HBAR/
7049 & RLTIM(IDK(IDBPRT(IMODE)))*BRZ(ITYPE)
7050 ELSE
7051 TEMP = BRFRAC(IDBPRT(IMODE))*HBAR/
7052 & RLTIM(IDK(IDBPRT(IMODE)))*BRW(ITYPE)
7053 ENDIF
7054 ENDIF
7055 WRITE(6,3030) WSUM/TEMP,WSSUM/TEMP
7056 ENDIF
7057C--set up the maximum weight
7058 IF(ITYPE.EQ.0) THEN
7059 WT3MAX(IMODE) = 1.1D0*WMAX
7060 ELSE
7061 WTBMAX(ITYPE,IMODE) = 1.1D0*WMAX
7062 ENDIF
7063C--if not initialising generate the momenta
7064 ELSE
7065C--generate a configuation
7066 NTRY = 0
7067 100 NTRY = NTRY+1
7068 CALL HWD3M0(ID,NDIA,WGT,WGTM,RHOIN,IDSPIN)
7069 WGT = WGT*PRE
7070C--check maximum isn't violated, increase and issue warning if it is
7071 IF(WGT.GT.WTMAX) THEN
7072 CALL HWWARN('HWD3ME',1)
7073 IF(ITYPE.EQ.0) THEN
7074 WRITE(6,3040) RNAME(IDP(1)),RNAME(IDP(2)),RNAME(IDP(3)),
7075 & RNAME(IDP(4)),WTMAX,WGT*1.1D0
7076 ELSE
7077 WRITE(6,3050) RNAME(IDP(1)),RNAME(IDP(2)),RNAME(IDP(5))
7078 WRITE(6,3060) RNAME(IDP(5)),RNAME(IDP(3)),RNAME(IDP(4)),
7079 & WTMAX,WGT*1.1D0
7080 ENDIF
7081 WTMAX = WGT*1.1D0
7082 IF(ITYPE.EQ.0) THEN
7083 WT3MAX(IMODE) = WTMAX
7084 ELSE
7085 WTBMAX(ITYPE,IMODE) = WTMAX
7086 ENDIF
7087 ENDIF
7088 IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 100
7089 IF(NTRY.GE.NSNTRY) THEN
7090 CALL HWWARN('HWD3ME',100)
7091 GOTO 999
7092 ENDIF
7093 ENDIF
7094 RETURN
7095C--format statements for the outputs
7096 3000 FORMAT(/' FOLLOWED BY ',A8,' --> ',A8,' ',A8)
7097 3010 FORMAT(' PARTIAL WIDTH = ',G12.4,' +/- ',G12.4)
7098 3020 FORMAT(' MAXIMUM WEIGHT = ',E12.4)
7099 3030 FORMAT(' RATIO TO ISAJET VALUE = ',G12.4,' +/- ',G12.4)
7100 3040 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8,' ',A8,
7101 & 'EXCEEDS MAX',
7102 & /10X,' MAXIMUM WEIGHT =',1PG24.16,
7103 & /10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
7104 3050 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8)
7105 3060 FORMAT(/' FOLLOWED BY ',A8,' --> ',A8,' ',A8,' EXCEEDS MAX',
7106 & /10X,' MAXIMUM WEIGHT =',1PG24.16,
7107 & /10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
7108 999 RETURN
7109 END
7110CDECK ID>, HWD3M0.
7111*CMZ :- -09/04/02 13:46:07 by Peter Richardson
7112*-- Author : Peter Richardson
7113C-----------------------------------------------------------------------
7114 SUBROUTINE HWD3M0(ID,NDIA,WGT,MWGT,RHOIN,IDSPIN)
7115C-----------------------------------------------------------------------
7116C Subroutine to calculate the matrix element for a given mode
7117C-----------------------------------------------------------------------
c63d70bc 7118 INCLUDE 'herwig65.inc'
65767955 7119 INTEGER I,J,P0,P1,P2,P3,P0P,IB,ID,IDP(4+NDIAGR),IDSPIN,NDIA,
7120 & DRTYPE(NDIAGR),NCTHRE,DRCF(NDIAGR)
7121 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,WGT,FJAC,M342,HWRUNI,
7122 & M34,PCMA,PCMB,HWUPCM,PHS,N(3),HWVDOT,PP,HWULDO,EPS,PTMP(5),
7123 & M232,M242,PRE,PLAB,PRW,XMASS,PCM,P(5,4),PM(5,4),MR,PREF(5),
7124 & MMIN,MMAX,MWGT,CFTHRE(NCFMAX,NCFMAX),WGTB(NCFMAX),WGTC,
7125 & HWRGEN,A02,A2
7126 DOUBLE COMPLEX S,D,ME(2,2,2,2,NCFMAX),MED(2,2,2,2),F01(2,2,8,8),
7127 & RHOIN(2,2),F0(2,2,8),F1(2,2,8),F2(2,2,8),F0M(2,2,8),
7128 & RHOB(2,2),F1M(2,2,8),F3(2,2,8)
7129 EXTERNAL HWRUNI,HWUPCM,HWVDOT,HWULDO,HWRGEN
7130 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
7131 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7132 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7133 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7134 COMMON/HWHEWS/S(8,8,2),D(8,8)
7135 PARAMETER(EPS=1D-10)
7136 SAVE PREF
7137 DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
7138C--select the momenta of the particles
7139C--first see if there is a boson mode
7140 IB = -1
7141 DO 1 I=1,NDIA
7142 IF(DRTYPE(I).EQ.1.OR.DRTYPE(I).EQ.5.OR.DRTYPE(I).EQ.6.OR.
7143 & DRTYPE(I).EQ.7) IB = IDP(I+4)
7144 1 CONTINUE
7145C--compute the mass of the 34 subsystem flat if no boson otherwise Breit-Wigner
7146 MMIN = (MA(3)+MA(4))**2
7147 MMAX = (MA(1)-MA(2))**2
7148 IF(IB.GT.0.AND.IB.NE.59) THEN
7149 CALL HWHGB1(1,2,IB,FJAC,M342,MMAX,MMIN)
7150 ELSEIF(IB.EQ.59) THEN
7151 M342 = HWRUNI(1,LOG(MMIN),LOG(MMAX))
7152 M342 = EXP(M342)
7153 FJAC = (LOG(MMAX)-LOG(MMIN))*M342
7154 ELSEIF((DRTYPE(1).EQ.2.OR.DRTYPE(1).EQ.17).AND.
7155 & IDP(5).EQ.206.OR.IDP(5).EQ.207) THEN
7156 A02 = ATAN((MMIN-MS(1))/MWD(1))
7157 A2 = ATAN((MMAX-MS(1))/MWD(1))-A02
7158 M342 = MS(1)+MWD(1)*TAN(A02+A2*HWRGEN(1))
7159 FJAC = A2*((M342-MS(1))**2+MWD(1)**2)/MWD(1)
7160 ELSE
7161 FJAC = MMAX-MMIN
7162 M342 = HWRUNI(1,MMIN,MMAX)
7163 ENDIF
7164 M34 = SQRT(M342)
7165 FJAC = HALF*FJAC/M34
7166C--copy the momentum of the decaying particle into the internal common block
7167 CALL HWVEQU(5,PHEP(1,ID),P(1,1))
7168 DO 2 I=2,4
7169 2 P(5,I) = MA(I)
7170C--perform the decay 1---> 2+34
7171 PCMA = HWUPCM(MA(1),MA(2),M34)
7172 PLAB(5,1) = M34
7173 CALL HWDTWO(P(1,1),PLAB(1,1),P(1,2),PCMA,2.0D0,.TRUE.)
7174C--perform the decay 34 --> 3+4
7175 PCMB = HWUPCM(M34,MA(3),MA(4))
7176 CALL HWDTWO(PLAB(1,1),P(1,3),P(1,4),PCMB,2.0D0,.TRUE.)
7177C--compute the phase sapce factors
7178 PHS = PCMA*PCMB*FJAC/32.0D0/PIFAC**3/MA2(1)
7179C--compute the other possible masses for the propagator
7180 M232 = MA2(2)+MA2(3)+TWO*HWULDO(P(1,2),P(1,3))
7181 M242 = MA2(2)+MA2(4)+TWO*HWULDO(P(1,2),P(1,4))
7182C--compute the vectors for the helicity amplitudes
7183 DO 3 I=1,4
7184C--compute the references vectors
7185C--not important if SM particle which can't have spin measured
7186C--ie anything other the top and tau
7187C--also not important if particle is approx massless
7188C--first the SM particles other than top and tau
7189 IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12
7190 & .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN
7191 CALL HWVEQU(5,PREF,PLAB(1,I+4))
7192C--all other particles
7193 ELSE
7194 PP = SQRT(HWVDOT(3,P(1,I),P(1,I)))
7195 CALL HWVSCA(3,ONE/PP,P(1,I),N)
7196 PLAB(4,I+4) = HALF*(P(4,I)-PP)
7197 PP = HALF*(PP-MA(I)-PP**2/(MA(I)+P(4,I)))
7198 CALL HWVSCA(3,PP,N,PLAB(1,I+4))
7199 CALL HWUMAS(PLAB(1,I+4))
7200 PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4))
7201C--fix to avoid problems if approx massless due to energy
7202 IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4))
7203 ENDIF
7204C--now the massless vectors
7205 PP = HALF*MA2(I)/HWULDO(PLAB(1,I+4),P(1,I))
7206 DO 4 J=1,4
7207 4 PLAB(J,I) = P(J,I)-PP*PLAB(J,I+4)
7208 3 CALL HWUMAS(PLAB(1,I))
7209C--change order of momenta for call to HE code
7210 DO 5 I=1,4
7211 PM(1,I) = P(3,I)
7212 PM(2,I) = P(1,I)
7213 PM(3,I) = P(2,I)
7214 PM(4,I) = P(4,I)
7215 5 PM(5,I) = P(5,I)
7216 DO 6 I=1,8
7217 PCM(1,I)=PLAB(3,I)
7218 PCM(2,I)=PLAB(1,I)
7219 PCM(3,I)=PLAB(2,I)
7220 PCM(4,I)=PLAB(4,I)
7221 6 PCM(5,I)=PLAB(5,I)
7222C--compute the S functions
7223 CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
7224 DO 7 I=1,8
7225 DO 7 J=1,8
7226 S(I,J,2) = -S(I,J,2)
7227 7 D(I,J) = TWO*D(I,J)
7228C--compute the F functions
7229 CALL HWVSUM(5,PM(1,1),PM(1,2),PTMP)
7230 CALL HWUMAS(PTMP)
7231 CALL HWH2F2(8,F0 ,5,PM(1,1), MA(1))
7232 CALL HWH2F1(8,F1 ,6,PM(1,2), MA(2))
7233 CALL HWH2F1(8,F2 ,7,PM(1,3), MA(3))
7234 CALL HWH2F1(8,F3 ,8,PM(1,4), MA(4))
7235 CALL HWH2F1(8,F0M,5,PM(1,1),-MA(1))
7236 CALL HWH2F2(8,F1M,6,PM(1,2),-MA(2))
7237 CALL HWH2F3(8,F01,PTMP,ZERO)
7238C--now find the prefactor for all the diagrams
7239 PRE = HWULDO(PCM(1,5),PM(1,1))*HWULDO(PCM(1,6),PM(1,2))*
7240 & HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4))
7241 PRE = ONE/SQRT(PRE)
7242C--zero the matrix element
7243 DO 8 P0=1,2
7244 DO 8 P1=1,2
7245 DO 8 P2=1,2
7246 DO 8 P3=1,2
7247 DO 8 I =1,NCTHRE
7248 8 ME(P0,P1,P2,P3,I) = (0.0D0,0.0D0)
7249C--now call the subroutines to compute the individual diagrams
7250 DO 9 I=1,NDIA
7251C--vector boson exchange diagram
7252 IF(DRTYPE(I).EQ.1) THEN
7253 CALL HWD3M1(I,MED)
7254C--Higgs boson exchange diagram
7255 ELSEIF(DRTYPE(I).EQ.2) THEN
7256 CALL HWD3M2(I,MED)
7257C--antisfermion exchange diagram
7258 ELSEIF(DRTYPE(I).EQ.3) THEN
7259 CALL HWD3M3(I,MED)
7260C--sfermion exchange diagram
7261 ELSEIF(DRTYPE(I).EQ.4) THEN
7262 CALL HWD3M4(I,MED)
7263C--antifermion vector boson exchange diagram
7264 ELSEIF(DRTYPE(I).EQ.5) THEN
7265 CALL HWD3M5(I,MED)
7266C--scalar vector boson exchange diagram
7267 ELSEIF(DRTYPE(I).EQ.6) THEN
7268 CALL HWD3M6(I,MED)
7269C--gravitino fermion fermion
7270 ELSEIF(DRTYPE(I).EQ.7) THEN
7271 CALL HWD3M7(I,MED)
7272C--fermion RPV1
7273 ELSEIF(DRTYPE(I).EQ.8) THEN
7274 CALL HWD3M8(I,MED)
7275C--fermion RPV2
7276 ELSEIF(DRTYPE(I).EQ.9) THEN
7277 CALL HWD3M9(I,MED)
7278C--fermion RPV3
7279 ELSEIF(DRTYPE(I).EQ.10) THEN
7280 CALL HWD3MA(I,MED)
7281C--fermion --> 3 fermions 1
7282 ELSEIF(DRTYPE(I).EQ.11) THEN
7283 CALL HWD3MB(I,MED)
7284C--fermion --> 3 fermions 2
7285 ELSEIF(DRTYPE(I).EQ.12) THEN
7286 CALL HWD3MC(I,MED)
7287C--fermion --> 3 fermions 3
7288 ELSEIF(DRTYPE(I).EQ.13) THEN
7289 CALL HWD3MD(I,MED)
7290C--fermion --> 3 antifermions 1
7291 ELSEIF(DRTYPE(I).EQ.14) THEN
7292 CALL HWD3MF(I,MED)
7293C--fermion --> 3 antifermions 2
7294 ELSEIF(DRTYPE(I).EQ.15) THEN
7295 CALL HWD3MG(I,MED)
7296C--fermion --> 3 antifermions 3
7297 ELSEIF(DRTYPE(I).EQ.16) THEN
7298 CALL HWD3MH(I,MED)
7299C--antifermion --> antifermion fermion fermion
7300 ELSEIF(DRTYPE(I).EQ.17) THEN
7301 CALL HWD3MI(I,MED)
7302C--error not known
7303 ELSE
7304 CALL HWWARN('HWD3M0',501)
7305 ENDIF
7306C--add up the matrix elements
7307 DO 10 P0=1,2
7308 DO 10 P1=1,2
7309 DO 10 P2=1,2
7310 DO 10 P3=1,2
7311 10 ME(P0,P1,P2,P3,DRCF(I)) = ME(P0,P1,P2,P3,DRCF(I))
7312 & +MED(P0,P1,P2,P3)
7313 9 CONTINUE
7314C--preform the final normalisation
7315 DO 15 P0=1,2
7316 DO 15 P1=1,2
7317 DO 15 P2=1,2
7318 DO 15 P3=1,2
7319 DO 15 I =1,NCTHRE
7320 15 ME(P0,P1,P2,P3,I) = PRE*ME(P0,P1,P2,P3,I)
7321C--compute the unnormalised spin density matrix
7322 DO 35 P0 =1,2
7323 DO 35 P0P=1,2
7324 RHOB(P0,P0P) = (0.0D0,0.0D0)
7325 DO 35 P1=1,2
7326 DO 35 P2=1,2
7327 DO 35 P3=1,2
7328 DO 35 I =1,NCTHRE
7329 DO 35 J =1,NCTHRE
7330 35 RHOB(P0,P0P)=RHOB(P0,P0P)+CFTHRE(I,J)*ME(P0,P1,P2,P3,I)*
7331 & DCONJG(ME(P0P,P1,P2,P3,J))
7332C--compute the weight
7333 WGT = ZERO
7334 DO 45 P0=1,2
7335 DO 45 P0P=1,2
7336 45 WGT = WGT+DREAL(RHOIN(P0,P0P)*RHOB(P0,P0P))
7337C--normalise this for phase space
7338 WGT = WGT*PHS
7339C--if initialising select the max weight
7340 IF(SYSPIN.OR.THREEB)
7341 & MWGT = PHS*(MAX(DBLE(RHOB(1,1)),DBLE(RHOB(2,2)))
7342 & +ABS(DBLE(RHOB(1,2)))+ABS(DIMAG(RHOB(1,2))))
7343C--if generating the event put the information in the common block
7344 IF(GENEV) THEN
7345C--put the matrix element into the spin common block
7346 IF(SYSPIN) THEN
7347 DO 25 P0=1,2
7348 DO 25 P1=1,2
7349 DO 25 P2=1,2
7350 DO 25 P3=1,2
7351 DO 25 I =1,NCTHRE
7352 25 MESPN(P0,P1,P2,P3,I,IDSPIN) = ME(P0,P1,P2,P3,I)
7353 NCFL(IDSPIN) = NCTHRE
7354 ENDIF
7355C--if more than one colour flow pick the flow
7356 IF(SPCOPT.EQ.2.AND.NCTHRE.NE.1) THEN
7357C--contstruct the matrix elements for the colour flows
7358 WGTC = ZERO
7359 DO 50 I=1,NCTHRE
7360 WGTB(I) = ZERO
7361 DO 55 P0=1,2
7362 DO 55 P0P=1,2
7363 DO 55 P1=1,2
7364 DO 55 P2=1,2
7365 DO 55 P3=1,2
7366 55 WGTB(I) = WGTB(I)+CFTHRE(I,I)*DREAL(
7367 & RHOIN(P0,P0P)*ME(P0 ,P1,P2,P3,I)*DCONJG(ME(P0P,P1,P2,P3,I)))
7368 WGTB(I) = WGTB(I)*PHS
7369 50 WGTC = WGTC+WGTB(I)
7370 WGTC = WGT/WGTC
7371 DO 60 I=1,NCTHRE
7372 60 WGTB(I) = WGTB(I)*WGTC
7373C--select the colour flow
7374 WGTC = HWRGEN(1)*WGT
7375 DO 70 I=1,NCTHRE
7376 IF(WGTB(I).GE.WGTC) THEN
7377 NCFL(IDSPIN) = I
7378 RETURN
7379 ENDIF
7380 70 WGTC = WGTC-WGTB(I)
7381C--otherwise if wrong options set issue warning
7382 ELSEIF(NCTHRE.NE.1) THEN
7383 WRITE(6,1000)
7384 CALL HWWARN('HWD3M0',500)
7385 ENDIF
7386 ENDIF
7387 1000 FORMAT(/'MULTIPLE COLOUR FLOWS IN DECAY'/'SPCOPT=2 MUST BE USED')
7388 END
7389CDECK ID>, HWD3M1.
7390*CMZ :- -10/10/01 14:34:54 by Peter Richardson
7391*-- Author : Peter Richardson
7392C-----------------------------------------------------------------------
7393 SUBROUTINE HWD3M1(ID,ME)
7394C-----------------------------------------------------------------------
7395C Subroutine to calculate the helicity amplitudes for the three body
7396C gauge boson exchange diagram
7397C-----------------------------------------------------------------------
c63d70bc 7398 INCLUDE 'herwig65.inc'
65767955 7399 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7400 & F0M(2,2,8),F2(2,2,8),PRE,C(2,2),E(2,2),ZI,APP(2,2),APM(2,2),
7401 & AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8)
7402 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,
7403 & MR,P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7404 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7405 & DRCF(NDIAGR)
7406 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7407 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7408 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7409 PARAMETER(ZI=(0.0D0,1.0D0))
7410 COMMON/HWHEWS/S(8,8,2),D(8,8)
7411 SAVE O
7412 DATA O/2,1/
7413C--compute the propagator factor
7414 PRE = -0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7415 CN = -ONE/MS(ID)
7416C--compute the C and D functions
7417 DO 10 P1=1,2
7418 DO 10 P2=1,2
7419 IF(P1.EQ.P2) THEN
7420C--the A functions
7421 APP(P1,P2) = B( P2 ,ID)*S(7,3,O(P1))*S(4,8, P1 )
7422 APM(P1,P2) = 0.0D0
7423 AMP(P1,P2) = 0.0D0
7424 AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4)
7425C--the C and E functions
7426 C(P1,P2) = A( P1 ,ID)*( MA2(1)*S(6,2,O(P2))*S(2,5, P2 )
7427 & -MA2(2)*S(6,1,O(P2))*S(1,5, P2 ))
7428 & +A(O(P1),ID)*MA(1)*MA(2)*( S(6,1,O(P2))*S(1,5, P2 )
7429 & -S(6,2,O(P2))*S(2,5, P2 ))
7430 E(P1,P2) =CN*(B( P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8, P1 )
7431 & +MA2(4)*S(7,3,O(P1))*S(3,8, P1 ))
7432 & -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8, P1 )
7433 & +S(7,4,O(P1))*S(4,8, P1 )))
7434 ELSE
7435C--the A functions
7436 APP(P1,P2) = 0.0D0
7437 APM(P1,P2) = B( P2 ,ID)*MA(3)*S(4,8,O(P1))
7438 AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1))
7439 AMM(P1,P2) = 0.0D0
7440C--the C and D functions
7441 C(P1,P2) = A( P1 ,ID)*MA(2)*( MA2(1)*S(6,5,O(P2))
7442 & -S(6,2,O(P2))*S(2,1, P2 )*S(1,5,O(P2)))
7443 & +A(O(P1),ID)*MA(1)*(-MA2(2)*S(6,5,O(P2))
7444 & +S(6,2,O(P2))*S(2,1, P2 )*S(1,5,O(P2)))
7445 E(P1,P2) =CN*( B( P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1))
7446 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1)))
7447 & -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1))
7448 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1))))
7449 ENDIF
7450 10 CONTINUE
7451C--compute the matrix element
7452 DO 20 P0=1,2
7453 DO 20 P1=1,2
7454 DO 20 P2=1,2
7455 DO 20 P3=1,2
7456 ME(P0,P1,P2,P3) =
7457 & APP(P2,P3)*( A(O(P2),ID)*F1(O(P1), P2 ,4)*F0( P2 ,O(P0),3)
7458 & +A( P2 ,ID)*F1(O(P1),O(P2),3)*F0(O(P2),O(P0),4))
7459 & +APM(P2,P3)*( A( P2 ,ID)*F1(O(P1),O(P2),4)*F0(O(P2),O(P0),7)
7460 & +A(O(P2),ID)*F1(O(P1), P2 ,7)*F0( P2 ,O(P0),4))
7461 & +AMP(P2,P3)*( A(O(P2),ID)*F1(O(P1), P2 ,8)*F0( P2 ,O(P0),3)
7462 & +A( P2 ,ID)*F1(O(P1),O(P2),3)*F0(O(P2),O(P0),8))
7463 & +AMM(P2,P3)*( A( P2 ,ID)*F1(O(P1),O(P2),8)*F0(O(P2),O(P0),7)
7464 & +A(O(P2),ID)*F1(O(P1), P2 ,7)*F0( P2 ,O(P0),8))
7465 20 ME(P0,P1,P2,P3) =PRE*(TWO*ME(P0,P1,P2,P3)+C(P0,P1)*E(P2,P3))
7466 END
7467CDECK ID>, HWD3M2.
7468*CMZ :- -10/10/01 14:34:54 by Peter Richardson
7469*-- Author : Peter Richardson
7470C-----------------------------------------------------------------------
7471 SUBROUTINE HWD3M2(ID,ME)
7472C-----------------------------------------------------------------------
7473C Subroutine to calculate the helicity amplitudes for the three body
7474C Higgs boson exchange diagram
7475C-----------------------------------------------------------------------
c63d70bc 7476 INCLUDE 'herwig65.inc'
65767955 7477 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7478 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7479 & F3(2,2,8)
7480 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7481 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7482 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7483 & DRCF(NDIAGR)
7484 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7485 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7486 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7487 COMMON/HWHEWS/S(8,8,2),D(8,8)
7488 PARAMETER(ZI=(0.0D0,1.0D0))
7489 SAVE O
7490 DATA O/2,1/
7491C--decide whether to do the diagram
7492 IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4).AND.
7493 & IDP(4+ID).NE.206) THEN
7494 DO 5 P0=1,2
7495 DO 5 P1=1,2
7496 DO 5 P2=1,2
7497 DO 5 P3=1,2
7498 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7499 RETURN
7500 ENDIF
7501C--calculate the propagator factor
7502 PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7503C--calculate the vertex functions
7504 DO 10 P1=1,2
7505 DO 10 P2=1,2
7506 V1(P1,P2) = PRE*( A( P1 ,ID)*F1(O(P2), P1 ,1)*S(1,5,P1)
7507 & +A(O(P1),ID)*F1(O(P2),O(P1),5)*MA(1))
7508 10 V2(P1,P2) = B( P2 ,ID)*F2(O(P1), P2 ,4)*S(4,8,P2)
7509 & -B(O(P2),ID)*F2(O(P1),O(P2),8)*MA(4)
7510C--calculate the matrix element
7511 DO 20 P0=1,2
7512 DO 20 P1=1,2
7513 DO 20 P2=1,2
7514 DO 20 P3=1,2
7515 20 ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
7516 END
7517CDECK ID>, HWD3M3.
7518*CMZ :- -10/10/01 14:34:54 by Peter Richardson
7519*-- Author : Peter Richardson
7520C-----------------------------------------------------------------------
7521 SUBROUTINE HWD3M3(ID,ME)
7522C-----------------------------------------------------------------------
7523C Subroutine to calculate the helicity amplitudes for the three body
7524C antisfermion exchange diagram
7525C-----------------------------------------------------------------------
c63d70bc 7526 INCLUDE 'herwig65.inc'
65767955 7527 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7528 & F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
7529 & F3(2,2,8)
7530 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7531 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7532 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7533 & DRCF(NDIAGR)
7534 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7535 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7536 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7537 COMMON/HWHEWS/S(8,8,2),D(8,8)
7538 PARAMETER(ZI=(0.0D0,1.0D0))
7539 SAVE O
7540 DATA O/2,1/
7541C--decide whether to do the diagram
7542 IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
7543 DO 5 P0=1,2
7544 DO 5 P1=1,2
7545 DO 5 P2=1,2
7546 DO 5 P3=1,2
7547 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7548 RETURN
7549 ENDIF
7550C--compute the propagator factor
7551 PRE = -0.25D0/(M242-MS(ID)+ZI*MWD(ID))
7552C--compute the vertex factors
7553 DO 10 P1=1,2
7554 DO 10 P2=1,2
7555 V1(P1,P2) = PRE*( A( P1 ,ID)*F2(O(P2), P1 ,1)*S(1,5,P1)
7556 & +A(O(P1),ID)*F2(O(P2),O(P1),5)*MA(1))
7557 10 V2(P1,P2) = B( P2 ,ID)*F1(O(P1), P2 ,4)*S(4,8,P2)
7558 & -B(O(P2),ID)*F1(O(P1),O(P2),8)*MA(4)
7559C--compute the matrix element
7560 DO 20 P0=1,2
7561 DO 20 P1=1,2
7562 DO 20 P2=1,2
7563 DO 20 P3=1,2
7564 20 ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
7565 END
7566CDECK ID>, HWD3M4.
7567*CMZ :- -10/10/01 14:34:54 by Peter Richardson
7568*-- Author : Peter Richardson
7569C-----------------------------------------------------------------------
7570 SUBROUTINE HWD3M4(ID,ME)
7571C-----------------------------------------------------------------------
7572C Subroutine to calculate the helicity amplitudes for the three body
7573C sfermion exchange diagram
7574C-----------------------------------------------------------------------
c63d70bc 7575 INCLUDE 'herwig65.inc'
65767955 7576 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7577 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7578 & F3(2,2,8)
7579 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7580 &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7581 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7582 & DRCF(NDIAGR)
7583 COMMON/HWHEWS/S(8,8,2),D(8,8)
7584 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7585 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7586 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7587 PARAMETER(ZI=(0.0D0,1.0D0))
7588 SAVE O
7589 DATA O/2,1/
7590C--decide whether to do the diagram
7591 IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
7592 DO 5 P0=1,2
7593 DO 5 P1=1,2
7594 DO 5 P2=1,2
7595 DO 5 P3=1,2
7596 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7597 RETURN
7598 ENDIF
7599C--compute the propagator factor
7600 PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID))
7601C--compute the factors for the two vertices
7602 DO 10 P1=1,2
7603 DO 10 P2=1,2
7604 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,4)*S(4,8, P2 )
7605 & -A(O(P2),ID)*F0M( P1 ,O(P2),8)*MA(4))
7606 10 V2(P1,P2) = B(O(P1),ID)*F2 (O(P2),O(P1),2)*S(2,6,O(P1))
7607 & -B( P1 ,ID)*F2 (O(P2), P1 ,6)*MA(2)
7608C--now compute the matrix element
7609 DO 20 P0=1,2
7610 DO 20 P1=1,2
7611 DO 20 P2=1,2
7612 DO 20 P3=1,2
7613 20 ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
7614 END
7615CDECK ID>, HWD3M5.
7616*CMZ :- -10/10/01 14:34:54 by Peter Richardson
7617*-- Author : Peter Richardson
7618C-----------------------------------------------------------------------
7619 SUBROUTINE HWD3M5(ID,ME)
7620C-----------------------------------------------------------------------
7621C Subroutine to calculate the helicity amplitudes for the three body
7622C gauge boson exchange diagram (antiparticle decay)
7623C-----------------------------------------------------------------------
c63d70bc 7624 INCLUDE 'herwig65.inc'
65767955 7625 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),
7626 & F0M(2,2,8),F2(2,2,8),PRE,C(2,2),E(2,2),ZI,APP(2,2),APM(2,2),
7627 & AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8),F01(2,2,8,8)
7628 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,MR,
7629 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7630 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7631 & DRCF(NDIAGR)
7632 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7633 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7634 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7635 PARAMETER(ZI=(0.0D0,1.0D0))
7636 COMMON/HWHEWS/S(8,8,2),D(8,8)
7637 SAVE O
7638 DATA O/2,1/
7639C--compute the propagator factor
7640 PRE = -0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7641 CN = -ONE/MS(ID)
7642C--compute the C and D functions
7643 DO 10 P1=1,2
7644 DO 10 P2=1,2
7645 IF(P1.EQ.P2) THEN
7646C--the A functions
7647 APP(P1,P2) = B( P2 ,ID)*S(7,3,O(P1))*S(4,8, P1 )
7648 APM(P1,P2) = 0.0D0
7649 AMP(P1,P2) = 0.0D0
7650 AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4)
7651C--the C and E functions
7652 C(P1,P2) = A( P2 ,ID)*( MA2(1)*S(5,2,O(P1))*S(2,6, P1 )
7653 & -MA2(2)*S(5,1,O(P1))*S(1,6, P1 ))
7654 & +A(O(P2),ID)*MA(1)*MA(2)*( S(5,1,O(P1))*S(1,6, P1 )
7655 & -S(5,2,O(P1))*S(2,6, P1 ))
7656 E(P1,P2) =CN*(B( P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8, P1 )
7657 & +MA2(4)*S(7,3,O(P1))*S(3,8, P1 ))
7658 & -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8, P1 )
7659 & +S(7,4,O(P1))*S(4,8, P1 )))
7660 ELSE
7661C--the A functions
7662 APP(P1,P2) = 0.0D0
7663 APM(P1,P2) = B( P2 ,ID)*MA(3)*S(4,8,O(P1))
7664 AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1))
7665 AMM(P1,P2) = 0.0D0
7666C--the C and D functions
7667 C(P1,P2) = A( P2 ,ID)*MA(1)*( MA2(2)*S(5,6,O(P1))
7668 & -S(5,1,O(P1))*S(1,2, P1 )*S(2,6,O(P1)))
7669 & +A(O(P2),ID)*MA(2)*(-MA2(1)*S(5,6,O(P1))
7670 & +S(5,1,O(P1))*S(1,2, P1 )*S(2,6,O(P1)))
7671 E(P1,P2) =CN*( B( P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1))
7672 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1)))
7673 & -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1))
7674 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1))))
7675 ENDIF
7676 10 CONTINUE
7677C--compute the matrix element
7678 DO 20 P0=1,2
7679 DO 20 P1=1,2
7680 DO 20 P2=1,2
7681 DO 20 P3=1,2
7682 ME(P0,P1,P2,P3) =
7683 & APP(P2,P3)*( A(O(P2),ID)*F0M(O(P0), P2 ,4)*F1M( P2 ,O(P1),3)
7684 & +A( P2 ,ID)*F0M(O(P0),O(P2),3)*F1M(O(P2),O(P1),4))
7685 & +APM(P2,P3)*( A( P2 ,ID)*F0M(O(P0),O(P2),4)*F1M(O(P2),O(P1),7)
7686 & +A(O(P2),ID)*F0M(O(P0), P2 ,7)*F1M( P2 ,O(P1),4))
7687 & +AMP(P2,P3)*( A(O(P2),ID)*F0M(O(P0), P2 ,8)*F1M( P2 ,O(P1),3)
7688 & +A( P2 ,ID)*F0M(O(P0),O(P2),3)*F1M(O(P2),O(P1),8))
7689 & +AMM(P2,P3)*( A( P2 ,ID)*F0M(O(P0),O(P2),8)*F1M(O(P2),O(P1),7)
7690 & +A(O(P2),ID)*F0M(O(P0), P2 ,7)*F1M( P2 ,O(P1),8))
7691 20 ME(P0,P1,P2,P3) =PRE*(TWO*ME(P0,P1,P2,P3)+C(P0,P1)*E(P2,P3))
7692 END
7693CDECK ID>, HWD3M6.
7694*CMZ :- -10/10/01 14:34:54 by Peter Richardson
7695*-- Author : Peter Richardson
7696C-----------------------------------------------------------------------
7697 SUBROUTINE HWD3M6(ID,ME)
7698C-----------------------------------------------------------------------
7699C Subroutine to calculate the helicity amplitudes for the three body
7700C gauge boson exchange diagram
7701C-----------------------------------------------------------------------
c63d70bc 7702 INCLUDE 'herwig65.inc'
65767955 7703 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),
7704 & F0M(2,2,8),F2(2,2,8),PRE,C(2,2),ZI,APP(2,2),APM(2,2),
7705 & AMP(2,2),AMM(2,2),F1M(2,2,8),F3(2,2,8),F01(2,2,8,8)
7706 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,CN,MR,
7707 & P(5,4),DOT,HWULDO,PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7708 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7709 & DRCF(NDIAGR)
7710 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7711 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7712 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7713 DOUBLE PRECISION XMASS,PLAB,PRW,PCM
7714 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
7715 PARAMETER(ZI=(0.0D0,1.0D0))
7716 COMMON/HWHEWS/S(8,8,2),D(8,8)
7717 EXTERNAL HWULDO
7718 SAVE O
7719 DATA O/2,1/
7720C--compute the propagator factor
7721 PRE = SQRT(HWULDO(PCM(1,5),PM(1,1))*HWULDO(PCM(1,6),PM(1,2)))
7722 PRE = -HALF*PRE*A(1,ID)/(M342-MS(ID)+ZI*MWD(ID))
7723 CN = -ONE/MS(ID)
7724 DOT = HWULDO(P(1,1),P(1,3))+HWULDO(P(1,1),P(1,4))
7725 & +HWULDO(P(1,2),P(1,3))+HWULDO(P(1,2),P(1,4))
7726C--compute the C and D functions
7727 DO 10 P1=1,2
7728 DO 10 P2=1,2
7729 IF(P1.EQ.P2) THEN
7730C--the A functions
7731 APP(P1,P2) = B( P2 ,ID)*S(7,3,O(P1))*S(4,8, P1 )
7732 APM(P1,P2) = 0.0D0
7733 AMP(P1,P2) = 0.0D0
7734 AMM(P1,P2) = -B(O(P2),ID)*MA(3)*MA(4)
7735C--the C function
7736 C(P1,P2) =CN*(B( P2 ,ID)*( MA2(3)*S(7,4,O(P1))*S(4,8, P1 )
7737 & +MA2(4)*S(7,3,O(P1))*S(3,8, P1 ))
7738 & -B(O(P2),ID)*MA(3)*MA(4)*( S(7,3,O(P1))*S(3,8, P1 )
7739 & +S(7,4,O(P1))*S(4,8, P1 )))
7740 ELSE
7741C--the A functions
7742 APP(P1,P2) = 0.0D0
7743 APM(P1,P2) = B( P2 ,ID)*MA(3)*S(4,8,O(P1))
7744 AMP(P1,P2) =-B(O(P2),ID)*MA(4)*S(7,3,O(P1))
7745 AMM(P1,P2) = 0.0D0
7746C--the C functions
7747 C(P1,P2) =CN*( B( P2 ,ID)*MA(3)*( MA2(4)*S(7,8,O(P1))
7748 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1)))
7749 & -B(O(P2),ID)*MA(4)*( MA2(3)*S(7,8,O(P1))
7750 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1))))
7751 ENDIF
7752 10 CONTINUE
7753C--compute the matrix element
7754 DO 15 P0=1,2
7755 DO 15 P1=1,2
7756 DO 15 P2=1,2
7757 DO 15 P3=1,2
7758 15 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7759 DO 20 P2=1,2
7760 DO 20 P3=1,2
7761 20 ME(1,1,P2,P3) = PRE*(DOT*C(P2,P3)
7762 & +APP(P2,P3)*F01( P2 , P2 ,3,4)+APM(P2,P3)*F01(O(P2),O(P2),7,4)
7763 & +AMP(P2,P3)*F01( P2 , P2 ,3,8)+AMM(P2,P3)*F01(O(P2),O(P2),7,8))
7764 END
7765CDECK ID>, HWD3M7.
7766*CMZ :- -13/03/02 14:19:47 by Peter Richardson
7767*-- Author : Peter Richardson
7768C-----------------------------------------------------------------------
7769 SUBROUTINE HWD3M7(ID,ME)
7770C-----------------------------------------------------------------------
7771C Subroutine to calculate the helicity amplitudes for the three body
7772C decay fermion --> gravitino fermion antifermion (via gauge boson)
7773C-----------------------------------------------------------------------
c63d70bc 7774 INCLUDE 'herwig65.inc'
65767955 7775 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7776 & F0M(2,2,8),F2(2,2,8),PRE,ZI,F1M(2,2,8),F3(2,2,8)
7777 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7778 &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX),HWULDO,DL(2,2)
7779 INTEGER P0,P1,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7780 & DRCF(NDIAGR)
7781 COMMON/HWHEWS/S(8,8,2),D(8,8)
7782 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7783 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7784 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7785 PARAMETER(ZI=(0.0D0,1.0D0))
7786 DOUBLE PRECISION XMASS,PLAB,PRW,PCM
7787 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
7788 EXTERNAL HWULDO
7789 SAVE O,DL
7790 DATA O/2,1/
7791 DATA DL/1.0D0,0.0D0,0.0D0,1.0D0/
7792C--compute the propagator factor
7793 PRE = HALF*HWULDO(PCM(1,6),PM(1,2))*
7794 & HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4))
7795 PRE = SQRT(PRE)
7796 PRE = PRE/(M342-MS(ID)+ZI*MWD(ID))
7797 DO 10 P0=1,2
7798 DO 10 P1=1,2
7799 ME(P0,P1, P1 , P1 ) = PRE*B( P1 ,ID)*(
7800 & A(1,ID)*S(2,3,P1)*S(3,4,O(P1))*S(3,2, P1 )*F0(O(P1),O(P0),2)
7801 & +A(2,ID)* DL(P1,1)*S(2,3, P1 )*S(4,2,O(P1))*F0( 1 ,O(P0),2))
7802 ME(P0,P1,O(P1),O(P1)) = PRE*B(O(P1),ID)*(
7803 & A(1,ID)*S(2,4,P1)*S(4,3,O(P1))*S(4,2, P1 )*F0(O(P1),O(P0),2)
7804 & +A(2,ID)* DL(P1,1)*S(2,4, P1 )*S(3,2,O(P1))*F0( 1 ,O(P0),2))
7805 ME(P0,P1,O(P1), P1 ) = (0.0D0,0.0D0)
7806 10 ME(P0,P1, P1 ,O(P1)) = (0.0D0,0.0D0)
7807 END
7808CDECK ID>, HWD3M8.
7809*CMZ :- -08/04/02 14:48:42 by Peter Richardson
7810*-- Author : Peter Richardson
7811C-----------------------------------------------------------------------
7812 SUBROUTINE HWD3M8(ID,ME)
7813C-----------------------------------------------------------------------
7814C Subroutine to calculate the helicity amplitudes for 1st 3 body RPV
7815C diagram f--> fbar fbar f
7816C-----------------------------------------------------------------------
c63d70bc 7817 INCLUDE 'herwig65.inc'
65767955 7818 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7819 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7820 & F3(2,2,8)
7821 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7822 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7823 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7824 & DRCF(NDIAGR)
7825 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7826 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7827 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7828 COMMON/HWHEWS/S(8,8,2),D(8,8)
7829 PARAMETER(ZI=(0.0D0,1.0D0))
7830 SAVE O
7831 DATA O/2,1/
7832C--decide whether to do the diagram
7833 IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN
7834 DO 5 P0=1,2
7835 DO 5 P1=1,2
7836 DO 5 P2=1,2
7837 DO 5 P3=1,2
7838 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7839 RETURN
7840 ENDIF
7841C--calculate the propagator factor
7842 PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7843C--calculate the vertex functions
7844 DO 10 P1=1,2
7845 DO 10 P2=1,2
7846 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,2)*S(2,6, P2)
7847 & -A(O(P2),ID)*F0M( P1 ,O(P2),6)*MA(2))
7848 10 V2(P1,P2) = B( P1 ,ID)*F3 (O(P2), P1 ,3)*S(3,7,P1)
7849 & -B(O(P1),ID)*F3 (O(P2),O(P1),7)*MA(3)
7850C--calculate the matrix element
7851 DO 20 P0=1,2
7852 DO 20 P1=1,2
7853 DO 20 P2=1,2
7854 DO 20 P3=1,2
7855 20 ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
7856 END
7857CDECK ID>, HWD3M9.
7858*CMZ :- -08/04/02 14:48:42 by Peter Richardson
7859*-- Author : Peter Richardson
7860C-----------------------------------------------------------------------
7861 SUBROUTINE HWD3M9(ID,ME)
7862C-----------------------------------------------------------------------
7863C Subroutine to calculate the helicity amplitudes for 2nd 3 body RPV
7864C diagram f --> fbar fbar f
7865C-----------------------------------------------------------------------
c63d70bc 7866 INCLUDE 'herwig65.inc'
65767955 7867 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7868 & F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
7869 & F3(2,2,8)
7870 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7871 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7872 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7873 & DRCF(NDIAGR)
7874 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7875 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7876 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7877 COMMON/HWHEWS/S(8,8,2),D(8,8)
7878 PARAMETER(ZI=(0.0D0,1.0D0))
7879 SAVE O
7880 DATA O/2,1/
7881C--decide whether to do the diagram
7882 IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
7883 DO 5 P0=1,2
7884 DO 5 P1=1,2
7885 DO 5 P2=1,2
7886 DO 5 P3=1,2
7887 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7888 RETURN
7889 ENDIF
7890C--compute the propagator factor
7891 PRE = -0.25D0/(M242-MS(ID)+ZI*MWD(ID))
7892C--compute the vertex factors
7893 DO 10 P1=1,2
7894 DO 10 P2=1,2
7895 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,3)*S(3,7,P2)
7896 & -A(O(P2),ID)*F0M( P1 ,O(P2),7)*MA(3))
7897 10 V2(P1,P2) = B( P1 ,ID)*F3 (O(P2), P1 ,2)*S(2,6,P1)
7898 & -B(O(P1),ID)*F3 (O(P2),O(P1),6)*MA(2)
7899C--compute the matrix element
7900 DO 20 P0=1,2
7901 DO 20 P1=1,2
7902 DO 20 P2=1,2
7903 DO 20 P3=1,2
7904 20 ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
7905 END
7906CDECK ID>, HWD3MA.
7907*CMZ :- -08/04/02 14:48:42 by Peter Richardson
7908*-- Author : Peter Richardson
7909C-----------------------------------------------------------------------
7910 SUBROUTINE HWD3MA(ID,ME)
7911C-----------------------------------------------------------------------
7912C Subroutine to calculate the helicity amplitudes for 3rd 3 body RPV
7913C diagram f --> fbar fbar f
7914C-----------------------------------------------------------------------
c63d70bc 7915 INCLUDE 'herwig65.inc'
65767955 7916 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7917 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7918 & F3(2,2,8)
7919 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7920 &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7921 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7922 & DRCF(NDIAGR)
7923 COMMON/HWHEWS/S(8,8,2),D(8,8)
7924 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7925 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7926 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7927 PARAMETER(ZI=(0.0D0,1.0D0))
7928 SAVE O
7929 DATA O/2,1/
7930C--decide whether to do the diagram
7931 IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
7932 DO 5 P0=1,2
7933 DO 5 P1=1,2
7934 DO 5 P2=1,2
7935 DO 5 P3=1,2
7936 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7937 RETURN
7938 ENDIF
7939C--compute the propagator factor
7940 PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID))
7941C--compute the factors for the two vertices
7942 DO 10 P1=1,2
7943 DO 10 P2=1,2
7944 V1(P1,P2) = PRE*( A( P1 ,ID)*F3(O(P2), P1 ,1)*S(1,5,P1)
7945 & +A(O(P1),ID)*F3(O(P2),O(P1),5)*MA(1))
7946 10 V2(P1,P2) = B( P2 ,ID)*F1( P1 , P2 ,3)*S(3,7,P2)
7947 & -B(O(P2),ID)*F1( P1 ,O(P2),7)*MA(3)
7948C--now compute the matrix element
7949 DO 20 P0=1,2
7950 DO 20 P1=1,2
7951 DO 20 P2=1,2
7952 DO 20 P3=1,2
7953 20 ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
7954 END
7955CDECK ID>, HWD3MB.
7956*CMZ :- -08/04/02 14:48:42 by Peter Richardson
7957*-- Author : Peter Richardson
7958C-----------------------------------------------------------------------
7959 SUBROUTINE HWD3MB(ID,ME)
7960C-----------------------------------------------------------------------
7961C Subroutine to calculate the helicity amplitudes for 4th 3 body RPV
7962C diagram f --> f f f
7963C-----------------------------------------------------------------------
c63d70bc 7964 INCLUDE 'herwig65.inc'
65767955 7965 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
7966 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
7967 & F3(2,2,8)
7968 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
7969 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
7970 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
7971 & DRCF(NDIAGR)
7972 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
7973 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
7974 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
7975 COMMON/HWHEWS/S(8,8,2),D(8,8)
7976 PARAMETER(ZI=(0.0D0,1.0D0))
7977 SAVE O
7978 DATA O/2,1/
7979C--decide whether to do the diagram
7980 IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN
7981 DO 5 P0=1,2
7982 DO 5 P1=1,2
7983 DO 5 P2=1,2
7984 DO 5 P3=1,2
7985 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
7986 RETURN
7987 ENDIF
7988C--calculate the propagator factor
7989 PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
7990C--calculate the vertex functions
7991 DO 10 P1=1,2
7992 DO 10 P2=1,2
7993 V1(P1,P2) = PRE*( A( P1 ,ID)*F1(O(P2), P1 ,1)*S(1,5,P1)
7994 & +A(O(P1),ID)*F1(O(P2),O(P1),5)*MA(1))
7995 10 V2(P1,P2) = B(O(P2),ID)*F2(O(P1),O(P2),4)*S(4,8,O(P2))
7996 & -B( P2 ,ID)*F2(O(P1), P2 ,8)*MA(4)
7997C--calculate the matrix element
7998 DO 20 P0=1,2
7999 DO 20 P1=1,2
8000 DO 20 P2=1,2
8001 DO 20 P3=1,2
8002 20 ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
8003 END
8004CDECK ID>, HWD3MC.
8005*CMZ :- -08/04/02 14:48:42 by Peter Richardson
8006*-- Author : Peter Richardson
8007C-----------------------------------------------------------------------
8008 SUBROUTINE HWD3MC(ID,ME)
8009C-----------------------------------------------------------------------
8010C Subroutine to calculate the helicity amplitudes for 5th 3 body RPV
8011C diagram f --> f f f
8012C-----------------------------------------------------------------------
c63d70bc 8013 INCLUDE 'herwig65.inc'
65767955 8014 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8015 & F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
8016 & F3(2,2,8)
8017 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8018 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8019 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8020 & DRCF(NDIAGR)
8021 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8022 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8023 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8024 COMMON/HWHEWS/S(8,8,2),D(8,8)
8025 PARAMETER(ZI=(0.0D0,1.0D0))
8026 SAVE O
8027 DATA O/2,1/
8028C--decide whether to do the diagram
8029 IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
8030 DO 5 P0=1,2
8031 DO 5 P1=1,2
8032 DO 5 P2=1,2
8033 DO 5 P3=1,2
8034 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8035 RETURN
8036 ENDIF
8037C--compute the propagator factor
8038 PRE =-0.25D0/(M242-MS(ID)+ZI*MWD(ID))
8039C--compute the vertex factors
8040 DO 10 P1=1,2
8041 DO 10 P2=1,2
8042 V1(P1,P2) = PRE*( A( P1 ,ID)*F2(O(P2), P1 ,1)*S(1,5,P1)
8043 & +A(O(P1),ID)*F2(O(P2),O(P1),5)*MA(1))
8044 10 V2(P1,P2) = B(O(P2),ID)*F1(O(P1),O(P2),4)*S(4,8,O(P2))
8045 & -B( P2 ,ID)*F1(O(P1), P2 ,8)*MA(4)
8046C--compute the matrix element
8047 DO 20 P0=1,2
8048 DO 20 P1=1,2
8049 DO 20 P2=1,2
8050 DO 20 P3=1,2
8051 20 ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
8052 END
8053CDECK ID>, HWD3MD.
8054*CMZ :- -08/04/02 14:48:42 by Peter Richardson
8055*-- Author : Peter Richardson
8056C-----------------------------------------------------------------------
8057 SUBROUTINE HWD3MD(ID,ME)
8058C-----------------------------------------------------------------------
8059C Subroutine to calculate the helicity amplitudes for 6th 3 body RPV
8060C diagram f --> f f f
8061C-----------------------------------------------------------------------
c63d70bc 8062 INCLUDE 'herwig65.inc'
65767955 8063 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8064 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
8065 & F3(2,2,8)
8066 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8067 &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8068 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8069 & DRCF(NDIAGR)
8070 COMMON/HWHEWS/S(8,8,2),D(8,8)
8071 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8072 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8073 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8074 PARAMETER(ZI=(0.0D0,1.0D0))
8075 SAVE O
8076 DATA O/2,1/
8077C--decide whether to do the diagram
8078 IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
8079 DO 5 P0=1,2
8080 DO 5 P1=1,2
8081 DO 5 P2=1,2
8082 DO 5 P3=1,2
8083 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8084 RETURN
8085 ENDIF
8086C--compute the propagator factor
8087 PRE = 0.25D0/(M232-MS(ID)+ZI*MWD(ID))
8088C--compute the factors for the two vertices
8089 DO 10 P1=1,2
8090 DO 10 P2=1,2
8091 V1(P1,P2) = PRE*( A(O(P2),ID)*F0M( P1 ,O(P2),4)*S(4,8,O(P2))
8092 & -A( P2 ,ID)*F0M( P1 , P2 ,8)*MA(4))
8093 10 V2(P1,P2) = B(O(P1),ID)*F2 (O(P2),O(P1),2)*S(2,6,O(P1))
8094 & -B( P1 ,ID)*F2 (O(P2), P1 ,6)*MA(2)
8095C--now compute the matrix element
8096 DO 20 P0=1,2
8097 DO 20 P1=1,2
8098 DO 20 P2=1,2
8099 DO 20 P3=1,2
8100 20 ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
8101 END
8102CDECK ID>, HWD3MF.
8103*CMZ :- -08/04/02 14:48:42 by Peter Richardson
8104*-- Author : Peter Richardson
8105C-----------------------------------------------------------------------
8106 SUBROUTINE HWD3MF(ID,ME)
8107C-----------------------------------------------------------------------
8108C Subroutine to calculate the helicity amplitudes for 7th 3 body RPV
8109C diagram f --> fbar fbar fbar
8110C-----------------------------------------------------------------------
c63d70bc 8111 INCLUDE 'herwig65.inc'
65767955 8112 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8113 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
8114 & F3(2,2,8)
8115 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8116 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8117 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8118 & DRCF(NDIAGR)
8119 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8120 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8121 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8122 COMMON/HWHEWS/S(8,8,2),D(8,8)
8123 PARAMETER(ZI=(0.0D0,1.0D0))
8124 SAVE O
8125 DATA O/2,1/
8126C--decide whether to do the diagram
8127 IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4)) THEN
8128 DO 5 P0=1,2
8129 DO 5 P1=1,2
8130 DO 5 P2=1,2
8131 DO 5 P3=1,2
8132 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8133 RETURN
8134 ENDIF
8135C--calculate the propagator factor
8136 PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
8137C--calculate the vertex functions
8138 DO 10 P1=1,2
8139 DO 10 P2=1,2
8140 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,2)*S(2,6,P2)
8141 & -A(O(P2),ID)*F0M( P1 ,O(P2),6)*MA(2))
8142 10 V2(P1,P2) = B( P2 ,ID)*F2( P1 , P2 ,4)*S(4,8,P2)
8143 & -B(O(P2),ID)*F2( P1 ,O(P2),8)*MA(4)
8144C--calculate the matrix element
8145 DO 20 P0=1,2
8146 DO 20 P1=1,2
8147 DO 20 P2=1,2
8148 DO 20 P3=1,2
8149 20 ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
8150 END
8151CDECK ID>, HWD3MG.
8152*CMZ :- -08/04/02 14:48:42 by Peter Richardson
8153*-- Author : Peter Richardson
8154C-----------------------------------------------------------------------
8155 SUBROUTINE HWD3MG(ID,ME)
8156C-----------------------------------------------------------------------
8157C Subroutine to calculate the helicity amplitudes for 8th 3 body RPV
8158C diagram f --> fbar fbar fbar
8159C-----------------------------------------------------------------------
c63d70bc 8160 INCLUDE 'herwig65.inc'
65767955 8161 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8162 & F0M(2,2,8),F2(2,2,8),PRE,V1(2,2),V2(2,2),ZI,F1M(2,2,8),
8163 & F3(2,2,8)
8164 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8165 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8166 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8167 & DRCF(NDIAGR)
8168 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8169 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8170 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8171 COMMON/HWHEWS/S(8,8,2),D(8,8)
8172 PARAMETER(ZI=(0.0D0,1.0D0))
8173 SAVE O
8174 DATA O/2,1/
8175C--decide whether to do the diagram
8176 IF(MB(3)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(4)) THEN
8177 DO 5 P0=1,2
8178 DO 5 P1=1,2
8179 DO 5 P2=1,2
8180 DO 5 P3=1,2
8181 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8182 RETURN
8183 ENDIF
8184C--compute the propagator factor
8185 PRE = 0.25D0/(M242-MS(ID)+ZI*MWD(ID))
8186C--compute the vertex factors
8187 DO 10 P1=1,2
8188 DO 10 P2=1,2
8189 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,3)*S(3,7, P2 )
8190 & -A(O(P2),ID)*F0M( P1 ,O(P2),7)*MA(3))
8191 10 V2(P1,P2) = B( P1 ,ID)*F3 ( P2 , P1 ,2)*S(2,6, P1 )
8192 & -B(O(P1),ID)*F3 ( P2 ,O(P1),6)*MA(2)
8193C--compute the matrix element
8194 DO 20 P0=1,2
8195 DO 20 P1=1,2
8196 DO 20 P2=1,2
8197 DO 20 P3=1,2
8198 20 ME(P0,P1,P2,P3) = V1(P0,P2)*V2(P1,P3)
8199 END
8200CDECK ID>, HWD3MH.
8201*CMZ :- -08/04/02 14:48:42 by Peter Richardson
8202*-- Author : Peter Richardson
8203C-----------------------------------------------------------------------
8204 SUBROUTINE HWD3MH(ID,ME)
8205C-----------------------------------------------------------------------
8206C Subroutine to calculate the helicity amplitudes for 9th 3 body RPV
8207C diagram f --> fbar fbar fbar
8208C-----------------------------------------------------------------------
c63d70bc 8209 INCLUDE 'herwig65.inc'
65767955 8210 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8211 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
8212 & F3(2,2,8)
8213 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8214 &P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8215 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8216 & DRCF(NDIAGR)
8217 COMMON/HWHEWS/S(8,8,2),D(8,8)
8218 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8219 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8220 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8221 PARAMETER(ZI=(0.0D0,1.0D0))
8222 SAVE O
8223 DATA O/2,1/
8224C--decide whether to do the diagram
8225 IF(MB(4)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(2)+MB(3)) THEN
8226 DO 5 P0=1,2
8227 DO 5 P1=1,2
8228 DO 5 P2=1,2
8229 DO 5 P3=1,2
8230 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8231 RETURN
8232 ENDIF
8233C--compute the propagator factor
8234 PRE = -0.25D0/(M232-MS(ID)+ZI*MWD(ID))
8235C--compute the factors for the two vertices
8236 DO 10 P1=1,2
8237 DO 10 P2=1,2
8238 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M( P1 , P2 ,4)*S(4,8,P2)
8239 & -A(O(P2),ID)*F0M( P1 ,O(P2),8)*MA(4))
8240 10 V2(P1,P2) = B( P1 ,ID)*F2 ( P2 , P1 ,2)*S(2,6,P1)
8241 & -B(O(P1),ID)*F2 ( P2 ,O(P1),6)*MA(2)
8242C--now compute the matrix element
8243 DO 20 P0=1,2
8244 DO 20 P1=1,2
8245 DO 20 P2=1,2
8246 DO 20 P3=1,2
8247 20 ME(P0,P1,P2,P3) = V1(P0,P3)*V2(P1,P2)
8248 END
8249CDECK ID>, HWD3MI.
8250*CMZ :- -09/04/02 13:37:38 by Peter Richardson
8251*-- Author : Peter Richardson
8252C-----------------------------------------------------------------------
8253 SUBROUTINE HWD3MI(ID,ME)
8254C-----------------------------------------------------------------------
8255C Subroutine to calculate the helicity amplitudes for the three body
8256C Higgs boson exchange diagram antifermion decay
8257C-----------------------------------------------------------------------
c63d70bc 8258 INCLUDE 'herwig65.inc'
65767955 8259 DOUBLE COMPLEX ME(2,2,2,2),S,D,F0(2,2,8),F1(2,2,8),F01(2,2,8,8),
8260 & F0M(2,2,8),F2(2,2,8),PRE,ZI,V1(2,2),V2(2,2),F1M(2,2,8),
8261 & F3(2,2,8)
8262 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
8263 & P(5,4),PM(5,4),CFTHRE(NCFMAX,NCFMAX)
8264 INTEGER P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),DRTYPE(NDIAGR),NCTHRE,
8265 & DRCF(NDIAGR)
8266 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
8267 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
8268 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
8269 COMMON/HWHEWS/S(8,8,2),D(8,8)
8270 PARAMETER(ZI=(0.0D0,1.0D0))
8271 SAVE O
8272 DATA O/2,1/
8273C--decide whether to do the diagram
8274 IF(MB(2)+MR(ID).LT.MB(1).AND.MR(ID).GT.MB(3)+MB(4).AND.
8275 & IDP(4+ID).NE.207) THEN
8276 DO 5 P0=1,2
8277 DO 5 P1=1,2
8278 DO 5 P2=1,2
8279 DO 5 P3=1,2
8280 5 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8281 RETURN
8282 ENDIF
8283C--calculate the propagator factor
8284 PRE = 0.25D0/(M342-MS(ID)+ZI*MWD(ID))
8285C--calculate the vertex functions
8286 DO 10 P1=1,2
8287 DO 10 P2=1,2
8288 V1(P1,P2) = PRE*( A( P2 ,ID)*F0M(O(P1), P2 ,2)*S(2,6,P2)
8289 & -A(O(P2),ID)*F0M(O(P1),O(P2),6)*MA(2))
8290 10 V2(P1,P2) = B( P2 ,ID)*F2(O(P1), P2 ,4)*S(4,8,P2)
8291 & -B(O(P2),ID)*F2(O(P1),O(P2),8)*MA(4)
8292C--calculate the matrix element
8293 DO 20 P0=1,2
8294 DO 20 P1=1,2
8295 DO 20 P2=1,2
8296 DO 20 P3=1,2
8297 20 ME(P0,P1,P2,P3) = V1(P0,P1)*V2(P2,P3)
8298 END
8299CDECK ID>, HWD4ME.
8300*CMZ :- -20/10/99 09:46:43 by Peter Richardson
8301*-- Author : Peter Richardson
8302C-----------------------------------------------------------------------
8303 SUBROUTINE HWD4ME(ID,ITYPE1,ITYPE2,IMODE)
8304C-----------------------------------------------------------------------
8305C Subroutine to perform the four body Higgs decays
8306C-----------------------------------------------------------------------
c63d70bc 8307 INCLUDE 'herwig65.inc'
65767955 8308 INTEGER IMODE,I,J,ID,IDP(4+NDIAGR),ITYPE(2),NTRY,ITYPE1,ITYPE2
8309 DOUBLE PRECISION A,B,MS,MWD,M,M2,WGT,HWRUNI,BRW(6),BRZ(12),
8310 & HWUPCM,WMAX,WSUM,WSSUM,MR,PRE,TEMP,HWRGEN,WTMAX,P(5,5)
8311 EXTERNAL HWRUNI,HWUPCM,HWRGEN
8312 COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP
8313 SAVE BRW,BRZ
8314 DATA BRW/0.321D0,0.321D0,0.000D0,0.108D0,0.108D0,0.108D0/
8315 DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
8316 & 0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
8317 ITYPE(1) = ITYPE1
8318 ITYPE(2) = ITYPE2
8319 WTMAX = WT4MAX(ITYPE(1),ITYPE(2),IMODE)
8320 PRE=P4MODE(ITYPE(1),ITYPE(2),IMODE)
8321C--compute the masses of external particles for the decay mode
8322 DO I=1,2
8323C--couplings and masses of the internal particles
8324 A(I) = A4MODE(I,ITYPE1,IMODE)
8325 B(I) = B4MODE(I,ITYPE2,IMODE)
8326 MR(I) = RMASS(I4MODE(I,IMODE))
8327 MS(I) = MR(I)**2
8328 IF(I4MODE(I,IMODE).EQ.200) THEN
8329 MWD(I) = MR(I)*GAMZ
8330 ELSE
8331 MWD(I) = MR(I)*GAMW
8332 ENDIF
8333 IDP(5+I) = I4MODE(I,IMODE)
8334C--id's of outgoing particles
8335 IF(I4MODE(I,IMODE).EQ.200) THEN
8336 IDP(2*I ) = ITYPE(I)
8337 IF(ITYPE(I).GT.6) IDP(2*I) = IDP(2*I)+114
8338 IDP(2*I+1) = IDP(2*I)+6
8339 ELSE
8340 IDP(2*I ) = 2*ITYPE(I)-1
8341 IF(ITYPE(I).GT.3) IDP(2*I) = IDP(2*I)+114
8342 IDP(2*I+1) = IDP(2*I)+7
8343 IF(I4MODE(I,IMODE).EQ.198) THEN
8344 J = IDP(2*I )+6
8345 IDP(2*I) = IDP(2*I+1)-6
8346 IDP(2*I+1) = J
8347 ENDIF
8348 ENDIF
8349 ENDDO
8350 IDP(1) = IDK(ID4PRT(IMODE))
8351 DO 1 I=1,5
8352 M(I) = RMASS(IDP(I))
8353 1 M2(I) = M(I)**2
8354 IF(M(1).LT.M(2)+M(3)+M(4)+M(5).OR.MR(1).LT.M(2)+M(3).OR.
8355 & MR(2).LT.M(4)+M(5)) RETURN
8356 IF(IPRINT.EQ.2.AND..NOT.GENEV)
8357 & WRITE(6,3000) RNAME(IDP(6)),RNAME(IDP(2)),RNAME(IDP(3)),
8358 & RNAME(IDP(7)),RNAME(IDP(4)),RNAME(IDP(5))
8359C--compute the width and maximum weight if initialising
8360 IF(.NOT.GENEV) THEN
8361 WMAX = ZERO
8362 WSUM = ZERO
8363 WSSUM = ZERO
8364 DO I=1,NSEARCH
8365 CALL HWD4M0(1,WGT)
8366 WGT = WGT*PRE
8367 IF(WGT.GT.WMAX) WMAX = WGT
8368 WSUM = WSUM+WGT
8369 WSSUM = WSSUM+WGT**2
8370 IF(WGT.LT.ZERO) CALL HWWARN('HWD4ME',500)
8371 ENDDO
8372 WSUM = WSUM/DBLE(NSEARCH)
8373 WSSUM = MAX(ZERO,WSSUM/DBLE(NSEARCH)-WSUM**2)
8374 WSSUM = SQRT(WSSUM/DBLE(NSEARCH))
8375 IF(IPRINT.EQ.2) WRITE(6,3010) WSUM,WSSUM
8376 IF(IPRINT.EQ.2) WRITE(6,3020) WMAX
8377 TEMP = BRFRAC(ID4PRT(IMODE))*HBAR/RLTIM(IDK(ID4PRT(IMODE)))
8378 DO J=1,2
8379 IF(I4MODE(J,IMODE).EQ.200) THEN
8380 TEMP = TEMP*BRZ(ITYPE(J))
8381 ELSE
8382 TEMP = TEMP*BRW(ITYPE(J))
8383 ENDIF
8384 ENDDO
8385 IF(IPRINT.EQ.2) WRITE(6,3030) WSUM/TEMP,WSSUM/TEMP
8386C--set up the maximum weight
8387 WT4MAX(ITYPE(1),ITYPE(2),IMODE) = WMAX
8388 ELSE
8389C--generate a configuation
8390 NTRY = 0
8391 IF(SYSPIN.AND.NSPN.NE.0) CALL HWWARN('HWD4ME',501)
8392 100 NTRY = NTRY+1
8393 CALL HWD4M0(ID,WGT)
8394 WGT = WGT*PRE
8395 IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 100
8396 IF(NTRY.GE.NSNTRY) THEN
8397 CALL HWWARN('HWD4ME',100)
8398 GOTO 999
8399 ENDIF
8400 ENDIF
8401 3000 FORMAT(/' FOLLOWED BY ',A8,' --> ',A8,' ',A8,' AND ',
8402 & A8,' --> ',A8,' ',A8)
8403 3010 FORMAT(' PARTIAL WIDTH = ',G12.4,' +/- ',G12.4)
8404 3020 FORMAT(' MAXIMUM WEIGHT = ',E12.4)
8405 3030 FORMAT(' RATIO TO ISAJET VALUE = ',G12.4,' +/- ',G12.4)
8406 999 RETURN
8407 END
8408CDECK ID>, HWD4M0.
8409*CMZ :- -11/10/01 12:32:39 by Peter Richardson
8410*-- Author : Peter Richardson
8411C-----------------------------------------------------------------------
8412 SUBROUTINE HWD4M0(ID,WGT)
8413C-----------------------------------------------------------------------
8414C Subroutine to calculate the matrix element for a given four body
8415C decay mode
8416C-----------------------------------------------------------------------
c63d70bc 8417 INCLUDE 'herwig65.inc'
65767955 8418 INTEGER I,J,P0,P1,P2,P3,ID,O(2),IDP(4+NDIAGR),II,P4
8419 DOUBLE PRECISION A,B,MS,MWD,M,M2,WGT,HWRUNI,
8420 & M23,PCMA,PCMB(2),HWUPCM,PHS,N(3),HWVDOT,PP,HWULDO,EPS,
8421 & M232,PRE,PLAB,PRW,XMASS,PCM,P(5,5),PM(5,5),MR,PREF(5),
8422 & M45,M452,MJAC(2),PTMP(5,2),CN(2),DOT
8423 DOUBLE COMPLEX S,D,ME(2,2,2,2),APP(2,2),AMP(2,2),APM(2,2),
8424 & AMM(2,2),BPP(2,2),BPM(2,2),BMP(2,2),BMM(2,2),ZI,
8425 & F45(2,2,8,8),F23(2,2,8,8),C(2,2),E(2,2)
8426 LOGICAL HWRLOG
8427 EXTERNAL HWRUNI,HWUPCM,HWVDOT,HWULDO,HWRLOG
8428 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
8429 COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP
8430 COMMON/HWHEWS/S(8,8,2),D(8,8)
8431 PARAMETER(EPS=1D-20,ZI=(0.0D0,1.0D0))
8432 SAVE O,PREF
8433 DATA O/2,1/
8434 DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
8435C--select the masses of the gauge bosons and compute Jacobians
8436 IF(HWRLOG(HALF)) THEN
8437 CALL HWHGB1(1,2,IDP(6),MJAC(1),M232,(M(1)-M(4)-M(5))**2,
8438 & (M(2)+M(3))**2)
8439 M23 = SQRT(M232)
8440 CALL HWHGB1(1,2,IDP(7),MJAC(2),M452,
8441 & (M(1)-M23)**2,(M(4)+M(5))**2)
8442 M45 = SQRT(M452)
8443 ELSE
8444 CALL HWHGB1(1,2,IDP(7),MJAC(2),M452,(M(1)-M(2)-M(3))**2,
8445 & (M(4)+M(5))**2)
8446 M45 = SQRT(M452)
8447 CALL HWHGB1(1,2,IDP(6),MJAC(1),M232,(M(1)-M45)**2,
8448 & (M(2)+M(3))**2)
8449 M23 = SQRT(M232)
8450 ENDIF
8451 MJAC(1) = MJAC(1)/((M232-MS(1))**2+MWD(1)**2)
8452 MJAC(2) = MJAC(2)/((M452-MS(2))**2+MWD(2)**2)
8453 DO 1 I=2,5
8454 1 P(5,I) = M(I)
8455 DO 2 I=1,2
8456 2 CN(I) = -ONE/MS(I)
8457C--now perform the decay of the Higgs to the bosons
8458 PCMA = HWUPCM(M(1),M23,M45)
8459 PLAB(5,1) = M23
8460 PLAB(5,2) = M45
8461 CALL HWVEQU(5,PHEP(1,ID),P(1,1))
8462 CALL HWDTWO(P(1,1),PLAB(1,1),PLAB(1,2),PCMA,2.0D0,.TRUE.)
8463 PCMB(1) = HWUPCM(M23,M(2),M(3))
8464 CALL HWDTWO(PLAB(1,1),P(1,2),P(1,3),PCMB(1),2.0D0,.TRUE.)
8465 PCMB(2) = HWUPCM(M45,M(4),M(5))
8466 CALL HWDTWO(PLAB(1,2),P(1,4),P(1,5),PCMB(2),2.0D0,.TRUE.)
8467 DOT = HWULDO(PLAB(1,1),PLAB(1,2))
8468C--compute the phase sapce factors
8469 PHS = PCMA*PCMB(1)*PCMB(2)*MJAC(1)*MJAC(2)/512.0D0/PIFAC**5/
8470 & M2(1)/M23/M45
8471C--compute the vectors for the helicity amplitudes
8472 DO 3 I=1,4
8473 II=I+1
8474C--compute the references vectors
8475C--not important if SM particle which can't have spin measured
8476C--ie anything other the top and tau
8477C--also not important if particle is approx massless
8478C--first the SM particles other than top and tau
8479 IF(IDP(II).LT.400.AND.(IDP(II).NE.6.AND.IDP(II).NE.12
8480 & .AND.IDP(II).NE.125.AND.IDP(II).NE.131)) THEN
8481 CALL HWVEQU(5,PREF,PLAB(1,I+4))
8482C--all other particles
8483 ELSE
8484 PP = SQRT(HWVDOT(3,P(1,II),P(1,II)))
8485 CALL HWVSCA(3,ONE/PP,P(1,II),N)
8486 PLAB(4,I+4) = HALF*(P(4,II)-PP)
8487 PP = HALF*(PP-M(II)-PP**2/(M(II)+P(4,II)))
8488 CALL HWVSCA(3,PP,N,PLAB(1,I+4))
8489 CALL HWUMAS(PLAB(1,I+4))
8490 PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4))
8491C--fix to avoid problems if approx massless due to energy
8492 IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4))
8493 ENDIF
8494C--now the massless vectors
8495 PP = HALF*M2(II)/HWULDO(PLAB(1,I+4),P(1,II))
8496 DO 4 J=1,4
8497 4 PLAB(J,I) = P(J,II)-PP*PLAB(J,I+4)
8498 3 CALL HWUMAS(PLAB(1,I))
8499C--change ordr of momenta for call to HE code
8500 DO 5 I=1,5
8501 PM(1,I) = P(3,I)
8502 PM(2,I) = P(1,I)
8503 PM(3,I) = P(2,I)
8504 PM(4,I) = P(4,I)
8505 5 PM(5,I) = P(5,I)
8506 DO 6 I=1,8
8507 PCM(1,I)=PLAB(3,I)
8508 PCM(2,I)=PLAB(1,I)
8509 PCM(3,I)=PLAB(2,I)
8510 PCM(4,I)=PLAB(4,I)
8511 6 PCM(5,I)=PLAB(5,I)
8512C--compute the S functions
8513 CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
8514 DO 7 I=1,8
8515 DO 7 J=1,8
8516 S(I,J,2) = -S(I,J,2)
8517 7 D(I,J) = TWO*D(I,J)
8518 CALL HWVSUM(4,PM(1,2),PM(1,3),PTMP(1,1))
8519 CALL HWVSUM(4,PM(1,4),PM(1,5),PTMP(1,2))
8520 CALL HWUMAS(PTMP(1,1))
8521 CALL HWUMAS(PTMP(1,2))
8522C--compute the F functions
8523 CALL HWH2F3(8,F23,PTMP(1,1),ZERO)
8524 CALL HWH2F3(8,F45,PTMP(1,2),ZERO)
8525C--now find the prefactor for all the diagrams
8526 PRE = HWULDO(PCM(1,5),PM(1,2))*HWULDO(PCM(1,6),PM(1,3))*
8527 & HWULDO(PCM(1,7),PM(1,4))*HWULDO(PCM(1,8),PM(1,5))
8528 PRE = 0.25D0/SQRT(PRE)
8529C--zero the matrix element
8530 DO 8 P0=1,2
8531 DO 8 P1=1,2
8532 DO 8 P2=1,2
8533 DO 8 P3=1,2
8534 8 ME(P0,P1,P2,P3) = (0.0D0,0.0D0)
8535C--compute the A, B, C and E functions
8536 DO 9 P1=1,2
8537 DO 9 P2=1,2
8538 IF(P1.EQ.P2) THEN
8539C--the A and B functions
8540 APP(P1,P2) = A( P2 )*S(5,1,O(P1))*S(2,6, P1 )
8541 APM(P1,P2) = 0.0D0
8542 AMP(P1,P2) = 0.0D0
8543 AMM(P1,P2) = -A(O(P2))*M(2)*M(3)
8544 BPP(P1,P2) = B( P2 )*S(7,3,O(P1))*S(4,8, P1 )
8545 BPM(P1,P2) = 0.0D0
8546 BMP(P1,P2) = 0.0D0
8547 BMM(P1,P2) = -B(O(P2))*M(4)*M(5)
8548C--the C and E functions
8549 C(P1,P2) =CN(1)*(A( P2 )*( M2(2)*S(5,2,O(P1))*S(2,6, P1 )
8550 & +M2(3)*S(5,1,O(P1))*S(1,6, P1 ))
8551 & -A(O(P2))*M(2)*M(3)*( S(5,1,O(P1))*S(1,6, P1 )
8552 & +S(5,2,O(P1))*S(2,6, P1 )))
8553 E(P1,P2) =CN(2)*(B( P2 )*( M2(4)*S(7,4,O(P1))*S(4,8, P1 )
8554 & +M2(5)*S(7,3,O(P1))*S(3,8, P1 ))
8555 & -B(O(P2))*M(4)*M(5)*( S(7,3,O(P1))*S(3,8, P1 )
8556 & +S(7,4,O(P1))*S(4,8, P1 )))
8557 ELSE
8558C--the A functions
8559 APP(P1,P2) = 0.0D0
8560 APM(P1,P2) = A( P2 )*M(2)*S(2,6,O(P1))
8561 AMP(P1,P2) =-A(O(P2))*M(3)*S(5,1,O(P1))
8562 AMM(P1,P2) = 0.0D0
8563 BPP(P1,P2) = 0.0D0
8564 BPM(P1,P2) = B( P2 )*M(4)*S(4,8,O(P1))
8565 BMP(P1,P2) =-B(O(P2))*M(5)*S(7,3,O(P1))
8566 BMM(P1,P2) = 0.0D0
8567C--the C and D functions
8568 C(P1,P2) =CN(1)*( A( P2 )*M(2)*( M2(3)*S(5,6,O(P1))
8569 & +S(5,1,O(P1))*S(1,2, P1 )*S(2,6,O(P1)))
8570 & -A(O(P2))*M(3)*( M2(2)*S(5,6,O(P1))
8571 & +S(5,1,O(P1))*S(1,2, P1 )*S(2,6,O(P1))))
8572 E(P1,P2) =CN(2)*( B( P2 )*M(4)*( M2(5)*S(7,8,O(P1))
8573 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1)))
8574 & -B(O(P2))*M(5)*( M2(4)*S(7,8,O(P1))
8575 & +S(7,3,O(P1))*S(3,4, P1 )*S(4,8,O(P1))))
8576 ENDIF
8577 9 CONTINUE
8578C--now put the whole thing together to give the matrix element
8579 DO 10 P1=1,2
8580 DO 10 P2=1,2
8581 DO 10 P3=1,2
8582 DO 10 P4=1,2
8583 P0=O(P1)
8584 IF(P1.EQ.P3) THEN
8585 ME(P1,P2,P3,P4) =
8586 & APP(P1,P2)*(S(1,3,P1)*(BPP(P3,P4)*S(4,2,P0)+BMP(P3,P4)*S(8,2,P0))
8587 & +S(7,2,P0)*(BPM(P3,P4)*S(1,4,P1)+BMM(P3,P4)*S(1,8,P1)))
8588 &+APM(P1,P2)*(S(5,7,P0)*(BPM(P3,P4)*S(4,2,P1)+BMM(P3,P4)*S(8,2,P1))
8589 & +S(3,2,P1)*(BPP(P3,P4)*S(5,4,P0)+BMP(P3,P4)*S(5,8,P0)))
8590 &+AMP(P1,P2)*(S(1,3,P1)*(BPP(P3,P4)*S(4,6,P0)+BMP(P3,P4)*S(8,6,P0))
8591 & +S(7,6,P0)*(BPM(P3,P4)*S(1,4,P1)+BMM(P3,P4)*S(1,8,P1)))
8592 &+AMM(P1,P2)*(S(3,6,P1)*(BPP(P3,P4)*S(5,4,P0)+BMP(P3,P4)*S(5,8,P0))
8593 & +S(5,7,P0)*(BPM(P3,P4)*S(4,6,P1)+BMM(P3,P4)*S(8,6,P1)))
8594 ELSE
8595 ME(P1,P2,P3,P4) =
8596 & APP(P1,P2)*(S(3,2,P0)*(BPP(P3,P4)*S(1,4,P1)+BMP(P3,P4)*S(1,8,P1))
8597 & +S(1,7,P1)*(BPM(P3,P4)*S(4,2,P0)+BMM(P3,P4)*S(8,2,P0)))
8598 &+APM(P1,P2)*(S(5,3,P0)*(BPP(P3,P4)*S(4,2,P1)+BMP(P3,P4)*S(8,2,P1))
8599 & +S(7,2,P1)*(BPM(P3,P4)*S(5,4,P0)+BMM(P3,P4)*S(5,8,P0)))
8600 &+AMP(P1,P2)*(S(3,6,P0)*(BPP(P3,P4)*S(1,4,P1)+BMP(P3,P3)*S(1,8,P1))
8601 & +S(1,7,P1)*(BPM(P3,P4)*S(4,6,P0)+BMM(P3,P4)*S(8,6,P0)))
8602 &+AMM(P1,P2)*(S(5,3,P0)*(BPP(P3,P4)*S(4,6,P1)+BMP(P3,P4)*S(8,6,P1))
8603 & +S(7,6,P1)*(BPM(P3,P4)*S(5,4,P0)+BMM(P3,P4)*S(5,8,P0)))
8604 ENDIF
8605 ME(P1,P2,P3,P4) = TWO*ME(P1,P2,P3,P4)
8606 & +C(P1,P2)*(
8607 & BPP(P3,P4)*F23(P3,P3,3,4)+BPM(P3,P4)*F23(O(P3),O(P3),7,4)
8608 & +BMP(P3,P4)*F23(P3,P3,3,8)+BMM(P3,P4)*F23(O(P3),O(P3),7,8))
8609 & +E(P3,P4)*(
8610 & APP(P1,P2)*F45(P1,P1,1,2)+APM(P1,P2)*F45(P0,P0,5,2)
8611 & +AMP(P1,P2)*F45(P1,P1,1,6)+AMM(P1,P2)*F45(P0,P0,5,6))
8612 & +DOT*C(P1,P2)*E(P3,P4)
8613 10 ME(P1,P2,P3,P4) = PRE*ME(P1,P2,P3,P4)
8614C--compute the weight
8615 WGT = ZERO
8616 DO 40 P1=1,2
8617 DO 40 P2=1,2
8618 DO 40 P3=1,2
8619 DO 40 P4=1,2
8620 40 WGT = WGT+DREAL(ME(P1,P2,P3,P4)*DCONJG(ME(P1,P2,P3,P4)))
8621C--normalise this for phase space
8622 WGT = WGT*PHS
8623C--enter the matrix element into the spin common block
8624 IF(GENEV.AND.SYSPIN) THEN
8625 NSPN = 5
8626 DO 11 P1=1,2
8627 DO 11 P2=1,2
8628 DO 11 P3=1,2
8629 DO 11 P4=1,2
8630 11 MESPN(P1,P2,P3,P4,1,1) = ME(P1,P2,P3,P4)
8631 SPNCFC(1,1,1) = ONE
8632 NCFL(1) = 1
8633 ENDIF
8634 END
8635CDECK ID>, HWDBOS.
8636*CMZ :- -23/05/96 18.34.17 by Mike Seymour
8637*-- Author : Mike Seymour
8638C-----------------------------------------------------------------------
8639 SUBROUTINE HWDBOS(IBOSON)
8640C-----------------------------------------------------------------------
8641C DECAY GAUGE BOSONS (ALREADY FOUND BY HWDHAD)
8642C USES SPIN DENSITY MATRIX IN RHOHEP (1ST CMPT=>-VE,2=>LONG,3=>+VE)
8643C IF BOSON CAME FROM HIGGS DECAY, GIVE BOTH THE SAME HELICITY (EPR)
8644C IF BOSON CAME FROM W+1JET, GIVE IT THE CORRECT DECAY CORRELATIONS
8645C--BRW FIX 20/07/04: ADD FULL DECAY CORRELATIONS FOR W/Z+HIGGS
8646C-----------------------------------------------------------------------
c63d70bc 8647 INCLUDE 'herwig65.inc'
65767955 8648 DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWULDO,R(3,3),CV,CA,BR,PCM,
8649 & PBOS(5),PMAX,PROB,RRLL,RLLR
8650 INTEGER HWRINT,IBOS,IBOSON,IPAIR,ICMF,IOPT,IHEL,IMOTH,
8651 & I,IQRK,IANT,ID,IQ
8652 LOGICAL QUARKS
8653 EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWULDO,HWRINT
8654 IBOS=IBOSON
8655 IF (IDHW(IBOS).LT.198.OR.IDHW(IBOS).GT.200) THEN
8656 CALL HWWARN('HWDBOS',101)
8657 GOTO 999
8658 ENDIF
8659 QUARKS=.FALSE.
8660C---SEE IF IT IS PART OF A PAIR
8661 IMOTH=JMOHEP(1,IBOS)
8662 IPAIR=JMOHEP(2,IBOS)
8663 ICMF=JMOHEP(1,IBOS)
8664C--BRW FIX 17/07/03
8665 IF (IPAIR.EQ.IBOS) THEN
8666 IOPT=0
8667 IF (IPRO.EQ.26.OR.IPRO.EQ.27) ICMF=JMOHEP(1,IMOTH)
8668 ELSE
8669 IF (IDHW(ICMF).EQ.IDHW(IBOS).AND.ISTHEP(ICMF)/10.EQ.12) THEN
8670 IPAIR=JMOHEP(2,ICMF)
8671 IF (IPAIR.NE.0) THEN
8672 IPAIR=JDAHEP(1,IPAIR)
8673 IF (IPAIR.NE.0) JMOHEP(2,IPAIR)=IBOS
8674 ENDIF
8675 ICMF=JMOHEP(1,ICMF)
8676 ENDIF
8677 IOPT=0
8678 IF (IPAIR.NE.0) THEN
8679 IF (JMOHEP(2,IPAIR).NE.IBOS.OR.
8680 & IDHW(IPAIR).LT.198.OR.IDHW(IPAIR).GT.200) IPAIR=0
8681 ENDIF
8682 IF (IPAIR.GT.0.AND.IPAIR.NE.IBOS) IOPT=1
8683 ENDIF
8684C--END FIX
8685C---SELECT DECAY PRODUCTS
8686 10 CALL HWDBOZ(IDHW(IBOS),IDN(1),IDN(2),CV,CA,BR,IOPT)
8687C---V + 1JET, V+HIGGS DECAYS ARE NOW HANDLED HERE !
8688 IF (IPRO.EQ.21.OR.IPRO.EQ.26.OR.IPRO.EQ.27) THEN
8689 IQRK=IDHW(JMOHEP(1,ICMF))
8690 IANT=IDHW(JMOHEP(2,ICMF))
8691 IF (IQRK.EQ.13 .AND. IANT.LE.6) THEN
8692 IQRK=JMOHEP(2,ICMF)
8693 IANT=JDAHEP(2,ICMF)
8694 ELSEIF (IQRK.EQ.13) THEN
8695 IQRK=JDAHEP(2,ICMF)
8696 IANT=JMOHEP(2,ICMF)
8697 ELSEIF (IANT.EQ.13 .AND. IQRK.LE.6) THEN
8698 IQRK=JMOHEP(1,ICMF)
8699 IANT=JDAHEP(2,ICMF)
8700 ELSEIF (IANT.EQ.13) THEN
8701 IQRK=JDAHEP(2,ICMF)
8702 IANT=JMOHEP(1,ICMF)
8703 ELSEIF (IQRK.GT.IANT) THEN
8704 IQRK=JMOHEP(2,ICMF)
8705 IANT=JMOHEP(1,ICMF)
8706 ELSE
8707 IQRK=JMOHEP(1,ICMF)
8708 IANT=JMOHEP(2,ICMF)
8709 ENDIF
8710 PHEP(5,NHEP+1)=RMASS(IDN(1))
8711 PHEP(5,NHEP+2)=RMASS(IDN(2))
8712 PCM=HWUPCM(PHEP(5,IBOS),PHEP(5,NHEP+1),PHEP(5,NHEP+2))
8713 IF (PCM.LT.ZERO) THEN
8714 CALL HWWARN('HWDBOS',103)
8715 GOTO 999
8716 ENDIF
8717 IF (IDHW(IBOS).EQ.200) THEN
8718 ID=IDN(1)
8719 IF (ID.GT.120) ID=ID-110
8720 IQ=IDHW(IQRK)
8721 IF (IQ.GT.6) IQ=IQ-6
8722 RRLL=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)*
8723 $ (VFCH(ID,1)**2+AFCH(ID,1)**2)
8724 $ +4*VFCH(IQ,1)*AFCH(IQ,1)*
8725 $ VFCH(ID,1)*AFCH(ID,1)
8726 RLLR=(VFCH(IQ,1)**2+AFCH(IQ,1)**2)*
8727 $ (VFCH(ID,1)**2+AFCH(ID,1)**2)
8728 $ -4*VFCH(IQ,1)*AFCH(IQ,1)*
8729 $ VFCH(ID,1)*AFCH(ID,1)
8730 ELSE
8731 RRLL=ONE
8732 RLLR=ZERO
8733 ENDIF
8734 IF (IPRO.EQ.21) THEN
8735 PMAX=(RRLL+RLLR)*(HWULDO(PHEP(1,IANT),PHEP(1,IBOS))**2+
8736 & HWULDO(PHEP(1,IQRK),PHEP(1,IBOS))**2)
8737 ELSE
8738 PMAX=(RRLL+RLLR)* HWULDO(PHEP(1,IANT),PHEP(1,IBOS))*
8739 & HWULDO(PHEP(1,IQRK),PHEP(1,IBOS))
8740 ENDIF
8741 1 CALL HWDTWO(PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
8742 & PCM,TWO,.TRUE.)
8743 IF (IPRO.EQ.21) THEN
8744 PROB=RRLL*(HWULDO(PHEP(1,IANT),PHEP(1,NHEP+1))**2+
8745 & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+2))**2)+
8746 & RLLR*(HWULDO(PHEP(1,IANT),PHEP(1,NHEP+2))**2+
8747 & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+1))**2)
8748 ELSE
8749 PROB=RRLL* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+1))*
8750 & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+2))+
8751 & RLLR* HWULDO(PHEP(1,IANT),PHEP(1,NHEP+2))*
8752 & HWULDO(PHEP(1,IQRK),PHEP(1,NHEP+1))
8753 ENDIF
8754 IF (PROB.GT.PMAX.OR.PROB.LT.ZERO) THEN
8755 CALL HWWARN('HWDBOS',104)
8756 GOTO 999
8757 ENDIF
8758 IF (PMAX*HWRGEN(0).GT.PROB) GOTO 1
8759 ELSE
8760C---SELECT HELICITY, UNLESS IT IS THE SECOND OF A HIGGS DECAY (EPR)
8761 IF (IPAIR.NE.IBOS .OR. IDHW(ICMF).NE.201) THEN
8762 IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).LE.ZERO) THEN
8763C---COPY PARENT HELICITY IF IT WAS A GAUGE BOSON
8764 IF (IDHW(IMOTH).GE.198.AND.IDHW(IMOTH).LE.200) THEN
8765 CALL HWVEQU(3,RHOHEP(1,IMOTH),RHOHEP(1,IBOS))
8766 IF (RHOHEP(1,IBOS)+RHOHEP(2,IBOS)+RHOHEP(3,IBOS).GT.ZERO)
8767 & GOTO 20
8768C---MAY BE FROM A SUSY DECAY
8769 ELSEIF (ABS(IDHEP(IMOTH)).LT.1000000) THEN
8770 CALL HWWARN('HWDBOS',1)
8771 ENDIF
8772 RHOHEP(1,IBOS)=1.
8773 RHOHEP(2,IBOS)=1.
8774 RHOHEP(3,IBOS)=1.
8775 ENDIF
8776 20 IHEL=HWRINT(1,3)
8777 IF (HWRGEN(0).GT.RHOHEP(IHEL,IBOS)) GOTO 20
8778 ENDIF
8779C---SELECT DIRECTION OF FERMION
8780 30 COSTH=HWRUNI(0,-ONE,ONE)
8781 IF (IHEL.EQ.1 .AND. (ONE+COSTH)**2.LT.HWRGEN(0)*FOUR) GOTO 30
8782 IF (IHEL.EQ.2 .AND. (ONE-COSTH**2).LT.HWRGEN(0) ) GOTO 30
8783 IF (IHEL.EQ.3 .AND. (ONE-COSTH)**2.LT.HWRGEN(0)*FOUR) GOTO 30
8784C---GENERATE DECAY RELATIVE TO Z-AXIS
8785 PHEP(5,NHEP+1)=RMASS(IDN(1))
8786 PHEP(5,NHEP+2)=RMASS(IDN(2))
8787 PCM=HWUPCM(PHEP(5,IBOS),PHEP(5,NHEP+1),PHEP(5,NHEP+2))
8788 IF (PCM.LT.ZERO) THEN
8789 CALL HWWARN('HWDBOS',102)
8790 GOTO 999
8791 ENDIF
8792 CALL HWRAZM(PCM*SQRT(1-COSTH**2),PHEP(1,NHEP+1),PHEP(2,NHEP+1))
8793 PHEP(3,NHEP+1)=PCM*COSTH
8794 PHEP(4,NHEP+1)=SQRT(PHEP(5,NHEP+1)**2+PCM**2)
8795C---ROTATE SO THAT Z-AXIS BECOMES BOSON'S DIRECTION IN ORIGINAL CM FRAME
8796 CALL HWULOF(PHEP(1,ICMF),PHEP(1,IBOS),PBOS)
8797 CALL HWUROT(PBOS, ONE,ZERO,R)
8798 CALL HWUROB(R,PHEP(1,NHEP+1),PHEP(1,NHEP+1))
8799C---BOOST BACK TO LAB
8800 CALL HWULOB(PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+1))
8801 CALL HWVDIF(4,PHEP(1,IBOS),PHEP(1,NHEP+1),PHEP(1,NHEP+2))
8802 ENDIF
8803C---STATUS, IDs AND POINTERS
8804 ISTHEP(IBOS)=195
8805 DO 50 I=1,2
8806 ISTHEP(NHEP+I)=193
8807 IDHW(NHEP+I)=IDN(I)
8808 IDHEP(NHEP+I)=IDPDG(IDN(I))
8809 JDAHEP(I,IBOS)=NHEP+I
8810 JMOHEP(1,NHEP+I)=IBOS
8811 JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS)
8812 50 CONTINUE
8813 NHEP=NHEP+2
8814 IF (IDN(1).LE.12) THEN
8815 ISTHEP(NHEP-1)=113
8816 ISTHEP(NHEP)=114
8817 JMOHEP(2,NHEP)=NHEP-1
8818 JDAHEP(2,NHEP)=NHEP-1
8819 JMOHEP(2,NHEP-1)=NHEP
8820 JDAHEP(2,NHEP-1)=NHEP
8821 QUARKS=.TRUE.
8822 ELSE
8823C--MHS FIX 07/03/05 - VERTEX POSITION FOR DECAYS TO LEPTONS
8824 CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP-1))
8825 CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP))
8826C--END FIX
8827 ENDIF
8828C---IF FIRST OF A PAIR, DO SECOND DECAY
8829 IF (IPAIR.NE.0 .AND. IPAIR.NE.IBOS) THEN
8830 IBOS=IPAIR
8831 GOTO 10
8832 ENDIF
8833C---IF QUARK DECAY, HADRONIZE
8834 IF (QUARKS) THEN
8835 EMSCA=PHEP(5,IBOS)
8836 CALL HWBGEN
8837 CALL HWDHOB
8838 CALL HWCFOR
8839 CALL HWCDEC
8840 ENDIF
8841 999 RETURN
8842 END
8843CDECK ID>, HWDBOZ.
8844*CMZ :- -29/04/91 18.00.03 by Federico Carminati
8845*-- Author : Mike Seymour
8846C-----------------------------------------------------------------------
8847 SUBROUTINE HWDBOZ(IDBOS,IFER,IANT,CV,CA,BR,IOPT)
8848C-----------------------------------------------------------------------
8849C CHOOSE DECAY MODE OF BOSON
8850C IOPT=2 TO RESET COUNTERS, 1 FOR BOSON PAIR, 0 FOR ANY OTHERS
8851C-----------------------------------------------------------------------
c63d70bc 8852 INCLUDE 'herwig65.inc'
65767955 8853 DOUBLE PRECISION HWRGEN,BRMODE(12,3),CV,CA,BR,BRLST,BRCOM,FACZ,
8854 & FACW
8855 INTEGER HWRINT,IDBOS,IDEC,IDMODE(2,12,3),IFER,IANT,IOPT,I1,I2,
8856 & I1LST,I2LST,NWGLST,NUMDEC,NPAIR,MODTMP,JFER
8857 LOGICAL GENLST
8858 EXTERNAL HWRGEN,HWRINT
8859 SAVE FACW,FACZ,NWGLST,GENLST,NUMDEC,NPAIR,I1LST,I2LST,BRLST
8860 SAVE IDMODE,BRMODE
8861 DATA NWGLST,GENLST,NPAIR/-1,.FALSE.,0/
8862C---STORE THE DECAY MODES (FERMION FIRST)
8863 DATA IDMODE/ 2, 7, 4, 9, 6, 11, 2, 9, 4, 7,
8864 & 122,127,124,129,126,131,8*0,
8865 & 1, 8, 3, 10, 5, 12, 3, 8, 1, 10,
8866 & 121,128,123,130,125,132,8*0,
8867 & 1, 7, 2, 8, 3, 9, 4, 10, 5, 11, 6, 12,
8868 & 121,127,123,129,125,131,122,128,124,130,126,132/
8869C---STORE THE BRANCHING RATIOS TO THESE MODES
8870 DATA BRMODE/0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
8871 & 0.108D0,0.108D0,4*0.0D0,
8872 & 0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
8873 & 0.108D0,0.108D0,4*0.0D0,
8874 & 0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
8875 & 0.033D0,0.033D0,0.033D0,0.067D0,0.067D0,0.067D0/
8876C---FACTORS FOR CV AND CA FOR W AND Z
8877 DATA FACW,FACZ/2*0.0D0/
8878 IF (FACZ.EQ.ZERO) FACZ=SQRT(SWEIN)
8879 IF (FACW.EQ.ZERO) FACW=0.5/SQRT(2D0)
8880 IF (IDBOS.LT.198.OR.IDBOS.GT.200) THEN
8881 CALL HWWARN('HWDBOZ',101)
8882 GOTO 999
8883 ENDIF
8884C---IF THIS IS A NEW EVENT SINCE LAST TIME, ZERO COUNTERS
8885 IF (NWGTS.NE.NWGLST .OR.(GENEV.NEQV.GENLST).OR. IOPT.EQ.2) THEN
8886 NPAIR=0
8887 NUMDEC=0
8888 NWGLST=NWGTS
8889 GENLST=GENEV
8890 IF (IOPT.EQ.2) RETURN
8891 ENDIF
8892 NUMDEC=NUMDEC+1
8893 IF (NUMDEC.GT.MODMAX) THEN
8894 CALL HWWARN('HWDBOZ',102)
8895 GOTO 999
8896 ENDIF
8897C---IF PAIR OPTION SPECIFIED FOR THE FIRST TIME, MAKE CHOICE
8898 IF (IOPT.EQ.1) THEN
8899 IF (NUMDEC.GT.MODMAX-1) THEN
8900 CALL HWWARN('HWDBOZ',103)
8901 GOTO 999
8902 ENDIF
8903 IF (NPAIR.EQ.0) THEN
8904 IF (HWRGEN(1).GT.HALF) THEN
8905 MODTMP=MODBOS(NUMDEC+1)
8906 MODBOS(NUMDEC+1)=MODBOS(NUMDEC)
8907 MODBOS(NUMDEC)=MODTMP
8908 ENDIF
8909 NPAIR=NUMDEC
8910 ELSE
8911 NPAIR=0
8912 ENDIF
8913 ENDIF
8914C---SELECT USER'S CHOICE
8915 IF (IDBOS.EQ.200) THEN
8916 IF (MODBOS(NUMDEC).EQ.1) THEN
8917 I1=1
8918 I2=6
8919 ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
8920 I1=7
8921 I2=7
8922 ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
8923 I1=8
8924 I2=8
8925 ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
8926 I1=9
8927 I2=9
8928 ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
8929 I1=7
8930 I2=8
8931 ELSEIF (MODBOS(NUMDEC).EQ.6) THEN
8932 I1=10
8933 I2=12
8934 ELSEIF (MODBOS(NUMDEC).EQ.7) THEN
8935 I1=5
8936 I2=5
8937 ELSE
8938 I1=1
8939 I2=12
8940 ENDIF
8941 ELSE
8942 IF (MODBOS(NUMDEC).EQ.1) THEN
8943 I1=1
8944 I2=5
8945 ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
8946 I1=6
8947 I2=6
8948 ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
8949 I1=7
8950 I2=7
8951 ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
8952 I1=8
8953 I2=8
8954 ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
8955 I1=6
8956 I2=7
8957 ELSE
8958 I1=1
8959 I2=8
8960 ENDIF
8961 ENDIF
8962 10 IDEC=HWRINT(I1,I2)
8963 IF (HWRGEN(0).GT.BRMODE(IDEC,IDBOS-197).AND.I1.NE.I2) GOTO 10
8964 IFER=IDMODE(1,IDEC,IDBOS-197)
8965 IANT=IDMODE(2,IDEC,IDBOS-197)
8966C---CALCULATE BRANCHING RATIO
8967C (RESULT IS NOT WELL-DEFINED AFTER THE FIRST CALL OF A PAIR)
8968 BR=0
8969 DO 20 IDEC=I1,I2
8970 20 BR=BR+BRMODE(IDEC,IDBOS-197)
8971 IF (IOPT.EQ.1) THEN
8972 IF (NPAIR.NE.0) THEN
8973 I1LST=I1
8974 I2LST=I2
8975 BRLST=BR
8976 ELSE
8977 BRCOM=0
8978 DO 30 IDEC=MAX(I1,I1LST),MIN(I2,I2LST)
8979 30 BRCOM=BRCOM+BRMODE(IDEC,IDBOS-197)
8980 BR=2*BR*BRLST - BRCOM**2
8981 ENDIF
8982 ENDIF
8983C---SET UP VECTOR AND AXIAL VECTOR COUPLINGS (NORMALIZED TO THE
8984C CONVENTION WHERE THE WEAK CURRENT IS G*(CV-CA*GAM5) )
8985 IF (IDBOS.EQ.200) THEN
8986 IF (IFER.LE.6) THEN
8987C Quark couplings
8988 CV=VFCH(IFER,1)
8989 CA=AFCH(IFER,1)
8990 ELSE
8991C lepton couplings
8992 JFER=IFER-110
8993 CV=VFCH(JFER,1)
8994 CA=AFCH(JFER,1)
8995 ENDIF
8996 CV=CV * FACZ
8997 CA=CA * FACZ
8998 ELSE
8999 CV=FACW
9000 CA=FACW
9001 ENDIF
9002 999 RETURN
9003 END
9004CDECK ID>, HWDBZ2.
9005*CMZ :- -02/04/01 12.11.55 by Peter Richardson
9006*-- Author : Peter Richardson based on Mike Seymour's HWDBOZ
9007C-----------------------------------------------------------------------
9008 SUBROUTINE HWDBZ2(IDBOS,IFER,IANT,CV,CA,BR,IOPT,MASS)
9009C-----------------------------------------------------------------------
9010C CHOOSE DECAY MODE OF BOSON
9011C IOPT=2 TO RESET COUNTERS, 1 FOR BOSON PAIR, 0 FOR ANY OTHERS
9012C IDENTICAL TO HWDBOZ BUT REQUIRES DECAY MODE ACCESSIBLE FOR GIVEN
9013C MASS
9014C-----------------------------------------------------------------------
c63d70bc 9015 INCLUDE 'herwig65.inc'
65767955 9016 DOUBLE PRECISION HWRGEN,BRMODE(12,3),CV,CA,BR,BRLST,BRCOM,FACZ,
9017 & FACW,MSMODE(12,3),MASS
9018 INTEGER HWRINT,IDBOS,IDEC,IDMODE(2,12,3),IFER,IANT,IOPT,I1,I2,
9019 & I1LST,I2LST,NWGLST,NUMDEC,NPAIR,MODTMP,JFER,NTRY
9020 LOGICAL GENLST
9021 EXTERNAL HWRGEN,HWRINT
9022 SAVE FACW,FACZ,MSMODE,NWGLST,GENLST,NUMDEC,NPAIR,I1LST,I2LST,BRLST
9023 SAVE IDMODE,BRMODE
9024 DATA NWGLST,GENLST,NPAIR/-1,.FALSE.,0/
9025C---STORE THE DECAY MODES (FERMION FIRST)
9026 DATA IDMODE/ 2, 7, 4, 9, 6, 11, 2, 9, 4, 7,
9027 & 122,127,124,129,126,131,8*0,
9028 & 1, 8, 3, 10, 5, 12, 3, 8, 1, 10,
9029 & 121,128,123,130,125,132,8*0,
9030 & 1, 7, 2, 8, 3, 9, 4, 10, 5, 11, 6, 12,
9031 & 121,127,123,129,125,131,122,128,124,130,126,132/
9032C---STORE THE BRANCHING RATIOS TO THESE MODES
9033 DATA BRMODE/0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
9034 & 0.108D0,0.108D0,4*0.0D0,
9035 & 0.321D0,0.321D0,0.000D0,0.017D0,0.017D0,0.108D0,
9036 & 0.108D0,0.108D0,4*0.0D0,
9037 & 0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
9038 & 0.033D0,0.033D0,0.033D0,0.067D0,0.067D0,0.067D0/
9039 DATA MSMODE/36*0.0D0/
9040C---FACTORS FOR CV AND CA FOR W AND Z
9041 DATA FACW,FACZ/2*0.0D0/
9042 IF (FACZ.EQ.ZERO) FACZ=SQRT(SWEIN)
9043 IF (FACW.EQ.ZERO) FACW=0.5/SQRT(2D0)
9044 IF (IDBOS.LT.198.OR.IDBOS.GT.200) THEN
9045 CALL HWWARN('HWDBZ2',101)
9046 GOTO 999
9047 ENDIF
9048 IF(MSMODE(1,1).EQ.ZERO) THEN
9049 DO I1=1,12
9050 DO I2=1,3
9051 MSMODE(I1,I2)=RMASS(IDMODE(1,I1,I2))+RMASS(IDMODE(2,I1,I2))
9052 ENDDO
9053 ENDDO
9054 ENDIF
9055C---IF THIS IS A NEW EVENT SINCE LAST TIME, ZERO COUNTERS
9056 IF (NWGTS.NE.NWGLST .OR.(GENEV.NEQV.GENLST).OR. IOPT.EQ.2) THEN
9057 NPAIR=0
9058 NUMDEC=0
9059 NWGLST=NWGTS
9060 GENLST=GENEV
9061 IF (IOPT.EQ.2) RETURN
9062 ENDIF
9063 NUMDEC=NUMDEC+1
9064 IF (NUMDEC.GT.MODMAX) THEN
9065 CALL HWWARN('HWDBZ2',102)
9066 GOTO 999
9067 ENDIF
9068C---IF PAIR OPTION SPECIFIED FOR THE FIRST TIME, MAKE CHOICE
9069 IF (IOPT.EQ.1) THEN
9070 IF (NUMDEC.GT.MODMAX-1) THEN
9071 CALL HWWARN('HWDBZ2',103)
9072 GOTO 999
9073 ENDIF
9074 IF (NPAIR.EQ.0) THEN
9075 IF (HWRGEN(1).GT.HALF) THEN
9076 MODTMP=MODBOS(NUMDEC+1)
9077 MODBOS(NUMDEC+1)=MODBOS(NUMDEC)
9078 MODBOS(NUMDEC)=MODTMP
9079 ENDIF
9080 NPAIR=NUMDEC
9081 ELSE
9082 NPAIR=0
9083 ENDIF
9084 ENDIF
9085C---SELECT USER'S CHOICE
9086 IF (IDBOS.EQ.200) THEN
9087 IF (MODBOS(NUMDEC).EQ.1) THEN
9088 I1=1
9089 I2=6
9090 ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
9091 I1=7
9092 I2=7
9093 ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
9094 I1=8
9095 I2=8
9096 ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
9097 I1=9
9098 I2=9
9099 ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
9100 I1=7
9101 I2=8
9102 ELSEIF (MODBOS(NUMDEC).EQ.6) THEN
9103 I1=10
9104 I2=12
9105 ELSEIF (MODBOS(NUMDEC).EQ.7) THEN
9106 I1=5
9107 I2=5
9108 ELSE
9109 I1=1
9110 I2=12
9111 ENDIF
9112 ELSE
9113 IF (MODBOS(NUMDEC).EQ.1) THEN
9114 I1=1
9115 I2=5
9116 ELSEIF (MODBOS(NUMDEC).EQ.2) THEN
9117 I1=6
9118 I2=6
9119 ELSEIF (MODBOS(NUMDEC).EQ.3) THEN
9120 I1=7
9121 I2=7
9122 ELSEIF (MODBOS(NUMDEC).EQ.4) THEN
9123 I1=8
9124 I2=8
9125 ELSEIF (MODBOS(NUMDEC).EQ.5) THEN
9126 I1=6
9127 I2=7
9128 ELSE
9129 I1=1
9130 I2=8
9131 ENDIF
9132 ENDIF
9133 NTRY = 0
9134 10 IDEC=HWRINT(I1,I2)
9135 NTRY = NTRY+1
9136 IF (HWRGEN(0).GT.BRMODE(IDEC,IDBOS-197).AND.I1.NE.I2) GOTO 10
9137 IF(MASS.LT.MSMODE(IDEC,IDBOS-197).AND.NTRY.LT.NBTRY) GOTO 10
9138 IF(NTRY.GE.NBTRY) THEN
9139 BR = ZERO
9140 RETURN
9141 ENDIF
9142 IFER=IDMODE(1,IDEC,IDBOS-197)
9143 IANT=IDMODE(2,IDEC,IDBOS-197)
9144C---CALCULATE BRANCHING RATIO
9145C (RESULT IS NOT WELL-DEFINED AFTER THE FIRST CALL OF A PAIR)
9146 BR=0
9147 DO 20 IDEC=I1,I2
9148 20 IF(MSMODE(IDEC,IDBOS-197).LT.MASS) BR=BR+BRMODE(IDEC,IDBOS-197)
9149 IF (IOPT.EQ.1) THEN
9150 IF (NPAIR.NE.0) THEN
9151 I1LST=I1
9152 I2LST=I2
9153 BRLST=BR
9154 ELSE
9155 BRCOM=0
9156 DO 30 IDEC=MAX(I1,I1LST),MIN(I2,I2LST)
9157 30 IF(MSMODE(IDEC,IDBOS-197).LT.MASS)
9158 & BRCOM=BRCOM+BRMODE(IDEC,IDBOS-197)
9159 BR=2*BR*BRLST - BRCOM**2
9160 ENDIF
9161 ENDIF
9162C---SET UP VECTOR AND AXIAL VECTOR COUPLINGS (NORMALIZED TO THE
9163C CONVENTION WHERE THE WEAK CURRENT IS G*(CV-CA*GAM5) )
9164 IF (IDBOS.EQ.200) THEN
9165 IF (IFER.LE.6) THEN
9166C Quark couplings
9167 CV=VFCH(IFER,1)
9168 CA=AFCH(IFER,1)
9169 ELSE
9170C lepton couplings
9171 JFER=IFER-110
9172 CV=VFCH(JFER,1)
9173 CA=AFCH(JFER,1)
9174 ENDIF
9175 CV=CV * FACZ
9176 CA=CA * FACZ
9177 ELSE
9178 CV=FACW
9179 CA=FACW
9180 ENDIF
9181 999 RETURN
9182 END
9183CDECK ID>, HWDCHK.
9184*CMZ :- -27/07/99 13.33.03 by Mike Seymour
9185*-- Author : Ian Knowles
9186C-----------------------------------------------------------------------
9187 SUBROUTINE HWDCHK(IDKY,L,IFGO)
9188C-----------------------------------------------------------------------
9189C Checks line L of decay table is compatible with decay of particle
9190C IDKY, tidies up the line and sets NPRODS.
9191C-----------------------------------------------------------------------
c63d70bc 9192 INCLUDE 'herwig65.inc'
65767955 9193 DOUBLE PRECISION EPS,QS,Q,DM
9194 INTEGER IDKY,L,IFAULT,I,ID,J
9195 LOGICAL IFGO
9196 PARAMETER (EPS=1.D-6)
9197 IFGO = .FALSE.
9198 IF (VTOCDK(IDKY).AND.VTORDK(IDKY)) THEN
9199 IFGO = .TRUE.
9200 RETURN
9201 ENDIF
9202 IFAULT=0
9203 QS=FLOAT(ICHRG(IDKY))
9204 IF (IDKY.LE.12.OR.(IDKY.GE.109.AND.IDKY.LE.120)
9205 & .OR.(IDKY.GE.209.AND.IDKY.LE.220)
9206 & .OR.(IDKY.GE.401.AND.IDKY.LE.424)) QS=QS/3.
9207 DM=RMASS(IDKY)
9208 NPRODS(L)=0
9209 DO 10 I=1,5
9210 ID=IDKPRD(I,L)
9211 IF (ID.LT.0.OR.ID.EQ.20.OR.ID.GT.NRES) THEN
9212 WRITE(6,20) L,RNAME(IDKY),(RNAME(IDKPRD(J,L)),J=1,5)
9213 IFAULT=IFAULT+1
9214 ELSEIF (ID.NE.0) THEN
9215 IF (VTORDK(ID)) THEN
9216 WRITE(6,30) L,RNAME(IDKY),(RNAME(IDKPRD(J,L)),J=1,5),RNAME(ID)
9217 IFAULT=IFAULT+1
9218 ENDIF
9219 NPRODS(L)=NPRODS(L)+1
9220 IDKPRD(NPRODS(L),L)=ID
9221 Q=FLOAT(ICHRG(ID))
9222 IF (ID.LE.12.OR.(ID.GE.109.AND.ID.LE.120)
9223 & .OR.(ID.GE.209.AND.ID.LE.220)
9224 & .OR.(ID.GE.401.AND.ID.LE.424)) Q=Q/3.
9225 QS=QS-Q
9226 DM=DM-RMASS(ID)
9227 ENDIF
9228 10 CONTINUE
9229C print any warnings
9230 IF (NPRODS(L).EQ.0) THEN
9231 WRITE(6,20) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5)
9232 IFAULT=IFAULT+1
9233 ELSE
9234 IF (ABS(QS).GT.EPS) THEN
9235 WRITE(6,40) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5),QS
9236 IFAULT=IFAULT+1
9237 ENDIF
9238C--modification so doesn't remove H --> W*W* Z*Z* modes
9239 IF (DM.LT.ZERO.AND..NOT.
9240 & (FOURB.AND.IDK(L).GE.203.AND.IDK(L).LE.205.AND.
9241 & IDKPRD(1,L).GE.198.AND.IDKPRD(2,L).LE.200.AND.
9242 & IDKPRD(2,L).GE.198.AND.IDKPRD(2,L).LE.200)) THEN
9243 WRITE(6,50) L,RNAME(IDKY),(RNAME(IDKPRD(I,L)),I=1,5),DM
9244 IFAULT=IFAULT+1
9245 ENDIF
9246 ENDIF
9247 20 FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
9248 & 1X,'contains no or unrecognised decay product(s)')
9249 30 FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
9250 & 1X,'contains decay product ',A8,' which is vetoed')
9251 40 FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
9252 & 1X,'violates charge conservation, Qin-Qout= ',F6.3)
9253 50 FORMAT(1X,'Line ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
9254 & 1X,'is kinematically not allowed, Min-Mout= ',F10.3)
9255 IF (IFAULT.NE.0) THEN
9256 IFGO = .TRUE.
9257 RETURN
9258 ELSE
9259 RETURN
9260 ENDIF
9261 END
9262CDECK ID>, HWDCLE.
9263*CMZ :- -28/01/92 12.34.44 by Mike Seymour
9264*-- Author : Luca Stanco
9265C-----------------------------------------------------------------------
9266 SUBROUTINE HWDCLE(IHEP)
9267C-----------------------------------------------------------------------
9268C INTERFACE TO QQ-CLEO MONTE CARLO (LS 11/12/91)
9269C-----------------------------------------------------------------------
c63d70bc 9270 INCLUDE 'herwig65.inc'
65767955 9271 INTEGER IHEP,IIHEP,NHEPHF,QQLMAT
9272 LOGICAL QQLERR
9273 CHARACTER*8 NAME
9274 EXTERNAL QQLMAT
9275C---QQ-CLEO COMMON'S
9276C*** MCPARS.INC
9277 INTEGER MCTRK, NTRKS, MCVRTX, NVTXS, MCHANS, MCDTRS, MPOLQQ
9278 INTEGER MCNUM, MCSTBL, MCSTAB, MCTLQQ, MDECQQ
9279 INTEGER MHLPRB, MHLLST, MHLANG, MCPLST, MFDECA
9280 PARAMETER (MCTRK = 512)
9281 PARAMETER (NTRKS = MCTRK)
9282 PARAMETER (MCVRTX = 256)
9283 PARAMETER (NVTXS = MCVRTX)
9284 PARAMETER (MCHANS = 4000)
9285 PARAMETER (MCDTRS = 8000)
9286 PARAMETER (MPOLQQ = 300)
9287 PARAMETER (MCNUM = 500)
9288 PARAMETER (MCSTBL = 40)
9289 PARAMETER (MCSTAB = 512)
9290 PARAMETER (MCTLQQ = 100)
9291 PARAMETER (MDECQQ = 300)
9292 PARAMETER (MHLPRB = 500)
9293 PARAMETER (MHLLST = 1000)
9294 PARAMETER (MHLANG = 500)
9295 PARAMETER (MCPLST = 200)
9296 PARAMETER (MFDECA = 5)
9297C*** MCPROP.INC
9298 REAL AMASS, CHARGE, CTAU, SPIN, RWIDTH, RMASMN, RMASMX
9299 REAL RMIXPP, RCPMIX
9300 INTEGER NPMNQQ, NPMXQQ, IDMC, INVMC, LPARTY, CPARTY
9301 INTEGER IMIXPP, ICPMIX
9302 COMMON/MCMAS1/
9303 * NPMNQQ, NPMXQQ,
9304 * AMASS(-20:MCNUM), CHARGE(-20:MCNUM), CTAU(-20:MCNUM),
9305 * IDMC(-20:MCNUM), SPIN(-20:MCNUM),
9306 * RWIDTH(-20:MCNUM), RMASMN(-20:MCNUM), RMASMX(-20:MCNUM),
9307 * LPARTY(-20:MCNUM), CPARTY(-20:MCNUM),
9308 * IMIXPP(-20:MCNUM), RMIXPP(-20:MCNUM),
9309 * ICPMIX(-20:MCNUM), RCPMIX(-20:MCNUM),
9310 * INVMC(0:MCSTBL)
9311C
9312 INTEGER NPOLQQ, IPOLQQ
9313 COMMON/MCPOL1/
9314 * NPOLQQ, IPOLQQ(5,MPOLQQ)
9315C
9316 CHARACTER QNAME*10, PNAME*10
9317 COMMON/MCNAMS/
9318 * QNAME(37), PNAME(-20:MCNUM)
9319C
9320C*** MCCOMS.INC
9321 INTEGER NCTLQQ, NDECQQ, IVRSQQ, IORGQQ, IRS1QQ
9322 INTEGER IEVTQQ, IRUNQQ, IBMRAD
9323 INTEGER NTRKMC, QQNTRK, NSTBMC, NSTBQQ, NCHGMC, NCHGQQ
9324 INTEGER IRANQQ, IRANMC, IRANCC, IRS2QQ
9325 INTEGER IPFTQQ, IPCDQQ, IPRNTV, ITYPEV, IDECSV, IDAUTV
9326 INTEGER ISTBMC, NDAUTV
9327 INTEGER IVPROD, IVDECA
9328 REAL BFLDQQ
9329 REAL ENERQQ, BEAMQQ, BMPSQQ, BMNGQQ, EWIDQQ, BWPSQQ, BWNGQQ
9330 REAL BPOSQQ, BSIZQQ
9331 REAL ECM, P4CMQQ, P4PHQQ, ENERNW, BEAMNW, BEAMP, BEAMN
9332 REAL PSAV, P4QQ, HELCQQ
9333 CHARACTER DATEQQ*20, TIMEQQ*20, FOUTQQ*80, FCTLQQ*80, FDECQQ*80
9334 CHARACTER FGEOQQ*80
9335 CHARACTER CCTLQQ*80, CDECQQ*80
9336C
9337 COMMON/MCCM1A/
9338 * NCTLQQ, NDECQQ, IVRSQQ, IORGQQ, IRS1QQ(3), BFLDQQ,
9339 * ENERQQ, BEAMQQ, BMPSQQ, BMNGQQ, EWIDQQ, BWPSQQ, BWNGQQ,
9340 * BPOSQQ(3), BSIZQQ(3),
9341 * IEVTQQ, IRUNQQ,
9342 * IBMRAD, ECM, P4CMQQ(4), P4PHQQ(4),
9343 * ENERNW, BEAMNW, BEAMP, BEAMN,
9344 * NTRKMC, QQNTRK, NSTBMC, NSTBQQ, NCHGMC, NCHGQQ,
9345 * IRANQQ(2), IRANMC(2), IRANCC(2), IRS2QQ(5),
9346 * IPFTQQ(MCTRK), IPCDQQ(MCTRK), IPRNTV(MCTRK), ITYPEV(MCTRK,2),
9347 * IDECSV(MCTRK), IDAUTV(MCTRK), ISTBMC(MCTRK), NDAUTV(MCTRK),
9348 * IVPROD(MCTRK), IVDECA(MCTRK),
9349 * PSAV(MCTRK,4), HELCQQ(MCTRK), P4QQ(4,MCTRK)
9350C
9351 COMMON/MCCM1B/
9352 * DATEQQ, TIMEQQ, FOUTQQ, FCTLQQ, FDECQQ, FGEOQQ,
9353 * CCTLQQ(MCTLQQ), CDECQQ(MDECQQ)
9354C
9355 INTEGER NVRTX, ITRKIN, NTRKOU, ITRKOU, IVKODE
9356 REAL XVTX, TVTX, RVTX
9357 COMMON/MCCM2/
9358 * NVRTX, XVTX(MCVRTX,3), TVTX(MCVRTX), RVTX(MCVRTX),
9359 * ITRKIN(MCVRTX), NTRKOU(MCVRTX), ITRKOU(MCVRTX),
9360 * IVKODE(MCVRTX)
9361C*** MCGEN.INC
9362 INTEGER QQIST,QQIFR,QQN,QQK,QQMESO,QQNC,QQKC,QQLASTN
9363 REAL QQPUD,QQPS1,QQSIGM,QQMAS,QQPAR,QQCMIX,QQCND,QQBSPI,QQBSYM,QQP
9364 REAL QQPC,QQCZF
9365C
9366 COMMON/DATA1/QQIST,QQIFR,QQPUD,QQPS1,QQSIGM,QQMAS(15),QQPAR(25)
9367 COMMON/DATA2/QQCZF(15),QQMESO(36),QQCMIX(6,2)
9368 COMMON/DATA3/QQCND(3)
9369 COMMON/DATA5/QQBSPI(5),QQBSYM(3)
9370 COMMON/JET/QQN,QQK(250,2),QQP(250,5),QQNC,QQKC(10),QQPC(10,4),
9371 * QQLASTN
9372C---
9373 IF(FSTEVT) THEN
9374C---INITIALIZE QQ-CLEO
9375 CALL QQINIT(QQLERR)
9376 IF(QQLERR) CALL HWWARN('HWDEUR',500)
9377 ENDIF
9378C---CONSTRUCT THE HADRON FOR QQ-CLEO
9379C NOTE: THE IDPDG CODE IS PROVIDED THROUGH THE QQLMAT ROUTINE
9380C FROM THE CLEO PACKAGE (QQ-CLEO <--> IDPDG CODE TRANSFORMATION)
9381 QQN=1
9382 IDHEP(IHEP)=IDPDG(IDHW(IHEP))
9383 QQK(1,1)=0
9384 QQK(1,2)=QQLMAT(IDHEP(IHEP),1)
9385 QQP(1,1)=SNGL(PHEP(1,IHEP))
9386 QQP(1,2)=SNGL(PHEP(2,IHEP))
9387 QQP(1,3)=SNGL(PHEP(3,IHEP))
9388 QQP(1,5)=AMASS(QQK(1,2))
9389 QQP(1,4)=SQRT(QQP(1,5)**2+QQP(1,1)**2+QQP(1,2)**2+QQP(1,3)**2)
9390C---LET QQ-CLEO DO THE JOB
9391 QQNTRK=0
9392 NVRTX=0
9393 CALL DECADD(.FALSE.)
9394C---UPDATE THE HERWIG TABLE : LOOP OVER QQN-CLEO FINAL PARTICLES
9395 DO 40 IIHEP=1,QQN
9396 NHEP=NHEP+1
9397 ISTHEP(NHEP)=198
9398 IF(ITYPEV(IIHEP,2).GE.0) ISTHEP(NHEP)=1
9399 IDHEP(NHEP)=QQLMAT(ITYPEV(IIHEP,1),2)
9400 CALL HWUIDT(1,IDHEP(NHEP),IDHW(NHEP),NAME)
9401 IF(IIHEP.EQ.1) THEN
9402 ISTHEP(IHEP)=199
9403 JDAHEP(1,IHEP)=NHEP
9404 JDAHEP(2,IHEP)=NHEP
9405 ISTHEP(NHEP)=199
9406 NHEPHF=NHEP
9407 JMOHEP(1,NHEP)=IHEP
9408 JMOHEP(2,NHEP)=IHEP
9409 ELSE
9410 JMOHEP(1,NHEP)=IPRNTV(IIHEP)+NHEPHF-1
9411 JMOHEP(2,NHEP)=NHEPHF
9412 ENDIF
9413 JDAHEP(1,NHEP)=0
9414 JDAHEP(2,NHEP)=0
9415 IF(NDAUTV(IIHEP).GT.0) THEN
9416 JDAHEP(1,NHEP)=IDAUTV(IIHEP)+NHEPHF-1
9417 JDAHEP(2,NHEP)=JDAHEP(1,NHEP)+NDAUTV(IIHEP)-1
9418 ENDIF
9419 PHEP(1,NHEP)=QQP(IIHEP,1)
9420 PHEP(2,NHEP)=QQP(IIHEP,2)
9421 PHEP(3,NHEP)=QQP(IIHEP,3)
9422 PHEP(4,NHEP)=QQP(IIHEP,4)
9423 PHEP(5,NHEP)=QQP(IIHEP,5)
9424 VHEP(1,NHEP)=XVTX(IVPROD(IIHEP),1)
9425 VHEP(2,NHEP)=XVTX(IVPROD(IIHEP),2)
9426 VHEP(3,NHEP)=XVTX(IVPROD(IIHEP),3)
9427 VHEP(4,NHEP)=0.
9428 40 CONTINUE
9429 END
9430CDECK ID>, HWDEUR.
9431*CMZ :- -28/01/92 12.34.44 by Mike Seymour
9432*-- Author : Luca Stanco
9433C-----------------------------------------------------------------------
9434 SUBROUTINE HWDEUR(IHEP)
9435C-----------------------------------------------------------------------
9436C INTERFACE TO EURODEC PACKAGE (LS 10/29/91)
9437C-----------------------------------------------------------------------
c63d70bc 9438 INCLUDE 'herwig65.inc'
65767955 9439 INTEGER IHEP,IIHEP,NHEPHF,IEUPDG,IPDGEU
9440 CHARACTER*8 NAME
9441C---EURODEC COMMON'S : INITIAL INPUT
9442 INTEGER EULUN0,EULUN1,EULUN2,EURUN,EUEVNT
9443 CHARACTER*4 EUDATD,EUTIT
9444 REAL AMINIE(12),EUWEI
9445 COMMON/INPOUT/EULUN0,EULUN1,EULUN2
9446 COMMON/FILNAM/EUDATD,EUTIT
9447 COMMON/HVYINI/AMINIE
9448 COMMON/RUNINF/EURUN,EUEVNT,EUWEI
9449C---EURODEC WORKING COMMON'S
9450 INTEGER NPMAX,NTMAX
9451 PARAMETER (NPMAX=18,NTMAX=2000)
9452 INTEGER EUNP,EUIP(NPMAX),EUPHEL(NPMAX),EUTEIL,EUINDX(NTMAX),
9453 & EUORIG(NTMAX),EUDCAY(NTMAX),EUTHEL(NTMAX)
9454 REAL EUAPM(NPMAX),EUPCM(5,NPMAX),EUPVTX(3,NPMAX),EUPTEI(5,NTMAX),
9455 & EUSECV(3,NTMAX)
9456 COMMON/MOMGEN/EUNP,EUIP,EUAPM,EUPCM,EUPHEL,EUPVTX
9457 COMMON/RESULT/EUTEIL,EUPTEI,EUINDX,EUORIG,EUDCAY,EUTHEL,EUSECV
9458C---EURODEC COMMON'S FOR DECAY PROPERTIES
9459 INTEGER NGMAX,NCMAX
9460 PARAMETER (NGMAX=400,NCMAX=9000)
9461 INTEGER EUNPA,EUIPC(NGMAX),EUIPDG(NGMAX),EUIDP(NGMAX),
9462 & EUCONV(NCMAX)
9463 REAL EUPM(NGMAX),EUPLT(NGMAX)
9464 COMMON/PCTABL/EUNPA,EUIPC,EUIPDG,EUPM,EUPLT,EUIDP
9465 COMMON/CONVRT/EUCONV
9466C---
9467 IF(FSTEVT) THEN
9468C---CHANGE HERE THE DEFAULT VALUES OF EURODEC COMMON'S
9469C
9470C---INITIALIZE EURODEC COMMON'S
9471CC CALL EUDCIN
9472C---INITIALIZE EURODEC
9473 CALL EUDINI
9474 ENDIF
9475C---CONSTRUCT THE HADRON FOR EURODEC FROM ID1,ID2
9476 EUNP=1
9477 IDHEP(IHEP)=IDPDG(IDHW(IHEP))
9478 EUIP(1)=IPDGEU(IDHEP(IHEP))
9479 EUAPM(1)=EUPM(EUCONV(IABS(EUIP(1))))
9480 EUPCM(1,1)=SNGL(PHEP(1,IHEP))
9481 EUPCM(2,1)=SNGL(PHEP(2,IHEP))
9482 EUPCM(3,1)=SNGL(PHEP(3,IHEP))
9483 EUPCM(5,1)=SQRT(EUPCM(1,1)**2+EUPCM(2,1)**2+EUPCM(3,1)**2)
9484 EUPCM(4,1)=SQRT(EUPCM(5,1)**2+EUAPM(1)**2)
9485C NOT POLARIZED HADRONS
9486 EUPHEL(1)=0
9487C HADRONS START FROM PRIMARY VERTEX
9488 EUPVTX(1,1)=0.
9489 EUPVTX(2,1)=0.
9490 EUPVTX(3,1)=0.
9491C---LET EURODEC DO THE JOB
9492 EUTEIL=0
9493 CALL FRAGMT(1,1,0)
9494C---UPDATE THE HERWIG TABLE : LOOP OVER N-EURODEC FINAL PARTICLES
9495 DO 40 IIHEP=1,EUTEIL
9496 NHEP=NHEP+1
9497 ISTHEP(NHEP)=198
9498 IF(EUDCAY(IIHEP).EQ.0) ISTHEP(NHEP)=1
9499 IDHEP(NHEP)=IEUPDG(EUINDX(IIHEP))
9500 CALL HWUIDT(1,IDHEP(NHEP),IDHW(NHEP),NAME)
9501 IF(IIHEP.EQ.1) THEN
9502 ISTHEP(IHEP)=199
9503 JDAHEP(1,IHEP)=NHEP
9504 JDAHEP(2,IHEP)=NHEP
9505 ISTHEP(NHEP)=199
9506 NHEPHF=NHEP
9507 JMOHEP(1,NHEP)=IHEP
9508 JMOHEP(2,NHEP)=IHEP
9509 JDAHEP(1,NHEP)=EUDCAY(IIHEP)/10000+NHEPHF-1
9510 JDAHEP(2,NHEP)=MOD(EUDCAY(IIHEP),10000)+NHEPHF-1
9511 ELSE
9512 JMOHEP(1,NHEP)=MOD(EUORIG(IIHEP),10000)+NHEPHF-1
9513 JMOHEP(2,NHEP)=NHEPHF
9514 JDAHEP(1,NHEP)=EUDCAY(IIHEP)/10000+NHEPHF-1
9515 JDAHEP(2,NHEP)=MOD(EUDCAY(IIHEP),10000)+NHEPHF-1
9516 ENDIF
9517 PHEP(1,NHEP)=EUPTEI(1,IIHEP)
9518 PHEP(2,NHEP)=EUPTEI(2,IIHEP)
9519 PHEP(3,NHEP)=EUPTEI(3,IIHEP)
9520 PHEP(4,NHEP)=EUPTEI(4,IIHEP)
9521 PHEP(5,NHEP)=EUPTEI(5,IIHEP)
9522 VHEP(1,NHEP)=EUSECV(1,IIHEP)
9523 VHEP(2,NHEP)=EUSECV(2,IIHEP)
9524 VHEP(3,NHEP)=EUSECV(3,IIHEP)
9525 VHEP(4,NHEP)=0.
9526 IF (IIHEP.GT.NTMAX) THEN
9527 CALL HWWARN('HWDEUR',99)
9528 GOTO 999
9529 ENDIF
9530 40 CONTINUE
9531 999 RETURN
9532 END
9533CDECK ID>, HWDFOR.
9534*CMZ :- -01/04/99 19.52.44 by Mike Seymour
9535*-- Author : Ian Knowles
9536C-----------------------------------------------------------------------
9537 SUBROUTINE HWDFOR(P0,P1,P2,P3,P4)
9538C-----------------------------------------------------------------------
9539C Generates 4-body decay 0->1+2+3+4 using pure phase space
9540C-----------------------------------------------------------------------
c63d70bc 9541 INCLUDE 'herwig65.inc'
65767955 9542 DOUBLE PRECISION HWRGEN,P0(5),P1(5),P2(5),P3(5),P4(5),B,C,AA,BB,
9543 & CC,DD,EE,TT,S1,RS1,FF,S2,PP,QQ,RR,P1CM,P234(5),P2CM,P34(5),P3CM
9544 INTEGER NTRY
9545 EXTERNAL HWRGEN
9546 B=P0(5)-P1(5)
9547 C=P2(5)+P3(5)+P4(5)
9548 IF (B.LT.C) THEN
9549 CALL HWWARN('HWDFOR',100)
9550 GOTO 999
9551 ENDIF
9552 AA=(P0(5)+P1(5))**2
9553 BB=B**2
9554 CC=C**2
9555 DD=(P3(5)+P4(5))**2
9556 EE=(P3(5)-P4(5))**2
9557 TT=(B-C)*P0(5)**7/16
9558C Select squared masses S1 and S2 of 234 and 34 subsystems
9559 NTRY=0
9560 10 NTRY=NTRY+1
9561 IF(NTRY.GT.NDETRY) THEN
9562 CALL HWWARN('HWDFOR',101)
9563 GOTO 999
9564 ENDIF
9565 S1=BB+HWRGEN(1)*(CC-BB)
9566 RS1=SQRT(S1)
9567 FF=(RS1-P2(5))**2
9568 S2=DD+HWRGEN(2)*(FF-DD)
9569 PP=(AA-S1)*(BB-S1)
9570 QQ=((RS1+P2(5))**2-S2)*(FF-S2)/S1
9571 RR=(S2-DD)*(S2-EE)/S2
9572 IF (PP*QQ*RR*(FF-DD)**2.LT.TT*S1*S2*HWRGEN(3)**2) GOTO 10
9573C Do two body decays: 0-->1+234, 234-->2+34 and 34-->3+4
9574 P1CM=SQRT(PP/4)/P0(5)
9575 P234(5)=RS1
9576 P2CM=SQRT(QQ/4)
9577 P34(5)=SQRT(S2)
9578 P3CM=SQRT(RR/4)
9579 CALL HWDTWO(P0 ,P1,P234,P1CM,TWO,.TRUE.)
9580 CALL HWDTWO(P234,P2,P34 ,P2CM,TWO,.TRUE.)
9581 CALL HWDTWO(P34 ,P3,P4 ,P3CM,TWO,.TRUE.)
9582 999 RETURN
9583 END
9584CDECK ID>, HWDFIV.
9585*CMZ :- -01/04/99 19.52.44 by Mike Seymour
9586*-- Author : Ian Knowles
9587C-----------------------------------------------------------------------
9588 SUBROUTINE HWDFIV(P0,P1,P2,P3,P4,P5)
9589C-----------------------------------------------------------------------
9590C Generates 5-body decay 0->1+2+3+4+5 using pure phase space
9591C-----------------------------------------------------------------------
c63d70bc 9592 INCLUDE 'herwig65.inc'
65767955 9593 DOUBLE PRECISION HWRGEN,P0(5),P1(5),P2(5),P3(5),P4(5),P5(5),B,C,
9594 & AA,BB,CC,DD,EE,FF,TT,S1,RS1,GG,S2,RS2,HH,S3,PP,QQ,RR,SS,P1CM,
9595 & P2345(5),P2CM,P345(5),P3CM,P45(5),P4CM
9596 INTEGER NTRY
9597 EXTERNAL HWRGEN
9598 B=P0(5)-P1(5)
9599 C=P2(5)+P3(5)+P4(5)+P5(5)
9600 IF (B.LT.C) THEN
9601 CALL HWWARN('HWDFIV',100)
9602 GOTO 999
9603 ENDIF
9604 AA=(P0(5)+P1(5))**2
9605 BB=B**2
9606 CC=C**2
9607 DD=(P3(5)+P4(5)+P5(5))**2
9608 EE=(P4(5)+P5(5))**2
9609 FF=(P4(5)-P5(5))**2
9610 TT=(B-C)*P0(5)**11/729
9611C Select squared masses S1, S2 and S3 of 2345, 345 and 45 subsystems
9612 NTRY=0
9613 10 NTRY=NTRY+1
9614 IF(NTRY.GT.NDETRY) THEN
9615 CALL HWWARN('HWDFIV',101)
9616 GOTO 999
9617 ENDIF
9618 S1=BB+HWRGEN(1)*(CC-BB)
9619 RS1=SQRT(S1)
9620 GG=(RS1-P2(5))**2
9621 S2=DD+HWRGEN(2)*(GG-DD)
9622 RS2=SQRT(S2)
9623 HH=(RS2-P3(5))**2
9624 S3=EE+HWRGEN(3)*(HH-EE)
9625 PP=(AA-S1)*(BB-S1)
9626 QQ=((RS1+P2(5))**2-S2)*(GG-S2)/S1
9627 RR=((RS2+P3(5))**2-S3)*(HH-S3)/S2
9628 SS=(S3-EE)*(S3-FF)/S3
9629 IF (PP*QQ*RR*SS*((GG-DD)*(HH-EE))**2.LT.TT*S1*S2*S3*HWRGEN(4)**2)
9630 & GOTO 10
9631C Do two body decays: 0-->1+2345, 2345-->2+345, 345-->3+45 and 45-->4+5
9632 P1CM=SQRT(PP/4)/P0(5)
9633 P2345(5)=RS1
9634 P2CM=SQRT(QQ/4)
9635 P345(5)=RS2
9636 P3CM=SQRT(RR/4)
9637 P45(5)=SQRT(S3)
9638 P4CM=SQRT(SS/4)
9639 CALL HWDTWO(P0 ,P1,P2345,P1CM,TWO,.TRUE.)
9640 CALL HWDTWO(P2345,P2,P345 ,P2CM,TWO,.TRUE.)
9641 CALL HWDTWO(P345 ,P3,P45 ,P3CM,TWO,.TRUE.)
9642 CALL HWDTWO(P45 ,P4,P5 ,P4CM,TWO,.TRUE.)
9643 999 RETURN
9644 END
9645CDECK ID>, HWDHAD.
9646*CMZ :- -26/04/91 11.11.54 by Peter Richardson
9647*-- Author : Ian Knowles, Bryan Webber & Mike Seymour
9648C-----------------------------------------------------------------------
9649 SUBROUTINE HWDHAD
9650C-----------------------------------------------------------------------
9651C GENERATES DECAYS OF UNSTABLE HADRONS AND LEPTONS
9652C Modified for TAUOLA interface 16/10/01 PR
9653C-----------------------------------------------------------------------
c63d70bc 9654 INCLUDE 'herwig65.inc'
65767955 9655 COMMON/FFS/TB,BT
9656 COMMON/SFF/IT1,IB1,IT2,IB2
9657 DOUBLE PRECISION TB,BT
9658 INTEGER IT1,IB1,IT2,IB2
9659 DOUBLE PRECISION HWRGEN,HWULDO,RN,BF,COSANG,RSUM,DIST(4),VERTX(4),
9660 & PMIX,WTMX,WTMX2,XS,DOT1,DOT2,HWDPWT,HWDWWT,HWDHWT,XXX,YYY
9661 INTEGER IHEP,ID,MHEP,IDM,I,IDS,IM,MO,IPDG
9662 LOGICAL STABLE
9663 EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWDHWT,HWULDO
9664 IF (IERROR.NE.0) RETURN
9665 DO 100 IHEP=1,NMXHEP
9666 IF (IHEP.GT.NHEP) THEN
9667 ISTAT=90
9668 RETURN
9669 ELSEIF (ISTHEP(IHEP).EQ.120 .AND.
9670 & JDAHEP(1,IHEP).EQ.IHEP.AND.JDAHEP(2,IHEP).EQ.IHEP) THEN
9671C---COPY COLOUR SINGLET CMF
9672 NHEP=NHEP+1
9673 IF (NHEP.GT.NMXHEP) THEN
9674 CALL HWWARN('HWDHAD',100)
9675 GOTO 999
9676 ENDIF
9677 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
9678 CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
9679 IDHW(NHEP)=IDHW(IHEP)
9680 IDHEP(NHEP)=IDHEP(IHEP)
9681 ISTHEP(NHEP)=190
9682 JMOHEP(1,NHEP)=IHEP
9683 JMOHEP(2,NHEP)=NHEP
9684 JDAHEP(2,NHEP)=NHEP
9685 JDAHEP(1,IHEP)=NHEP
9686 JDAHEP(2,IHEP)=NHEP
9687 ELSEIF (ISTHEP(IHEP).GE.190.AND.ISTHEP(IHEP).LE.193) THEN
9688C---FIRST CHECK FOR STABILITY
9689 ID=IDHW(IHEP)
9690 IF (RSTAB(ID)) THEN
9691 ISTHEP(IHEP)=1
9692 JDAHEP(1,IHEP)=0
9693 JDAHEP(2,IHEP)=0
9694C---SPECIAL FOR GAUGE BOSON DECAY
9695 IF (ID.GE.198.AND.ID.LE.200) CALL HWDBOS(IHEP)
9696C---SPECIAL FOR HIGGS BOSON DECAY
9697 IF (ID.EQ.201) CALL HWDHIG(ZERO)
9698 ELSE
9699C---UNSTABLE.
9700C Calculate position of decay vertex
9701 IF (DKLTM(ID).EQ.ZERO) THEN
9702 CALL HWVEQU(4,VHEP(1,IHEP),VERTX)
9703 MHEP=IHEP
9704 IDM=ID
9705 ELSE
9706 CALL HWUDKL(ID,PHEP(1,IHEP),DIST)
9707 CALL HWVSUM(4,VHEP(1,IHEP),DIST,VERTX)
9708 IF (MAXDKL) THEN
9709 CALL HWDXLM(VERTX,STABLE)
9710 IF (STABLE) THEN
9711 ISTHEP(IHEP)=1
9712 JDAHEP(1,IHEP)=0
9713 JDAHEP(2,IHEP)=0
9714 GOTO 100
9715 ENDIF
9716 ENDIF
9717 IF (MIXING.AND.(ID.EQ.221.OR.ID.EQ.223.OR.
9718 & ID.EQ.245.OR.ID.EQ.247)) THEN
9719C Select flavour of decaying b-meson allowing for flavour oscillation
9720 IDS=MOD(ID,3)
9721 XXX=XMRCT(IDS)*DIST(4)/PHEP(4,IHEP)
9722 YYY=YMRCT(IDS)*DIST(4)/PHEP(4,IHEP)
9723 IF (ABS(YYY).LT.10) THEN
9724 PMIX=HALF*(ONE-COS(XXX)/COSH(YYY))
9725 ELSE
9726 PMIX=HALF
9727 ENDIF
9728 IF (HWRGEN(1).LE.PMIX) THEN
9729 IF (ID.LE.223) THEN
9730 IDM=ID+24
9731 ELSE
9732 IDM=ID-24
9733 ENDIF
9734 ELSE
9735 IDM=ID
9736 ENDIF
9737C Introduce a decaying neutral b-meson
9738 IF (NHEP+1.GT.NMXHEP) THEN
9739 CALL HWWARN('HWDHAD',101)
9740 GOTO 999
9741 ENDIF
9742 MHEP=NHEP+1
9743 ISTHEP(MHEP)=ISTHEP(IHEP)
9744 ISTHEP(IHEP)=200
9745 JDAHEP(1,IHEP)=MHEP
9746 JDAHEP(2,IHEP)=MHEP
9747 IDHW(MHEP)=IDM
9748 IDHEP(MHEP)=IDPDG(IDM)
9749 JMOHEP(1,MHEP)=IHEP
9750 JMOHEP(2,MHEP)=JMOHEP(2,IHEP)
9751 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,MHEP))
9752 CALL HWVEQU(4,VERTX,VHEP(1,MHEP))
9753 NHEP=NHEP+1
9754 ELSE
9755 MHEP=IHEP
9756 IDM=ID
9757 ENDIF
9758 ENDIF
9759C Use CLEO/EURODEC packages for b-hadrons if requested
9760 IF ((IDM.GE.221.AND.IDM.LE.231).OR.
9761 & (IDM.GE.245.AND.IDM.LE.254)) THEN
9762 IF (BDECAY.EQ.'CLEO') THEN
9763 CALL HWDCLE(MHEP)
9764 GOTO 100
9765 ELSEIF (BDECAY.EQ.'EURO') THEN
9766 CALL HWDEUR(MHEP)
9767 GOTO 100
9768 ENDIF
9769 ENDIF
9770C Use TAUOLA package for tau decays if requested
9771 IF((IDM.EQ.125.OR.IDM.EQ.131).AND.TAUDEC.EQ.'TAUOLA') THEN
9772 CALL HWDTAU(1,MHEP,0.0D0)
9773 GOTO 100
9774 ENDIF
9775C Choose decay mode
9776 ISTHEP(MHEP)=ISTHEP(MHEP)+5
9777 RN=HWRGEN(2)
9778 BF=0.
9779 IM=LSTRT(IDM)
9780 DO 10 I=1,NMODES(IDM)
9781 BF=BF+BRFRAC(IM)
9782 IF (BF.GE.RN) GOTO 20
9783 10 IM=LNEXT(IM)
9784 CALL HWWARN('HWDHAD',50)
9785 GOTO 20
9786 20 IF ((IDKPRD(1,IM).GE.1.AND.IDKPRD(1,IM).LE.13).OR.
9787 & (IDKPRD(3,IM).GE.1.AND.IDKPRD(3,IM).LE.13)) THEN
9788C Partonic decay of a heavy-(b,c)-hadron, store details
9789 NQDK=NQDK+1
9790 IF (NQDK.GT.NMXQDK) THEN
9791 CALL HWWARN('HWDHAD',102)
9792 GOTO 999
9793 ENDIF
9794 LOCQ(NQDK)=MHEP
9795 IMQDK(NQDK)=IM
9796 CALL HWVEQU(4,VERTX,VTXQDK(1,NQDK))
9797 GOTO 100
9798 ELSE
9799C Exclusive decay, add decay products to event record
9800 IF (NHEP+NPRODS(IM).GT.NMXHEP) THEN
9801 CALL HWWARN('HWDHAD',103)
9802 GOTO 999
9803 ENDIF
9804 JDAHEP(1,MHEP)=NHEP+1
9805 DO 30 I=1,NPRODS(IM)
9806 NHEP=NHEP+1
9807 IDHW(NHEP)=IDKPRD(I,IM)
9808 IDHEP(NHEP)=IDPDG(IDKPRD(I,IM))
9809 ISTHEP(NHEP)=193
9810 JMOHEP(1,NHEP)=MHEP
9811 JMOHEP(2,NHEP)=JMOHEP(2,MHEP)
9812 PHEP(5,NHEP)=RMASS(IDKPRD(I,IM))
9813 30 CALL HWVEQU(4,VERTX,VHEP(1,NHEP))
9814 JDAHEP(2,MHEP)=NHEP
9815 ENDIF
9816C Next choose momenta:
9817 IF (NPRODS(IM).EQ.1) THEN
9818C 1-body decay: K0(BR) --> K0S,K0L
9819 CALL HWVEQU(4,PHEP(1,MHEP),PHEP(1,NHEP))
9820 ELSEIF (NPRODS(IM).EQ.2) THEN
9821C 2-body decay
9822C---SPECIAL TREATMENT OF POLARIZED MESONS
9823 COSANG=TWO
9824 IF (ID.EQ.IDHW(JMOHEP(1,MHEP))) THEN
9825 MO=JMOHEP(1,MHEP)
9826 RSUM=0
9827 DO 40 I=1,3
9828 40 RSUM=RSUM+RHOHEP(I,MO)
9829 IF (RSUM.GT.ZERO) THEN
9830 RSUM=RSUM*HWRGEN(3)
9831 IF (RSUM.LT.RHOHEP(1,MO)) THEN
9832C---(1+COSANG)**2
9833 COSANG=MAX(HWRGEN(4),HWRGEN(5),HWRGEN(6))*TWO-ONE
9834 ELSEIF (RSUM.LT.RHOHEP(1,MO)+RHOHEP(2,MO)) THEN
9835C---1-COSANG**2
9836 COSANG=2*COS((ACOS(HWRGEN(7)*TWO-ONE)+PIFAC)/THREE)
9837 ELSE
9838C---(1-COSANG)**2
9839 COSANG=MIN(HWRGEN(8),HWRGEN(9),HWRGEN(10))*TWO-ONE
9840 ENDIF
9841 ENDIF
9842 ENDIF
9843 CALL HWDTWO(PHEP(1,MHEP),PHEP(1,NHEP-1),
9844 & PHEP(1,NHEP),CMMOM(IM),COSANG,.FALSE.)
9845 ELSEIF (NPRODS(IM).EQ.3) THEN
9846C 3-body decay
9847 IF (NME(IM).EQ.100) THEN
9848C Use free massless (V-A)*(V-A) Matrix Element
9849 CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-1),PHEP(1,NHEP-2),
9850 & PHEP(1,NHEP),HWDWWT)
9851 ELSEIF (NME(IM).EQ.101) THEN
9852C Use bound massless (V-A)*(V-A) Matrix Element
9853 WTMX=((PHEP(5,MHEP)-PHEP(5,NHEP))
9854 & *(PHEP(5,MHEP)+PHEP(5,NHEP))
9855 & +(PHEP(5,NHEP-1)-PHEP(5,NHEP-2))
9856 & *(PHEP(5,NHEP-1)+PHEP(5,NHEP-2)))/TWO
9857 WTMX2=WTMX**2
9858 IPDG=ABS(IDHEP(MHEP))
9859 XS=ONE-MAX(RMASS(MOD(IPDG/1000,10)),
9860 & RMASS(MOD(IPDG/100,10)),RMASS(MOD(IPDG/10,10)))
9861 & /(RMASS(MOD(IPDG/1000,10))+RMASS(MOD(IPDG/100,10))
9862 & +RMASS(MOD(IPDG/10,10)))
9863 50 CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-1),PHEP(1,NHEP-2),
9864 & PHEP(1,NHEP),HWDWWT)
9865 DOT1=HWULDO(PHEP(1,MHEP),PHEP(1,NHEP-1))
9866 DOT2=HWULDO(PHEP(1,MHEP),PHEP(1,NHEP-2))
9867 IF (DOT1*(WTMX-DOT1-XS*DOT2).LT.HWRGEN(11)*WTMX2) GOTO 50
9868 ELSE IF (NME(IM).EQ.200) THEN
9869C Use free massless ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) Matrix Element
9870C sort tan(beta)
9871 IF((IDK(IM).EQ. 2).OR.(IDK(IM).EQ. 4).OR.
9872 & (IDK(IM).EQ. 6).OR.(IDK(IM).EQ. 8).OR.
9873 & (IDK(IM).EQ. 10).OR.(IDK(IM).EQ. 12).OR.
9874 & (IDK(IM).EQ.122).OR.(IDK(IM).EQ.124).OR.
9875 & (IDK(IM).EQ.126).OR.(IDK(IM).EQ.128).OR.
9876 & (IDK(IM).EQ.130).OR.(IDK(IM).EQ.132))THEN
9877 TB=TANB
9878 ELSE
9879 TB=1./TANB
9880 END IF
9881 IF((IDKPRD(1,IM).EQ. 2).OR.(IDKPRD(1,IM).EQ. 4).OR.
9882 & (IDKPRD(1,IM).EQ. 6).OR.(IDKPRD(1,IM).EQ. 8).OR.
9883 & (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR.
9884 & (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR.
9885 & (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR.
9886 & (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN
9887 BT=TANB
9888 ELSE
9889 BT=1./TANB
9890 END IF
9891 IT1=IDK(IM)
9892 IB1=IDKPRD(3,IM)
9893 IT2=IDKPRD(1,IM)
9894 IB2=IDKPRD(2,IM)
9895 CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP),PHEP(1,NHEP-2),
9896 & PHEP(1,NHEP-1),HWDHWT)
9897 ELSE
9898 CALL HWDTHR(PHEP(1,MHEP),PHEP(1,NHEP-2),PHEP(1,NHEP-1),
9899 & PHEP(1,NHEP),HWDPWT)
9900 ENDIF
9901 ELSEIF (NPRODS(IM).EQ.4) THEN
9902C 4-body decay
9903 CALL HWDFOR(PHEP(1,MHEP ),PHEP(1,NHEP-3),PHEP(1,NHEP-2),
9904 & PHEP(1,NHEP-1),PHEP(1,NHEP))
9905 IF(IERROR.NE.0) RETURN
9906 ELSEIF (NPRODS(IM).EQ.5) THEN
9907C 5-body decay
9908 CALL HWDFIV(PHEP(1,MHEP ),PHEP(1,NHEP-4),PHEP(1,NHEP-3),
9909 & PHEP(1,NHEP-2),PHEP(1,NHEP-1),PHEP(1,NHEP))
9910 IF(IERROR.NE.0) RETURN
9911 ELSE
9912 CALL HWWARN('HWDHAD',104)
9913 GOTO 999
9914 ENDIF
9915 ENDIF
9916 ENDIF
9917 100 CONTINUE
9918C---MAY HAVE OVERFLOWED /HEPEVT/
9919 CALL HWWARN('HWDHAD',105)
9920 999 RETURN
9921 END
9922CDECK ID>, HWDHGC.
9923*CMZ :- -26/04/91 11.11.55 by Bryan Webber
9924*-- Author : Mike Seymour
9925C-----------------------------------------------------------------------
9926 SUBROUTINE HWDHGC(TAU,FNREAL,FNIMAG)
9927C-----------------------------------------------------------------------
9928C CALCULATE THE COMPLEX FUNCTION F OF HHG eq 2.18
9929C FOR USE IN H-->GAMMGAMM DECAYS
9930C-----------------------------------------------------------------------
c63d70bc 9931 INCLUDE 'herwig65.inc'
65767955 9932 DOUBLE PRECISION TAU,FNREAL,FNIMAG,FNLOG,FNSQR
9933 IF (TAU.GT.ONE) THEN
9934 FNREAL=(ASIN(1/SQRT(TAU)))**2
9935 FNIMAG=0
9936 ELSEIF (TAU.LT.ONE) THEN
9937 FNSQR=SQRT(1-TAU)
9938 FNLOG=LOG((1+FNSQR)/(1-FNSQR))
9939 FNREAL=-0.25 * (FNLOG**2 - PIFAC**2)
9940 FNIMAG= 0.5 * PIFAC*FNLOG
9941 ELSE
9942 FNREAL=0.25*PIFAC**2
9943 FNIMAG=0
9944 ENDIF
9945 END
9946CDECK ID>, HWDHGF.
9947*CMZ :- -02/05/91 11.11.45 by Federico Carminati
9948*-- Author : Mike Seymour
9949C-----------------------------------------------------------------------
9950 FUNCTION HWDHGF(X,Y)
9951C-----------------------------------------------------------------------
9952C CALCULATE THE DOUBLE BREIT-WIGNER INTEGRAL
9953C X=(EMV/EMH)**2 , Y=EMV*GAMV/EMH**2
9954C-----------------------------------------------------------------------
c63d70bc 9955 INCLUDE 'herwig65.inc'
65767955 9956 DOUBLE PRECISION HWDHGF,X,Y,CHANGE,X1,X2,FAC1,FAC2,TH1,TH2,TH1HI,
9957 & TH1LO,TH2HI,TH2LO,X2MAX,SQFAC
9958 INTEGER NBIN,IBIN1,IBIN2
9959C CHANGE IS THE POINT WHERE DIRECT INTEGRATION BEGINS TO CONVERGE
9960C FASTER THAN STANDARD BREIT-WIGNER SUBSTITUTION
9961 SAVE CHANGE,NBIN
9962 DATA CHANGE,NBIN/0.425D0,25/
9963 HWDHGF=0
9964 IF (Y.LT.ZERO) RETURN
9965 IF (X.GT.CHANGE) THEN
9966C---DIRECT INTEGRATION
9967 FAC1=0.25 / NBIN
9968 DO 200 IBIN1=1,NBIN
9969 X1=(IBIN1-0.5) * FAC1
9970 FAC2=( (1-SQRT(X1))**2-X1 ) / NBIN
9971 DO 100 IBIN2=1,NBIN
9972 X2=(IBIN2-0.5) * FAC2 + X1
9973 SQFAC=1+X1**2+X2**2-2*(X1+X2+X1*X2)
9974 IF (SQFAC.LT.ZERO) GOTO 100
9975 HWDHGF=HWDHGF + 2.
9976 & * ((1-X1-X2)**2+8*X1*X2)
9977 & * SQRT(SQFAC)
9978 & / ((X1-X)**2+Y**2) *Y
9979 & / ((X2-X)**2+Y**2) *Y
9980 & * FAC1*FAC2
9981 100 CONTINUE
9982 200 CONTINUE
9983 ELSE
9984C---INTEGRATION USING TAN THETA SUBSTITUTIONS
9985 TH1LO=ATAN((0-X)/Y)
9986 TH1HI=ATAN((1-X)/Y)
9987 FAC1=(TH1HI-TH1LO) / NBIN
9988 DO 400 IBIN1=1,NBIN
9989 TH1=(IBIN1-0.5) * FAC1 + TH1LO
9990 X1=Y*TAN(TH1) + X
9991 X2MAX=MIN(X1,(1-SQRT(X1))**2)
9992 TH2LO=ATAN((0-X)/Y)
9993 TH2HI=ATAN((X2MAX-X)/Y)
9994 FAC2=(TH2HI-TH2LO) / NBIN
9995 DO 300 IBIN2=1,NBIN
9996 TH2=(IBIN2-0.5) * FAC2 + TH2LO
9997 X2=Y*TAN(TH2) + X
9998 SQFAC=1+X1**2+X2**2-2*(X1+X2+X1*X2)
9999 IF (SQFAC.LT.ZERO) GOTO 300
10000 HWDHGF=HWDHGF + 2.
10001 & * ((1-X1-X2)**2+8*X1*X2)
10002 & * SQRT(SQFAC)
10003 & * FAC1 * FAC2
10004 300 CONTINUE
10005 400 CONTINUE
10006 ENDIF
10007 HWDHGF=HWDHGF/(PIFAC*PIFAC)
10008 END
10009CDECK ID>, HWDHIG.
10010*CMZ :- -24/04/92 14.23.44 by Mike Seymour
10011*-- Author : Mike Seymour
10012C-----------------------------------------------------------------------
10013 SUBROUTINE HWDHIG(GAMINP)
10014C-----------------------------------------------------------------------
10015C HIGGS DECAY ROUTINE
10016C A) FOR GAMinp=0 FIND AND DECAY HIGGS
10017C B) FOR GAMinp>0 CALCULATE TOTAL HIGGS WIDTH
10018C FOR EMH=GAMINP. STORE RESULT IN GAMINP.
10019C-----------------------------------------------------------------------
c63d70bc 10020 INCLUDE 'herwig65.inc'
65767955 10021 DOUBLE PRECISION HWDHGF,HWRGEN,HWRUNI,HWUSQR,HWUPCM,GAMINP,EMH,
10022 & EMF,COLFAC,ENF,K1,K0,BET0,BET1,GAM0,GAM1,SCLOG,CFAC,XF,EM,GAMLIM,
10023 & GAM,XW,EMW,XZ,EMZ,YW,YZ,EMI,TAUT,TAUW,WIDHIG,VECDEC,EMB,GAMB,
10024 & TMIN,TMAX1,EM1,TMAX2,EM2,X1,X2,PROB,PCM,SUMR,SUMI,TAUTR,TAUTI,
10025 & TAUWR,TAUWI,GFACTR
10026 INTEGER HWRINT,IHIG,I,IFERM,NLOOK,I1,I2,IPART,IMODE,IDEC,MMAX
10027 LOGICAL HWRLOG
10028 EXTERNAL HWDHGF,HWRGEN,HWRUNI,HWUSQR,HWUPCM,HWRINT,HWRLOG
10029 SAVE GAM,EM,VECDEC
10030 PARAMETER (NLOOK=100)
10031 DIMENSION VECDEC(2,0:NLOOK)
10032 EQUIVALENCE (EMW,RMASS(198)),(EMZ,RMASS(200))
10033 SAVE GAMLIM
10034 DATA GAMLIM,GAM,EM/10D0,2*0D0/
10035C---IF DECAY, FIND HIGGS (HWDHAD WILL HAVE GIVEN IT STATUS=1)
10036 IF (GAMINP.EQ.ZERO) THEN
10037 IHIG=0
10038 DO 10 I=1,NHEP
10039 10 IF (IHIG.EQ.0.AND.IDHW(I).EQ.201.AND.ISTHEP(I).EQ.1) IHIG=I
10040 IF (IHIG.EQ.0) THEN
10041 CALL HWWARN('HWDHIG',101)
10042 GOTO 999
10043 ENDIF
10044 EMH=PHEP(5,IHIG)
10045 IF (EMH.LE.ZERO) THEN
10046 CALL HWWARN('HWDHIG',102)
10047 GOTO 999
10048 ENDIF
10049 EMSCA=EMH
10050 ELSE
10051 EMH=GAMINP
10052 IF (EMH.LE.ZERO) THEN
10053 GAMINP=0
10054 RETURN
10055 ENDIF
10056 ENDIF
10057C---CALCULATE BRANCHING FRACTIONS
10058C---FERMIONS
10059C---NLL CORRECTION TO QUARK DECAY RATE (HHG eq 2.6-9)
10060 ENF=0
10061 DO 1 I=1,6
10062 1 IF (2*RMASS(I).LT.EMH) ENF=ENF+1
10063 K1=5/PIFAC**2
10064 K0=3/(4*PIFAC**2)
10065 BET0=(11*CAFAC-2*ENF)/3
10066 BET1=(34*CAFAC**2-(10*CAFAC+6*CFFAC)*ENF)/3
10067 GAM0=-8
10068 GAM1=-404./3+40*ENF/9
10069 SCLOG=LOG(EMH**2/QCDLAM**2)
10070 CFAC=1 + ( K1/K0 - 2*GAM0 + GAM0*BET1/BET0**2*LOG(SCLOG)
10071 & + (GAM0*BET1-GAM1*BET0)/BET0**2) / (BET0*SCLOG)
10072 DO 100 IFERM=1,9
10073 IF (IFERM.LE.6) THEN
10074 EMF=RMASS(IFERM)
10075 XF=(EMF/EMH)**2
10076 COLFAC=FLOAT(NCOLO)
10077 IF (EMF.GT.QCDLAM)
10078 & EMF=EMF*(LOG(EMH/QCDLAM)/LOG(EMF/QCDLAM))**(GAM0/(2*BET0))
10079 ELSE
10080 EMF=RMASS(107+IFERM*2)
10081 XF=(EMF/EMH)**2
10082 COLFAC=1
10083 CFAC=1
10084 ENDIF
10085 IF (FOUR*XF.LT.ONE) THEN
10086 GFACTR=ALPHEM/(8.*SWEIN*EMW**2)
10087 BRHIG(IFERM)=COLFAC*GFACTR*EMH*EMF**2 * (1-4*XF)**1.5 * CFAC
10088 ELSE
10089 BRHIG(IFERM)=0
10090 ENDIF
10091 100 CONTINUE
10092C---W*W*/Z*Z*
10093 IF (ABS(EM-EMH).GE.GAMLIM*GAM) THEN
10094C---OFF EDGE OF LOOK-UP TABLE
10095 XW=(EMW/EMH)**2
10096 XZ=(EMZ/EMH)**2
10097 YW=EMW*GAMW/EMH**2
10098 YZ=EMZ*GAMZ/EMH**2
10099 BRHIG(10)=.50*GFACTR * EMH**3 * HWDHGF(XW,YW)
10100 BRHIG(11)=.25*GFACTR * EMH**3 * HWDHGF(XZ,YZ)
10101 ELSE
10102C---LOOK IT UP
10103 EMI=((EMH-EM)/(GAM*GAMLIM)+1)*NLOOK/2.0
10104 I1=INT(EMI)
10105 I2=INT(EMI+1)
10106 BRHIG(10)=.50*GFACTR * EMH**3 * ( VECDEC(1,I1)*(I2-EMI) +
10107 & VECDEC(1,I2)*(EMI-I1) )
10108 BRHIG(11)=.25*GFACTR * EMH**3 * ( VECDEC(2,I1)*(I2-EMI) +
10109 & VECDEC(2,I2)*(EMI-I1) )
10110 ENDIF
10111C---GAMMAGAMMA
10112 TAUT=(2*RMASS(6)/EMH)**2
10113 TAUW=(2*EMW/EMH)**2
10114 CALL HWDHGC(TAUT,TAUTR,TAUTI)
10115 CALL HWDHGC(TAUW,TAUWR,TAUWI)
10116 SUMR=4./3*( - 2*TAUT*( 1 + (1-TAUT)*TAUTR ) ) * ENHANC(6)
10117 & +(2 + 3*TAUW*( 1 + (2-TAUW)*TAUWR ) ) * ENHANC(10)
10118 SUMI=4./3*( - 2*TAUT*( (1-TAUT)*TAUTI ) ) * ENHANC(6)
10119 & +( 3*TAUW*( (2-TAUW)*TAUWI ) ) * ENHANC(10)
10120 BRHIG(12)=GFACTR*.03125*(ALPHEM/PIFAC)**2
10121 & *EMH**3 * (SUMR**2 + SUMI**2)
10122 WIDHIG=0
10123 DO 200 IPART=1, 12
10124 IF (IPART.LT.12) BRHIG(IPART)=BRHIG(IPART)*ENHANC(IPART)**2
10125 200 WIDHIG=WIDHIG+BRHIG(IPART)
10126 IF (WIDHIG.EQ.ZERO) THEN
10127 CALL HWWARN('HWDHIG',103)
10128 GOTO 999
10129 ENDIF
10130 DO 300 IPART=1, 12
10131 300 BRHIG(IPART)=BRHIG(IPART)/WIDHIG
10132 IF (EM.NE.RMASS(201)) THEN
10133C---SET UP W*W*/Z*Z* LOOKUP TABLES
10134 EM=EMH
10135 GAM=WIDHIG
10136 GAMLIM=MAX(GAMLIM,GAMMAX)
10137 DO 400 I=0,NLOOK
10138 EMH=(I*2.0/NLOOK-1)*GAM*GAMLIM+EM
10139 XW=(EMW/EMH)**2
10140 XZ=(EMZ/EMH)**2
10141 YW=EMW*GAMW/EMH**2
10142 YZ=EMZ*GAMZ/EMH**2
10143 VECDEC(1,I)=HWDHGF(XW,YW)
10144 VECDEC(2,I)=HWDHGF(XZ,YZ)
10145 400 CONTINUE
10146 EMH=EM
10147 ENDIF
10148 IF (GAMINP.GT.ZERO) THEN
10149 GAMINP=WIDHIG
10150 RETURN
10151 ENDIF
10152C---SEE IF USER SPECIFIED A DECAY MODE
10153 IMODE=MOD(ABS(IPROC),100)
10154C---IF NOT, CHOOSE ONE
10155 IF (IMODE.LT.1.OR.IMODE.GT.12) THEN
10156 MMAX=12
10157 IF (IMODE.LT.1) MMAX=6
10158 500 IMODE=HWRINT(1,MMAX)
10159 IF (BRHIG(IMODE).LT.HWRGEN(0)) GOTO 500
10160 ENDIF
10161C---SEE IF SPECIFIED DECAY IS POSSIBLE
10162 IF (BRHIG(IMODE).EQ.ZERO) THEN
10163 CALL HWWARN('HWDHIG',104)
10164 GOTO 999
10165 ENDIF
10166 IF (IMODE.LE.6) THEN
10167 IDEC=IMODE
10168 ELSEIF (IMODE.LE.9) THEN
10169 IDEC=107+IMODE*2
10170 ELSEIF (IMODE.EQ.10) THEN
10171 IDEC=198
10172 ELSEIF (IMODE.EQ.11) THEN
10173 IDEC=200
10174 ELSEIF (IMODE.EQ.12) THEN
10175 IDEC=59
10176 ENDIF
10177C---STATUS, IDs AND POINTERS
10178 ISTHEP(IHIG)=195
10179 DO 600 I=1,2
10180 ISTHEP(NHEP+I)=193
10181 IDHW(NHEP+I)=IDEC
10182 IDHEP(NHEP+I)=IDPDG(IDEC)
10183 JDAHEP(I,IHIG)=NHEP+I
10184 JMOHEP(1,NHEP+I)=IHIG
10185 JMOHEP(2,NHEP+I)=NHEP+(3-I)
10186 JDAHEP(2,NHEP+I)=NHEP+(3-I)
10187 PHEP(5,NHEP+I)=RMASS(IDEC)
10188 IDEC=IDEC+6
10189 IF (IDEC.EQ.204) IDEC=199
10190 IF (IDEC.EQ.206) IDEC=200
10191 IF (IDEC.EQ. 65) IDEC= 59
10192 600 CONTINUE
10193C---ALLOW W/Z TO BE OFF-SHELL
10194 IF (IMODE.EQ.10.OR.IMODE.EQ.11) THEN
10195 IF (IMODE.EQ.10) THEN
10196 EMB=EMW
10197 GAMB=GAMW
10198 ELSE
10199 EMB=EMZ
10200 GAMB=GAMZ
10201 ENDIF
10202C---STANDARD MASS DISTRIBUTION
10203 700 TMIN=ATAN(-EMB/GAMB)
10204 TMAX1=ATAN((EMH**2/EMB-EMB)/GAMB)
10205 EM1=HWUSQR(EMB*(GAMB*TAN(HWRUNI(0,TMIN,TMAX1))+EMB))
10206 TMAX2=ATAN(((EMH-EM1)**2/EMB-EMB)/GAMB)
10207 EM2=HWUSQR(EMB*(GAMB*TAN(HWRUNI(0,TMIN,TMAX2))+EMB))
10208 X1=(EM1/EMH)**2
10209 X2=(EM2/EMH)**2
10210C---CORRECT MASS DISTRIBUTION
10211 PROB=HWUSQR(1+X1**2+X2**2-2*X1-2*X2-2*X1*X2)
10212 & * ((X1+X2-1)**2 + 8*X1*X2)
10213 IF (.NOT.HWRLOG(PROB)) GOTO 700
10214C---CALCULATE SPIN DENSITY MATRIX
10215 RHOHEP(1,NHEP+1)=4*X1*X2 / (8*X1*X2 + (X1+X2-1)**2)
10216 RHOHEP(2,NHEP+1)=(X1+X2-1)**2 / (8*X1*X2 + (X1+X2-1)**2)
10217 RHOHEP(3,NHEP+1)=RHOHEP(1,NHEP+1)
10218C---SYMMETRIZE DISTRIBUTIONS IN PARTICLES 1,2
10219 IF (HWRLOG(HALF)) THEN
10220 PHEP(5,NHEP+1)=EM1
10221 PHEP(5,NHEP+2)=EM2
10222 ELSE
10223 PHEP(5,NHEP+1)=EM2
10224 PHEP(5,NHEP+2)=EM1
10225 ENDIF
10226 ENDIF
10227C---DO DECAY
10228 PCM=HWUPCM(EMH,PHEP(5,NHEP+1),PHEP(5,NHEP+2))
10229 IF (PCM.LT.ZERO) THEN
10230 CALL HWWARN('HWDHIG',105)
10231 GOTO 999
10232 ENDIF
10233 CALL HWDTWO(PHEP(1,IHIG),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
10234 & PCM,TWO,.TRUE.)
10235 NHEP=NHEP+2
10236C---IF QUARK DECAY, HADRONIZE
10237 IF (IMODE.LE.6) THEN
10238 ISTHEP(NHEP-1)=113
10239 ISTHEP(NHEP)=114
10240 CALL HWBGEN
10241 CALL HWDHOB
10242 CALL HWCFOR
10243 CALL HWCDEC
10244C--MHS FIX 07/03/05 - VERTEX POSITION FOR DECAYS TO LEPTONS OR PHOTONS
10245 ELSEIF (IMODE.LE.9.OR.IMODE.EQ.12) THEN
10246 CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP-1))
10247 CALL HWVEQU(4,VTXPIP,VHEP(1,NHEP))
10248C--END FIX
10249 ENDIF
10250 999 RETURN
10251 END
10252CDECK ID>, HWDHOB.
10253*CMZ :- -17/10/01 10:19:15 by Peter Richardson
10254*-- Author : Ian Knowles & Bryan Webber
10255C-----------------------------------------------------------------------
10256 SUBROUTINE HWDHOB
10257C-----------------------------------------------------------------------
10258C Performs decays of heavy objects (heavy quarks & SUSY particles)
10259C MODIFIED TO INCLUDE R-PARITY VIOLATING SUSY PR 9/4/99
10260C MODIFIED TO CALL A NUMBER OF ROUTINES TO DO THE VARIOUS BITS OF
10261C THE PROCESS
10262C-----------------------------------------------------------------------
c63d70bc 10263 INCLUDE 'herwig65.inc'
65767955 10264 DOUBLE PRECISION PW(5)
10265 INTEGER IHEP,IS,ID,IM,KHEP,LHEP,MHEP,NPR,CLSAVE(2),NHEPST
10266 LOGICAL FOUND
10267 SAVE NHEPST
10268 IF (IERROR.NE.0) RETURN
10269 10 FOUND=.FALSE.
10270 NHEPST = NHEP
10271 CLSAVE(1) = 0
10272 CLSAVE(2) = 0
10273 DO 60 IHEP=1,NMXHEP
10274 IS=ISTHEP(IHEP)
10275 ID=IDHW(IHEP)
10276 IF(SYSPIN.AND.NSPN.NE.0) CALL HWDSIN(CLSAVE)
10277 IF (.NOT.RSTAB(ID).AND.(ID.EQ.6.OR.ID.EQ.12.OR.
10278 & (ID.GE.203.AND.ID.LE.218).OR.ABS(IDPDG(ID)).GT.1000000).AND.
10279 & ((IS.EQ.120.AND.JDAHEP(1,IHEP).EQ.IHEP).OR.
10280 & IS.EQ.190.OR.(IS.GE.147.AND.IS.LE.151))) THEN
10281 FOUND=.TRUE.
10282C--select the decay mode and enter the decay products in the event record
10283 CALL HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP)
10284 IF (IERROR.NE.0) RETURN
10285C--select the momenta of the decay products
10286 CALL HWDHO2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW)
10287 IF (IERROR.NE.0) RETURN
10288C--make the colour connections
10289 CALL HWDHO3(ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE)
10290 IF (IERROR.NE.0) RETURN
10291C--perform the parton-showers
10292 CALL HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW)
10293 IF (IERROR.NE.0) RETURN
10294 ENDIF
10295C--perform the colour corrections for RPV
10296 CALL HWDHO5(MHEP,LHEP,CLSAVE)
10297 IF(IERROR.NE.0) RETURN
10298 IF (IHEP.EQ.NHEP) GOTO 70
10299 60 CONTINUE
10300 70 IF(SYSPIN.AND.NHEP.NE.NHEPST) FOUND=.TRUE.
10301 IF (FOUND) THEN
10302C--final check for colour disconnection
10303 CALL HWDHO6
10304C Go back to check for further heavy decay products
10305 GOTO 10
10306 ENDIF
10307 END
10308CDECK ID>, HWDHO1.
10309*CMZ :- -17/10/01 10:19:15 by Peter Richardson
10310*-- Author : Ian Knowles & Bryan Webber
10311C-----------------------------------------------------------------------
10312 SUBROUTINE HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP)
10313C-----------------------------------------------------------------------
10314C Subroutine to perform the first part of the heavy object decays
10315C IE to select the decay mode
10316C was part of HWDHOB
10317C-----------------------------------------------------------------------
c63d70bc 10318 INCLUDE 'herwig65.inc'
65767955 10319 DOUBLE PRECISION HWUMBW,HWRGEN,SDKM,RN,BF
10320 INTEGER IST(3),IHEP,ID,IM,I,JHEP,LHEP,MHEP,NPR,MTRY,NTRY,IS
10321 EXTERNAL HWRGEN
10322 SAVE IST
10323 DATA IST/113,114,114/
10324 IF (IERROR.NE.0) RETURN
10325 IF(.NOT.RPARTY) THEN
10326 NHEP = NHEP+1
10327 ISTHEP(NHEP) = 3
10328 IDHW(NHEP) = 20
10329 IDHEP(NHEP) = 0
10330 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
10331 CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
10332 JMOHEP(1,NHEP)=JMOHEP(1,IHEP)
10333 JMOHEP(2,NHEP)=JMOHEP(2,IHEP)
10334 JDAHEP(1,NHEP)=JDAHEP(1,IHEP)
10335 JDAHEP(2,NHEP)=JDAHEP(2,IHEP)
10336 ENDIF
10337C Make a copy of decaying object
10338 NHEP=NHEP+1
10339 ISTHEP(NHEP)=155
10340 IDHW(NHEP)=IDHW(IHEP)
10341 IDHEP(NHEP)=IDHEP(IHEP)
10342 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,NHEP))
10343 CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,NHEP))
10344 JMOHEP(1,NHEP)=JMOHEP(1,IHEP)
10345 JMOHEP(2,NHEP)=JMOHEP(2,IHEP)
10346C--copy the location of the particle in the spin block
10347 IF(SYSPIN.AND.NSPN.NE.0) THEN
10348 IF(ISNHEP(IHEP).EQ.0) THEN
10349 IS = IHEP
10350 MTRY = 0
10351 5 MTRY = MTRY+1
10352 IS = JMOHEP(1,IS)
10353 IF(ISNHEP(IS).EQ.0.AND.MTRY.LE.NETRY) GOTO 5
10354 IF(MTRY.GT.NETRY) THEN
10355 CALL HWWARN('HWDHO1',102)
10356 GOTO 999
10357 ENDIF
10358 ISNHEP(IHEP) = ISNHEP(IS)
10359 ENDIF
10360 ISNHEP(NHEP) = ISNHEP(JMOHEP(1,NHEP))
10361 ENDIF
10362 MTRY=0
10363 15 MTRY=MTRY+1
10364C Select decay mode
10365 RN=HWRGEN(0)
10366 BF=0.
10367 IM=LSTRT(ID)
10368 DO 20 I=1,NMODES(ID)
10369 BF=BF+BRFRAC(IM)
10370 IF (BF.GE.RN) GOTO 30
10371 20 IM=LNEXT(IM)
10372 CALL HWWARN('HWDHO1',50)
10373 30 IF (NHEP+5.GT.NMXHEP) THEN
10374 CALL HWWARN('HWDHO1',100)
10375 GOTO 999
10376 ENDIF
10377 NPR=NPRODS(IM)
10378 JDAHEP(1,NHEP)=NHEP+1
10379 JDAHEP(2,NHEP)=NHEP+NPR
10380C Reset colour pointers (if set)
10381 JHEP=JMOHEP(2,IHEP)
10382 IF (JHEP.GT.0) THEN
10383 IF (JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
10384 IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
10385 & .AND.ABS(IDHEP(JHEP)).GT.1000000
10386 & .AND.JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1) = NHEP
10387 ENDIF
10388 JHEP=JDAHEP(2,IHEP)
10389 IF (JHEP.GT.0) THEN
10390 IF (JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
10391 IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
10392 & .AND.ABS(IDHEP(JHEP)).GT.1000000
10393 & .AND.JMOHEP(2,JHEP-1).EQ.IHEP) JMOHEP(2,JHEP-1) = NHEP
10394 ENDIF
10395C--Reset colour pointers if baryon number violated
10396 IF(.NOT.RPARTY) THEN
10397 DO JHEP=1,NHEP
10398 IF(ISTHEP(JHEP).EQ.155
10399 & .AND.ABS(IDHEP(JHEP)).GT.1000000.AND.
10400 & JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1)= NHEP
10401 IF(JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
10402 IF(JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
10403 ENDDO
10404 IF(HRDCOL(1,1).EQ.IHEP) HRDCOL(1,1)=NHEP
10405 ENDIF
10406C Relabel original track
10407 IF (ISTHEP(IHEP).NE.120) ISTHEP(IHEP)=3
10408 JMOHEP(2,IHEP)=JMOHEP(1,IHEP)
10409 JDAHEP(1,IHEP)=NHEP
10410 JDAHEP(2,IHEP)=NHEP
10411C Label decay products and choose masses
10412 LHEP=NHEP
10413 MHEP=LHEP+1
10414 NTRY=0
10415 35 NTRY=NTRY+1
10416 SDKM=PHEP(5,NHEP)
10417 DO 40 I=1,NPR
10418 NHEP=NHEP+1
10419 IDHW(NHEP)=IDKPRD(I,IM)
10420 IDHEP(NHEP)=IDPDG(IDKPRD(I,IM))
10421 ISTHEP(NHEP)=IST(I)
10422 JMOHEP(1,NHEP)=LHEP
10423 JDAHEP(1,NHEP)=0
10424 PHEP(5,NHEP)=HWUMBW(IDKPRD(I,IM))
10425 40 SDKM=SDKM-PHEP(5,NHEP)
10426 IF (SDKM.LT.ZERO) THEN
10427 NHEP=NHEP-NPR
10428 IF (NTRY.LE.NETRY) GO TO 35
10429 CALL HWWARN('HWDHO1',1)
10430 IF (MTRY.LE.NETRY) GO TO 15
10431 CALL HWWARN('HWDHO1',101)
10432 GOTO 999
10433 ENDIF
10434C Assign production vertices to decay products
10435 CALL HWUDKL(ID,PHEP(1,IHEP),VHEP(1,MHEP))
10436 CALL HWVSUM(4,VHEP(1,IHEP),VHEP(1,MHEP),VHEP(1,MHEP))
10437 CALL HWVEQU(4,VHEP(1,MHEP),VHEP(1,NHEP))
10438 999 RETURN
10439 END
10440CDECK ID>, HWDH02.
10441*CMZ :- -30/09/02 14:05:28 by Peter Richardson
10442*-- Author : Ian Knowles & Bryan Webber
10443C-----------------------------------------------------------------------
10444 SUBROUTINE HWDHO2(IHEP,IM,NPR,MHEP,LHEP,KHEP,PW)
10445C-----------------------------------------------------------------------
10446C Subroutine to perform the second part of the heavy object decays
10447C IE generate the kinematics for the decay
10448C was part of HWDHOB
10449C-----------------------------------------------------------------------
c63d70bc 10450 INCLUDE 'herwig65.inc'
65767955 10451 COMMON/FFS/TB,BT
10452 COMMON/SFF/IT1,IB1,IT2,IB2
10453 DOUBLE PRECISION TB,BT
10454 INTEGER IT1,IB1,IT2,IB2,ISP
10455 DOUBLE PRECISION GAMHPM
10456 DOUBLE PRECISION HWUPCM,HWRGEN,PCM,
10457 & EMMX,EMWSQ,GMWSQ,EMLIM,PW(5),EMTST,HWDPWT,HWDWWT,HWULDO,HWDHWT
10458 DOUBLE COMPLEX RHOIN(2,2,2)
10459 INTEGER IHEP,IM,KHEP,LHEP,MHEP,NPR,RHEP
10460 EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWDHWT
10461 SAVE RHOIN
10462 DATA RHOIN/(1.0D0,0.0D0),(0.0D0,0.0D0),
10463 & (0.0D0,0.0D0),(0.0D0,0.0D0),
10464 & (0.5D0,0.0D0),(0.0D0,0.0D0),
10465 & (0.0D0,0.0D0),(0.5D0,0.0D0)/
10466 ISP = INT(2*RSPIN(IDHW(IHEP)))+1
10467 IF (IERROR.NE.0) RETURN
10468 IF (NPR.EQ.2) THEN
10469C Two body decay: LHEP -> MHEP + NHEP
10470 IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN
10471C--generate a two body decay to a gauge boson as a three body decay
10472 CALL HWDSM3(2,IHEP,MHEP,NHEP,0,NME(IM)-20000,RHOIN(1,1,ISP),1)
10473C--generate a two body decay of a Higgs to two gauge bosons
10474 ELSEIF(NME(IM).GT.40000.AND.NME(IM).LT.50000) THEN
10475 CALL HWDSM4(1,IHEP,MHEP,NHEP,NME(IM)-40000)
10476C--if spin correlations call the routine to set-up the matrix element
10477 ELSEIF(SYSPIN.AND.NME(IM).GE.30000.AND.NME(IM).LE.40000) THEN
10478 CALL HWDSM2(IHEP,MHEP,NHEP,NME(IM)-30000,RHOIN(1,1,ISP),1)
10479 ELSE
10480 PCM=HWUPCM(PHEP(5,IHEP),PHEP(5,MHEP),PHEP(5,NHEP))
10481 CALL HWDTWO(PHEP(1,IHEP),PHEP(1,MHEP),
10482 & PHEP(1,NHEP),PCM,TWO,.FALSE.)
10483 ENDIF
10484 ELSEIF (NPR.EQ.3) THEN
10485C Three body decay: LHEP -> KHEP + MHEP + NHEP
10486 KHEP=MHEP
10487 MHEP=MHEP+1
10488C Provisional colour self-connection of KHEP
10489 JMOHEP(2,KHEP)=KHEP
10490 JDAHEP(2,KHEP)=KHEP
10491 IF (NME(IM).EQ.100) THEN
10492C Generate decay momenta using full (V-A)*(V-A) matrix element
10493 EMMX=PHEP(5,IHEP)-PHEP(5,NHEP)
10494 EMWSQ=RMASS(198)**2
10495 GMWSQ=(RMASS(198)*GAMW)**2
10496 EMLIM=GMWSQ
10497 IF (EMMX.LT.RMASS(198)) EMLIM=EMLIM+(EMWSQ-EMMX**2)**2
10498 50 CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
10499 & PHEP(1,KHEP),PHEP(1,NHEP),HWDWWT)
10500 CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
10501 PW(5)=HWULDO(PW,PW)
10502 EMTST=(EMWSQ-PW(5))**2
10503 IF ((EMTST+GMWSQ)*HWRGEN(1).GT.EMLIM) GOTO 50
10504 PW(5)=SQRT(PW(5))
10505C Assign production vertices to 1 and 2
10506 CALL HWUDKL(198,PW,VHEP(1,KHEP))
10507 CALL HWVSUM(4,VHEP(1,NHEP),VHEP(1,KHEP),VHEP(1,KHEP))
10508 ELSE IF (NME(IM).EQ.200) THEN
10509C Generate decay momenta using full
10510C ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) matrix element
10511 GAMHPM=RMASS(206)/DKLTM(206)
10512C sort tan(beta)
10513 IF((IDK(IM).EQ. 2).OR.(IDK(IM).EQ. 4).OR.
10514 & (IDK(IM).EQ. 6).OR.(IDK(IM).EQ. 8).OR.
10515 & (IDK(IM).EQ. 10).OR.(IDK(IM).EQ. 12).OR.
10516 & (IDK(IM).EQ.122).OR.(IDK(IM).EQ.124).OR.
10517 & (IDK(IM).EQ.126).OR.(IDK(IM).EQ.128).OR.
10518 & (IDK(IM).EQ.130).OR.(IDK(IM).EQ.132))THEN
10519 TB=TANB
10520 ELSE
10521 TB=1./TANB
10522 END IF
10523 IF((IDKPRD(1,IM).EQ. 2).OR.(IDKPRD(1,IM).EQ. 4).OR.
10524 & (IDKPRD(1,IM).EQ. 6).OR.(IDKPRD(1,IM).EQ. 8).OR.
10525 & (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR.
10526 & (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR.
10527 & (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR.
10528 & (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN
10529 BT=TANB
10530 ELSE
10531 BT=1./TANB
10532 END IF
10533 IT1=IDK(IM)
10534 IB1=IDKPRD(3,IM)
10535 IT2=IDKPRD(1,IM)
10536 IB2=IDKPRD(2,IM)
10537 EMMX=PHEP(5,IHEP)-PHEP(5,NHEP)
10538 EMWSQ=RMASS(206)**2
10539 GMWSQ=(RMASS(206)*GAMHPM)**2
10540 EMLIM=GMWSQ
10541 IF (EMMX.LT.RMASS(206)) EMLIM=EMLIM+(EMWSQ-EMMX**2)**2
10542 55 CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP),
10543 & PHEP(1,KHEP),PHEP(1,MHEP),HWDHWT)
10544 CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
10545 PW(5)=HWULDO(PW,PW)
10546 EMTST=(EMWSQ-PW(5))**2
10547 IF ((EMTST+GMWSQ)*HWRGEN(2).GT.EMLIM) GOTO 55
10548 PW(5)=SQRT(PW(5))
10549C Assign production vertices to 1 and 2
10550 CALL HWUDKL(206,PW,VHEP(1,KHEP))
10551 CALL HWVSUM(4,VHEP(1,NHEP),VHEP(1,KHEP),VHEP(1,KHEP))
10552 ELSEIF(NME(IM).EQ.300) THEN
10553C Generate momenta using 3-body RPV matrix element
10554 CALL HWDRME(LHEP,KHEP)
10555C--Three body SUSY decay
10556 ELSEIF(NME(IM).GE.10000.AND.NME(IM).LT.20000) THEN
10557 CALL HWDSM3(3,IHEP,MHEP,KHEP,NHEP,NME(IM)-10000,
10558 & RHOIN(1,1,ISP),1)
10559C--special for top decay
10560 IF(ABS(IDHEP(IHEP)).EQ.6) THEN
10561 CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
10562 CALL HWUMAS(PW)
10563 ENDIF
10564 ELSE
10565C Three body phase space decay
10566 CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
10567 & PHEP(1,KHEP),PHEP(1,NHEP),HWDPWT)
10568 ENDIF
10569 CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
10570 ELSEIF(NPR.EQ.4) THEN
10571C Four body decay: LHEP -> KHEP + RHEP + MHEP + NHEP
10572 KHEP = MHEP
10573 RHEP = MHEP+1
10574 MHEP = MHEP+2
10575 ISTHEP(NHEP) = 114
10576C Provisional colour connections of KHEP and RHEP
10577 JMOHEP(2,KHEP)=RHEP
10578 JDAHEP(2,KHEP)=RHEP
10579 JMOHEP(2,RHEP)=KHEP
10580 JDAHEP(2,RHEP)=KHEP
10581C Four body phase space decay
10582 CALL HWDFOR(PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,RHEP),
10583 & PHEP(1,MHEP),PHEP(1,NHEP))
10584 IF(IERROR.NE.0) RETURN
10585 CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,RHEP))
10586 CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
10587 ELSE
10588 CALL HWWARN('HWDHO2',100)
10589 ENDIF
10590 END
10591CDECK ID>, HWDHO3.
10592*CMZ :- -17/10/01 10:19:15 by Peter Richardson
10593*-- Author : Ian Knowles & Bryan Webber
10594C-----------------------------------------------------------------------
10595 SUBROUTINE HWDHO3(ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE)
10596C-----------------------------------------------------------------------
10597C Subroutine to perform the third part of the heavy object decays
10598C IE setup the colour connections
10599C was part of HWDHOB
10600C-----------------------------------------------------------------------
c63d70bc 10601 INCLUDE 'herwig65.inc'
65767955 10602 INTEGER ID,IM,KHEP,LHEP,MHEP,NPR,CLSAVE(2)
10603 IF (IERROR.NE.0) RETURN
10604C Colour connections
10605 IF (ID.EQ.6.OR.ID.EQ.12.OR.(ID.GE.209.AND.ID.LE.212)
10606 & .OR.(ID.GE.215.AND.ID.LE.218)) THEN
10607 IF ((NPR.EQ.3.AND.NME(IM).EQ.100).OR.
10608 & ((SYSPIN.OR.THREEB).AND.NPR.EQ.3.AND.
10609 & NME(IM).GE.10000.AND.NME(IM).LE.20000)) THEN
10610C usual heavy quark decay
10611 JMOHEP(2,KHEP)=MHEP
10612 JDAHEP(2,KHEP)=MHEP
10613 JMOHEP(2,MHEP)=KHEP
10614 JDAHEP(2,MHEP)=KHEP
10615 JMOHEP(2,NHEP)=LHEP
10616 JDAHEP(2,NHEP)=LHEP
10617 ELSEIF (ABS(IDHEP(MHEP)).EQ.37) THEN
10618C heavy quark to charged Higgs 2->2
10619 JMOHEP(2,MHEP)=MHEP
10620 JDAHEP(2,MHEP)=MHEP
10621 JMOHEP(2,NHEP)=LHEP
10622 JDAHEP(2,NHEP)=LHEP
10623 ELSEIF (ABS(IDHEP(NHEP)).EQ.37) THEN
10624C heavy quark to charged Higgs 2->2
10625 JMOHEP(2,MHEP)=LHEP
10626 JDAHEP(2,MHEP)=LHEP
10627 JMOHEP(2,NHEP)=NHEP
10628 JDAHEP(2,NHEP)=NHEP
10629 ELSE IF (NPR.EQ.3.AND.NME(IM).EQ.200) THEN
10630C heavy quark to charged Higgs 2->3
10631 JMOHEP(2,KHEP)=MHEP
10632 JDAHEP(2,KHEP)=MHEP
10633 JMOHEP(2,MHEP)=KHEP
10634 JDAHEP(2,MHEP)=KHEP
10635 JMOHEP(2,NHEP)=LHEP
10636 JDAHEP(2,NHEP)=LHEP
10637 ELSE
10638 CALL HWWARN('HWDHO3',100)
10639 GOTO 999
10640 ENDIF
10641 ELSE
10642 IF(.NOT.RPARTY.AND.
10643 & ((NPR.EQ.2.AND.ID.GE.401.AND.ID.LT.448.AND.
10644 & IDHW(MHEP).LE.132.AND.IDHW(NHEP).LE.132)
10645 & .OR.(NPR.EQ.3.AND.ID.GE.449.AND.ID.LE.457.AND.
10646 & IDHW(MHEP).LE.132.AND.IDHW(NHEP).LE.132.AND.
10647 & IDHW(MHEP-1).LE.132))) THEN
10648C R-parity violating SUSY decays
10649 IF(NPR.EQ.2) THEN
10650C--Rparity slepton colour connections
10651 IF(ID.GE.425.AND.ID.LE.448) THEN
10652 IF(IDHW(MHEP).GT.12) THEN
10653 JMOHEP(2,MHEP) = MHEP
10654 JDAHEP(2,MHEP) = MHEP
10655 JMOHEP(2,NHEP) = NHEP
10656 JDAHEP(2,NHEP) = NHEP
10657 ELSE
10658 JMOHEP(2,MHEP) = NHEP
10659 JDAHEP(2,MHEP) = NHEP
10660 JMOHEP(2,NHEP) = MHEP
10661 JDAHEP(2,NHEP) = MHEP
10662 ENDIF
10663C--Rparity squark colour connections
10664 ELSE
10665 IF(IDHEP(LHEP).GT.0) THEN
10666C--LQD decay colour connections
10667 IF(IDHW(MHEP).GT.12) THEN
10668 JMOHEP(2,MHEP) = MHEP
10669 JDAHEP(2,MHEP) = MHEP
10670 JMOHEP(2,NHEP) = LHEP
10671 JDAHEP(2,NHEP) = LHEP
10672 ELSE
10673C--UDD decay colour connections
10674 HVFCEN = .TRUE.
10675 CALL HWDRCL(LHEP,MHEP,CLSAVE)
10676 ENDIF
10677 ELSE
10678C--Antisquark connections
10679 IF(IDHW(MHEP).GT.12) THEN
10680 JMOHEP(2,MHEP) = MHEP
10681 JDAHEP(2,MHEP) = MHEP
10682 JMOHEP(2,NHEP) = LHEP
10683 JDAHEP(2,NHEP) = LHEP
10684 ELSE
10685 HVFCEN = .TRUE.
10686 CALL HWDRCL(LHEP,MHEP,CLSAVE)
10687 ENDIF
10688 ENDIF
10689 ENDIF
10690 ELSE
10691 IF(ID.GE.450.AND.ID.LE.457) THEN
10692C--Rparity Neutralino/Chargino colour connection
10693 IF(IDHW(MHEP-1).LE.12.AND.IDHW(MHEP).LE.12.
10694 & AND.IDHW(NHEP).LE.12) THEN
10695 HVFCEN = .TRUE.
10696 CALL HWDRCL(LHEP,MHEP,CLSAVE)
10697 ELSE
10698 JMOHEP(2,MHEP) = NHEP
10699 JDAHEP(2,MHEP) = NHEP
10700 JMOHEP(2,NHEP) = MHEP
10701 JDAHEP(2,NHEP) = MHEP
10702 ENDIF
10703C--Rparity gluino colour connections
10704 ELSEIF(ID.EQ.449) THEN
10705 IF(IDHW(MHEP-1).LE.12.AND.IDHW(MHEP).LE.12.
10706 & AND.IDHW(NHEP).LE.12) THEN
10707 HVFCEN = .TRUE.
10708 CALL HWDRCL(LHEP,MHEP,CLSAVE)
10709C--Now the lepton number violating decay
10710 ELSE
10711 IF(IDHW(MHEP).LE.6) THEN
10712 JMOHEP(2,MHEP) = LHEP
10713 JDAHEP(2,MHEP) = NHEP
10714 JMOHEP(2,NHEP) = MHEP
10715 JDAHEP(2,NHEP) = LHEP
10716 ELSE
10717 JMOHEP(2,MHEP) = NHEP
10718 JDAHEP(2,MHEP) = LHEP
10719 JMOHEP(2,NHEP) = LHEP
10720 JDAHEP(2,NHEP) = MHEP
10721 ENDIF
10722 ENDIF
10723 ELSE
10724 CALL HWWARN('HWDHO3',101)
10725 GOTO 999
10726 ENDIF
10727 ENDIF
10728 ELSE
10729C Normal SUSY decays
10730 IF (ID.LE.448.AND.ID.GT.207) THEN
10731C Squark (or slepton)
10732 IF (IDHW(MHEP).EQ.449) THEN
10733 IF (IDHEP(LHEP).GT.0) THEN
10734 JMOHEP(2,MHEP)=LHEP
10735 JDAHEP(2,MHEP)=NHEP
10736 JMOHEP(2,NHEP)=MHEP
10737 JDAHEP(2,NHEP)=LHEP
10738 ELSE
10739 JMOHEP(2,MHEP)=NHEP
10740 JDAHEP(2,MHEP)=LHEP
10741 JMOHEP(2,NHEP)=LHEP
10742 JDAHEP(2,NHEP)=MHEP
10743 ENDIF
10744 ELSE
10745 IF(NPR.EQ.3.AND.IDHW(MHEP).LE.12) THEN
10746 JMOHEP(2,MHEP)=NHEP
10747 JDAHEP(2,MHEP)=NHEP
10748 JMOHEP(2,NHEP)=MHEP
10749 JDAHEP(2,NHEP)=MHEP
10750 ELSE
10751 JMOHEP(2,MHEP)=MHEP
10752 JDAHEP(2,MHEP)=MHEP
10753 JMOHEP(2,NHEP)=LHEP
10754 JDAHEP(2,NHEP)=LHEP
10755 ENDIF
10756 ENDIF
10757 ELSEIF (ID.EQ.449) THEN
10758C Gluino
10759 IF (IDHW(NHEP).EQ.13) THEN
10760 JMOHEP(2,MHEP)=MHEP
10761 JDAHEP(2,MHEP)=MHEP
10762 JMOHEP(2,NHEP)=LHEP
10763 JDAHEP(2,NHEP)=LHEP
10764 ELSEIF (IDHEP(MHEP).GT.0) THEN
10765 JMOHEP(2,MHEP)=LHEP
10766 JDAHEP(2,MHEP)=NHEP
10767 JMOHEP(2,NHEP)=MHEP
10768 JDAHEP(2,NHEP)=LHEP
10769 ELSE
10770 JMOHEP(2,MHEP)=NHEP
10771 JDAHEP(2,MHEP)=LHEP
10772 JMOHEP(2,NHEP)=LHEP
10773 JDAHEP(2,NHEP)=MHEP
10774 ENDIF
10775 ELSE
10776C Gaugino or Higgs
10777 JMOHEP(2,MHEP)=NHEP
10778 JDAHEP(2,MHEP)=NHEP
10779 JMOHEP(2,NHEP)=MHEP
10780 JDAHEP(2,NHEP)=MHEP
10781 ENDIF
10782 ENDIF
10783 ENDIF
10784 999 RETURN
10785 END
10786CDECK ID>, HWDHO4.
10787*CMZ :- -30/09/02 14:05:28 by Peter Richardson
10788*-- Author : Ian Knowles & Bryan Webber
10789C-----------------------------------------------------------------------
10790 SUBROUTINE HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW)
10791C-----------------------------------------------------------------------
10792C Subroutine to perform the fourth part of the heavy object decays
10793C IE parton-showers with special treatment for top
10794C was part of HWDHOB
10795C-----------------------------------------------------------------------
c63d70bc 10796 INCLUDE 'herwig65.inc'
65767955 10797 DOUBLE PRECISION PW(5),PDW(5,3)
10798 INTEGER IHEP,ID,IM,I,KHEP,LHEP,MHEP,NPR,NTRY,WHEP,SHEP
10799 DOUBLE COMPLEX RHOIN(2,2)
10800 SAVE RHOIN
10801 DATA RHOIN/(0.5D0,0.0D0),(0.0D0,0.0D0),
10802 & (0.0D0,0.0D0),(0.5D0,0.0D0)/
10803 IF (IERROR.NE.0) RETURN
10804 SHEP = NHEP
10805C---SPECIAL CASE FOR THREE-BODY TOP DECAYS:
10806C RELABEL THEM AS TWO TWO-BODY DECAYS FOR PARTON SHOWERING
10807 IF ((ID.EQ.6.OR.ID.EQ.12).AND.NPR.EQ.3.AND.
10808 & (NME(IM).EQ.100.OR.NME(IM).EQ.200.OR.
10809 & (NME(IM).GT.10000.AND.NME(IM).LE.20000.AND.
10810 & (SYSPIN.OR.THREEB)))) THEN
10811C---STORE W/H DECAY PRODUCTS
10812 CALL HWVEQU(10,PHEP(1,KHEP),PDW)
10813C---BOOST THEM INTO W/H REST FRAME
10814 CALL HWULOF(PW,PDW(1,1),PDW(1,3))
10815C---REPLACE THEM BY W/H
10816 CALL HWVEQU(5,PW,PHEP(1,KHEP))
10817 WHEP=KHEP
10818 IF (NME(IM).EQ.100.OR.(NME(IM).GT.10000.AND.
10819 & NME(IM).LE.20000.AND.(SYSPIN.OR.THREEB)))IDHW(KHEP)=198
10820 IF((NME(IM).EQ.100.OR.(NME(IM).GT.10000.AND.
10821 & NME(IM).LE.20000.AND.(SYSPIN.OR.THREEB))).AND.(ID.EQ.12))
10822 & IDHW(KHEP)=199
10823 IF (NME(IM).EQ.200)IDHW(KHEP)=206
10824 IF((NME(IM).EQ.200).AND.(ID.EQ.12))IDHW(KHEP)=207
10825 IDHEP(KHEP)=IDPDG(IDHW(KHEP))
10826 JMOHEP(2,KHEP)=KHEP
10827 JDAHEP(2,KHEP)=KHEP
10828 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,KHEP))
10829C---AND MOVE B UP
10830 CALL HWVEQU(5,PHEP(1,NHEP),PHEP(1,MHEP))
10831 IDHW(MHEP)=IDHW(NHEP)
10832 IDHEP(MHEP)=IDHEP(NHEP)
10833 JDAHEP(2,LHEP)=MHEP
10834 JMOHEP(2,MHEP)=JMOHEP(2,NHEP)
10835 JDAHEP(2,MHEP)=JDAHEP(2,NHEP)
10836 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,MHEP))
10837 NHEP=MHEP
10838C---DO PARTON SHOWER
10839 EMSCA=PHEP(5,IHEP)
10840 CALL HWBGEN
10841 IF (IERROR.NE.0) RETURN
10842C---FIND BOOSTED W/H MOMENTUM
10843 NTRY=0
10844 41 NTRY=NTRY+1
10845 IF (NTRY.GT.NHEP.OR.WHEP.LE.0.OR.WHEP.GT.NHEP) THEN
10846 CALL HWWARN('HWDHO4',100)
10847 GOTO 999
10848 ENDIF
10849 WHEP=JDAHEP(1,WHEP)
10850 IF (ISTHEP(WHEP).NE.190) GOTO 41
10851C---AND HENCE ITS CHILDRENS MOMENTA
10852 CALL HWULOB(PHEP(1,WHEP),PDW(1,3),PHEP(1,NHEP+1))
10853 CALL HWVDIF(4,PHEP(1,WHEP),PHEP(1,NHEP+1),PHEP(1,NHEP+2))
10854 PHEP(5,NHEP+2)=PDW(5,2)
10855C---LABEL THEM
10856 ISTHEP(WHEP)=195
10857 DO 51 I=1,2
10858 IDHW(NHEP+I)=IDKPRD(I,IM)
10859 IDHEP(NHEP+I)=IDPDG(IDHW(NHEP+I))
10860 ISTHEP(NHEP+I)=112+I
10861 JDAHEP(I,WHEP)=NHEP+I
10862 JMOHEP(1,NHEP+I)=WHEP
10863 JMOHEP(2,NHEP+I)=NHEP+3-I
10864 JDAHEP(2,NHEP+I)=NHEP+3-I
10865 51 CONTINUE
10866 NHEP=NHEP+2
10867C---ASSIGN PRODUCTION VERTICES TO 1 AND 2
10868 IF(NME(IM).EQ.100)CALL HWUDKL(198,PW,VHEP(1,NHEP))
10869 IF(NME(IM).EQ.200)CALL HWUDKL(206,PW,VHEP(1,NHEP))
10870 CALL HWVSUM(4,VHEP(1,WHEP),VHEP(1,NHEP),VHEP(1,NHEP))
10871 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
10872C---DO PARTON SHOWERS
10873 EMSCA=PW(5)
10874C--modification to use photos in top decays
10875 IF(ITOPRD.EQ.1) CALL HWPHTP(WHEP)
10876C--end of modification
10877 CALL HWBGEN
10878 IF (IERROR.NE.0) RETURN
10879 ELSE
10880C Do parton showers
10881 EMSCA=PHEP(5,IHEP)
10882 CALL HWBGEN
10883 IF (IERROR.NE.0) RETURN
10884C--special for gauge boson decay modes of gauginos and four body higgs
10885C--call routine to add decay products and generate parton shower
10886 IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN
10887 CALL HWDSM3(-1,IHEP,MHEP,SHEP,0,NME(IM)-20000,RHOIN,
10888 & ISNHEP(IHEP))
10889 ELSEIF(NME(IM).GT.40000.AND.NME(IM).LT.50000) THEN
10890 CALL HWDSM4(2,IHEP,MHEP,SHEP,NME(IM)-40000)
10891 ENDIF
10892 IF (IERROR.NE.0) RETURN
10893 ENDIF
10894 999 RETURN
10895 END
10896CDECK ID>, HWDHO5.
10897*CMZ :- -17/10/01 10:19:15 by Peter Richardson
10898*-- Author : Ian Knowles & Bryan Webber
10899C-----------------------------------------------------------------------
10900 SUBROUTINE HWDHO5(MHEP,LHEP,CLSAVE)
10901C-----------------------------------------------------------------------
10902C Subroutine to perform the fifth part of the heavy object decays
10903C IE sort out RPV colour connections
10904C was part of HWDHOB
10905C-----------------------------------------------------------------------
c63d70bc 10906 INCLUDE 'herwig65.inc'
65767955 10907 INTEGER ID,LHEP,MHEP,IDM,IDM2,THEP,CLSAVE(2)
10908 IF (IERROR.NE.0) RETURN
10909C--New to correct colour connections in Rslash
10910 IF(CLSAVE(1).NE.0) THEN
10911 THEP = MHEP+1
10912 ID = IDHW(CLSAVE(1))
10913 IDM = IDHW(JMOHEP(1,CLSAVE(1)))
10914 IDM2 = IDHW(LHEP)
10915 IF(IDM.EQ.15) ID=IDHW(JMOHEP(1,JMOHEP(1,CLSAVE(1))))
10916 IF((ID.LE.6.AND.((IDM.GE.419.AND.IDM.LE.424).OR.IDM.EQ.411.OR.
10917 & IDM.EQ.412).
10918 & AND.((IDM2.GE.413.AND.IDM2.LE.418)
10919 & .OR.IDM2.EQ.449).OR.IDM2.EQ.405.OR.IDM2.EQ.406)
10920 & .OR.(ID.LE.6.AND.IDM.EQ.449.AND.
10921 & (((IDM2.GE.413.AND.IDM2.LE.418).OR.IDM2.EQ.405.OR.IDM2.EQ.406)
10922 & .OR.IDM2.EQ.449)).OR.
10923 & (IDM.EQ.15.AND.ID.LE.12.AND.ID.GE.7.AND.((IDM2.GE.413.AND.
10924 & IDM2.LE.418).OR.IDM2.EQ.449.OR.IDM2.
10925 & EQ.405.OR.IDM2.EQ.406))) THEN
10926 IF(JMOHEP(2,CLSAVE(1)).EQ.MHEP) THEN
10927 IF(IDHW(CLSAVE(1)).NE.13.AND.IDHW(CLSAVE(1)).NE.449)
10928 & JMOHEP(2,CLSAVE(2)) = THEP
10929 JDAHEP(2,MHEP) = CLSAVE(1)
10930 JDAHEP(2,THEP) = CLSAVE(2)
10931 ELSE
10932 IF(IDHW(CLSAVE(1)).NE.13.AND.IDHW(CLSAVE(1)).NE.449)
10933 & JMOHEP(2,CLSAVE(2)) = MHEP
10934 JDAHEP(2,MHEP) = CLSAVE(2)
10935 JDAHEP(2,THEP) = CLSAVE(1)
10936 ENDIF
10937 ELSEIF((ID.GT.6.AND.ID.LE.12.
10938 & AND.((IDM.GE.413.AND.IDM.LE.418).OR.IDM.EQ.405.OR.
10939 & IDM.EQ.406).AND.
10940 & ((IDM2.GE.419.AND.IDM2.LE.424).OR.IDM2.EQ.449.OR.
10941 & IDM2.EQ.411.OR.IDM2.EQ.412)).OR.
10942 & (ID.GT.6.AND.ID.LE.12.AND.IDM.EQ.449.
10943 & AND.((IDM2.GE.419.AND.IDM2.LE.424).OR.IDM2.EQ.449.OR.
10944 & IDM2.EQ.411.OR.IDM2.EQ.412)).OR.
10945 & (IDM.EQ.15.AND.ID.LE.6.AND.((IDM2.GE.419.AND.
10946 & IDM2.LE.424).OR.IDM2.EQ.449.OR.IDM2.EQ.411.OR.
10947 & IDM2.EQ.412))) THEN
10948 IF(JDAHEP(2,CLSAVE(1)).EQ.MHEP) THEN
10949 JDAHEP(2,CLSAVE(2))=THEP
10950 JMOHEP(2,MHEP)=CLSAVE(1)
10951 JMOHEP(2,THEP)=CLSAVE(2)
10952 ELSE
10953 JDAHEP(2,CLSAVE(2))=MHEP
10954 JMOHEP(2,MHEP)=CLSAVE(2)
10955 JMOHEP(2,THEP)=CLSAVE(1)
10956 ENDIF
10957 ENDIF
10958 COLUPD = .FALSE.
10959 CALL HWBCON
10960 ENDIF
10961 END
10962CDECK ID>, HWDHO6.
10963*CMZ :- -17/10/01 10:19:15 by Peter Richardson
10964*-- Author : Ian Knowles & Bryan Webber
10965C-----------------------------------------------------------------------
10966 SUBROUTINE HWDHO6
10967C-----------------------------------------------------------------------
10968C Subroutine to perform the final part of the heavy object decays
10969C IE sort out any colour connection problems
10970C-----------------------------------------------------------------------
c63d70bc 10971 INCLUDE 'herwig65.inc'
65767955 10972 INTEGER IHEP,IM,JHEP,ISM,JCM
10973 IF (IERROR.NE.0) RETURN
10974C Fix any SUSY colour disconnections
10975 DO 80 IHEP=1,NHEP
10976 IF (ISTHEP(IHEP).GE.147.AND.ISTHEP(IHEP).LE.151
10977 & .AND.JDAHEP(2,IHEP).EQ.0) THEN
10978 IM=JMOHEP(1,IHEP)
10979C Chase connection back through SUSY decays
10980 75 IM=JMOHEP(1,IM)
10981 ISM=ISTHEP(IM)
10982 IF (ISM.EQ.120) GOTO 80
10983 IF (ISM.NE.123.AND.ISM.NE.124.AND.ISM.NE.155) GOTO 75
10984C Look for unclustered parton to connect
10985 DO JHEP=1,NHEP
10986 IF (ISTHEP(JHEP).GE.147.AND.ISTHEP(JHEP).LE.151) THEN
10987 JCM=JMOHEP(2,JHEP)
10988 IF (JCM.EQ.IM) THEN
10989C Found it: connect
10990 JMOHEP(2,JHEP)=IHEP
10991 JDAHEP(2,IHEP)=JHEP
10992 GOTO 80
10993 ENDIF
10994 ENDIF
10995 ENDDO
10996C Not found: need to go further back
10997 GOTO 75
10998 ENDIF
10999 80 CONTINUE
11000 END
11001CDECK ID>, HWDHVY.
11002*CMZ :- -26/04/91 12.19.24 by Federico Carminati
11003*-- Author : Ian Knowles & Bryan Webber
11004C-----------------------------------------------------------------------
11005 SUBROUTINE HWDHVY
11006C-----------------------------------------------------------------------
11007C Performs partonic decays of hadrons containing heavy quark(s):
11008C either, meson/baryon spectator model weak decays;
11009C or, quarkonia -> 2-gluons, q-qbar, 3-gluons, or 2-gluons + photon.
11010C-----------------------------------------------------------------------
c63d70bc 11011 INCLUDE 'herwig65.inc'
65767955 11012 COMMON/FFS/TB,BT
11013 COMMON/SFF/IT1,IB1,IT2,IB2
11014 DOUBLE PRECISION TB,BT
11015 INTEGER IT1,IB1,IT2,IB2
11016 DOUBLE PRECISION GAMHPM
11017 DOUBLE PRECISION HWULDO,HWRGEN,XS,XB,EMWSQ,GMWSQ,EMLIM,PW(4),
11018 & EMTST,X1,X2,X3,TEST,HWDWWT,HWDHWT,HWDPWT
11019 INTEGER IST(3),I,IHEP,IM,ID,IDQ,IQ,IS,J
11020 EXTERNAL HWRGEN,HWDWWT,HWDHWT,HWDPWT,HWULDO
11021 SAVE IST
11022 DATA IST/113,114,114/
11023 IF (IERROR.NE.0) RETURN
11024 DO 100 I=1,NMXQDK
11025 IF (I.GT.NQDK) THEN
11026 NQDK=0
11027 RETURN
11028 ENDIF
11029 IHEP=LOCQ(I)
11030 IF (ISTHEP(IHEP).EQ.199) GOTO 100
11031 IM=IMQDK(I)
11032 IF (NHEP+NPRODS(IM).GT.NMXHEP) THEN
11033 CALL HWWARN('HWDHVY',100)
11034 GOTO 999
11035 ENDIF
11036 IF (IDKPRD(4,IM).NE.0) THEN
11037C Weak decay of meson or baryon
11038C Idenitify decaying heavy quark and spectator
11039 ID=IDHW(IHEP)
11040 IF (ID.EQ.136.OR.ID.EQ.140.OR.ID.EQ.144.OR.
11041 & ID.EQ.150.OR.ID.EQ.155.OR.ID.EQ.158.OR.ID.EQ.161.OR.
11042 & (ID.EQ.254.AND.IDKPRD(4,IM).EQ.11)) THEN
11043C c hadron or c decay of B_c+
11044 IDQ=4
11045 IQ=NHEP+1
11046 IS=NHEP+2
11047 ELSEIF (ID.EQ.171.OR.ID.EQ.175.OR.ID.EQ.179.OR.
11048 & ID.EQ.185.OR.ID.EQ.190.OR.ID.EQ.194.OR.ID.EQ.196.OR.
11049 & (ID.EQ.230.AND.IDKPRD(4,IM).EQ.5)) THEN
11050C cbar hadron or cbar decay of B_c-
11051 IDQ=10
11052 IS=NHEP+1
11053 IQ=NHEP+2
11054 ELSEIF ((ID.GE.221.AND.ID.LE.229).OR.
11055 & (ID.EQ.230.AND.IDKPRD(4,IM).EQ.10)) THEN
11056C b hadron or b decay of B_c-
11057 IDQ=5
11058 IQ=NHEP+1
11059 IS=NHEP+2
11060 ELSEIF ((ID.GE.245.AND.ID.LE.253).OR.
11061 & (ID.EQ.254.AND.IDKPRD(4,IM).EQ.4)) THEN
11062C bbar hadron or bbar decay of B_c+
11063 IDQ=11
11064 IS=NHEP+1
11065 IQ=NHEP+2
11066 ELSE
11067C Decay not recognized
11068 CALL HWWARN('HWDHVY',101)
11069 GOTO 999
11070 ENDIF
11071C Label constituents
11072 IF (NHEP+5.GT.NMXHEP) THEN
11073 CALL HWWARN('HWDHVY',102)
11074 GOTO 999
11075 ENDIF
11076 ISTHEP(IHEP)=199
11077 JDAHEP(1,IHEP)=NHEP+1
11078 JDAHEP(2,IHEP)=NHEP+2
11079 IDHW(IQ)=IDQ
11080 IDHW(IS)=IDKPRD(4,IM)
11081 IDHEP(IQ)=IDPDG(IDQ)
11082 IDHEP(IS)=IDPDG(IDKPRD(4,IM))
11083 ISTHEP(IQ)=155
11084 ISTHEP(IS)=115
11085 JMOHEP(1,IQ)=IHEP
11086 JMOHEP(2,IQ)=IS
11087 JDAHEP(1,IQ)=NHEP+3
11088 JDAHEP(2,IQ)=NHEP+5
11089 JMOHEP(1,IS)=IHEP
11090 JMOHEP(2,IS)=NHEP+5
11091 JDAHEP(1,IS)=0
11092 JDAHEP(2,IS)=NHEP+5
11093 NHEP=NHEP+2
11094C and weak decay product jets
11095 DO 10 J=1,3
11096 NHEP=NHEP+1
11097 IDHW(NHEP)=IDKPRD(J,IM)
11098 IDHEP(NHEP)=IDPDG(IDKPRD(J,IM))
11099 ISTHEP(NHEP)=IST(J)
11100 JMOHEP(1,NHEP)=IQ
11101 JDAHEP(1,NHEP)=0
11102 10 PHEP(5,NHEP)=RMASS(IDKPRD(J,IM))
11103 JMOHEP(2,NHEP-2)=NHEP-1
11104 JDAHEP(2,NHEP-2)=NHEP-1
11105 JMOHEP(2,NHEP-1)=NHEP-2
11106 JDAHEP(2,NHEP-1)=NHEP-2
11107 JMOHEP(2,NHEP )=IQ
11108 JDAHEP(2,NHEP )=IQ
11109C Share momenta in ratio of masses, preserving specator mass
11110 XS=RMASS(IDHW(IS))/PHEP(5,IHEP)
11111 XB=ONE-XS
11112 CALL HWVSCA(5,XB,PHEP(1,IHEP),PHEP(1,IQ))
11113 CALL HWVSCA(5,XS,PHEP(1,IHEP),PHEP(1,IS))
11114 IF (NME(IM).EQ.100) THEN
11115C Generate decay momenta using full (V-A)*(V-A) matrix element
11116 EMWSQ=RMASS(198)**2
11117 GMWSQ=(RMASS(198)*GAMW)**2
11118 EMLIM=GMWSQ+(EMWSQ-(PHEP(5,IQ)-PHEP(5,NHEP))**2)**2
11119 20 CALL HWDTHR(PHEP(1,IQ ),PHEP(1,NHEP-1),
11120 & PHEP(1,NHEP-2),PHEP(1,NHEP),HWDWWT)
11121 CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
11122 EMTST=(HWULDO(PW,PW)-EMWSQ)**2
11123 IF ((EMTST+GMWSQ)*HWRGEN(0).GT.EMLIM) GOTO 20
11124 ELSEIF (NME(IM).EQ.200) THEN
11125C Generate decay momenta using full
11126C ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) matrix element
11127 GAMHPM=RMASS(206)/DKLTM(206)
11128C sort tan(beta)
11129 IF((IQ.EQ. 2).OR.(IQ.EQ. 4).OR.
11130 & (IQ.EQ. 6).OR.(IQ.EQ. 8).OR.
11131 & (IQ.EQ. 10).OR.(IQ.EQ. 12).OR.
11132 & (IQ.EQ.122).OR.(IQ.EQ.124).OR.
11133 & (IQ.EQ.126).OR.(IQ.EQ.128).OR.
11134 & (IQ.EQ.130).OR.(IQ.EQ.132))THEN
11135 TB=TANB
11136 ELSE
11137 TB=1./TANB
11138 END IF
11139 IF((IDKPRD(1,IM).EQ. 2).OR.(IDKPRD(1,IM).EQ. 4).OR.
11140 & (IDKPRD(1,IM).EQ. 6).OR.(IDKPRD(1,IM).EQ. 8).OR.
11141 & (IDKPRD(1,IM).EQ. 10).OR.(IDKPRD(1,IM).EQ. 12).OR.
11142 & (IDKPRD(1,IM).EQ.122).OR.(IDKPRD(1,IM).EQ.124).OR.
11143 & (IDKPRD(1,IM).EQ.126).OR.(IDKPRD(1,IM).EQ.128).OR.
11144 & (IDKPRD(1,IM).EQ.130).OR.(IDKPRD(1,IM).EQ.132))THEN
11145 BT=TANB
11146 ELSE
11147 BT=1./TANB
11148 END IF
11149 IT1=IQ
11150 IB1=IDKPRD(3,IM)
11151 IT2=IDKPRD(1,IM)
11152 IB2=IDKPRD(2,IM)
11153 EMWSQ=RMASS(206)**2
11154 GMWSQ=(RMASS(206)*GAMHPM)**2
11155 EMLIM=GMWSQ+(EMWSQ-(PHEP(5,IQ)-PHEP(5,NHEP))**2)**2
11156 25 CALL HWDTHR(PHEP(1,IQ ),PHEP(1,NHEP),
11157 & PHEP(1,NHEP-2),PHEP(1,NHEP-1),HWDHWT)
11158 CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
11159 EMTST=(HWULDO(PW,PW)-EMWSQ)**2
11160 IF ((EMTST+GMWSQ)*HWRGEN(0).GT.EMLIM) GOTO 25
11161 ELSE
11162C Use phase space
11163 CALL HWDTHR(PHEP(1,IQ ),PHEP(1,NHEP-2),
11164 & PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
11165 CALL HWVSUM(4,PHEP(1,NHEP-2),PHEP(1,NHEP-1),PW)
11166 ENDIF
11167C Set up production vertices
11168 CALL HWVZRO(4,VHEP(1,IQ))
11169 CALL HWVEQU(4,VHEP(1,IQ),VHEP(1,IS))
11170 CALL HWVEQU(4,VHEP(1,IQ),VHEP(1,NHEP))
11171 CALL HWUDKL(198,PW,VHEP(1,NHEP-2))
11172 CALL HWVSUM(4,VHEP(1,IQ),VHEP(1,NHEP-2),VHEP(1,NHEP-2))
11173 CALL HWVEQU(4,VHEP(1,NHEP-2),VHEP(1,NHEP-1))
11174 EMSCA=PHEP(5,IQ)
11175 ELSE
11176C Quarkonium decay
11177C Label products
11178 ISTHEP(IHEP)=199
11179 JDAHEP(1,IHEP)=NHEP+1
11180 DO 30 J=1,NPRODS(IM)
11181 NHEP=NHEP+1
11182 IDHW(NHEP)=IDKPRD(J,IM)
11183 IDHEP(NHEP)=IDPDG(IDKPRD(J,IM))
11184 ISTHEP(NHEP)=IST(J)
11185 JMOHEP(1,NHEP)=IHEP
11186 JDAHEP(1,NHEP)=0
11187 PHEP(5,NHEP)=RMASS(IDKPRD(J,IM))
11188 30 CALL HWVZRO(4,VHEP(1,NHEP))
11189 JDAHEP(2,IHEP)=NHEP
11190C Establish colour connections and select momentum configuration
11191 IF (NPRODS(IM).EQ.3) THEN
11192 IF (IDKPRD(3,IM).EQ.13) THEN
11193C 3-gluon decay
11194 JMOHEP(2,NHEP-2)=NHEP
11195 JMOHEP(2,NHEP-1)=NHEP-2
11196 JMOHEP(2,NHEP )=NHEP-1
11197 JDAHEP(2,NHEP-2)=NHEP-1
11198 JDAHEP(2,NHEP-1)=NHEP
11199 JDAHEP(2,NHEP )=NHEP-2
11200 ELSE
11201C or 2-gluon + photon decay
11202 JMOHEP(2,NHEP-2)=NHEP-1
11203 JMOHEP(2,NHEP-1)=NHEP-2
11204 JMOHEP(2,NHEP )=NHEP
11205 JDAHEP(2,NHEP-2)=NHEP-1
11206 JDAHEP(2,NHEP-1)=NHEP-2
11207 JDAHEP(2,NHEP )=NHEP
11208 ENDIF
11209 IF (NME(IM).EQ.130) THEN
11210C Use Ore & Powell orthopositronium matrix element
11211 40 CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP-2),
11212 & PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
11213 X1=TWO*HWULDO(PHEP(1,IHEP),PHEP(1,NHEP-2))/PHEP(5,IHEP)**2
11214 X2=TWO*HWULDO(PHEP(1,IHEP),PHEP(1,NHEP-1))/PHEP(5,IHEP)**2
11215 X3=TWO-X1-X2
11216 TEST=((X1*(ONE-X1))**2+(X2*(ONE-X2))**2+(X3*(ONE-X3))**2)
11217 & /(X1*X2*X3)**2
11218 IF (TEST.LT.TWO*HWRGEN(0)) GOTO 40
11219 ELSE
11220C Use phase space
11221 CALL HWDTHR(PHEP(1,IHEP),PHEP(1,NHEP-2),
11222 & PHEP(1,NHEP-1),PHEP(1,NHEP),HWDPWT)
11223 ENDIF
11224 ELSE
11225C Parapositronium 2-gluon or q-qbar decay
11226 JMOHEP(2,NHEP-1)=NHEP
11227 JMOHEP(2,NHEP )=NHEP-1
11228 JDAHEP(2,NHEP-1)=NHEP
11229 JDAHEP(2,NHEP )=NHEP-1
11230 CALL HWDTWO(PHEP(1,IHEP),PHEP(1,NHEP-1),
11231 & PHEP(1,NHEP),CMMOM(IM),TWO,.FALSE.)
11232 ENDIF
11233 EMSCA=PHEP(5,IHEP)
11234 ENDIF
11235C Process this new hard scatter
11236 CALL HWVEQU(4,VTXQDK(1,I),VTXPIP)
11237 CALL HWBGEN
11238 CALL HWCFOR
11239 CALL HWCDEC
11240 CALL HWDHAD
11241 100 CONTINUE
11242 NQDK=0
11243 999 RETURN
11244 END
11245CDECK ID>, HWDRCL.
11246*CMZ :- -20/07/99 10:56:12 by Peter Richardson
11247*-- Author : Peter Richardson
11248C-----------------------------------------------------------------------
11249 SUBROUTINE HWDRCL(IHEP,MHEP,CLSAVE)
11250C-----------------------------------------------------------------------
11251C Sets the colour connections in Baryon number violating decays
11252C-----------------------------------------------------------------------
c63d70bc 11253 INCLUDE 'herwig65.inc'
65767955 11254 INTEGER IHEP,MHEP,ID,ID2,IDM2,IDM3,COLCON(2,2,3),FLACON(2,3),JHEP,
11255 & DECAY,COLANT,KHEP,IDM,IDMB,IDMB2,IDMB3,IDMB4,QHEP,IDM4,
11256 & CLSAVE(2),XHEP,I,HWRINT,THEP
11257 LOGICAL CONBV
11258C--Colour connections for the decays
11259 SAVE COLCON,FLACON
11260 DATA COLCON/-1,1,-1,-2,-2,1,-3,-1,-1,1,-2,-1/
11261 DATA FLACON/1,-1,1,-1,-1,0/
11262C--identify the decay
11263 IF(IERROR.NE.0) RETURN
11264 ID = IDHW(IHEP)
11265 ID2 = IDHW(MHEP)
11266 IF(ID.GE.450.AND.ID.LE.457) THEN
11267 DECAY = 1
11268 ELSEIF(ID.EQ.449) THEN
11269 DECAY = 2
11270 ELSEIF((ID.GE.411.AND.ID.LE.424).OR.ID.EQ.405.OR.ID.EQ.406) THEN
11271 DECAY = 3
11272 ELSE
11273C--UNKNOWN DECAY
11274 CALL HWWARN('HWDRCL',100)
11275 GOTO 999
11276 ENDIF
11277 COLANT = 1
11278C--identify the colour partner
11279 IF(DECAY.GT.1.AND.ID2.LE.6) THEN
11280C--colour partner
11281 COLANT = 2
11282 KHEP = JDAHEP(2,IHEP-1)
11283 ELSEIF(DECAY.GT.1.AND.ID2.GE.7) THEN
11284C--anticolour partner
11285 COLANT = 3
11286 KHEP = JMOHEP(2,IHEP)
11287 ELSE
11288 KHEP=IHEP
11289 ENDIF
11290 IDM = IDHW(JMOHEP(1,KHEP))
11291 IF(ABS(IDPDG(IDM)).GT.1000000.OR.IDM.EQ.15) THEN
11292 IDM2 = IDHW(JDAHEP(1,JMOHEP(1,KHEP)))
11293 IDM3 = IDHW(JDAHEP(2,JMOHEP(1,KHEP)))
11294 IDM4 = IDHW(JDAHEP(2,JMOHEP(1,KHEP))-1)
11295 QHEP = JMOHEP(1,KHEP)
11296 IDMB = IDHW(JMOHEP(1,QHEP))
11297 IDMB2 = IDHW(JMOHEP(2,QHEP))
11298 IDMB3 = IDHW(JDAHEP(1,QHEP))
11299 IDMB4 = IDHW(JDAHEP(2,QHEP))
11300 ENDIF
11301C--Now decide if the colour partner decayed via BV
11302 IF(COLANT.EQ.2.AND.((((IDM.GE.413.AND.IDM.LE.418).OR.
11303 & IDM.EQ.449.OR.IDM.EQ.405.OR.IDM.EQ.406).AND.
11304 & (IDM2.GE.7.AND.IDM2.LE.12.AND.
11305 & IDM3.GE.7.AND.IDM3.LE.12.AND.
11306 & IDM4.GE.7.AND.IDM4.LE.12)).OR.
11307 & (IDM.EQ.15.AND.IDMB.LE.6.AND.IDMB2.LE.6.AND.
11308 & ((IDMB3.GE.7.AND.IDMB4.GE.12.AND.IDMB4.EQ.449).OR.
11309 & (IDMB3.GE.198.AND.IDMB3.LE.207.AND.
11310 & ABS(IDPDG(IDMB4)).GT.1000000))))) THEN
11311 CONBV = .TRUE.
11312 COLUPD = .TRUE.
11313 HVFCEN = .FALSE.
11314 XHEP = JMOHEP(2,JDAHEP(2,JMOHEP(1,KHEP)))
11315 ELSEIF(COLANT.EQ.3.AND.((((IDM.GE.419.AND.IDM.LE.424).OR.
11316 & IDM.EQ.449.OR.IDM.EQ.411.OR.IDM.EQ.412).AND.
11317 & (IDM2.LE.6.AND.IDM3.LE.6.AND.IDM4.LE.6)).OR.
11318 & (IDM.EQ.15.AND.IDMB.GE.7.AND.IDMB.LE.12.AND.
11319 & IDMB2.GE.7.AND.IDMB2.LE.12.AND.((IDMB3.LE.6.AND.
11320 & IDMB4.EQ.449).OR.(ABS(IDPDG(IDMB4)).GT.1000000
11321 & .AND.IDMB3.GE.198.AND.IDMB3.LE.207))))) THEN
11322 CONBV = .TRUE.
11323 COLUPD = .TRUE.
11324 HVFCEN = .FALSE.
11325 XHEP = JDAHEP(2,JDAHEP(2,JMOHEP(1,KHEP)))
11326 ELSE
11327 CONBV = .FALSE.
11328 COLUPD = .FALSE.
11329 XHEP = 0
11330 ENDIF
11331 IF(CONBV) THEN
11332 IF(IDM.NE.15) THEN
11333 CLSAVE(1) = JDAHEP(2,JMOHEP(1,KHEP))-1
11334 CLSAVE(2) = CLSAVE(1)+1
11335 ELSE
11336 IF(IDMB4.EQ.449) THEN
11337 DO I=1,2
11338 CLSAVE(I) = JMOHEP(I,JMOHEP(1,KHEP))
11339 IF(CLSAVE(I).EQ.XHEP) CLSAVE(I)=JDAHEP(1,JMOHEP(1,KHEP))
11340 ENDDO
11341 ELSE
11342 CLSAVE(1) = JMOHEP(1,JMOHEP(1,KHEP))
11343 CLSAVE(2) = JMOHEP(2,JMOHEP(1,KHEP))
11344 ENDIF
11345 ENDIF
11346 ELSE
11347 CLSAVE(1)=0
11348 CLSAVE(2)=0
11349 ENDIF
11350C--Now set the colours for angular ordering
11351 THEP = MHEP-1
11352 IF(DECAY.EQ.1) THEN
11353 IF(ID2.LE.6) THEN
11354 JMOHEP(2,THEP) = THEP+HWRINT(1,2)
11355 JDAHEP(2,THEP) = THEP
11356 ELSE
11357 JMOHEP(2,THEP) = THEP
11358 JDAHEP(2,THEP) = THEP+HWRINT(1,2)
11359 ENDIF
11360 ELSEIF(DECAY.EQ.2) THEN
11361 IF(ID2.LE.6) THEN
11362 JMOHEP(2,THEP) = IHEP
11363 JDAHEP(2,THEP) = THEP
11364 ELSE
11365 JMOHEP(2,THEP) = THEP
11366 JDAHEP(2,THEP) = IHEP
11367 ENDIF
11368 ENDIF
11369C--Colour of the second two
11370 DO JHEP=1,2
11371 IF(ID2.LE.6) THEN
11372 JMOHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+
11373 & COLCON(HWRINT(1,2),JHEP,DECAY)
11374 JDAHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+FLACON(JHEP,DECAY)
11375 ELSE
11376 JDAHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+
11377 & COLCON(HWRINT(1,2),JHEP,DECAY)
11378 JMOHEP(2,MHEP+JHEP-1) = MHEP+JHEP-1+FLACON(JHEP,DECAY)
11379 ENDIF
11380 ENDDO
11381C--Now set the colours of the colour partner
11382 IF(DECAY.GT.1.AND..NOT.CONBV) THEN
11383 IF(ID2.LE.6) JMOHEP(2,KHEP) = MHEP+HWRINT(0,1)
11384 IF(ID2.GE.7) JDAHEP(2,KHEP) = MHEP+HWRINT(0,1)
11385 ELSEIF(CONBV) THEN
11386 IF(ID2.GT.6) THEN
11387 JMOHEP(2,CLSAVE(1)) = MHEP+HWRINT(0,1)
11388 IF(JMOHEP(2,CLSAVE(1)).EQ.MHEP) THEN
11389 JMOHEP(2,CLSAVE(2)) = MHEP+1
11390 ELSE
11391 JMOHEP(2,CLSAVE(2)) = MHEP
11392 ENDIF
11393 ELSE
11394 JDAHEP(2,CLSAVE(1)) = MHEP+HWRINT(0,1)
11395 IF(JDAHEP(2,CLSAVE(1)).EQ.MHEP) THEN
11396 JDAHEP(2,CLSAVE(2)) = MHEP+1
11397 ELSE
11398 JDAHEP(2,CLSAVE(2)) = MHEP
11399 ENDIF
11400 ENDIF
11401 ENDIF
11402 999 RETURN
11403 END
11404CDECK ID>, HWDRME.
11405*CMZ :- -20/07/99 10:56:12 by Peter Richardson
11406*-- Author : Peter Richardson
11407C-----------------------------------------------------------------------
11408 SUBROUTINE HWDRME(LHEP,MHEP)
11409C-----------------------------------------------------------------------
11410C SUBROUTINE TO IMPLEMENT ALL RPARITY DECAY MATRIX ELEMENTS
11411C-----------------------------------------------------------------------
c63d70bc 11412 INCLUDE 'herwig65.inc'
65767955 11413 DOUBLE PRECISION SM(6),SW(6),HWULDO,INFCOL,AM, M12SQ,M23SQ,MSGN,
11414 & M13SQ,A(6),B(6),SWEAK,MW,DECMOM(5),TEST(3),EPS,
11415 & M12SQT(6),M23SQT(6),M13SQT(6),LIMIT,M(4),RAND,
11416 & MC(2),MX2(6),MX(6),HWDPWT,HWRGEN,HWDRM1,LAMD(3),
11417 & TEST2
11418 EXTERNAL HWDRM1,HWULDO,HWDPWT,HWRGEN
11419 INTEGER K,SN(3),LHEP,CSP,I,SB(3),J,ND,LTRY,MHEP,NSP,ID(3),IG,
11420 & IDHWTP,IDHPTP,MTRY
11421 PARAMETER(EPS=1D-20)
11422 IF(IERROR.NE.0) RETURN
11423C--Electroweak parameters, etc
11424 SWEAK = SQRT(SWEIN)
11425 MW = RMASS(198)
11426 M(4) = PHEP(5,LHEP)
11427 IG = IDHW(LHEP)
11428C--Find the masses of the final state and zero parameters
11429 DO K=1,3
11430 ID(K) = IDHW(MHEP+K-1)
11431 IF(ID(K).LE.12) THEN
11432 SN(K)=ID(K)
11433 ELSE
11434 SN(K)=ID(K)-120
11435 ENDIF
11436 IF(SN(K).GT.6) SN(K)=SN(K)-6
11437 M(K) = PHEP(5,LHEP+K)
11438 SB(K)=SN(K)
11439 LAMD(K) = ZERO
11440 ENDDO
11441 DO J=1,6
11442 MX2(J) = ZERO
11443 MX(J) = ZERO
11444 M13SQT(J) = ZERO
11445 M23SQT(J) = ZERO
11446 M12SQT(J) = ZERO
11447 ENDDO
11448C--Evaluate the coefficents for the mode we want
11449 IF(IG.GE.450.AND.IG.LE.453) THEN
11450C--NEUTRALINO
11451 NSP = IG-449
11452 AM = RMASS(IG)
11453 MSGN = ZSGNSS(NSP)
11454 MC(1) = ZMIXSS(NSP,3)/(2*MW*COSB*SWEAK)
11455 MC(2) = ZMIXSS(NSP,4)/(2*MW*SINB*SWEAK)
11456C--Calculate the combinations of couplings needed
11457 IF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11458C--first for the UDD modes
11459 DO J=1,2
11460 A(J) = M(1)*MC(2)*QMIXSS(SN(1),2,J)
11461 & +SLFCH(SN(1),NSP)*QMIXSS(SN(1),1,J)
11462 B(J) = MSGN*(M(1)*MC(2)*QMIXSS(SN(1),1,J)
11463 & +SRFCH(SN(1),NSP)*QMIXSS(SN(1),2,J))
11464 MX2(J) = QMIXSS(SN(1),2,J)
11465 A(J+2) = M(2)*MC(1)*QMIXSS(SN(2),2,J)
11466 & +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
11467 B(J+2) = MSGN*(M(2)*MC(1)*QMIXSS(SN(2),1,J)
11468 & +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
11469 MX2(J+2) = QMIXSS(SN(2),2,J)
11470 A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
11471 & +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
11472 B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
11473 & +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
11474 MX2(J+2) = QMIXSS(SN(3),2,J)
11475 ENDDO
11476 DO K=1,3
11477 SN(K) = SN(K)+400
11478 SB(K) = SB(K)+412
11479 ENDDO
11480 ELSEIF(ID(1).GE.121.AND.ID(2).GE.121.AND.ID(3).GE.121) THEN
11481C--Now for the LLE modes
11482 DO J=1,2
11483 A(J) = MSGN*(M(1)*MC(1)*LMIXSS(SN(1),1,J)
11484 & +SRFCH(10+SN(1),NSP)*LMIXSS(SN(1),2,J))
11485 B(J) = M(1)*MC(1)*LMIXSS(SN(1),2,J)
11486 & +SLFCH(10+SN(1),NSP)*LMIXSS(SN(2),1,J)
11487 MX2(J)= LMIXSS(SN(1),1,J)
11488 A(J+2) = ZERO
11489 B(J+2) = SLFCH(10+SN(2),NSP)*LMIXSS(SN(2),1,J)
11490 MX2(J+2) = LMIXSS(SN(2),1,J)
11491 A(J+4) = M(3)*MC(1)*LMIXSS(SN(3),2,J)
11492 & +SLFCH(10+SN(3),NSP)*LMIXSS(SN(3),1,J)
11493 B(J+4) = MSGN*(M(3)*MC(1)*LMIXSS(SN(3),1,J)
11494 & +SRFCH(10+SN(3),NSP)*LMIXSS(SN(3),2,J))
11495 MX2(4+J) = LMIXSS(SN(3),2,J)
11496 ENDDO
11497 DO J=1,3
11498 SN(J) = SN(J) + 424
11499 SB(J) = SB(J) + 436
11500 ENDDO
11501 ELSE
11502C--Now for both types of LQD modes
11503 IF(MOD(SN(1),2).EQ.0) THEN
11504C--First the neutrino,down,antidown mode
11505 DO J=1,2
11506 A(J) = ZERO
11507 B(J) = SLFCH(10+SN(1),NSP)*
11508 & LMIXSS(SN(1),1,J)
11509 MX2(J) = LMIXSS(SN(1),1,J)
11510 A(J+2) = MSGN*(M(2)*MC(1)*QMIXSS(SN(2),1,J)
11511 & +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
11512 B(J+2) = M(2)*MC(1)*QMIXSS(SN(2),2,J)
11513 & +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
11514 MX2(2+J) = QMIXSS(SN(2),1,J)
11515 A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
11516 & +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
11517 B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
11518 & +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
11519 MX2(J+4) = QMIXSS(SN(3),2,J)
11520 ENDDO
11521 ELSE
11522C--Now the charged lepton, antiup,down modes
11523 DO J=1,2
11524 A(J) = MSGN*(M(1)*MC(1)*LMIXSS(SN(1),1,J)
11525 & +SRFCH(10+SN(1),NSP)*LMIXSS(SN(1),2,J))
11526 B(J) = M(1)*MC(1)*LMIXSS(SN(1),2,J)
11527 & +SLFCH(10+SN(1),NSP)*LMIXSS(SN(1),1,J)
11528 MX2(J) = LMIXSS(SN(1),1,J)
11529 A(J+2) =MSGN*(M(2)*MC(2)*QMIXSS(SN(2),1,J)
11530 & +SRFCH(SN(2),NSP)*QMIXSS(SN(2),2,J))
11531 B(J+2) = M(2)*MC(2)*QMIXSS(SN(2),2,J)
11532 & +SLFCH(SN(2),NSP)*QMIXSS(SN(2),1,J)
11533 MX2(2+J) = QMIXSS(SN(2),1,J)
11534 A(J+4) = M(3)*MC(1)*QMIXSS(SN(3),2,J)
11535 & +SLFCH(SN(3),NSP)*QMIXSS(SN(3),1,J)
11536 B(J+4) = MSGN*(M(3)*MC(1)*QMIXSS(SN(3),1,J)
11537 & +SRFCH(SN(3),NSP)*QMIXSS(SN(3),2,J))
11538 MX2(J+4) = QMIXSS(SN(3),2,J)
11539 ENDDO
11540 ENDIF
11541 SN(1) = SN(1) + 424
11542 SB(1) = SB(1) + 436
11543 DO J=2,3
11544 SN(J) = SN(J) + 400
11545 SB(J) = SB(J) + 412
11546 ENDDO
11547 ENDIF
11548 DO K=1,3
11549 SM(2*K-1) = RMASS(SN(K))
11550 SM(2*K) = RMASS(SB(K))
11551 SW(2*K-1) = HBAR/RLTIM(SN(K))
11552 SW(2*K) = HBAR/RLTIM(SB(K))
11553 ENDDO
11554 ND = 3
11555 DO K=1,3
11556 LAMD(K) = ONE
11557 ENDDO
11558 INFCOL = ONE
11559 ELSEIF(IG.EQ.449) THEN
11560C--GLUINO
11561C--First obtian the masses and widths needed
11562 AM = RMASS(IG)
11563 ND = 3
11564C--Calculate the combinations of couplings needed
11565 IF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11566C--first for the UDD modes
11567 INFCOL = -0.5D0
11568C--Couplings
11569 DO I=1,3
11570 DO J=1,2
11571 A(2*I-2+J) = -QMIXSS(SN(I),1,J)
11572 B(2*I-2+J) = QMIXSS(SN(I),2,J)
11573 MX2(2*I-2+J) = QMIXSS(SN(I),2,J)
11574 ENDDO
11575 SN(I) = SN(I)+400
11576 SB(I) = SB(I)+412
11577 ENDDO
11578 ELSE
11579 INFCOL = ONE
11580C--Now for both types of LQD modes
11581 IF(MOD(SN(1),2).EQ.0) THEN
11582C--First the neutrino,down,antidown mode
11583 DO J=1,2
11584 A(J) = ZERO
11585 B(J) = ZERO
11586 MX2(J) = ZERO
11587 A(J+2) = QMIXSS(SN(2),2,J)
11588 B(J+2) = -QMIXSS(SN(2),1,J)
11589 MX2(J+2) = QMIXSS(SN(2),1,J)
11590 A(J+4) = -QMIXSS(SN(3),1,J)
11591 B(J+4) = QMIXSS(SN(3),2,J)
11592 MX2(4+J) = QMIXSS(SN(3),2,J)
11593 ENDDO
11594 ELSEIF(MOD(SN(1),2).EQ.1) THEN
11595C--Now the charged lepton, antiup,down modes
11596 DO J=1,2
11597 A(J) = ZERO
11598 B(J) = ZERO
11599 MX2(J) = ZERO
11600 A(J+2) = QMIXSS(SN(2),2,J)
11601 B(J+2) = -QMIXSS(SN(2),1,J)
11602 MX2(J+2) = QMIXSS(SN(2),1,J)
11603 A(J+4) = -QMIXSS(SN(3),1,J)
11604 B(J+4) = QMIXSS(SN(3),2,J)
11605 MX2(J+4) = QMIXSS(SN(3),2,J)
11606 ENDDO
11607 ENDIF
11608 SN(1) = SN(1) + 424
11609 SB(1) = SB(1) + 436
11610 DO K=2,3
11611 SN(K) = SN(K) + 400
11612 SB(K) = SB(K) + 412
11613 ENDDO
11614 ENDIF
11615 DO K=1,3
11616 SM(2*K-1) = RMASS(SN(K))
11617 SM(2*K) = RMASS(SB(K))
11618 SW(2*K-1) = HBAR/RLTIM(SN(K))
11619 SW(2*K) = HBAR/RLTIM(SB(K))
11620 ENDDO
11621 DO K=1,3
11622 LAMD(K) = ONE
11623 ENDDO
11624 ELSEIF(IG.GE.454.AND.IG.LE.457) THEN
11625C--CHARGINO
11626 CSP = IG-453
11627 IF(CSP.GT.2) CSP = CSP-2
11628 AM = RMASS(IG)
11629 INFCOL = -ONE
11630 MSGN = WSGNSS(CSP)
11631 MC(1) = ONE/(SQRT(2.0D0)*MW*COSB)
11632 MC(2) = ONE/(SQRT(2.0D0)*MW*SINB)
11633C--Calculate the combinations of the couplings needed
11634 IF(ID(1).GT.120.AND.ID(2).GT.120.AND.ID(3).GT.120) THEN
11635C--first for the LLE modes, three modes
11636 IF(MOD(SN(1),2).EQ.0.AND.MOD(SN(3),2).EQ.0) THEN
11637C--the one diagram mode nubar,positron, nu
11638 DO J=1,2
11639 A(J+4) = LMIXSS(SN(3)-1,1,J)*WMXUSS(CSP,1)
11640 & -RMASS(SN(3)+119)*MC(1)*LMIXSS(SN(3)-1,2,J)*WMXUSS(CSP,2)
11641 B(J+4) = ZERO
11642 MX2(J+4) = LMIXSS(SN(3)-1,2,J)
11643 ENDDO
11644 ND = 1
11645 SN(3) = SN(3)+423
11646 SB(3) = SB(3)+435
11647 ELSEIF(MOD(SN(1),2).EQ.0.AND.MOD(SN(2),2).EQ.0) THEN
11648C--the first two diagram mode nu, nu, positron
11649 DO J=1,2
11650 A(J) = ZERO
11651 B(J) = LMIXSS(SN(1)-1,1,J)*WMXUSS(CSP,1)
11652 & -RMASS(SN(1)+119)*MC(1)*LMIXSS(SN(1)-1,2,J)*WMXUSS(CSP,2)
11653 A(J+2) = ZERO
11654 B(J+2) = LMIXSS(SN(2)-1,1,J)*WMXUSS(CSP,1)
11655 & -RMASS(SN(2)+119)*MC(1)*LMIXSS(SN(2)-1,2,J)*WMXUSS(CSP,2)
11656 MX2(J) = LMIXSS(SN(1)-1,1,J)
11657 MX2(J+2) = LMIXSS(SN(2)-1,1,J)
11658 ENDDO
11659 ND = 2
11660 DO J=1,2
11661 SN(J) = SN(J)+423
11662 SB(J) = SB(J)+435
11663 ENDDO
11664 ELSE
11665C--the second two diagram mode positron, positron, electron
11666 DO J=1,2
11667 A(J) = -M(1)*WMXUSS(CSP,2)*MC(1)*LMIXSS(SN(1)+1,1,J)
11668 B(J) = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(1)+1,1,J)
11669 A(J+2) = -M(2)*WMXUSS(CSP,2)*MC(1)*LMIXSS(SN(2)+1,1,J)
11670 B(J+2) = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(2)+1,1,J)
11671 MX2(J) = LMIXSS(SN(1)+1,1,J)
11672 MX2(J+2) = LMIXSS(SN(2)+1,1,J)
11673 ENDDO
11674 DO J=1,2
11675 SN(J) = SN(J)+425
11676 SB(J) = SB(J)+437
11677 ENDDO
11678 ND = 2
11679 ENDIF
11680 DO K=1,3
11681 LAMD(K) = ONE
11682 ENDDO
11683 ELSEIF(ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11684C--now for the UDD
11685 IF(MOD(SN(1),2).EQ.0) THEN
11686C--two diagram mode
11687 LAMD(1) = LAMDA3(SN(2)/2,SN(1)/2,(SN(3)+1)/2)
11688 LAMD(2) = LAMDA3(SN(1)/2,SN(2)/2,(SN(3)+1)/2)
11689 DO J=1,2
11690 A(J) = WMXUSS(CSP,1)*QMIXSS(SN(1)-1,1,J)
11691 & -RMASS(SN(1)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(1)-1,2,J)
11692 B(J) = -MSGN*M(2)*WMXVSS(CSP,2)*QMIXSS(SN(1)-1,1,J)
11693 A(J+2) = WMXUSS(CSP,1)*QMIXSS(SN(2)-1,1,J)
11694 & -RMASS(SN(2)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(2)-1,2,J)
11695 B(J+2) = -MSGN*M(2)*WMXVSS(CSP,2)*QMIXSS(SN(2)-1,1,J)
11696 MX2(J) = QMIXSS(SN(1)-1,2,J)
11697 MX2(J+2) = QMIXSS(SN(2)-1,2,J)
11698 ENDDO
11699 DO J=1,2
11700 SN(J) = SN(J) + 399
11701 SB(J) = SB(J) + 411
11702 ENDDO
11703 ND = 2
11704 ELSE
11705C--three diagram mode
11706 LAMD(1) = LAMDA3((SN(1)+1)/2,(SN(2)+1)/2,(SN(3)+1)/2)
11707 LAMD(2) = LAMDA3((SN(2)+1)/2,(SN(1)+1)/2,(SN(3)+1)/2)
11708 LAMD(3) = LAMDA3((SN(3)+1)/2,(SN(2)+1)/2,(SN(1)+1)/2)
11709 DO I=1,3
11710 DO J=1,2
11711 A(J+2*I-2) = MSGN*(WMXVSS(CSP,1)*QMIXSS(SN(I)+1,1,J)
11712 & -RMASS(SN(I)+1)*MC(2)*WMXVSS(CSP,2)*QMIXSS(SN(I)+1,2,J))
11713 B(J+2*I-2) = -M(I)*MC(1)*WMXUSS(CSP,2)
11714 & *QMIXSS(SN(I)+1,1,J)
11715 MX2(J+2*I-2) = QMIXSS(SN(I)+1,2,J)
11716 ENDDO
11717 SN(I) = SN(I) + 401
11718 SB(I) = SB(I) + 413
11719 ENDDO
11720 ND = 3
11721 ENDIF
11722 ELSE
11723C--now for the LQD modes
11724 IF(MOD(SN(2),2).EQ.1.AND.MOD(SN(3),2).EQ.0) THEN
11725C--first one diagram mode nubar, dbar, up
11726 DO J=1,2
11727 A(J+4) = -MSGN*M(3)*WMXVSS(CSP,2)*MC(2)*
11728 & QMIXSS(SN(3)-1,1,J)
11729 B(J+4) = WMXUSS(CSP,1)*QMIXSS(SN(3)-1,1,J)
11730 & -RMASS(SN(3)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(3)-1,2,1)
11731 MX2(J+4) = QMIXSS(SN(3)-1,2,J)
11732 ENDDO
11733 SN(3) = SN(3) + 399
11734 SB(3) = SB(3) + 411
11735 ND = 1
11736 ELSEIF(MOD(SN(2),2).EQ.0.AND.MOD(SN(3),2).EQ.0) THEN
11737C--second one diagram mode positron, ubar, up
11738 DO J=1,2
11739 A(J+4) = -MSGN*M(3)*WMXVSS(CSP,2)*MC(2)*
11740 & QMIXSS(SN(3)-1,1,J)
11741 B(J+4) = WMXUSS(CSP,1)*QMIXSS(SN(3)-1,1,J)
11742 & -RMASS(SN(3)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(3)-1,2,1)
11743 MX2(J+4) = QMIXSS(SN(3)-1,2,J)
11744 ENDDO
11745 SN(3) = SN(3) + 399
11746 SB(3) = SB(3) + 411
11747 ND = 1
11748 ELSEIF(MOD(SN(2),2).EQ.1.AND.MOD(SN(3),2).EQ.1) THEN
11749C--first two diagram mode positron, dbar, down
11750 DO J=1,2
11751 A(J) = -M(1)*MC(1)*WMXUSS(CSP,2)*LMIXSS(SN(1)+1,1,J)
11752 B(J) = MSGN*WMXVSS(CSP,1)*LMIXSS(SN(2)+1,1,J)
11753 A(J+2) = -M(2)*WMXUSS(CSP,2)*MC(1)*QMIXSS(SN(2)+1,1,J)
11754 B(J+2) = MSGN*(WMXVSS(CSP,1)*QMIXSS(SN(2)+1,1,J)
11755 & -RMASS(SN(2)+1)*MC(2)*WMXVSS(CSP,2)*QMIXSS(SN(2)+1,2,J))
11756 MX2(J) = LMIXSS(SN(1)+1,1,J)
11757 MX2(J+2) = QMIXSS(SN(2)+1,1,J)
11758 ENDDO
11759 SN(1) = SN(1) + 425
11760 SB(1) = SB(1) + 437
11761 SN(2) = SN(2) + 401
11762 SB(2) = SB(2) + 413
11763 ND = 2
11764 ELSE
11765C--second two diagram mode nu, up, dbar
11766 DO J=1,2
11767 A(J) = ZERO
11768 B(J) = WMXUSS(CSP,1)*LMIXSS(SN(1)-1,1,J)
11769 & -RMASS(119+SN(1))*MC(1)*WMXUSS(CSP,2)*LMIXSS(SN(1)-1,2,J)
11770 A(J+2) = -MSGN*M(2)*MC(2)*WMXVSS(CSP,2)*
11771 & QMIXSS(SN(2)-1,1,J)
11772 B(J+2) = WMXUSS(CSP,1)*QMIXSS(SN(2)-1,1,J)
11773 & -RMASS(SN(2)-1)*MC(1)*WMXUSS(CSP,2)*QMIXSS(SN(2)-1,2,J)
11774 MX2(J) = LMIXSS(SN(1)-1,1,J)
11775 MX2(J+2) = QMIXSS(SN(2)-1,1,J)
11776 ENDDO
11777 SN(1) = SN(1) + 423
11778 SB(1) = SB(1) + 435
11779 SN(2) = SN(2) + 399
11780 SB(2) = SB(2) + 411
11781 ND = 2
11782 ENDIF
11783 DO K=1,3
11784 LAMD(K) = ONE
11785 ENDDO
11786 ENDIF
11787 IF(ND.EQ.1) THEN
11788 DO K=1,2
11789 SM(2*K-1) = 0.0D0
11790 SM(2*K) = 0.0D0
11791 SW(2*K-1) = 0.0D0
11792 SW(2*K) = 0.0D0
11793 ENDDO
11794 SM(5) = RMASS(SN(3))
11795 SM(6) = RMASS(SB(3))
11796 SW(5) = HBAR/RLTIM(SN(3))
11797 SW(6) = HBAR/RLTIM(SB(3))
11798 ELSE
11799 DO K=1,2
11800 SM(2*K-1) = RMASS(SN(K))
11801 SM(2*K) = RMASS(SB(K))
11802 SW(2*K-1) = HBAR/RLTIM(SN(K))
11803 SW(2*K) = HBAR/RLTIM(SB(K))
11804 SM(4+K) = ZERO
11805 SW(4+K) = ZERO
11806 ENDDO
11807 ENDIF
11808 ELSE
11809C--UNKNOWN
11810 CALL HWWARN('HWDRME',500)
11811 ENDIF
11812C--Set mixing to zero if diagram not available
11813 IF((AM.LT.(ABS(SM(1))+M(1)).OR.ABS(SM(1)).LT.(M(2)+M(3)))
11814 & .AND.ABS(MX2(1)).GT.ZERO.AND.ND.NE.1) MX(1) = MX2(1)*LAMD(1)
11815 IF((AM.LT.(ABS(SM(2))+M(1)).OR.ABS(SM(2)).LT.(M(2)+M(3)))
11816 & .AND.ABS(MX2(2)).GT.ZERO.AND.ND.NE.1) MX(2) = MX2(2)*LAMD(1)
11817 IF((AM.LT.(ABS(SM(3))+M(2)).OR.ABS(SM(3)).LT.(M(1)+M(3)))
11818 & .AND.ABS(MX2(3)).GT.ZERO.AND.ND.NE.1) MX(3) = MX2(3)*LAMD(2)
11819 IF((AM.LT.(ABS(SM(4))+M(2)).OR.ABS(SM(4)).LT.(M(1)+M(3)))
11820 & .AND.ABS(MX2(4)).GT.ZERO.AND.ND.NE.1) MX(4) = MX2(4)*LAMD(2)
11821 IF((AM.LT.(ABS(SM(5))+M(3)).OR.ABS(SM(5)).LT.(M(1)+M(2)))
11822 & .AND.ABS(MX2(5)).GT.ZERO.AND.ND.NE.2) MX(5) = MX2(5)*LAMD(3)
11823 IF((AM.LT.(ABS(SM(6))+M(3)).OR.ABS(SM(6)).LT.(M(1)+M(2)))
11824 & .AND.ABS(MX2(6)).GT.ZERO.AND.ND.NE.2) MX(6) = MX2(6)*LAMD(3)
11825C--Calculate the limiting points
11826 DO J=1,2
11827 IF(ND.NE.1) THEN
11828 IF(ABS(MX(J)).GT.EPS) CALL HWDRM5(M23SQT(J),M13SQT(J),
11829 & M12SQT(J),A(J),B(J),M(2),M(3),M(1),M(4),SM(J),SW(J))
11830 IF(ABS(MX(J+2)).GT.EPS) CALL HWDRM5(M13SQT(2+J),M23SQT(2+J),
11831 & M12SQT(2+J),A(2+J),B(2+J),M(1),M(3),M(2),M(4),SM(2+J),SW(2+J))
11832 ENDIF
11833 IF(ND.NE.2) THEN
11834 IF(ABS(MX(J+4)).GT.EPS) CALL HWDRM5(M12SQT(4+J),M23SQT(4+J),
11835 & M13SQT(4+J),A(4+J),B(4+J),M(1),M(2),M(3),M(4),SM(4+J),SW(4+J))
11836 ENDIF
11837 ENDDO
11838C--Now evaluate the limit using these points
11839 LIMIT = ZERO
11840 DO 100 I=1,6
11841 IF(ABS(MX(I)).LT.EPS) GOTO 100
11842 LIMIT = LIMIT+HWDRM1(TEST,M12SQT(I),M13SQT(I),M23SQT(I),A,B,MX,
11843 & M,SM,SW,INFCOL,AM,0,ND)
11844 100 CONTINUE
11845 LIMIT = TWO*LIMIT
11846C--Now evaluate at a random point
11847 MTRY = 0
11848 25 MTRY = MTRY+1
11849 LTRY = 0
11850 35 LTRY = LTRY+1
11851 CALL HWDTHR(PHEP(1,LHEP),PHEP(1,MHEP),
11852 & PHEP(1,MHEP+1),PHEP(1,MHEP+2),HWDPWT)
11853C--Now calculate the m12sq etc for the actual point
11854 M12SQ = M(1)**2+M(2)**2+2*HWULDO(PHEP(1,MHEP),PHEP(1,MHEP+1))
11855 M13SQ = M(1)**2+M(3)**2+2*HWULDO(PHEP(1,MHEP),PHEP(1,MHEP+2))
11856 M23SQ = M(2)**2+M(3)**2+2*HWULDO(PHEP(1,MHEP+1),PHEP(1,MHEP+2))
11857C--Now calulate the matrix element
11858 TEST2 = HWDRM1(TEST,M12SQ,M13SQ,M23SQ,A,B,MX,
11859 & M,SM,SW,INFCOL,AM,1,ND)
11860C--Now test the value againest the limit
11861 RAND = HWRGEN(0)*LIMIT
11862 IF(TEST2.GT.LIMIT) THEN
11863 LIMIT = 1.1D0*TEST2
11864 CALL HWWARN('HWDRME',51)
11865 GOTO 150
11866 ENDIF
11867 150 IF(TEST2.LT.RAND.AND.LTRY.LT.NETRY) THEN
11868 GOTO 35
11869 ELSEIF(LTRY.GE.NETRY) THEN
11870 IF(MTRY.LE.NETRY) THEN
11871 LIMIT = LIMIT*0.9D0
11872 CALL HWWARN('HWDRME',52)
11873 GOTO 25
11874 ELSE
11875 CALL HWWARN('HWDRME',100)
11876 GOTO 999
11877 ENDIF
11878 ENDIF
11879C--Reorder the particles in gluino decay to get angular ordering right
11880 IF(IG.EQ.449.AND.ID(1).LE.12.AND.ID(2).LE.12.AND.ID(3).LE.12) THEN
11881 DO LTRY=1,3
11882 IF(TEST(LTRY).GT.RAND) THEN
11883 IF(LTRY.EQ.2) THEN
11884 IDHWTP = IDHW(MHEP)
11885 IDHW(MHEP) = IDHW(MHEP+1)
11886 IDHW(MHEP+1) = IDHWTP
11887 IDHPTP = IDHEP(MHEP)
11888 IDHEP(MHEP) = IDHEP(MHEP+1)
11889 IDHEP(MHEP+1) = IDHPTP
11890 CALL HWVEQU(5,PHEP(1,MHEP),DECMOM)
11891 CALL HWVEQU(5,PHEP(1,MHEP+1),PHEP(1,MHEP))
11892 CALL HWVEQU(5,DECMOM,PHEP(1,MHEP+1))
11893 ELSEIF(LTRY.EQ.3) THEN
11894 IDHWTP = IDHW(MHEP)
11895 IDHW(MHEP) = IDHW(MHEP+2)
11896 IDHW(MHEP+2) = IDHWTP
11897 IDHPTP = IDHEP(MHEP)
11898 IDHEP(MHEP) = IDHEP(MHEP+2)
11899 IDHEP(MHEP+2) = IDHPTP
11900 DO I=1,5
11901 CALL HWVEQU(5,PHEP(1,MHEP),DECMOM)
11902 CALL HWVEQU(5,PHEP(1,MHEP+2),PHEP(1,MHEP))
11903 CALL HWVEQU(5,DECMOM,PHEP(1,MHEP+2))
11904 ENDDO
11905 ENDIF
11906 GOTO 52
11907 ENDIF
11908 RAND=RAND-TEST(LTRY)
11909 ENDDO
11910 ENDIF
11911 52 CONTINUE
11912 999 RETURN
11913 END
11914CDECK ID>, HWDRM1.
11915*CMZ :- -20/07/99 10:56:12 by Peter Richardson
11916*-- Author : Peter Richardson
11917C-----------------------------------------------------------------------
11918 FUNCTION HWDRM1(TEST,M12SQ,M13SQ,M23SQ,A,B,MX,M,SM,SW
11919 & ,INFCOL,AM,LM,ND)
11920C-----------------------------------------------------------------------
11921C FUNCTION TO GIVE THE R-PARITY VIOLATING MATRIX ELEMENT AT A GIVEN
11922C PHASE-SPACE POINT
11923C-----------------------------------------------------------------------
11924 IMPLICIT NONE
11925 DOUBLE PRECISION M12SQ,M13SQ,M23SQ,MX(6),A(6),B(6),SM(6),SW(6),
11926 & INFCOL,AM,TERM(21),TEST(3),PLN,NPLN,ZERO,
11927 & M(4),HWDRM1,HWDRM2,HWDRM3,HWDRM4
11928 PARAMETER (ZERO=0)
11929 EXTERNAL HWDRM2,HWDRM3,HWDRM4
11930 INTEGER LM,K,ND
11931C--Zero the array
11932 DO K=1,21
11933 TERM(K) = 0.0D0
11934 ENDDO
11935 HWDRM1 = 0.0D0
11936C--The amplitude
11937 IF(ABS(MX(1)).GT.ZERO.AND.ND.NE.1) THEN
11938 TERM(1) = MX(1)**2*HWDRM2(M23SQ,M(2),M(3),M(1),M(4),SM(1),
11939 & SW(1),A(1),B(1))
11940 IF(ABS(MX(2)).GT.ZERO) TERM(7)= MX(1)*MX(2)*HWDRM3(M23SQ,M(2),
11941 & M(3),M(1),M(4),SM(1),SM(2),SW(1),SW(2),A(1),A(2),B(1),B(2))
11942 IF(ABS(MX(3)).GT.ZERO) TERM(10)=-MX(1)*MX(3)*HWDRM4(M13SQ,M23SQ,
11943 & M(1),M(3),M(2),M(4),SM(3),SM(1),SW(3),SW(1),A(1),A(3),B(1),B(3))
11944 IF(ABS(MX(4)).GT.ZERO) TERM(11)=-MX(1)*MX(4)*HWDRM4(M13SQ,M23SQ,
11945 & M(1),M(3),M(2),M(4),SM(4),SM(1),SW(4),SW(1),A(1),A(4),B(1),B(4))
11946 IF(ABS(MX(5)).GT.ZERO) TERM(12)=-MX(1)*MX(5)*HWDRM4(M23SQ,M12SQ,
11947 & M(3),M(2),M(1),M(4),SM(1),SM(5),SW(1),SW(5),A(5),A(1),B(5),B(1))
11948 IF(ABS(MX(6)).GT.ZERO) TERM(13)=-MX(1)*MX(6)*HWDRM4(M23SQ,M12SQ,
11949 & M(3),M(2),M(1),M(4),SM(1),SM(6),SW(1),SW(6),A(6),A(1),B(6),B(1))
11950 ENDIF
11951 IF(ABS(MX(2)).GT.ZERO.AND.ND.NE.1) THEN
11952 TERM(2) = MX(2)**2*HWDRM2(M23SQ,M(2),M(3),M(1),M(4),SM(2),
11953 & SW(2),A(2),B(2))
11954 IF(ABS(MX(3)).GT.ZERO) TERM(14)=-MX(2)*MX(3)*HWDRM4(M13SQ,M23SQ,
11955 & M(1),M(3),M(2),M(4),SM(3),SM(2),SW(3),SW(2),A(2),A(3),B(2),B(3))
11956 IF(ABS(MX(4)).GT.ZERO) TERM(15)=-MX(2)*MX(4)*HWDRM4(M13SQ,M23SQ,
11957 & M(1),M(3),M(2),M(4),SM(4),SM(2),SW(4),SW(2),A(2),A(4),B(2),B(4))
11958 IF(ABS(MX(5)).GT.ZERO) TERM(16)=-MX(2)*MX(5)*HWDRM4(M23SQ,M12SQ,
11959 & M(3),M(2),M(1),M(4),SM(2),SM(5),SW(2),SW(5),A(5),A(2),B(5),B(2))
11960 IF(ABS(MX(6)).GT.ZERO) TERM(17)=-MX(2)*MX(6)*HWDRM4(M23SQ,M12SQ,
11961 & M(3),M(2),M(1),M(4),SM(2),SM(6),SW(2),SW(6),A(6),A(2),B(6),B(2))
11962 ENDIF
11963 IF(ABS(MX(3)).GT.ZERO.AND.ND.NE.1) THEN
11964 TERM(3) = MX(3)**2*HWDRM2(M13SQ,M(1),M(3),M(2),M(4),SM(3),
11965 & SW(3),A(3),B(3))
11966 IF(ABS(MX(4)).GT.ZERO) TERM(8)= MX(3)*MX(4)*HWDRM3(M13SQ,M(1),
11967 & M(3),M(2),M(4),SM(3),SM(4),SW(3),SW(4),A(3),A(4),B(3),B(4))
11968 IF(ABS(MX(5)).GT.ZERO) TERM(18)=-MX(3)*MX(5)*HWDRM4(M12SQ,M13SQ,
11969 & M(2),M(1),M(3),M(4),SM(5),SM(3),SW(5),SW(3),A(3),A(5),B(3),B(5))
11970 IF(ABS(MX(6)).GT.ZERO) TERM(19)=-MX(3)*MX(6)*HWDRM4(M12SQ,M13SQ,
11971 & M(2),M(1),M(3),M(4),SM(6),SM(3),SW(6),SW(3),A(3),A(6),B(3),B(6))
11972 ENDIF
11973 IF(ABS(MX(4)).GT.ZERO.AND.ND.NE.1) THEN
11974 TERM(4) = MX(4)**2*HWDRM2(M13SQ,M(1),M(3),M(2),M(4),SM(4),
11975 & SW(4),A(4),B(4))
11976 IF(ABS(MX(5)).GT.ZERO) TERM(20)=-MX(4)*MX(5)*HWDRM4(M12SQ,M13SQ,
11977 & M(2),M(1),M(3),M(4),SM(5),SM(4),SW(5),SW(4),A(4),A(5),B(4),B(5))
11978 IF(ABS(MX(6)).GT.ZERO) TERM(21)=-MX(4)*MX(6)*HWDRM4(M12SQ,M13SQ,
11979 & M(2),M(1),M(3),M(4),SM(6),SM(4),SW(6),SW(4),A(4),A(6),B(4),B(6))
11980 ENDIF
11981 IF(ABS(MX(5)).GT.ZERO.AND.ND.NE.2) THEN
11982 TERM(5) = MX(5)**2*HWDRM2(M12SQ,M(1),M(2),M(3),M(4),SM(5),
11983 & SW(5),A(5),B(5))
11984 IF(ABS(MX(6)).GT.ZERO) TERM(9)= MX(5)*MX(6)*HWDRM3(M12SQ,M(1),
11985 & M(2),M(3),M(4),SM(5),SM(6),SW(5),SW(6),A(5),A(6),B(5),B(6))
11986 ENDIF
11987 IF(ABS(MX(6)).GT.ZERO.AND.ND.NE.2) TERM(6) = MX(6)**2*
11988 & HWDRM2(M12SQ,M(1),M(2),M(3),M(4),SM(6),SW(6),A(6),B(6))
11989 DO K=10,21
11990 TERM(K)=TERM(K)*INFCOL
11991 ENDDO
11992C--Add them up
11993 DO K=1,21
11994 HWDRM1 = HWDRM1+TERM(K)
11995 ENDDO
11996C--Different colour flows for the gluino
11997 IF(LM.NE.0) THEN
11998 NPLN = 0.0D0
11999 PLN = 0.0D0
12000 DO K=1,9
12001 PLN = PLN+TERM(K)
12002 ENDDO
12003 DO K=10,21
12004 NPLN= NPLN+TERM(K)
12005 ENDDO
12006 DO K=1,3
12007 TEST(K) = (TERM(2*K-1)+TERM(2*K)+TERM(6+K))*(1+NPLN/PLN)
12008 ENDDO
12009 ELSE
12010 DO K=1,3
12011 TEST(K) = 0.0D0
12012 ENDDO
12013 ENDIF
12014 IF(HWDRM1.LT.ZERO) CALL HWWARN('HWDRM1',50)
12015 END
12016CDECK ID>, HWDRM2.
12017*CMZ :- -20/07/99 10:56:12 by Peter Richardson
12018*-- Author : Peter Richardson
12019C-----------------------------------------------------------------------
12020 FUNCTION HWDRM2(X,MA,MB,MC,MD,MR1,GAM1,A,B)
12021C-----------------------------------------------------------------------
12022C Function to compute the matrix element squared part of a 3-body
12023C R-parity decay
12024C-----------------------------------------------------------------------
12025 IMPLICIT NONE
12026 DOUBLE PRECISION X,MA,MB,MC,MD,A,B,HWDRM2,MR1,GAM1
12027 HWDRM2 = (X - MA**2 - MB**2)*(4*A*B*MC*MD +
12028 & (A**2 + B**2)*(-X + MC**2 + MD**2))/
12029 & ((X-MR1**2)**2+GAM1**2*MR1**2)
12030 END
12031CDECK ID>, HWDRM3.
12032*CMZ :- -20/07/99 10:56:12 by Peter Richardson
12033*-- Author : Peter Richardson
12034C-----------------------------------------------------------------------
12035 FUNCTION HWDRM3(X,MA,MB,MC,MD,MR1,MR2,GAM1,GAM2,A1,A2,B1,B2)
12036C-----------------------------------------------------------------------
12037C Function to compute the light/heavy interference part of a 3-body
12038C R-parity decay
12039C-----------------------------------------------------------------------
12040 IMPLICIT NONE
12041 DOUBLE PRECISION X,MA,MB,MC,MD,A1,A2,B1,B2,HWDRM3,MR1,MR2,GAM1
12042 & ,GAM2
12043C
12044 HWDRM3 = 2*(X - MA**2 - MB**2)*(2*(A2*B1 + A1*B2)*MC*MD +
12045 & (A1*A2 + B1*B2)*(-X + MC**2 + MD**2))*
12046 & (GAM1*GAM2*MR1*MR2 + (X - MR1**2)*(X - MR2**2))/
12047 & (((X-MR1**2)**2+GAM1**2*MR1**2)*((X-MR2**2)**2+GAM2**2*MR2**2))
12048 END
12049CDECK ID>, HWDRM4.
12050*CMZ :- -20/07/99 10:56:12 by Peter Richardson
12051*-- Author : Peter Richardson
12052C-----------------------------------------------------------------------
12053 FUNCTION HWDRM4(X,Y,MA,MB,MC,MD,MR1,MR2,GAM1,GAM2,A1,A2,B1,B2)
12054C-----------------------------------------------------------------------
12055C Function to compute the interference part of a 3-body
12056C R-parity decay
12057C-----------------------------------------------------------------------
12058 IMPLICIT NONE
12059 DOUBLE PRECISION X,Y,MA,MB,MC,MD,A1,A2,B1,B2,HWDRM4,MR1,MR2,GAM1
12060 & ,GAM2
12061C
12062 HWDRM4 = 2*((GAM1*GAM2*MR1*MR2 + (X - MR1**2)*(Y - MR2**2))*
12063 & (A2*B1*MC*MD*(X - MA**2 - MB**2) +
12064 & A1*A2*MA*MC*(X + Y - MA**2 - MC**2) +
12065 & A1*B2*MA*MD*(Y - MB**2 - MC**2) +
12066 & B1*B2*(X*Y - MA**2*MC**2 - MB**2*MD**2)))/
12067 & (((X-MR1**2)**2+GAM1**2*MR1**2)*((Y-MR2**2)**2+GAM2**2*MR2**2))
12068 END
12069CDECK ID>, HWDRM5.
12070*CMZ :- -20/07/99 10:56:12 by Peter Richardson
12071*-- Author : Peter Richardson
12072C-----------------------------------------------------------------------
12073 SUBROUTINE HWDRM5(X,Y,Z,A,B,MA,MB,MC,MD,MR,GAM)
12074C-----------------------------------------------------------------------
12075C Subroutine to find the maximum of the ME
12076C-----------------------------------------------------------------------
12077 IMPLICIT NONE
12078 DOUBLE PRECISION X,Y,Z,MA,MB,MC,MD,MR,GAM,RES(3),A,B,C,D,
12079 & E2S,E3S,E2M,E3M,LOW,UPP,HWRUNI,EPS,ZERO
12080 EXTERNAL HWRUNI
12081 PARAMETER(EPS=1D-9,ZERO=0)
12082 C = A**2+B**2
12083 D = 4*A*B
12084 RES(1) = -D*(MA**2 + MB**2)*MC*MD +
12085 & C*(GAM**2*MR**2 + MR**4 - MA**2*MC**2 - MB**2*MC**2 -
12086 & MA**2*MD**2 - MB**2*MD**2)
12087 RES(2) = (GAM**2*MR**2 + (-MR**2 + MA**2 + MB**2)**2)*
12088 & (D**2*MC**2*MD**2 +
12089 & 2*C*D*MC*MD*(-MR**2 + MC**2 + MD**2) +
12090 & C**2*(GAM**2*MR**2 + (-MR**2 + MC**2 + MD**2)**2))
12091 RES(3) = -D*MC*MD+C*(2*MR**2-(MA**2+MB**2+MC**2+MD**2))
12092 IF(RES(2).GT.ZERO) THEN
12093 RES(2) = SQRT(RES(2))
12094 ELSE
12095 RES(2) = 0.0D0
12096 ENDIF
12097 IF((RES(1)+RES(2))/RES(3).GT.(MD-MC)**2.OR.
12098 & (RES(1)+RES(2))/RES(3).LT.(MA+MB)**2) THEN
12099 X = (RES(1)-RES(2))/RES(3)
12100 ELSE
12101 X = (RES(1)+RES(2))/RES(3)
12102 ENDIF
12103 IF(X.GT.(MD-MC)**2) X = (MD-MC)**2
12104 IF(X.LT.(MA+MB)**2) X = (MA+MB)**2
12105 E2S = (X-MA**2+MB**2)/(2*SQRT(X))
12106 E3S = (MD**2-X-MC**2)/(2*SQRT(X))
12107 E2M = E2S**2-MB**2
12108 E3M = E3S**2-MC**2
12109 IF(E2M.LT.ZERO) THEN
12110 IF(ABS(E2M/E2S).GT.EPS) CALL HWWARN('HWDRM5',2)
12111 E2M= 0.0D0
12112 ENDIF
12113 IF(E3M.LT.ZERO) THEN
12114 IF(ABS(E3M/E3S).GT.EPS) CALL HWWARN('HWDRM5',3)
12115 E3M= 0.0D0
12116 ENDIF
12117 E2M = SQRT(E2M)
12118 E3M = SQRT(E3M)
12119 LOW = (E2S+E3S)**2-(E2M+E3M)**2
12120 UPP = (E2S+E3S)**2-(E2M-E3M)**2
12121 Y = HWRUNI(1,LOW,UPP)
12122 Z = MA**2+MB**2+MC**2+MD**2-X-Y
12123 END
12124CDECK ID>, HWDPWT.
12125*CMZ :- -26/04/91 11.11.55 by Bryan Webber
12126*-- Author : Bryan Webber
12127C-----------------------------------------------------------------------
12128 FUNCTION HWDPWT(EMSQ,A,B,C)
12129C-----------------------------------------------------------------------
12130C MATRIX ELEMENT SQUARED FOR PHASE SPACE DECAY
12131C-----------------------------------------------------------------------
12132 IMPLICIT NONE
12133 DOUBLE PRECISION HWDPWT,EMSQ,A,B,C
12134 HWDPWT=1.
12135 END
12136CDECK ID>, HWDSIN.
12137*CMZ :- -30/09/02 14:05:28 by Peter Richardson
12138*-- Author : Peter Richardson
12139C-----------------------------------------------------------------------
12140 SUBROUTINE HWDSIN(CLSAVE)
12141C-----------------------------------------------------------------------
12142C Subroutine to perform decays including spin correlations
12143C-----------------------------------------------------------------------
c63d70bc 12144 INCLUDE 'herwig65.inc'
65767955 12145 DOUBLE PRECISION PW(5)
12146 INTEGER IDEC,IP,IS,IHEP,ID,IM,LHEP,MHEP,NPR,KHEP,CLSAVE(2),NTRY,
12147 & ID1
12148 IF(IERROR.NE.0) RETURN
12149 NTRY = 0
12150 IDEC = 1
12151 1 NTRY = NTRY+1
12152C--search the decay products and decide which one to decay next
12153 IF(.NOT.DECSPN(IDEC)) THEN
12154 CALL HWDSI1(IDEC,IP)
12155 ELSE
12156 IDEC = JMOSPN(IDEC)
12157 GOTO 1
12158 ENDIF
12159C--first no more particles in this decay to develop so move up chain
12160 IF(IP.EQ.0) THEN
12161 IDEC = JMOSPN(IDEC)
12162C--reached the end of this spin chain go back to HWDHOB
12163 IF(IDEC.EQ.0) THEN
12164 NSPN = 0
12165 RETURN
12166C--otherwise keep going up the chain
12167 ELSE
12168 IF(NTRY.LE.NBTRY) THEN
12169 GOTO 1
12170 ELSE
12171 CALL HWWARN('HWDSIN',100)
12172 GOTO 999
12173 ENDIF
12174 ENDIF
12175C--special for tau decays call spin correlation in tau decay routine
12176 ELSEIF(ABS(IDHEP(IDSPN(IP))).EQ.15) THEN
12177 CALL HWDSI3(IP)
12178 IF(IERROR.NE.0) RETURN
12179 GOTO 1
12180 ENDIF
12181C--work out where that particle is
12182 IHEP = IDSPN(IP)
12183C--if particle has daughters
12184 10 IF(JDAHEP(1,IHEP).NE.0) THEN
12185 IF(ISTHEP(IHEP).GE.141.AND.ISTHEP(IHEP).LE.144) THEN
12186 DO ID1=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
12187 IF(IDHW(ID1).EQ.ID) IHEP=ID1
12188 ENDDO
12189 ELSE
12190 IHEP = JDAHEP(1,IHEP)
12191 ENDIF
12192 ENDIF
12193 IS=ISTHEP(IHEP)
12194 ID=IDHW(IHEP)
12195 NTRY = NTRY+1
12196 IF(NTRY.GE.NBTRY) THEN
12197 CALL HWWARN('HWDSIN',101)
12198 GOTO 999
12199 ENDIF
12200 IF (.NOT.RSTAB(ID).AND.(ID.EQ.6.OR.ID.EQ.12.OR.
12201 & (ID.GE.203.AND.ID.LE.218).OR.ABS(IDPDG(ID)).GT.1000000).AND.
12202 & (IS.EQ.190.OR.(IS.GE.147.AND.IS.LE.151))) THEN
12203 CALL HWDHO1(IHEP,ID,IM,NPR,LHEP,MHEP)
12204 IF(IERROR.NE.0) RETURN
12205 ELSE
12206 GOTO 10
12207 ENDIF
12208C--perform the decay including spin correlations
12209 CALL HWDSI2(IHEP,IM,NPR,MHEP,KHEP,PW)
12210 IF(IERROR.NE.0) RETURN
12211C--make the colour connections
12212 CALL HWDHO3(ID,IM,NPR,MHEP,LHEP,KHEP,CLSAVE)
12213 IF (IERROR.NE.0) RETURN
12214C--perform the parton-showers
12215 CALL HWDHO4(IHEP,ID,IM,NPR,MHEP,LHEP,KHEP,PW)
12216 IF(IERROR.NE.0) RETURN
12217C--perform RPV colour connections
12218 CALL HWDHO5(MHEP,LHEP,CLSAVE)
12219 IF(IERROR.NE.0) RETURN
12220C--continue and perform the next decay
12221 IDEC = IP
12222 IF(NTRY.LE.NBTRY) THEN
12223 GOTO 1
12224 ELSE
12225 CALL HWWARN('HWDSIN',102)
12226 ENDIF
12227 999 RETURN
12228 END
12229CDECK ID>, HWDSI1.
12230*CMZ :- -30/09/02 14:05:28 by Peter Richardson
12231*-- Author : Peter Richardson
12232C-----------------------------------------------------------------------
12233 SUBROUTINE HWDSI1(IDEC,IP)
12234C-----------------------------------------------------------------------
12235C Subroutine to check a vertex and decide which branch to treat
12236C-----------------------------------------------------------------------
c63d70bc 12237 INCLUDE 'herwig65.inc'
65767955 12238 INTEGER IDEC,I,IPICK(5),IP,HWRINT,P1,P2,P3,P4,P3P,P4P,NPR,P0,P0P,
12239 & P1P,P2P,IF1,IF2,P5,P5P
12240 DOUBLE PRECISION NORM
12241 DOUBLE COMPLEX RHOLP(2,2),RHOPS(2,2)
12242 EXTERNAL HWRINT
12243C--loop over the daughters and decide what to do
12244 IP = 0
12245C--if daughters of particle the same issue warning
12246 IF(JDASPN(1,IDEC).EQ.JDASPN(2,IDEC)) THEN
12247 CALL HWWARN('HWDSI1',100)
12248 GOTO 999
12249 ENDIF
12250C--loop over the decay products
12251 DO I=JDASPN(1,IDEC),JDASPN(2,IDEC)
12252 IF(.NOT.DECSPN(I)) THEN
12253C--first SM particles other than tau and top and stable particles
12254 IF(RSTAB(IDHW(IDSPN(I)))
12255 & .OR.(IDHW(IDSPN(I)).LE.12.AND.ABS(IDHEP(IDSPN(I))).NE.6)
12256 & .OR.(IDHW(IDSPN(I)).GE.121.AND.IDHW(IDSPN(I)).LE.132.AND.
12257 & ABS(IDHEP(IDSPN(I))).NE.15)) THEN
12258 DECSPN(I) = .TRUE.
12259 RHOSPN(1,1,I) = HALF
12260 RHOSPN(1,2,I) = ZERO
12261 RHOSPN(2,1,I) = ZERO
12262 RHOSPN(2,2,I) = HALF
12263C--spinless particles
12264 ELSEIF(RSPIN(IDHW(IDSPN(I))).EQ.ZERO) THEN
12265 DECSPN(I) = .TRUE.
12266 RHOSPN(1,1,I) = ONE
12267 RHOSPN(1,2,I) = ZERO
12268 RHOSPN(2,1,I) = ZERO
12269 RHOSPN(2,2,I) = ZERO
12270 ELSE
12271C--particle which needs development
12272 IP = IP+1
12273 IPICK(IP) = I
12274 ENDIF
12275 ENDIF
12276 ENDDO
12277C--pick the particle to decay next
12278 IF(IP.EQ.0) THEN
12279 IF(JMOSPN(IDEC).EQ.0) RETURN
12280C--done everything compute the decay matrix and move up
12281 DECSPN(IDEC) = .TRUE.
12282 NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1
12283 DO 20 P0=1,2
12284 DO 20 P0P=1,2
12285 20 RHOSPN(P0,P0P,IDEC) = ZERO
12286C--two body decay
12287 IF(NPR.EQ.2) THEN
12288 DO 21 P0 =1,2
12289 DO 21 P0P=1,2
12290 DO 21 P1 =1,2
12291 DO 21 P1P=1,2
12292 DO 21 P2 =1,2
12293 DO 21 P2P=1,2
12294 21 RHOSPN(P0,P0P,IDEC) = RHOSPN(P0,P0P,IDEC)+
12295 & MESPN(P0 ,P1 ,P2 ,1,NCFL(IDEC),IDEC)*
12296 & DCONJG(MESPN(P0P,P1P,P2P,1,NCFL(IDEC),IDEC))*
12297 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*RHOSPN(P2,P2P,JDASPN(2,IDEC))
12298C--three body decay
12299 ELSEIF(NPR.EQ.3) THEN
12300 DO 25 P0 =1,2
12301 DO 25 P0P=1,2
12302 DO 25 P1 =1,2
12303 DO 25 P1P=1,2
12304 DO 25 P2 =1,2
12305 DO 25 P2P=1,2
12306 DO 25 P3 =1,2
12307 DO 25 P3P=1,2
12308 25 RHOSPN(P0,P0P,IDEC) = RHOSPN(P0,P0P,IDEC)+
12309 & MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
12310 & DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
12311 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12312 & RHOSPN(P3,P3P,JDASPN(2,IDEC))
12313C--higher
12314 ELSE
12315 CALL HWWARN('HWDSI1',500)
12316 ENDIF
12317C--now normalise this
12318 NORM = DBLE(RHOSPN(1,1,IDEC))+DBLE(RHOSPN(2,2,IDEC))
12319 IF(NORM.GT.ZERO) THEN
12320 NORM = ONE/NORM
12321 DO 35 P0=1,2
12322 DO 35 P0P=1,2
12323 35 RHOSPN(P0,P0P,IDEC) = NORM*RHOSPN(P0,P0P,IDEC)
12324 ELSE
12325 CALL HWWARN('HWDSI1',101)
12326 GOTO 999
12327 ENDIF
12328 ELSE
12329C--pick the particle to be decayed
12330 IP = IPICK(HWRINT(1,IP))
12331C--setup the spin density matrix for the decay
12332C--special for the hard process
12333 IF(ISTHEP(IDSPN(IDEC)).EQ.120) THEN
12334 NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1
12335C--set up the spin density matrices for the incoming partons
12336C--zero off diagonal elements
12337 RHOLP(2,1) = ZERO
12338 RHOLP(1,2) = ZERO
12339 RHOPS(2,1) = ZERO
12340 RHOPS(1,2) = ZERO
12341C--set up for polarized incoming beams in lepton collisons
12342 IF(IDHW(JMOHEP(1,IDSPN(IDEC))).GE.121.AND.
12343 & IDHW(JMOHEP(1,IDSPN(IDEC))).LE.132) THEN
12344 RHOLP(1,1) = HALF*(ONE+EPOLN(3))
12345 RHOLP(2,2) = HALF*(ONE-EPOLN(3))
12346 RHOPS(1,1) = HALF*(ONE-PPOLN(3))
12347 RHOPS(2,2) = HALF*(ONE+PPOLN(3))
12348C--otherwise average
12349 ELSE
12350 RHOLP(1,1) = HALF
12351 RHOLP(2,2) = HALF
12352 RHOPS(1,1) = HALF
12353 RHOPS(2,2) = HALF
12354 ENDIF
12355C--first decay product
12356 IF(NPR.EQ.2) THEN
12357 IF(IP.EQ.JDASPN(1,IDEC)) THEN
12358C--if using first colour flow option
12359 IF(SPCOPT.EQ.1) THEN
12360 DO 5 P3 =1,2
12361 DO 5 P3P=1,2
12362 RHOSPN(P3,P3P,IP) = ZERO
12363 DO 5 IF1=1,NCFL(1)
12364 DO 5 IF2=1,NCFL(1)
12365 DO 5 P1 =1,2
12366 DO 5 P1P=1,2
12367 DO 5 P2 =1,2
12368 DO 5 P2P=1,2
12369 DO 5 P4 =1,2
12370 DO 5 P4P=1,2
12371 5 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+SPNCFC(IF1,IF2,1)*
12372 & MESPN(P1 ,P2 ,P3 ,P4 ,IF1,1)*
12373 & DCONJG(MESPN(P1P,P2P,P3P,P4P,IF2,1))*
12374 & RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P4,P4P,IP+1)
12375C--if using second colour flow option
12376 ELSEIF(SPCOPT.EQ.2) THEN
12377 DO 6 P3 =1,2
12378 DO 6 P3P=1,2
12379 RHOSPN(P3,P3P,IP) = ZERO
12380 DO 6 P1 =1,2
12381 DO 6 P1P=1,2
12382 DO 6 P2 =1,2
12383 DO 6 P2P=1,2
12384 DO 6 P4 =1,2
12385 DO 6 P4P=1,2
12386 6 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)
12387 & +SPNCFC(NCFL(1),NCFL(1),1)*
12388 & MESPN(P1 ,P2 ,P3 ,P4 ,NCFL(1),1)*
12389 & DCONJG(MESPN(P1P,P2P,P3P,P4P,NCFL(1),1))*
12390 & RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P4,P4P,IP+1)
12391C--unknown option issue warning
12392 ELSE
12393 CALL HWWARN('HWDSI1',501)
12394 ENDIF
12395C--second decay product
12396 ELSE
12397 IF(SPCOPT.EQ.1) THEN
12398 DO 10 P4 =1,2
12399 DO 10 P4P=1,2
12400 RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0)
12401 DO 10 IF1=1,NCFL(1)
12402 DO 10 IF2=1,NCFL(1)
12403 DO 10 P1 =1,2
12404 DO 10 P1P=1,2
12405 DO 10 P2 =1,2
12406 DO 10 P2P=1,2
12407 DO 10 P3 =1,2
12408 DO 10 P3P=1,2
12409 10 RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)+SPNCFC(IF1,IF2,1)*
12410 & MESPN(P1 ,P2 ,P3 ,P4 ,IF1,1)*
12411 & DCONJG(MESPN(P1P,P2P,P3P,P4P,IF2,1))*
12412 & RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P3,P3P,IP-1)
12413 ELSEIF(SPCOPT.EQ.2) THEN
12414 DO 11 P4 =1,2
12415 DO 11 P4P=1,2
12416 RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0)
12417 DO 11 P1 =1,2
12418 DO 11 P1P=1,2
12419 DO 11 P2 =1,2
12420 DO 11 P2P=1,2
12421 DO 11 P3 =1,2
12422 DO 11 P3P=1,2
12423 11 RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)
12424 & +SPNCFC(NCFL(1),NCFL(1),1)*
12425 & MESPN(P1 ,P2 ,P3 ,P4 ,NCFL(1),1)*
12426 & DCONJG(MESPN(P1P,P2P,P3P,P4P,NCFL(1),1))*
12427 & RHOLP(P1,P1P)*RHOPS(P2,P2P)*RHOSPN(P3,P3P,IP-1)
12428 ELSE
12429 CALL HWWARN('HWDSI1',502)
12430 GOTO 999
12431 ENDIF
12432 ENDIF
12433C--new for four body gauge boson pair processes
12434 ELSEIF(NPR.EQ.4) THEN
12435C--first particle
12436 IF(IP.EQ.JDASPN(1,IDEC)) THEN
12437 DO 41 P1 =1,2
12438 DO 41 P1P=1,2
12439 RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12440 DO 41 P3 =1,2
12441 DO 41 P3P=1,2
12442 DO 41 P5 =1,2
12443 DO 41 P5P=1,2
12444 41 RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+
12445 & MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12446 & RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)*
12447 & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12448 & RHOSPN(P3,P3P,JDASPN(2,IDEC))
12449C--second particle
12450 ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN
12451 DO 42 P1 =1,2
12452 DO 42 P1P=1,2
12453 RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12454 DO 42 P3 =1,2
12455 DO 42 P3P=1,2
12456 DO 42 P5 =1,2
12457 DO 42 P5P=1,2
12458 42 RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+
12459 & MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12460 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12461 & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12462 & RHOSPN(P3,P3P,JDASPN(2,IDEC))
12463C--third particle
12464 ELSEIF(IP.EQ.JDASPN(1,IDEC)+2) THEN
12465 DO 43 P3 =1,2
12466 DO 43 P3P=1,2
12467 RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0)
12468 DO 43 P1 =1,2
12469 DO 43 P1P=1,2
12470 DO 43 P5 =1,2
12471 DO 43 P5P=1,2
12472 43 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+
12473 & MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12474 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12475 & RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)*
12476 & RHOSPN(P3,P3P,JDASPN(2,IDEC))
12477C--fourth particle
12478 ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN
12479 DO 44 P3 =1,2
12480 DO 44 P3P=1,2
12481 RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0)
12482 DO 44 P1 =1,2
12483 DO 44 P1P=1,2
12484 DO 44 P5 =1,2
12485 DO 44 P5P=1,2
12486 44 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+
12487 & MESPN(P5,P1,P3,1,1,1)*DCONJG(MESPN(P5P,P1P,P3P,1,1,1))*
12488 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12489 & RHOSPN(P1,P1P,JDASPN(1,IDEC)+1)*
12490 & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)
12491C--unrecognized issue warning
12492 ELSE
12493 CALL HWWARN('HWDSI1',509)
12494 GOTO 999
12495 ENDIF
12496C--unrecognized issue warning
12497 ELSE
12498 CALL HWWARN('HWDSI1',508)
12499 GOTO 999
12500 ENDIF
12501 ELSE
12502 NPR = JDASPN(2,IDEC)-JDASPN(1,IDEC)+1
12503 DO 50 P1 =1,2
12504 DO 50 P1P=1,2
12505 50 RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12506C--set-up matrix for 2-body decay
12507 IF(NPR.EQ.2) THEN
12508 IF(NCFL(IDEC).NE.1) CALL HWWARN('HWDSI1',503)
12509 IF(IP.EQ.JDASPN(1,IDEC)) THEN
12510 DO 60 P0 =1,2
12511 DO 60 P0P=1,2
12512 DO 60 P1 =1,2
12513 DO 60 P1P=1,2
12514 DO 60 P2 =1,2
12515 DO 60 P2P=1,2
12516 60 RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+RHOSPN(P0,P0P,IDEC)*
12517 & MESPN(P0 ,P1 ,P2 ,1,1,IDEC)*
12518 & DCONJG(MESPN(P0P,P1P,P2P,1,1,IDEC))*
12519 & RHOSPN(P2,P2P,JDASPN(2,IDEC))
12520 ELSE
12521 DO 70 P0 =1,2
12522 DO 70 P0P=1,2
12523 DO 70 P1 =1,2
12524 DO 70 P1P=1,2
12525 DO 70 P2 =1,2
12526 DO 70 P2P=1,2
12527 70 RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+RHOSPN(P0,P0P,IDEC)*
12528 & MESPN(P0 ,P1 ,P2 ,1,1,IDEC)*
12529 & DCONJG(MESPN(P0P,P1P,P2P,1,1,IDEC))*
12530 & RHOSPN(P1,P1P,JDASPN(1,IDEC))
12531 ENDIF
12532C--set-up matrix for 3-body decay
12533 ELSEIF(NPR.EQ.3) THEN
12534 IF(SPCOPT.NE.2.AND.NCFL(IDEC).NE.1)
12535 & CALL HWWARN('HWDSI1',504)
12536C--first particle
12537 IF(IP.EQ.JDASPN(1,IDEC)) THEN
12538 DO 100 P0 =1,2
12539 DO 100 P0P=1,2
12540 DO 100 P1 =1,2
12541 DO 100 P1P=1,2
12542 DO 100 P2 =1,2
12543 DO 100 P2P=1,2
12544 DO 100 P3 =1,2
12545 DO 100 P3P=1,2
12546 100 RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+RHOSPN(P0,P0P,IDEC)*
12547 & MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
12548 & DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
12549 & RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12550 & RHOSPN(P3,P3P,JDASPN(2,IDEC))
12551C--second particle
12552 ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN
12553 DO 105 P0 =1,2
12554 DO 105 P0P=1,2
12555 DO 105 P1 =1,2
12556 DO 105 P1P=1,2
12557 DO 105 P2 =1,2
12558 DO 105 P2P=1,2
12559 DO 105 P3 =1,2
12560 DO 105 P3P=1,2
12561 105 RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+RHOSPN(P0,P0P,IDEC)*
12562 & MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
12563 & DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
12564 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12565 & RHOSPN(P3,P3P,JDASPN(2,IDEC))
12566C--third particle
12567 ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN
12568 DO 110 P0 =1,2
12569 DO 110 P0P=1,2
12570 DO 110 P1 =1,2
12571 DO 110 P1P=1,2
12572 DO 110 P2 =1,2
12573 DO 110 P2P=1,2
12574 DO 110 P3 =1,2
12575 DO 110 P3P=1,2
12576 110 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+RHOSPN(P0,P0P,IDEC)*
12577 & MESPN(P0 ,P1 ,P2 ,P3 ,NCFL(IDEC),IDEC)*
12578 & DCONJG(MESPN(P0P,P1P,P2P,P3P,NCFL(IDEC),IDEC))*
12579 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12580 & RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)
12581C--unrecognized
12582 ELSE
12583 CALL HWWARN('HWDSI1',102)
12584 GOTO 999
12585 ENDIF
12586 ELSEIF(NPR.EQ.4) THEN
12587C--first particle
12588 IF(IP.EQ.JDASPN(1,IDEC)) THEN
12589 DO 151 P1 =1,2
12590 DO 151 P1P=1,2
12591 RHOSPN(P1,P1P,IP) = (0.0D0,0.0D0)
12592 DO 151 P2 =1,2
12593 DO 151 P2P=1,2
12594 DO 151 P3 =1,2
12595 DO 151 P3P=1,2
12596 DO 151 P4 =1,2
12597 DO 151 P4P=1,2
12598 151 RHOSPN(P1,P1P,IP) = RHOSPN(P1,P1P,IP)+
12599 & MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12600 & DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12601 & RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12602 & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12603 & RHOSPN(P4,P4P,JDASPN(2,IDEC))
12604C--second particle
12605 ELSEIF(IP.EQ.JDASPN(1,IDEC)+1) THEN
12606 DO 152 P2 =1,2
12607 DO 152 P2P=1,2
12608 RHOSPN(P2,P2P,IP) = (0.0D0,0.0D0)
12609 DO 152 P1 =1,2
12610 DO 152 P1P=1,2
12611 DO 152 P3 =1,2
12612 DO 152 P3P=1,2
12613 DO 152 P4 =1,2
12614 DO 152 P4P=1,2
12615 152 RHOSPN(P2,P2P,IP) = RHOSPN(P2,P2P,IP)+
12616 & MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12617 & DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12618 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12619 & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)*
12620 & RHOSPN(P4,P4P,JDASPN(2,IDEC))
12621C--third particle
12622 ELSEIF(IP.EQ.JDASPN(1,IDEC)+2) THEN
12623 DO 153 P3 =1,2
12624 DO 153 P3P=1,2
12625 RHOSPN(P3,P3P,IP) = (0.0D0,0.0D0)
12626 DO 153 P1 =1,2
12627 DO 153 P1P=1,2
12628 DO 153 P2 =1,2
12629 DO 153 P2P=1,2
12630 DO 153 P4 =1,2
12631 DO 153 P4P=1,2
12632 153 RHOSPN(P3,P3P,IP) = RHOSPN(P3,P3P,IP)+
12633 & MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12634 & DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12635 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12636 & RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12637 & RHOSPN(P4,P4P,JDASPN(2,IDEC))
12638C--fourth particle
12639 ELSEIF(IP.EQ.JDASPN(2,IDEC)) THEN
12640 DO 154 P4 =1,2
12641 DO 154 P4P=1,2
12642 RHOSPN(P4,P4P,IP) = (0.0D0,0.0D0)
12643 DO 154 P1 =1,2
12644 DO 154 P1P=1,2
12645 DO 154 P2 =1,2
12646 DO 154 P2P=1,2
12647 DO 154 P3 =1,2
12648 DO 154 P3P=1,2
12649 154 RHOSPN(P4,P4P,IP) = RHOSPN(P4,P4P,IP)+
12650 & MESPN(P1 ,P2 ,P3 ,P4 ,1,1)*
12651 & DCONJG(MESPN(P1P,P2P,P3P,P4P,1,1))*
12652 & RHOSPN(P1,P1P,JDASPN(1,IDEC))*
12653 & RHOSPN(P2,P2P,JDASPN(1,IDEC)+1)*
12654 & RHOSPN(P3,P3P,JDASPN(1,IDEC)+2)
12655 ELSE
12656 CALL HWWARN('HWDSI1',505)
12657 ENDIF
12658 ELSE
12659 CALL HWWARN('HWDSI1',506)
12660 ENDIF
12661 ENDIF
12662C--normalise the spin density matrix
12663 NORM = DBLE(RHOSPN(1,1,IP))+DBLE(RHOSPN(2,2,IP))
12664 IF(NORM.GT.ZERO) THEN
12665 NORM = ONE/NORM
12666 DO 15 P3=1,2
12667 DO 15 P3P=1,2
12668 15 RHOSPN(P3,P3P,IP) = NORM*RHOSPN(P3,P3P,IP)
12669 ELSE
12670 CALL HWWARN('HWDSI1',107)
12671 GOTO 999
12672 ENDIF
12673 ENDIF
12674 999 RETURN
12675 END
12676CDECK ID>, HWDSI2.
12677*CMZ :- -30/09/02 14:05:28 by Peter Richardson
12678*-- Author : Peter Richardson
12679C-----------------------------------------------------------------------
12680 SUBROUTINE HWDSI2(IHEP,IM,NPR,MHEP,KHEP,PW)
12681C-----------------------------------------------------------------------
12682C Subroutine to perform the second part of the heavy object decays
12683C IE generate the kinematics for the decay
12684C including spin correlations
12685C was part of HWDHOB
12686C-----------------------------------------------------------------------
c63d70bc 12687 INCLUDE 'herwig65.inc'
65767955 12688 DOUBLE PRECISION HWRGEN,PW(5),HWDPWT,HWDWWT,PCM,HWUPCM
12689 INTEGER IHEP,IM,KHEP,MHEP,NPR,ISN,RHEP
12690 EXTERNAL HWRGEN,HWDPWT,HWDWWT,HWUPCM
12691 IF (IERROR.NE.0) RETURN
12692 ISN = ISNHEP(IHEP)
12693 IF (NPR.EQ.2) THEN
12694C Two body decay: LHEP -> MHEP + NHEP
12695 IF(NME(IM).GT.20000.AND.NME(IM).LT.30000) THEN
12696C--generate a two body decay to a gauge boson as a three body decay
12697 CALL HWDSM3(2,IHEP,MHEP,NHEP,0,NME(IM)-20000,
12698 & RHOSPN(1,1,ISN),ISN)
12699C--two body decay
12700 ELSEIF(NME(IM).GT.30000.AND.NME(IM).LT.40000) THEN
12701 CALL HWDSM2(IHEP,MHEP,NHEP,NME(IM)-30000,
12702 & RHOSPN(1,1,ISN),ISN)
12703C--otherwise issue warning
12704C--change by PR 9/30/02 to issue non-terminal warning and continue
12705 ELSE
12706 CALL HWWARN('HWDSI2',1)
12707 PCM=HWUPCM(PHEP(5,IHEP),PHEP(5,MHEP),PHEP(5,NHEP))
12708 CALL HWDTWO(PHEP(1,IHEP),PHEP(1,MHEP),
12709 & PHEP(1,NHEP),PCM,TWO,.FALSE.)
12710 DECSPN(ISN) = .TRUE.
12711 IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN
12712 RHOSPN(1,1,ISN) = ONE
12713 RHOSPN(1,2,ISN) = ZERO
12714 RHOSPN(2,1,ISN) = ZERO
12715 RHOSPN(2,2,ISN) = ZERO
12716 ELSE
12717 RHOSPN(1,1,ISN) = HALF
12718 RHOSPN(1,2,ISN) = ZERO
12719 RHOSPN(2,1,ISN) = ZERO
12720 RHOSPN(2,2,ISN) = HALF
12721 ENDIF
12722 ENDIF
12723 ELSEIF (NPR.EQ.3) THEN
12724C Three body decay: LHEP -> KHEP + MHEP + NHEP
12725 KHEP=MHEP
12726 MHEP=MHEP+1
12727C Provisional colour self-connection of KHEP
12728 JMOHEP(2,KHEP)=KHEP
12729 JDAHEP(2,KHEP)=KHEP
12730C--if old codes issue warning
12731 IF (NME(IM).EQ.100.OR.NME(IM).EQ.200.OR.NME(IM).EQ.300) THEN
12732 CALL HWWARN('HWDSI2',502)
12733C--three body spin matrix element
12734 ELSEIF(NME(IM).GE.10000.AND.NME(IM).LT.20000) THEN
12735 CALL HWDSM3(3,IHEP,MHEP,KHEP,NHEP,NME(IM)-10000,
12736 & RHOSPN(1,1,ISN),ISN)
12737C--special for top decay
12738 IF(ABS(IDHEP(IHEP)).EQ.6) THEN
12739 CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,MHEP),PW)
12740 CALL HWUMAS(PW)
12741 ENDIF
12742C--unknown issue warning
12743 ELSE
12744 CALL HWWARN('HWDSI2',2)
12745C Three body phase space decay
12746 CALL HWDTHR(PHEP(1,IHEP),PHEP(1,MHEP),
12747 & PHEP(1,KHEP),PHEP(1,NHEP),HWDPWT)
12748 CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
12749 DECSPN(ISN) = .TRUE.
12750 IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN
12751 RHOSPN(1,1,ISN) = ONE
12752 RHOSPN(1,2,ISN) = ZERO
12753 RHOSPN(2,1,ISN) = ZERO
12754 RHOSPN(2,2,ISN) = ZERO
12755 ELSE
12756 RHOSPN(1,1,ISN) = HALF
12757 RHOSPN(1,2,ISN) = ZERO
12758 RHOSPN(2,1,ISN) = ZERO
12759 RHOSPN(2,2,ISN) = HALF
12760 ENDIF
12761 ENDIF
12762 ELSEIF(NPR.EQ.4) THEN
12763 CALL HWWARN('HWDSI2',3)
12764C Four body decay: LHEP -> KHEP + RHEP + MHEP + NHEP
12765 KHEP = MHEP
12766 RHEP = MHEP+1
12767 MHEP = MHEP+2
12768 ISTHEP(NHEP) = 114
12769C Provisional colour connections of KHEP and RHEP
12770 JMOHEP(2,KHEP)=RHEP
12771 JDAHEP(2,KHEP)=RHEP
12772 JMOHEP(2,RHEP)=KHEP
12773 JDAHEP(2,RHEP)=KHEP
12774C Four body phase space decay
12775 CALL HWDFOR(PHEP(1,IHEP),PHEP(1,KHEP),PHEP(1,RHEP),
12776 & PHEP(1,MHEP),PHEP(1,NHEP))
12777 IF(IERROR.NE.0) RETURN
12778 CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,RHEP))
12779 CALL HWVEQU(4,VHEP(1,KHEP),VHEP(1,MHEP))
12780 DECSPN(ISN) = .TRUE.
12781 IF(RSPIN(IDHW(IHEP)).EQ.ZERO) THEN
12782 RHOSPN(1,1,ISN) = ONE
12783 RHOSPN(1,2,ISN) = ZERO
12784 RHOSPN(2,1,ISN) = ZERO
12785 RHOSPN(2,2,ISN) = ZERO
12786 ELSE
12787 RHOSPN(1,1,ISN) = HALF
12788 RHOSPN(1,2,ISN) = ZERO
12789 RHOSPN(2,1,ISN) = ZERO
12790 RHOSPN(2,2,ISN) = HALF
12791 ENDIF
12792 ELSE
12793 CALL HWWARN('HWDSI2',100)
12794 ENDIF
12795 END
12796CDECK ID>, HWDSI3.
12797*CMZ :- -30/09/02 14:05:28 by Peter Richardson
12798*-- Author : Peter Richardson
12799C-----------------------------------------------------------------------
12800 SUBROUTINE HWDSI3(IP)
12801C-----------------------------------------------------------------------
12802C Subroutine to handle spin correlations in tau decays
12803C averages spin if not using TAUOLA
12804C if using TAUOLA selects the spin and uses TAUOLA to perform the
12805C decay
12806C-----------------------------------------------------------------------
c63d70bc 12807 INCLUDE 'herwig65.inc'
65767955 12808 INTEGER IP,IHEP,ID1,ID,NTRY
12809 DOUBLE PRECISION PPOL,HWRGEN,POL
12810 EXTERNAL HWRGEN
12811C--if HERWIG is performing tau decays average over spins and return
12812C--spin averaged tau decay will be done later
12813 IF(TAUDEC.EQ.'HERWIG') THEN
12814 DECSPN(IP) = .TRUE.
12815 RHOSPN(1,1,IP) = HALF
12816 RHOSPN(2,1,IP) = ZERO
12817 RHOSPN(1,2,IP) = ZERO
12818 RHOSPN(2,2,IP) = HALF
12819C--if using tauola select the polarization for the decay
12820 ELSEIF(TAUDEC.EQ.'TAUOLA') THEN
12821C--work out where that particle is
12822 IHEP = IDSPN(IP)
12823 NTRY = 0
12824 10 ID = IDHW(IHEP)
12825 IF(JDAHEP(1,IHEP).NE.0) THEN
12826 IF(ISTHEP(IHEP).GE.141.AND.ISTHEP(IHEP).LE.144) THEN
12827 DO ID1=JDAHEP(1,IHEP),JDAHEP(2,IHEP)
12828 IF(IDHW(ID1).EQ.ID) IHEP=ID1
12829 ENDDO
12830 ELSE
12831 IHEP = JDAHEP(1,IHEP)
12832 ENDIF
12833 NTRY = NTRY+1
12834 IF(NTRY.LT.NBTRY) THEN
12835 GOTO 10
12836 ELSE
12837 CALL HWWARN('HWDSI3',100)
12838 GOTO 999
12839 ENDIF
12840 ENDIF
12841C--select the tau polarization
12842 PPOL = DBLE(RHOSPN(1,1,IP))
12843 IF(PPOL.GE.HWRGEN(0)) THEN
12844 POL = 1.0D0
12845 RHOSPN(1,1,IP) = ONE
12846 RHOSPN(2,1,IP) = ZERO
12847 RHOSPN(1,2,IP) = ZERO
12848 RHOSPN(2,2,IP) = ZERO
12849 ELSE
12850 POL =-1.0D0
12851 RHOSPN(1,1,IP) = ZERO
12852 RHOSPN(2,1,IP) = ZERO
12853 RHOSPN(1,2,IP) = ZERO
12854 RHOSPN(2,2,IP) = ONE
12855 ENDIF
12856C--decay the particle
12857 CALL HWDTAU(1,IHEP,POL)
12858 DECSPN(IP) = .TRUE.
12859 ELSE
12860 CALL HWWARN('HWDSI3',500)
12861 ENDIF
12862 999 RETURN
12863 END
12864CDECK ID>, HWDSM2.
12865*CMZ :- -09/04/02 13:46:07 by Peter Richardson
12866*-- Author : Peter Richardson
12867C-----------------------------------------------------------------------
12868 SUBROUTINE HWDSM2(ID,IOUT1,IOUT2,IMODE,RHOIN,IDSPIN)
12869C-----------------------------------------------------------------------
12870C Subroutine to calculate the two body matrix element for spin
12871C correlations
12872C-----------------------------------------------------------------------
c63d70bc 12873 INCLUDE 'herwig65.inc'
65767955 12874 INTEGER IOUT1,IOUT2,IMODE,IDSPIN,ID,I,J,IDP(3),P0,P1,P2,O(2),P0P,
12875 & NTRY
12876 DOUBLE PRECISION XMASS,PLAB,PRW,PCM,PREF(5),P(5,3),PM(5,3),PCMA,
12877 & HWUPCM,MA(3),MA2(3),HWULDO,PP,HWVDOT,N(3),EPS,PRE,PHS,A(2),
12878 & WGT,WTMAX,HWRGEN
12879 DOUBLE COMPLEX RHOIN(2,2),S,D,ME(2,2,2),F1(2,2,8),F0(2,2,8),
12880 & F2M(2,2,8),F1M(2,2,8),F1F(2,2,8),F2(2,2,8,8),F0B(2,2,8,8)
12881 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
12882 SAVE O,PREF
12883 DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
12884 DATA O/2,1/
12885 COMMON/HWHEWS/S(8,8,2),D(8,8)
12886 PARAMETER(EPS=1D-20)
12887 EXTERNAL HWUPCM,HWULDO,HWVDOT,HWRGEN
12888C--first setup if this is the start of a new spin chain
12889 IF(NSPN.EQ.0) THEN
12890C--zero the elements of the array
12891 CALL HWVZRI( NMXHEP,ISNHEP)
12892 CALL HWVZRI( NMXSPN,JMOSPN)
12893 CALL HWVZRI(2*NMXSPN,JDASPN)
12894 CALL HWVZRI( NMXSPN, IDSPN)
12895 NSPN = NSPN+1
12896 JMOSPN(NSPN) = 0
12897 IDSPN (NSPN) = ID
12898 DECSPN(NSPN) = .FALSE.
12899 IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN
12900 RHOSPN(1,1,NSPN) = ONE
12901 RHOSPN(2,1,NSPN) = ZERO
12902 RHOSPN(1,2,NSPN) = ZERO
12903 RHOSPN(2,2,NSPN) = ZERO
12904 ELSE
12905 RHOSPN(1,1,NSPN) = HALF
12906 RHOSPN(2,1,NSPN) = ZERO
12907 RHOSPN(1,2,NSPN) = ZERO
12908 RHOSPN(2,2,NSPN) = HALF
12909 ENDIF
12910 ISNHEP(ID) = NSPN
12911 ENDIF
12912C--MA is mass for this decay (OFF-SHELL)
12913C--generate the momenta for a two body decay
12914 P(5,1) = PHEP(5, ID)
12915 P(5,2) = PHEP(5,IOUT1)
12916 P(5,3) = PHEP(5,IOUT2)
12917 IDP(1) = IDHW(ID)
12918 IDP(2) = IDHW(IOUT1)
12919 IDP(3) = IDHW(IOUT2)
12920 DO 1 I=1,3
12921 MA(I) = P(5,I)
12922 1 MA2(I) = MA(I)**2
12923 PCMA = HWUPCM(P(5,1),P(5,2),P(5,3))
12924C--setup the couplings
12925 DO 2 I=1,2
12926 2 A(I) = A2MODE(I,IMODE)
12927C--phase space factor
12928 PHS = PCMA/MA2(1)/8.0D0/PIFAC
12929C--maximum weight
12930 WTMAX = WT2MAX(IMODE)
12931 NTRY = 0
12932 1000 NTRY = NTRY+1
12933 CALL HWVEQU(5,PHEP(1,ID),P(1,1))
12934 CALL HWDTWO(P(1,1),P(1,2),P(1,3),PCMA,2.0D0,.TRUE.)
12935 DO 3 I=1,3
12936C--compute the references vectors
12937C--not important if SM particle which can't have spin measured
12938C--ie anything other the top and tau
12939C--also not important if particle is approx massless
12940C--first the SM particles other than top and tau
12941 IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12
12942 & .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN
12943 CALL HWVEQU(5,PREF,PLAB(1,I+3))
12944C--all other particles
12945 ELSE
12946 PP = SQRT(HWVDOT(3,P(1,I),P(1,I)))
12947 CALL HWVSCA(3,ONE/PP,P(1,I),N)
12948 PLAB(4,I+3) = HALF*(P(4,I)-PP)
12949 PP = HALF*(PP-MA(I)-PP**2/(MA(I)+P(4,I)))
12950 CALL HWVSCA(3,PP,N,PLAB(1,I+3))
12951 CALL HWUMAS(PLAB(1,I+3))
12952 PP = HWVDOT(3,PLAB(1,I+3),PLAB(1,I+3))
12953C--fix to avoid problems if approx massless due to energy
12954 IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+3))
12955 ENDIF
12956C--now the massless vectors
12957 PP = HALF*P(5,I)**2/HWULDO(PLAB(1,I+3),P(1,I))
12958 DO 4 J=1,4
12959 4 PLAB(J,I) = P(J,I)-PP*PLAB(J,I+3)
12960 3 CALL HWUMAS(PLAB(1,I))
12961C--change order of momenta for call to HE code
12962 DO 5 I=1,3
12963 PM(1,I) = P(3,I)
12964 PM(2,I) = P(1,I)
12965 PM(3,I) = P(2,I)
12966 PM(4,I) = P(4,I)
12967 5 PM(5,I) = P(5,I)
12968 DO 6 I=1,6
12969 PCM(1,I)=PLAB(3,I)
12970 PCM(2,I)=PLAB(1,I)
12971 PCM(3,I)=PLAB(2,I)
12972 PCM(4,I)=PLAB(4,I)
12973 6 PCM(5,I)=PLAB(5,I)
12974C--compute the S functions
12975 CALL HWHEW2(6,PCM(1,1),S(1,1,2),S(1,1,1),D)
12976 DO 7 I=1,6
12977 DO 7 J=1,6
12978 S(I,J,2) = -S(I,J,2)
12979 7 D(I,J) = TWO*D(I,J)
12980C--now compute the F functions needed
12981 CALL HWH2F2(6,F1 ,5,PM(1,2), MA(2))
12982 CALL HWH2F2(6,F0 ,4,PM(1,1), MA(1))
12983 CALL HWH2F2(6,F1M,5,PM(1,2),-MA(2))
12984 CALL HWH2F2(6,F2M,6,PM(1,3),-MA(3))
12985 CALL HWH2F1(6,F1F,5,PM(1,2), MA(2))
12986 CALL HWH2F3(6,F2 ,PM(1,3),ZERO )
12987 CALL HWH2F3(6,F0B ,PM(1,1),ZERO )
12988C--now compute the diagrams
12989C--fermion --> fermion scalar
12990 IF(I2DRTP(IMODE).EQ.1) THEN
12991 PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))
12992 PRE = HALF/SQRT(PRE)
12993 DO 10 P0=1,2
12994 DO 10 P1=1,2
12995 ME(P0,P1,2) = (0.0D0,0.0D0)
12996 10 ME(P0,P1,1) = PRE*( A(O(P1))*S(5,2,O(P1))*F0( P1 ,O(P0),2)
12997 & +A( P1 )*MA(2)* F0(O(P1),O(P0),5))
12998C--fermion --> scalar fermion diagrams
12999 ELSEIF(I2DRTP(IMODE).EQ.2) THEN
13000 PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
13001 PRE = HALF/SQRT(PRE)
13002 DO 20 P0=1,2
13003 DO 20 P2=1,2
13004 ME(P0,2,P2) = (0.0D0,0.0D0)
13005 20 ME(P0,1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F0( P2 ,O(P0),3)
13006 & +A( P2 )*MA(3)* F0(O(P2),O(P0),6))
13007C--fermion --> scalar antifermion
13008 ELSEIF(I2DRTP(IMODE).EQ.3) THEN
13009 PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
13010 PRE =-HALF/SQRT(PRE)
13011 DO 30 P0=1,2
13012 DO 30 P2=1,2
13013 ME(P0,2,P2) = (0.0D0,0.0D0)
13014 30 ME(P0,1,P2) = PRE*( A( P0 )*S(4,1,P0)*F2M(O(P0),O(P2),1)
13015 & -A(O(P0))*MA(1) *F2M( P0 ,O(P2),4))
13016C--fermion --> fermion gauge boson
13017 ELSEIF(I2DRTP(IMODE).EQ.4) THEN
13018 PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))*
13019 & HWULDO(PM(1,3),PCM(1,6))
13020 PRE = HALF/SQRT(PRE)
13021 DO 40 P0=1,2
13022 DO 40 P1=1,2
13023 ME(P0,P1,1) =-PRE*A(1)*F1F(O(P1),2,3)*S(3,6,2)*F0(1,O(P0),3)
13024 40 ME(P0,P1,2) = PRE* F1F(O(P1),1,3)*S(3,6,1)*F0(2,O(P0),3)
13025C--scalar --> fermion antifermion
13026 ELSEIF(I2DRTP(IMODE).EQ.5) THEN
13027 PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
13028 PRE =-HALF/SQRT(PRE)
13029 DO 50 P1=1,2
13030 DO 50 P2=1,2
13031 ME(2,P1,P2) = (0.0D0,0.0D0)
13032 50 ME(1,P1,P2) = PRE*( A(O(P1))*S(5,2,O(P1))*F2M( P1 ,O(P2),2)
13033 & +A( P1 )*MA(2)* F2M(O(P1),O(P2),5))
13034C--scalar --> fermion fermion
13035 ELSEIF(I2DRTP(IMODE).EQ.6) THEN
13036 PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
13037 PRE = HALF/SQRT(PRE)
13038 DO 60 P1=1,2
13039 DO 60 P2=1,2
13040 ME(2,P1,P2) = (0.0D0,0.0D0)
13041 60 ME(1,P1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F1M( P2 ,P1,3)
13042 & +A( P2 )*MA(3)* F1M(O(P2),P1,6))
13043C--fermion --> fermion pion
13044 ELSEIF(I2DRTP(IMODE).EQ.7) THEN
13045 PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,2),PCM(1,5))
13046 PRE = 0.25D0/SQRT(PRE)/RMASS(198)**2
13047 DO 70 P0=1,2
13048 DO 70 P1=1,2
13049 ME(P0,P1,2) = (0.0D0,0.0D0)
13050 70 ME(P0,P1,1) =PRE*(
13051 & MA(1)*A(O(P0))*( S(5,2,O(P1))*F2( P1 ,O(P0),2,4)
13052 & +MA(2)*F2(O(P1),O(P0),5,4))
13053 & +A(P0)*S(1,4,P0)*( S(5,2,O(P1))*F2( P1 , P0 ,2,1)
13054 & +MA(2)*F2(O(P1), P0 ,5,1)))
13055C--scalar --> antifermion fermion
13056 ELSEIF(I2DRTP(IMODE).EQ.8) THEN
13057 PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
13058 PRE =-HALF/SQRT(PRE)
13059 DO 80 P1=1,2
13060 DO 80 P2=1,2
13061 ME(2,P1,P2) = (0.0D0,0.0D0)
13062 80 ME(1,P1,P2) = PRE*( A(O(P2))*S(6,3,O(P2))*F1M( P2 ,O(P1),3)
13063 & +A( P2 )*MA(3)* F1M(O(P2),O(P1),6))
13064C--neutralino --> gravitino photon
13065 ELSEIF(I2DRTP(IMODE).EQ.9) THEN
13066 PRE = TWO*HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
13067 PRE = TWO/SQRT(PRE)
13068 DO 90 P1=1,2
13069 DO 90 P2=1,2
13070 ME(P1,P2,O(P2)) = (0.0D0,0.0D0)
13071 90 ME(P1,P2, P2 ) = PRE*S(2,3,P2)*S(3,6,O(P2))*
13072 & S(3,2,P2)*F0(O(P2),P1,2)
13073C--neutralino --> gravitino scalar
13074 ELSEIF(I2DRTP(IMODE).EQ.10) THEN
13075 PRE = TWO*HWULDO(PM(1,1),PCM(1,4))
13076 PRE = ONE/SQRT(PRE)
13077 DO 100 P1=1,2
13078 DO 100 P2=1,2
13079 ME(P1,P2,2) = (0.0D0,0.0D0)
13080 100 ME(P1,P2,1) = PRE*F2(P2,1,2,2)*F0(1,O(P1),2)
13081C--sfermion --> fermion gravitino
13082 ELSEIF(I2DRTP(IMODE).EQ.11) THEN
13083 PRE = TWO*HWULDO(PM(1,2),PCM(1,5))
13084 PRE = ONE/SQRT(PRE)
13085 DO 110 P1=1,2
13086 DO 110 P2=1,2
13087 ME(2,P1,P2) = (0.0D0,0.0D0)
13088 110 ME(1,P1,P2) = PRE*A(O(P2))*F1M(O(P1),P2,3)*F0B(P2,P2,3,3)
13089C--antisfermion --> antifermion gravitino
13090 ELSEIF(I2DRTP(IMODE).EQ.12) THEN
13091 PRE = TWO*HWULDO(PM(1,2),PCM(1,5))
13092 PRE = ONE/SQRT(PRE)
13093 DO 120 P1=1,2
13094 DO 120 P2=1,2
13095 ME(2,P1,P2) = (0.0D0,0.0D0)
13096 120 ME(1,P1,P2) = PRE*A(O(P2))*F0B(P2,P2,3,3)*F1(P2,O(P1),3)
13097C--scalar --> antifermion antifermion
13098 ELSEIF(I2DRTP(IMODE).EQ.13) THEN
13099 PRE = HWULDO(PM(1,2),PCM(1,5))*HWULDO(PM(1,3),PCM(1,6))
13100 PRE = HALF/SQRT(PRE)
13101 DO 130 P1=1,2
13102 DO 130 P2=1,2
13103 ME(2,P1,P2) = (0.0D0,0.0D0)
13104 130 ME(1,P1,P2) = PRE*( A( P1 )*S(5,2, P1 )*F2M(O(P1),O(P2),2)
13105 & +A(O(P1))*MA(2) *F2M( P1 ,O(P2),5))
13106C--antifermion --> scalar antifermion
13107 ELSEIF(I2DRTP(IMODE).EQ.14) THEN
13108 PRE = HWULDO(PM(1,1),PCM(1,4))*HWULDO(PM(1,3),PCM(1,6))
13109 PRE = HALF/SQRT(PRE)
13110 DO 140 P0=1,2
13111 DO 140 P2=1,2
13112 ME(P0,2,P2) = (0.0D0,0.0D0)
13113 140 ME(P0,1,P2) = PRE*( A(O(P0))*S(4,1,O(P0))*F2M( P0 ,O(P2),1)
13114 & -A( P0 )*MA(1) *F2M(O(P0),O(P2),4))
13115C--unrecognized type of diagram
13116 ELSE
13117 CALL HWWARN('HWDSM2',500)
13118 ENDIF
13119C--now compute the weight
13120 WGT = ZERO
13121 DO 500 P0 =1,2
13122 DO 500 P0P=1,2
13123 DO 500 P1 =1,2
13124 DO 500 P2 =1,2
13125 500 WGT = WGT+PHS*P2MODE(IMODE)*DREAL(
13126 & ME(P0,P1,P2)*DCONJG(ME(P0P,P1,P2))*RHOIN(P0,P0P))
13127 IF(I2DRTP(IMODE).EQ.5.OR.I2DRTP(IMODE).EQ.6.OR.
13128 & I2DRTP(IMODE).EQ.8.OR.I2DRTP(IMODE).EQ.13) GOTO 300
13129C--issue warning if greater than maximum
13130 IF(WGT.GT.WTMAX) THEN
13131 CALL HWWARN('HWDSM2',1)
13132 WRITE(6,2000) RNAME(IDK(ID2PRT(IMODE))),
13133 & RNAME(IDKPRD(1,ID2PRT(IMODE))),RNAME(IDKPRD(2,ID2PRT(IMODE))),
13134 & WTMAX,1.1D0*WGT
13135 WT2MAX(IMODE) = 1.1D0*WGT
13136 WTMAX = WT2MAX(IMODE)
13137 ENDIF
13138 IF(HWRGEN(0)*WTMAX.GT.WGT.AND.NTRY.LT.NSNTRY) GOTO 1000
13139 IF(NTRY.GE.NSNTRY) THEN
13140 CALL HWWARN('HWDSM2',100)
13141 GOTO 999
13142 ENDIF
13143C--now enter the momenta in the common block
13144 300 CALL HWVEQU(5,P(1,2),PHEP(1,IOUT1))
13145 CALL HWVEQU(5,P(1,3),PHEP(1,IOUT2))
13146C--set up the spin information
13147C--setup for all decays
13148 JMOSPN(NSPN+1) = IDSPIN
13149 JMOSPN(NSPN+2) = IDSPIN
13150 JDASPN(1,IDSPIN) = NSPN+1
13151 JDASPN(2,IDSPIN) = NSPN+2
13152 IDSPN(NSPN+1) = IOUT1
13153 IDSPN(NSPN+2) = IOUT2
13154 DO 11 I=1,2
13155 DECSPN(NSPN+I) = .FALSE.
13156 DO 11 J=1,2
13157 11 JDASPN(I,NSPN+J) = 0
13158 ISNHEP(IOUT1) = NSPN+1
13159 ISNHEP(IOUT2) = NSPN+2
13160 DO 12 I=1,2
13161 IF(RSPIN(IDHW(IDSPN(NSPN+I))).EQ.ZERO) THEN
13162 RHOSPN(1,1,NSPN+I) = ONE
13163 RHOSPN(2,1,NSPN+I) = ZERO
13164 RHOSPN(1,2,NSPN+I) = ZERO
13165 RHOSPN(2,2,NSPN+I) = ZERO
13166 ELSE
13167 RHOSPN(1,1,NSPN+I) = HALF
13168 RHOSPN(2,1,NSPN+I) = ZERO
13169 RHOSPN(1,2,NSPN+I) = ZERO
13170 RHOSPN(2,2,NSPN+I) = HALF
13171 ENDIF
13172 12 CONTINUE
13173 NSPN = NSPN+2
13174C--now enter the matrix element
13175 DO 150 P0=1,2
13176 DO 150 P1=1,2
13177 DO 150 P2=1,2
13178 MESPN(P0,P1,P2,2,1,IDSPIN) = (0.0D0,0.0D0)
13179 150 MESPN(P0,P1,P2,1,1,IDSPIN) = ME(P0,P1,P2)
13180 SPNCFC(1,1,IDSPIN) = ONE
13181 NCFL(IDSPIN) = 1
13182 RETURN
13183C--format statements
13184 2000 FORMAT(/'WEIGHT FOR DECAY ',A8,' --> ',A8,' ',A8, 'EXCEEDS MAX',
13185 & /10X,' MAXIMUM WEIGHT =',1PG24.16,
13186 & /10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
13187 999 RETURN
13188 END
13189CDECK ID>, HWDSM3.
13190*CMZ :- -09/04/02 13:46:07 by Peter Richardson
13191*-- Author : Peter Richardson
13192C-----------------------------------------------------------------------
13193 SUBROUTINE HWDSM3(NPR,ID,IOUT1,IOUT2,IOUT3,IMODE,RHOIN,IDSPIN)
13194C-----------------------------------------------------------------------
13195C Master subroutine for three body SUSY and spin ME's
13196C Uses HWD3ME to generate the momenta etc
13197C-----------------------------------------------------------------------
c63d70bc 13198 INCLUDE 'herwig65.inc'
65767955 13199 DOUBLE COMPLEX F0(2,2,8),F1(2,2,8),F1M(2,2,8),F3(2,2,8),
13200 & F0M(2,2,8),F2(2,2,8),RHOIN(2,2),F01(2,2,8,8)
13201 DOUBLE PRECISION A,B,MS,MWD,MA,MB,MA2,MB2,M342,M232,M242,MR,
13202 & P(5,4),PZ(5),HWRGEN,CV,CA,BR,PM(5,4),CFTHRE(NCFMAX,NCFMAX)
13203 INTEGER ID,IDP(4+NDIAGR),NPR,ITYPE,I,IB,ID1,ID2,IDSPIN,
13204 & DRTYPE(NDIAGR),IOUT(3),IMODE,IOUT1,IOUT2,IOUT3,J,NCTHRE,
13205 & DRCF(NDIAGR)
13206 COMMON/HWD3BY/F0,F0M,F1M,F1,F2,F3,F01,A(2,NDIAGR),B(2,NDIAGR),
13207 & MS(NDIAGR),MWD(NDIAGR),MR(NDIAGR),MA(4),MA2(4),MB(4),MB2(4),
13208 & M342,M232,M242,P,PM,CFTHRE,IDP,DRTYPE,NCTHRE,DRCF
13209 EXTERNAL HWRGEN
13210 SAVE PZ,IOUT,ITYPE,ID1,ID2
13211C--calculate the matrix element for a three body decay
13212 IF(NPR.EQ.3) THEN
13213C--set up the decay products, if a SUSY decay the SUSY particle
13214C--must be the first decay product
13215 IF(ABS(IDHEP(IOUT1)).GT.1000000) THEN
13216 IOUT(1) = IOUT1
13217 IOUT(2) = IOUT2
13218 IOUT(3) = IOUT3
13219 ELSEIF(ABS(IDHEP(IOUT2)).GT.1000000) THEN
13220 IOUT(1) = IOUT2
13221 IOUT(2) = IOUT1
13222 IOUT(3) = IOUT3
13223 ELSEIF(ABS(IDHEP(IOUT3)).GT.1000000) THEN
13224 IOUT(1) = IOUT3
13225 IOUT(2) = IOUT1
13226 IOUT(3) = IOUT3
13227C--special for top decay (bottom must be first)
13228 ELSEIF(ABS(IDHEP(ID)).EQ.6) THEN
13229 IOUT(1) = IOUT3
13230 IOUT(2) = IOUT1
13231 IOUT(3) = IOUT2
13232 ELSE
13233 IOUT(1) = IOUT2
13234 IOUT(2) = IOUT1
13235 IOUT(3) = IOUT3
13236 ENDIF
13237C--fermion must be second and antifermion third
13238 IF(IDHEP(IOUT(2)).LT.0.AND.
13239 & (ABS(IDHEP(IOUT(1))).GT.1000000.OR.ABS(IDHEP(ID)).EQ.6)) THEN
13240 I = IOUT(2)
13241 IOUT(2) = IOUT(3)
13242 IOUT(3) = I
13243 ENDIF
13244C--setup the OFF SHELL MASSES
13245 MA(1) = PHEP(5,ID)
13246 DO 1 I=1,3
13247 1 MA(I+1) = PHEP(5,IOUT(I))
13248 DO 2 I=1,4
13249 2 MA2(I) = MA(I)**2
13250C--call to ME code
13251 CALL HWD3ME(ID,0,IMODE,RHOIN,IDSPIN)
13252 IF(IERROR.NE.0) RETURN
13253C--juggle the momenta for the RPV BV gluino if needed
13254 IF(SPCOPT.EQ.2.AND.N3NCFL(IMODE).EQ.3) THEN
13255 IF(NCFL(IDSPIN).EQ.2) THEN
13256 IOUT(1) = IOUT1
13257 IOUT(2) = IOUT2
13258 IOUT(3) = IOUT3
13259 ELSEIF(NCFL(IDSPIN).EQ.3) THEN
13260 IOUT(1) = IOUT3
13261 IOUT(2) = IOUT2
13262 IOUT(3) = IOUT1
13263 ENDIF
13264 DO I=1,3
13265 IDHW(IOUT(I)) = IDP(I+1)
13266 ENDDO
13267 ENDIF
13268C--copy momenta into event record
13269 DO 3 I=1,3
13270 3 CALL HWVEQU(5,P(1,1+I),PHEP(1,IOUT(I)))
13271C--enter the spin information in the common block
13272 IF(SYSPIN) THEN
13273C--set up if start of new spin chain
13274 IF(NSPN.EQ.0) THEN
13275C--zero the elements
13276 CALL HWVZRI( NMXHEP,ISNHEP)
13277 CALL HWVZRI( NMXSPN,JMOSPN)
13278 CALL HWVZRI(2*NMXSPN,JDASPN)
13279 CALL HWVZRI( NMXSPN, IDSPN)
13280 NSPN = NSPN+1
13281 JMOSPN(NSPN) = 0
13282 IDSPN (NSPN) = ID
13283 DECSPN(NSPN) = .FALSE.
13284C--set up spin density matrix for particle
13285 IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN
13286 RHOSPN(1,1,NSPN) = ONE
13287 RHOSPN(2,1,NSPN) = ZERO
13288 RHOSPN(1,2,NSPN) = ZERO
13289 RHOSPN(2,2,NSPN) = ZERO
13290 ELSE
13291 RHOSPN(1,1,NSPN) = HALF
13292 RHOSPN(2,1,NSPN) = ZERO
13293 RHOSPN(1,2,NSPN) = ZERO
13294 RHOSPN(2,2,NSPN) = HALF
13295 ENDIF
13296 ISNHEP(ID) = NSPN
13297 ENDIF
13298C--enter the decay products
13299 JDASPN(1,IDSPIN) = NSPN+1
13300 JDASPN(2,IDSPIN) = NSPN+3
13301 DO 7 I=1,3
13302 JMOSPN(NSPN+I ) = IDSPIN
13303 IDSPN (NSPN+I ) = IOUT(I)
13304 DECSPN(NSPN+I ) = .FALSE.
13305 ISNHEP(IOUT(I) ) = NSPN+I
13306 IF(RSPIN(IDHW(IOUT(I))).EQ.ZERO) THEN
13307 RHOSPN(1,1,NSPN+I) = ONE
13308 RHOSPN(2,1,NSPN+I) = ZERO
13309 RHOSPN(1,2,NSPN+I) = ZERO
13310 RHOSPN(2,2,NSPN+I) = ZERO
13311 ELSE
13312 RHOSPN(1,1,NSPN+I) = HALF
13313 RHOSPN(2,1,NSPN+I) = ZERO
13314 RHOSPN(1,2,NSPN+I) = ZERO
13315 RHOSPN(2,2,NSPN+I) = HALF
13316 ENDIF
13317 DO 7 J=1,2
13318 7 JDASPN(J,NSPN+I) = 0
13319 NSPN = NSPN+3
13320 ENDIF
13321C--select the decay mode and generate the decay for a two body mode
13322 ELSEIF(NPR.EQ.2) THEN
13323 IF(IDHW(IOUT2).GE.198.AND.IDHW(IOUT2).LE.200) THEN
13324 IB = IDHW(IOUT2)
13325 IOUT(1) = IOUT1
13326 IOUT(2) = IOUT2
13327 ELSEIF(IDHW(IOUT1).GE.198.AND.IDHW(IOUT1).LE.200) THEN
13328 IB = IDHW(IOUT1)
13329 IOUT(1) = IOUT2
13330 IOUT(2) = IOUT1
13331 ELSE
13332 CALL HWWARN('HWDSM3',501)
13333 ENDIF
13334C--setup the off shell masses and particle ids for me code
13335 MA(1) = PHEP(5,ID)
13336 MA(2) = PHEP(5,IOUT(1))
13337 CALL HWDBOZ(IB,ID1,ID2,CV,CA,BR,0)
13338 ITYPE = ID1
13339 IF(IB.EQ.199) ITYPE = ITYPE+1
13340 IF(ITYPE.GT.120) ITYPE = ITYPE-114
13341 IF(IB.NE.200) ITYPE = ITYPE/2
13342C--generate momenta of decay products
13343 CALL HWD3ME(ID,ITYPE,IMODE,RHOIN,IDSPIN)
13344 CALL HWVEQU(5,P(1,2),PHEP(1,IOUT(1)))
13345 CALL HWVSUM(4,P(1,3),P(1,4),PZ)
13346 CALL HWUMAS(PZ)
13347 CALL HWVEQU(5,PZ,PHEP(1,IOUT(2)))
13348C--enter the spin information in the common block if starting new chain
13349 IF(SYSPIN.AND.NSPN.EQ.0) THEN
13350C--zero elements of common block
13351 CALL HWVZRI( NMXHEP,ISNHEP)
13352 CALL HWVZRI( NMXSPN,JMOSPN)
13353 CALL HWVZRI(2*NMXSPN,JDASPN)
13354 CALL HWVZRI( NMXSPN, IDSPN)
13355 NSPN = NSPN+1
13356 JMOSPN(NSPN) = 0
13357 IDSPN (NSPN) = ID
13358 DECSPN(NSPN) = .FALSE.
13359 IF(RSPIN(IDHW(ID)).EQ.ZERO) THEN
13360 RHOSPN(1,1,NSPN) = ONE
13361 RHOSPN(2,1,NSPN) = ZERO
13362 RHOSPN(1,2,NSPN) = ZERO
13363 RHOSPN(2,2,NSPN) = ZERO
13364 ELSE
13365 RHOSPN(1,1,NSPN) = HALF
13366 RHOSPN(2,1,NSPN) = ZERO
13367 RHOSPN(1,2,NSPN) = ZERO
13368 RHOSPN(2,2,NSPN) = HALF
13369 ENDIF
13370 ISNHEP(ID) = NSPN
13371 ENDIF
13372 IF(SYSPIN) THEN
13373 IDSPN (NSPN+1 ) = IOUT(1)
13374 ISNHEP(IOUT(1)) = NSPN+1
13375 ENDIF
13376C--put the boson decay products into the event record for a two body mode
13377 ELSEIF(NPR.EQ.-1) THEN
13378 IOUT(1) = JDAHEP(1,IOUT(2))
13379 IOUT(2) = NHEP+1
13380 IOUT(3) = NHEP+2
13381C--set up the status of the particles
13382 ISTHEP(IOUT(1)) = 195
13383 JDAHEP(1,IOUT(1)) = NHEP+1
13384 JDAHEP(2,IOUT(1)) = NHEP+2
13385C--find the ID's of the particles
13386 IF(IDHW(IOUT(1)).EQ.200) THEN
13387 ID1 = ITYPE
13388 IF(ITYPE.GT.6) ID1 = ID1+114
13389 ID2 = ID1+6
13390 ELSE
13391 ID1 = 2*ITYPE-1
13392 IF(ITYPE.GT.3) ID1 = ID1+114
13393 ID2 = ID1+7
13394 IF(IDHW(IOUT(1)).EQ.198) THEN
13395 I = ID1+6
13396 ID1 = ID2-6
13397 ID2 = I
13398 ENDIF
13399 ENDIF
13400C--put id's of decay products into the event record
13401 IDHW(NHEP+1) = ID1
13402 IDHW(NHEP+2) = ID2
13403 IDHEP(NHEP+1) = IDPDG(ID1)
13404 IDHEP(NHEP+2) = IDPDG(ID2)
13405C--boost decay products momenta to rest frame of boson
13406 CALL HWULOF(PZ,P(1,3),P(1,3))
13407 CALL HWULOF(PZ,P(1,4),P(1,4))
13408C--boost back to lab using new boson
13409 CALL HWULOB(PHEP(1,IOUT(1)),P(1,3),PHEP(1,NHEP+1))
13410 CALL HWULOB(PHEP(1,IOUT(1)),P(1,4),PHEP(1,NHEP+2))
13411C--setup for decay to quarks
13412 IF(ID1.LE.12) THEN
13413 ISTHEP(NHEP+1) = 113
13414 ISTHEP(NHEP+2) = 114
13415 JMOHEP(2,NHEP+1) = NHEP+2
13416 JDAHEP(2,NHEP+1) = NHEP+2
13417 JMOHEP(2,NHEP+2) = NHEP+1
13418 JDAHEP(2,NHEP+2) = NHEP+1
13419 JMOHEP(1,NHEP+1) = IOUT(1)
13420 JMOHEP(1,NHEP+2) = IOUT(1)
13421C--setup for decay to leptons
13422 ELSE
13423 ISTHEP(NHEP+1) = 193
13424 ISTHEP(NHEP+2) = 193
13425 JMOHEP(1,NHEP+1) = IOUT(1)
13426 JMOHEP(1,NHEP+2) = IOUT(1)
13427 JMOHEP(2,NHEP+1) = JMOHEP(1,IOUT(1))
13428 JMOHEP(2,NHEP+2) = JMOHEP(1,IOUT(1))
13429 JDAHEP(1,NHEP+1) = 0
13430 JDAHEP(1,NHEP+2) = 0
13431 JDAHEP(2,NHEP+1) = 0
13432 JDAHEP(2,NHEP+2) = 0
13433 ENDIF
13434 NHEP=NHEP+2
13435C--finish entering the spin information in the common block
13436 IF(SYSPIN) THEN
13437 JDASPN(1,IDSPIN) = NSPN+1
13438 JDASPN(2,IDSPIN) = NSPN+3
13439 DO 6 I=1,3
13440 JMOSPN(NSPN+I ) = IDSPIN
13441 DECSPN(NSPN+I ) = .FALSE.
13442 IF(RSPIN(IDHW(IOUT(I))).EQ.ZERO) THEN
13443 RHOSPN(1,1,NSPN+I) = ONE
13444 RHOSPN(2,1,NSPN+I) = ZERO
13445 RHOSPN(1,2,NSPN+I) = ZERO
13446 RHOSPN(2,2,NSPN+I) = ZERO
13447 ELSE
13448 RHOSPN(1,1,NSPN+I) = HALF
13449 RHOSPN(2,1,NSPN+I) = ZERO
13450 RHOSPN(1,2,NSPN+I) = ZERO
13451 RHOSPN(2,2,NSPN+I) = HALF
13452 ENDIF
13453 DO 6 J=1,2
13454 6 JDASPN(J,NSPN+I) =0
13455 NSPN = NSPN+3
13456 IDSPN (NSPN-1) = NHEP-1
13457 IDSPN (NSPN ) = NHEP
13458 ISNHEP(NHEP-1) = NSPN-1
13459 ISNHEP(NHEP ) = NSPN
13460 ENDIF
13461C--perform the parton shower for the decay products of the gauge boson
13462 IF(ID1.LE.12) CALL HWBGEN
13463C--error issue warning
13464 ELSE
13465 CALL HWWARN('HWDSM3',500)
13466 ENDIF
13467 END
13468CDECK ID>, HWDSM4.
13469*CMZ :- -11/10/01 14:03:42 by Peter Richardson
13470*-- Author : Peter Richardson
13471C-----------------------------------------------------------------------
13472 SUBROUTINE HWDSM4(IOPT,ID,IOUT1,IOUT2,IMODE)
13473C-----------------------------------------------------------------------
13474C Subroutine to perform the four body decays
13475C IOPT = 1 select decay mode and generate momenta
13476C IOPT = 2 enter first decays and perform parton shower
13477C-----------------------------------------------------------------------
c63d70bc 13478 INCLUDE 'herwig65.inc'
65767955 13479 INTEGER IOPT,ID,IOUT1,IOUT2,IB(2),I,IDF(4),ITYPE(2),IMODE,
13480 & IDP(4+NDIAGR),ID1,ID2,J
13481 DOUBLE PRECISION CV,CA,A,B,MS,MWD,MR,M,M2,P(5,5),PW(5,2),BR
13482 COMMON/HWD4BY/A(2),B(2),MS(2),MWD(2),MR(2),M(5),M2(5),P,IDP
13483 SAVE PW,ITYPE
13484C--generate the decay
13485 IF(IOPT.EQ.1) THEN
13486 IB(1) = IDHW(IOUT1)
13487 IB(2) = IDHW(IOUT2)
13488C--select the decays of the bosons
13489 DO 1 I=1,2
13490 CALL HWDBOZ(IB(I),IDF(2*I-1),IDF(2*I),CV,CA,BR,1)
13491 ITYPE(I) = IDF(2*I-1)
13492 IF(IB(I).EQ.199) ITYPE(I) = ITYPE(I)+1
13493 IF(ITYPE(I).GT.120) ITYPE(I) = ITYPE(I)-114
13494 1 IF(IB(I).NE.200) ITYPE(I) = ITYPE(I)/2
13495C--generate the momenta of the decay products
13496 CALL HWD4ME(ID,ITYPE(1),ITYPE(2),IMODE)
13497 DO 2 I=1,2
13498 CALL HWVSUM(4,P(1,2*I),P(1,2*I+1),PW(1,I))
13499 2 CALL HWUMAS(PW(1,I))
13500 CALL HWVEQU(5,PW(1,1),PHEP(1,IOUT1))
13501 CALL HWVEQU(5,PW(1,2),PHEP(1,IOUT2))
13502 IF(SYSPIN) THEN
13503 IDSPN(1) = JDAHEP(1,ID)
13504 DECSPN(1) = .FALSE.
13505 ISNHEP(JDAHEP(1,ID)) = 1
13506 JDASPN(1,1) = 2
13507 JDASPN(2,1) = 5
13508 DO 4 I=2,5
13509 DECSPN(I) = .FALSE.
13510 4 JMOSPN(I) = 1
13511 ENDIF
13512 ELSEIF(IOPT.EQ.2) THEN
13513 IB(1) = JDAHEP(1,IOUT1)
13514 IB(2) = JDAHEP(1,IOUT2)
13515 DO 3 I=1,2
13516 ISTHEP(IB(I)) = 195
13517 JDAHEP(1,IB(I)) = NHEP+1
13518 JDAHEP(2,IB(I)) = NHEP+2
13519C--find the ID's of the particles
13520 IF(IDHW(IB(I)).EQ.200) THEN
13521 ID1 = ITYPE(I)
13522 IF(ITYPE(I).GT.6) ID1 = ID1+114
13523 ID2 = ID1+6
13524 ELSE
13525 ID1 = 2*ITYPE(I)-1
13526 IF(ITYPE(I).GT.3) ID1 = ID1+114
13527 ID2 = ID1+7
13528 IF(IDHW(IB(I)).EQ.198) THEN
13529 J = ID1+6
13530 ID1 = ID2-6
13531 ID2 = J
13532 ENDIF
13533 ENDIF
13534C--put id's of decay products into the event record
13535 IDHW(NHEP+1) = ID1
13536 IDHW(NHEP+2) = ID2
13537 IDHEP(NHEP+1) = IDPDG(ID1)
13538 IDHEP(NHEP+2) = IDPDG(ID2)
13539C--boost decay products momenta to rest frame of boson
13540 CALL HWULOF(PW(1,I),P(1,2*I ),P(1,2*I ))
13541 CALL HWULOF(PW(1,I),P(1,2*I+1),P(1,2*I+1))
13542C--boost back to lab using new boson
13543 CALL HWULOB(PHEP(1,IB(I)),P(1,2*I ),PHEP(1,NHEP+1))
13544 CALL HWULOB(PHEP(1,IB(I)),P(1,2*I+1),PHEP(1,NHEP+2))
13545C--setup for decay to quarks
13546 IF(ID1.LE.12) THEN
13547 ISTHEP(NHEP+1) = 113
13548 ISTHEP(NHEP+2) = 114
13549 JMOHEP(2,NHEP+1) = NHEP+2
13550 JDAHEP(2,NHEP+1) = NHEP+2
13551 JMOHEP(2,NHEP+2) = NHEP+1
13552 JDAHEP(2,NHEP+2) = NHEP+1
13553 JMOHEP(1,NHEP+1) = IB(I)
13554 JMOHEP(1,NHEP+2) = IB(I)
13555C--setup for decay to leptons
13556 ELSE
13557 ISTHEP(NHEP+1) = 193
13558 ISTHEP(NHEP+2) = 193
13559 JMOHEP(1,NHEP+1) = IB(I)
13560 JMOHEP(1,NHEP+2) = IB(I)
13561 JMOHEP(2,NHEP+1) = JMOHEP(1,IB(I))
13562 JMOHEP(2,NHEP+2) = JMOHEP(1,IB(I))
13563 ENDIF
13564C--enter the information in the spin common block
13565 IF(SYSPIN) THEN
13566 IDSPN(2*I ) = NHEP+1
13567 IDSPN(2*I+1) = NHEP+2
13568 ISNHEP(NHEP+1) = 2*I
13569 ISNHEP(NHEP+2) = 2*I+1
13570 ENDIF
13571 NHEP=NHEP+2
13572C--perform the parton shower for the decay products of the gauge boson
13573 IF(ID1.LE.12) CALL HWBGEN
13574 3 CONTINUE
13575 ENDIF
13576 END
13577CDECK ID>, HWDTAU.
13578*CMZ :- -17/10/01 09:42:21 by Peter Richardson
13579*-- Author : Peter Richardson
13580C-----------------------------------------------------------------------
13581 SUBROUTINE HWDTAU(IOPT,IHEP,POL)
13582C-----------------------------------------------------------------------
13583C HERWIG-TAUOLA interface to perform tau decays using TAUOLA rather
13584C than HERWIG
13585C IOPT =-1 initialises
13586C IOPT = 1 performs decay
13587C IOPT = 2 write outs final TAUOLA information
13588C-----------------------------------------------------------------------
c63d70bc 13589 INCLUDE 'herwig65.inc'
65767955 13590 INTEGER IOPT,IHEP,ID,ITAU,I,IMO,NHEPPO
13591 DOUBLE PRECISION POL
13592 REAL POL1(4)
13593 CHARACTER *8 DUMMY
13594C--common block for PHOTOS
13595 LOGICAL QEDRAD
13596 COMMON /PHOQED/ QEDRAD(NMXHEP)
13597C--common blocks for TAUOLA
13598 INTEGER NP1,NP2
13599 COMMON /TAUPOS/ NP1, NP2
13600 DOUBLE PRECISION Q1(4),Q2(4),P1(4),P2(4),P3(4),P4(4)
13601 COMMON / MOMDEC / Q1,Q2,P1,P2,P3,P4
13602C--initialisation
13603 IF(IOPT.EQ.-1) THEN
13604C--initialise TAUOLA
13605 CALL INIETC(JAK1,JAK2,ITDKRC,IFPHOT)
13606 CALL INIMAS
13607 CALL INIPHX(0.01d0)
13608 CALL INITDK
13609C--generate a decay
13610 ELSEIF(IOPT.EQ.1) THEN
13611 ISTHEP(IHEP)=195
13612 ID = IDHW(IHEP)
13613 IMO = IHEP
13614 1 IMO = JMOHEP(1,IMO)
13615 IF(IDHW(IMO).EQ.ID) GOTO 1
13616C--id of tau for tauola
13617 IF(ID.EQ.125) THEN
13618 ITAU = 2
13619 NP1 = IHEP
13620 NP2 = IHEP
13621 ELSEIF(ID.EQ.131) THEN
13622 ITAU = 1
13623 NP1 = IHEP
13624 NP2 = IHEP
13625 ELSE
13626 CALL HWWARN('HWDTAU',501)
13627 ENDIF
13628C--set up the tau polarization
13629 POL1(1) = 0.
13630 POL1(2) = 0.
13631 POL1(3) = REAL(POL)
13632 POL1(4) = 0.
13633C--tau momentum
13634C--three components
13635 DO I=1,3
13636 IF(ID.EQ.125) THEN
13637 P1(I) =-PHEP(I,IHEP)
13638 P2(I) = PHEP(I,IHEP)
13639 ELSE
13640 P1(I) = PHEP(I,IHEP)
13641 P2(I) =-PHEP(I,IHEP)
13642 ENDIF
13643C--we measure tau spins in lab frame
13644 Q1(I) = ZERO
13645 ENDDO
13646C--energies
13647 P1(4)=PHEP(4,IHEP)
13648 P2(4)=PHEP(4,IHEP)
13649 Q1(4)=P1(4)+P2(4)
13650C--perform the decay and generate QED radiation if needed
13651 NHEPPO=NHEP
13652 CALL DEXAY(ITAU,POL1)
13653 IF(IFPHOT.EQ.1) THEN
13654 IF(ID.EQ.1) THEN
13655 CALL PHOTOS(NP1)
13656 ELSE
13657 CALL PHOTOS(NP2)
13658 ENDIF
13659 ENDIF
13660 IF(NHEPPO.NE.NHEP) THEN
13661 DO 2 I=NHEPPO+1,NHEP
13662 CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,I))
13663 2 CALL HWUIDT(1,IDHEP(I),IDHW(I),DUMMY)
13664 ENDIF
13665C--write out info at end
13666 ELSEIF(IOPT.EQ.2) THEN
13667 CALL DEXAY(100,POL1)
13668C--otherwise issue warning
13669 ELSE
13670 CALL HWWARN('HWDTAU',500)
13671 ENDIF
13672 END
13673CDECK ID>, HWDTHR.
13674*CMZ :- -26/04/91 14.55.44 by Federico Carminati
13675*-- Author : Bryan Webber
13676C-----------------------------------------------------------------------
13677 SUBROUTINE HWDTHR(P0,P1,P2,P3,WEIGHT)
13678C-----------------------------------------------------------------------
13679C GENERATES THREE-BODY DECAY 0->1+2+3 DISTRIBUTED
13680C ACCORDING TO PHASE SPACE * WEIGHT
13681C-----------------------------------------------------------------------
13682 IMPLICIT NONE
13683 DOUBLE PRECISION HWRGEN,HWRUNI,A,B,C,D,AA,BB,CC,DD,EE,FF,PP,QQ,WW,
13684 & RR,PCM1,PC23,WEIGHT,P0(5),P1(5),P2(5),P3(5),P23(5),TWO
13685 EXTERNAL HWRGEN,HWRUNI,WEIGHT
13686 PARAMETER (TWO=2.D0)
13687 A=P0(5)+P1(5)
13688 B=P0(5)-P1(5)
13689 C=P2(5)+P3(5)
13690 IF (B.LT.C) THEN
13691 CALL HWWARN('HWDTHR',100)
13692 GOTO 999
13693 ENDIF
13694 D=ABS(P2(5)-P3(5))
13695 AA=A*A
13696 BB=B*B
13697 CC=C*C
13698 DD=D*D
13699 EE=(B-C)*(A-D)
13700 A=0.5*(AA+BB)
13701 B=0.5*(CC+DD)
13702 C=4./(A-B)**2
13703C
13704C CHOOSE MASS OF SUBSYSTEM 23 WITH PRESCRIBED DISTRIBUTION
13705C
13706 10 FF=HWRUNI(0,BB,CC)
13707 PP=(AA-FF)*(BB-FF)
13708 QQ=(CC-FF)*(DD-FF)
13709 WW=WEIGHT(FF,A,B,C)**2
13710 RR=EE*FF*HWRGEN(0)
13711 IF (PP*QQ*WW.LT.RR*RR) GOTO 10
13712C
13713C FF IS MASS SQUARED OF SUBSYSTEM 23.
13714C
13715C DO 2-BODY DECAYS 0->1+23, 23->2+3
13716C
13717 P23(5)=SQRT(FF)
13718 PCM1=SQRT(PP)*0.5/P0(5)
13719 PC23=SQRT(QQ)*0.5/P23(5)
13720 CALL HWDTWO(P0,P1,P23,PCM1,TWO,.TRUE.)
13721 CALL HWDTWO(P23,P2,P3,PC23,TWO,.TRUE.)
13722 999 RETURN
13723 END
13724CDECK ID>, HWDTOP.
13725*CMZ :- -09/12/92 11.03.46 by Bryan Webber
13726*-- Author : Bryan Webber
13727C-----------------------------------------------------------------------
13728 SUBROUTINE HWDTOP(DECAY)
13729C-----------------------------------------------------------------------
13730C DECIDES WHETHER TO DO TOP QUARK DECAY BEFORE HADRONIZATION
13731C-----------------------------------------------------------------------
c63d70bc 13732 INCLUDE 'herwig65.inc'
65767955 13733 LOGICAL DECAY
13734 DECAY=RMASS(6).GT.130D0
13735 END
13736CDECK ID>, HWDTWO.
13737*CMZ :- -27/01/94 17.38.49 by Mike Seymour
13738*-- Author : Bryan Webber & Mike Seymour
13739C-----------------------------------------------------------------------
13740 SUBROUTINE HWDTWO(P0,P1,P2,PCM,COSTH,ZAXIS)
13741C-----------------------------------------------------------------------
13742C GENERATES DECAY 0 -> 1+2
13743C
13744C PCM IS CM MOMENTUM
13745C
13746C COSTH = COS THETA IN P0 REST FRAME (>1 FOR ISOTROPIC)
13747C IF ZAXIS=.TRUE., COS THETA IS MEASURED FROM THE ZAXIS
13748C IF .FALSE., IT IS MEASURED FROM P0'S DIRECTION
13749C-----------------------------------------------------------------------
13750 IMPLICIT NONE
13751 DOUBLE PRECISION HWRUNI,ONE,ZERO,PCM,COSTH,C,S,P0(5),P1(5),P2(5),
13752 & PP(5),R(9)
13753 LOGICAL ZAXIS
13754 EXTERNAL HWRUNI
13755 PARAMETER (ZERO=0.D0, ONE=1.D0)
13756C--CHOOSE C.M. ANGLES
13757 C=COSTH
13758 IF (C.GT.ONE) C=HWRUNI(0,-ONE,ONE)
13759 S=SQRT(ONE-C*C)
13760 CALL HWRAZM(PCM*S,PP(1),PP(2))
13761C--PP IS MOMENTUM OF 2 IN C.M.
13762 PP(3)=-PCM*C
13763 PP(4)=SQRT(P2(5)**2+PCM**2)
13764 PP(5)=P2(5)
13765C--ROTATE IF NECESSARY
13766 IF (COSTH.LE.ONE.AND..NOT.ZAXIS) THEN
13767 CALL HWUROT(P0,ONE,ZERO,R)
13768 CALL HWUROB(R,PP,PP)
13769 ENDIF
13770C--BOOST FROM C.M. TO LAB FRAME
13771 CALL HWULOB(P0,PP,P2)
13772 CALL HWVDIF(4,P0,P2,P1)
13773 END
13774CDECK ID>, HWDWWT.
13775*CMZ :- -26/04/91 11.11.55 by Bryan Webber
13776*-- Author : Bryan Webber
13777C-----------------------------------------------------------------------
13778 FUNCTION HWDWWT(EMSQ,A,B,C)
13779C-----------------------------------------------------------------------
13780C MATRIX ELEMENT SQUARED FOR V-A WEAK DECAY
13781C-----------------------------------------------------------------------
13782 IMPLICIT NONE
13783 DOUBLE PRECISION HWDWWT,EMSQ,A,B,C
13784 HWDWWT=(A-EMSQ)*(EMSQ-B)*C
13785 END
13786CDECK ID>, HWDHWT.
13787*CMZ :- -26/06/01 14.44.53 by Stefano Moretti
13788*-- Author : Stefano Moretti
13789C-----------------------------------------------------------------------
13790 FUNCTION HWDHWT(EMSQ,DUMMYA,DUMMYB,DUMMYC)
13791C-----------------------------------------------------------------------
13792C MATRIX ELEMENT SQUARED FOR
13793C ((V-A)*TB1+(V+A)*CT1)*((V-A)*TB2+(V+A)*CT2)) WEAK DECAY
13794C-----------------------------------------------------------------------
c63d70bc 13795 INCLUDE 'herwig65.inc'
65767955 13796 COMMON/FFS/TB,BT
13797 COMMON/SFF/IT1,IB1,IT2,IB2
13798 DOUBLE PRECISION TB,BT
13799 INTEGER IT1,IB1,IT2,IB2
13800 DOUBLE PRECISION TBH,HBT,CB1,TB1,CB2,TB2
13801 DOUBLE PRECISION DUMMYA,DUMMYB,DUMMYC
13802 DOUBLE PRECISION HWDHWT,EMSQ
13803 CB1=RMASS(IT1)**2
13804 TB1=RMASS(IB1)**2
13805 CB2=RMASS(IT2)**2
13806 TB2=RMASS(IB2)**2
13807C use formula (4.52) page 217 of `Higgs Hunter Guide'.
13808 TBH=(TB1+CB1-EMSQ)*(TB1*TB*TB+CB1/TB/TB)+4.*TB1*CB1
13809C use formula (B. 1) page 411 of `Higgs Hunter Guide'.
13810 HBT=(EMSQ-TB2-CB2)*(TB2*BT*BT+CB2/BT/BT)-4.*TB2*CB2
13811 HWDHWT=TBH*HBT
13812 HWDHWT=ABS(HWDHWT)*SQRT(EMSQ)
13813 END
13814CDECK ID>, HWDXLM.
13815*CMZ :- -07/09/00 10:06:23 by Peter Richardson
13816*-- Author : Ian Knowles
13817C-----------------------------------------------------------------------
13818 SUBROUTINE HWDXLM(DKVRTX,STAB)
13819C-----------------------------------------------------------------------
13820C Sets STAB=.TRUE. if DKVRTX lies outside the specified region.
13821C Revised 05/09/00 by BRW to put parameters in common
13822C-----------------------------------------------------------------------
c63d70bc 13823 INCLUDE 'herwig65.inc'
65767955 13824 DOUBLE PRECISION DKVRTX(4),RR
13825 LOGICAL STAB
13826 STAB=.FALSE.
13827 RR=DKVRTX(1)**2+DKVRTX(2)**2
13828 IF (IOPDKL.EQ.1) THEN
13829C Cylindrical geometry
13830 IF (RR.GE.DXRCYL**2.OR.ABS(DKVRTX(3)).GE.DXZMAX) STAB=.TRUE.
13831 ELSEIF (IOPDKL.EQ.2) THEN
13832C Spherical geometry
13833 RR=RR+DKVRTX(3)**2
13834 IF (RR.GE.DXRSPH**2) STAB=.TRUE.
13835 ELSE
13836C User supplied geometry -- missing
13837 CALL HWWARN('HWDXLM',500)
13838 ENDIF
13839 END
13840CDECK ID>, HWECIR.
13841*CMZ :- -11/05/01 15.44.55 by Mike Seymour
13842*-- Author : Mike Seymour
13843C-----------------------------------------------------------------------
13844 FUNCTION HWECIR(Y)
13845C-----------------------------------------------------------------------
13846C INTEGRAND OF BEAMSTRAHLUNG FUNCTION INTEGRATION
13847C NOTE THAT THE JACOBIAN TRANSFORMATION (1-Z)^ETA HAS ETA HARDCODED
13848C-----------------------------------------------------------------------
13849 IMPLICIT NONE
13850 DOUBLE PRECISION HWECIR,Y,Z,ETA,CIRCEE
13851 EXTERNAL CIRCEE
13852 ETA=0.6D0
13853 Z=1-Y**(1/(1-ETA))
13854 HWECIR=(1-Z)**ETA/(1-ETA)*CIRCEE(Z,-1D0)/SQRT(CIRCEE(-1D0,-1D0))
13855 END
13856CDECK ID>, HWEFIN.
13857*CMZ :- -15/07/02 17.56.53 by Peter Richardson
13858*-- Author : Bryan Webber
13859C-----------------------------------------------------------------------
13860 SUBROUTINE HWEFIN
13861C-----------------------------------------------------------------------
13862C TERMINAL CALCULATIONS ON ELEMENTARY PROCESS
13863C Modified 28/03/01 by BRW to handle negative weights
13864C Modified 15/07/02 by PR for Les Houches Accord
13865C-----------------------------------------------------------------------
c63d70bc 13866 INCLUDE 'herwig65.inc'
65767955 13867 INTEGER I
13868 DOUBLE PRECISION RNWGT,SPWGT,ERWGT
13869C--Les Houches Common Block
13870 INTEGER MAXPUP
13871 PARAMETER(MAXPUP=100)
13872 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
13873 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
13874 COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
13875 & IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
13876 & XMAXUP(MAXPUP),LPRUP(MAXPUP)
13877 IF(TAUDEC.EQ.'TAUOLA') CALL HWDTAU(2,0,0.0D0)
13878 IF (NWGTS.EQ.0) THEN
13879 WRITE (6,1)
13880 WRITE (6,10)
13881 10 FORMAT(10X,'NO WEIGHTS GENERATED')
13882 RETURN
13883 ENDIF
13884C--output Les Houches common block information
13885 IF(IPROC.LE.0) THEN
13886C--WRITE THE HEADER
13887 WRITE(6,13)
13888 WRITE(6,14)
13889C--FOR THE FIRST WEIGHT OPTION CALCULATE THE CROSS SECTION
13890 IF(ABS(IDWTUP).EQ.1) THEN
13891 DO I=1,NPRUP
13892 RNWGT = 1.0D0/DBLE(LHIWGT(I))
13893 LHXSCT(I) = LHWGT(I)*RNWGT
13894 LHXERR(I) = SQRT(MAX(LHWGTS(I)*RNWGT-LHXSCT(I)**2,ZERO))
13895 LHXERR(I) = LHXERR(I)*SQRT(RNWGT)
13896 LHXSCT(I) = LHXSCT(I)*1.0D3
13897 LHXERR(I) = LHXERR(I)*1.0D3
13898 LHXMAX(I) = LHXMAX(I)*1.0D3
13899 ENDDO
13900C--FOR THE SECOND WEIGHT OPTION THIS WAS AN INPUT
13901 ELSEIF(ABS(IDWTUP).EQ.2) THEN
13902 DO I=1,NPRUP
13903 LHXMAX(I) = LHXMAX(I)*1.0D3
13904 ENDDO
13905 ENDIF
13906 IF(ABS(IDWTUP).LE.2) THEN
13907 AVWGT = ZERO
13908 ERWGT = ZERO
13909 DO I=1,NPRUP
13910 WRITE(6,15) LPRUP(I),LHXSCT(I),LHXERR(I),LHXMAX(I)*1.0D-3,
13911 & LHNEVT(I)
13912 AVWGT = AVWGT+LHXSCT(I)
13913 ERWGT = ERWGT+LHXERR(I)**2
13914 ENDDO
13915 AVWGT = AVWGT*1.0D-3
13916 ERWGT = SQRT(ERWGT)*1.0D-3
13917 ELSE
13918 RNWGT=1./FLOAT(NWGTS)
13919 IF (NEGWTS) AVABW=ABWSUM*RNWGT
13920 AVWGT=WGTSUM*RNWGT
13921 SPWGT=SQRT(MAX(WSQSUM*RNWGT-AVWGT**2,ZERO))
13922 ERWGT=SPWGT*SQRT(RNWGT)
13923 IF (.NOT.NOWGT) WGTMAX=AVWGT
13924 IF (WGTMAX.EQ.ZERO) WGTMAX=ONE
13925 ENDIF
13926C--STANDARD HERWIG OPTION
13927 ELSE
13928 RNWGT=1./FLOAT(NWGTS)
13929 IF (NEGWTS) AVABW=ABWSUM*RNWGT
13930 AVWGT=WGTSUM*RNWGT
13931 SPWGT=SQRT(MAX(WSQSUM*RNWGT-AVWGT**2,ZERO))
13932 ERWGT=SPWGT*SQRT(RNWGT)
13933 IF (.NOT.NOWGT) WGTMAX=AVWGT
13934 IF (WGTMAX.EQ.ZERO) WGTMAX=ONE
13935 ENDIF
13936C--PRINT OUT THE INFO
13937 WRITE (6,1)
13938 1 FORMAT(/10X,'OUTPUT ON ELEMENTARY PROCESS'/)
13939 IF (NEGWTS) THEN
13940 WRITE (6,12) NEVHEP,NNEGEV,NWGTS,NNEGWT,AVWGT,SPWGT,
13941 & AVABW,WBIGST,WGTMAX,IPROC,
13942 & 1000.*AVWGT,1000.*ERWGT,100.*AVWGT/WGTMAX
13943 ELSE
13944 WRITE (6,11) NEVHEP,NWGTS,AVWGT,SPWGT,WBIGST,WGTMAX,
13945 & IPROC,
13946 & 1000.*AVWGT,1000.*ERWGT,100.*AVWGT/WGTMAX
13947 ENDIF
13948 11 FORMAT(1P,
13949 & 10X,'N.B. NEGATIVE WEIGHTS NOT ALLOWED'//
13950 & 10X,'NUMBER OF EVENTS = ',I11/
13951 & 10X,'NUMBER OF WEIGHTS = ',I11/
13952 & 10X,'MEAN VALUE OF WGT =',E12.4/
13953 & 10X,'RMS SPREAD IN WGT =',E12.4/
13954 & 10X,'ACTUAL MAX WEIGHT =',E12.4/
13955 & 10X,'ASSUMED MAX WEIGHT =',E12.4//
13956 & 10X,'PROCESS CODE IPROC = ',I11/
13957 & 10X,'CROSS SECTION (PB) =',G12.4/
13958 & 10X,'ERROR IN C-S (PB) =',G12.4/
13959 & 10X,'EFFICIENCY PERCENT =',G12.4)
13960 12 FORMAT(1P,
13961 & 10X,'N.B. NEGATIVE WEIGHTS ALLOWED'//
13962 & 10X,'NUMBER OF EVENTS = ',I11/
13963 & 10X,'NEGATIVE EVENTS = ',I11/
13964 & 10X,'NUMBER OF WEIGHTS = ',I11/
13965 & 10X,'NEGATIVE WEIGHTS = ',I11/
13966 & 10X,'MEAN VALUE OF WGT =',E12.4/
13967 & 10X,'RMS SPREAD IN WGT =',E12.4/
13968 & 10X,'MEAN ABS WEIGHT =',E12.4/
13969 & 10X,'ACTUAL MAX ABS WGT =',E12.4/
13970 & 10X,'ASSUMED MAXABS WGT =',E12.4//
13971 & 10X,'PROCESS CODE IPROC = ',I11/
13972 & 10X,'CROSS SECTION (PB) =',G12.4/
13973 & 10X,'ERROR IN C-S (PB) =',G12.4/
13974 & 10X,'EFFICIENCY PERCENT =',G12.4)
13975 13 FORMAT(/1P,10X,'OUTPUT ON LES HOUCHES EVENTS'/)
13976 14 FORMAT(/1P,5X,' PROC CODE',1X,' XSECT(pb) ',1X,
13977 & ' XERR(pb) ',1X,' Max wgt(nb)',1X,'No. of events'/)
13978 15 FORMAT(5X,I7,E15.5,1X,E15.5,1X,E15.5,2X,I7)
13979 END
13980CDECK ID>, HWEGAM.
13981*CMZ :- -26/04/91 11.11.55 by Bryan Webber
13982*-- Author : Bryan Webber & Luca Stanco
13983C-----------------------------------------------------------------------
13984 SUBROUTINE HWEGAM(IHEP,ZMI,ZMA,WWA)
13985C-----------------------------------------------------------------------
13986C GENERATES A PHOTON IN WEIZSACKER-WILLIAMS (WWA=.TRUE.) OR
13987C ELSE EQUIVALENT PHOTON APPROX FROM INCOMING E+, E-, MU+ OR MU-
13988C-----------------------------------------------------------------------
c63d70bc 13989 INCLUDE 'herwig65.inc'
65767955 13990 DOUBLE PRECISION HWRGEN,HWRUNI,EGMIN,ZMIN,ZMAX,ZGAM,SS,ZMI,ZMA,
13991 & PPL,PMI,QT2,Q2,QQMIN,QQMAX,S0,A
13992 INTEGER IHEP,IHADIS
13993 LOGICAL WWA
13994 EXTERNAL HWRGEN,HWRUNI
13995 SAVE EGMIN
13996 DATA EGMIN/5.D0/
13997 IF (IERROR.NE.0) RETURN
13998 IF (IHEP.LT.1.OR.IHEP.GT.2) CALL HWWARN('HWEGAM',500)
13999 SS=PHEP(5,3)
14000 IF (IHEP.EQ.1) THEN
14001 IHADIS=2
14002 ELSE
14003 IHADIS=1
14004 IF (JDAHEP(1,IHADIS).NE.0) IHADIS=JDAHEP(1,IHADIS)
14005 ENDIF
14006C---DEFINE LIMITS FOR GAMMA MOMENTUM FRACTION
14007 IF (ZMI.LE.ZERO .OR. ZMA.GT.ONE) THEN
14008 CALL HWEGAS(S0)
14009 IF (S0.GT.ZERO) THEN
14010 S0 = (SQRT(S0)+ABS(PHEP(5,IHADIS)))**2-PHEP(5,IHADIS)**2
14011 S0 = MAX(S0,WHMIN**2)
14012 ZMIN = S0 / (SS**2 - PHEP(5,IHEP)**2 - PHEP(5,IHADIS)**2)
14013 ZMAX = ONE
14014 ELSE
14015C---UNKNOWN PROCESS: USE ENERGY CUTOFF, AND WARN USER
14016 IF (FSTWGT) CALL HWWARN('HWEGAM',1)
14017 ZMIN = EGMIN / PHEP(4,IHEP)
14018 ZMAX = ONE
14019 ENDIF
14020 ELSE
14021 ZMIN=ZMI
14022 ZMAX=ZMA
14023 ENDIF
14024C---APPLY USER DEFINED CUTS YWWMIN,YWWMAX AND INDIRECT LIMITS ON Z
14025 IF (.NOT.WWA) THEN
14026 ZMIN=MAX(ZMIN,YWWMIN,SQRT(Q2WWMN)/ABS(PHEP(3,IHEP)))
14027 ZMAX=MIN(ZMAX,YWWMAX)
14028 ELSE
14029 ZMAX=MIN(ZMAX,1-PHEP(5,IHEP)/PHEP(4,IHEP))
14030 ENDIF
14031 IF (ZMIN.GE.ZMAX) THEN
14032 GAMWT=ZERO
14033 RETURN
14034 ENDIF
14035C---GENERATE GAMMA MOMENTUM FRACTION
14036 A=HALF
14037 10 IF (HWRGEN(2).LT.A) THEN
14038 ZGAM=(ZMIN/ZMAX)**HWRGEN(1)*ZMAX
14039 ELSE
14040 ZGAM=(ZMAX-ZMIN)*HWRGEN(1)+ZMIN
14041 ENDIF
14042 GAMWT = GAMWT * .5*ALPHEM/PIFAC *
14043 + (1+(1-ZGAM)**2)/(A/LOG(ZMAX/ZMIN)+(1-A)/(ZMAX-ZMIN)*ZGAM)
14044 IF (WWA) THEN
14045 GAMWT = GAMWT * LOG((ONE-ZGAM)/ZGAM*(SS/PHEP(5,IHEP))**2)
14046 ELSE
14047C---Q2WWMN AND Q2WWMX ARE USER-DEFINED LIMITS IN THE Q**2 INTEGRATION
14048 QQMAX=MIN(Q2WWMX,(ZGAM*PHEP(3,IHEP))**2)
14049 QQMIN=MAX(Q2WWMN,(PHEP(5,IHEP)*ZGAM)**2/(1.-ZGAM))
14050 IF (QQMIN.GT.QQMAX) THEN
14051 CALL HWWARN('HWEGAM',50)
14052 GOTO 10
14053 ENDIF
14054 Q2=EXP(HWRUNI(0,LOG(QQMIN),LOG(QQMAX)))
14055 GAMWT = GAMWT * LOG(QQMAX/QQMIN)
14056 ENDIF
14057 IF (GAMWT.LT.ZERO) GAMWT=ZERO
14058C---FILL PHOTON
14059 NHEP=NHEP+1
14060 IDHW(NHEP)=59
14061 ISTHEP(NHEP)=3
14062 IDHEP(NHEP)=22
14063 JMOHEP(1,NHEP)=IHEP
14064 JMOHEP(2,NHEP)=0
14065 JDAHEP(1,NHEP)=0
14066 JDAHEP(2,NHEP)=0
14067 JDAHEP(1,IHEP)=NHEP
14068 IF (WWA) THEN
14069C---FOR COLLINEAR KINEMATICS, ZGAM IS THE ENERGY FRACTION
14070 PHEP(4,NHEP)=PHEP(4,IHEP)*ZGAM
14071 PHEP(3,NHEP)=PHEP(3,IHEP)-SIGN(SQRT(
14072 & (PHEP(4,IHEP)-PHEP(4,NHEP))**2-PHEP(5,IHEP)**2),PHEP(3,IHEP))
14073 PHEP(2,NHEP)=0
14074 PHEP(1,NHEP)=0
14075 CALL HWUMAS(PHEP(1,NHEP))
14076 ELSE
14077C---FOR EXACT KINEMATICS, ZGAM IS TAKEN TO BE FRACTION OF (E+PZ)
14078 PPL=ZGAM*(ABS(PHEP(3,IHEP))+PHEP(4,IHEP))
14079 QT2=(ONE-ZGAM)*Q2-(ZGAM*PHEP(5,IHEP))**2
14080 PMI=(QT2-Q2)/PPL
14081 PHEP(5,NHEP)=-SQRT(Q2)
14082 PHEP(4,NHEP)=(PPL+PMI)/TWO
14083 PHEP(3,NHEP)=SIGN((PPL-PMI)/TWO,PHEP(3,IHEP))
14084 CALL HWRAZM(SQRT(QT2),PHEP(1,NHEP),PHEP(2,NHEP))
14085 ENDIF
14086C---UPDATE OVERALL CM FRAME
14087 JMOHEP(IHEP,3)=NHEP
14088 CALL HWVDIF(4,PHEP(1,3),PHEP(1,IHEP),PHEP(1,3))
14089 CALL HWVSUM(4,PHEP(1,NHEP),PHEP(1,3),PHEP(1,3))
14090 CALL HWUMAS(PHEP(1,3))
14091C---FILL OUTGOING LEPTON
14092 NHEP=NHEP+1
14093 IDHW(NHEP)=IDHW(IHEP)
14094 ISTHEP(NHEP)=1
14095 IDHEP(NHEP)=IDHEP(IHEP)
14096 JMOHEP(1,NHEP)=IHEP
14097 JMOHEP(2,NHEP)=0
14098 JDAHEP(1,NHEP)=0
14099 JDAHEP(2,NHEP)=0
14100 JDAHEP(2,IHEP)=NHEP
14101 CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,NHEP-1),PHEP(1,NHEP))
14102 PHEP(5,NHEP)=PHEP(5,IHEP)
14103 END
14104CDECK ID>, HWEGAS.
14105*CMZ :- -18/04/04 10.45.55 by Mike Seymour
14106*-- Author : Bryan Webber & Luca Stanco
14107C-----------------------------------------------------------------------
14108 SUBROUTINE HWEGAS(S0)
14109C-----------------------------------------------------------------------
14110C FIND MINIMUM INVARIANT MASS SQUARED NEEDED FOR HARD PROCESS, S0
14111C-----------------------------------------------------------------------
c63d70bc 14112 INCLUDE 'herwig65.inc'
65767955 14113 DOUBLE PRECISION S0,RPM(2)
14114 INTEGER HQ,I
14115 IF (IPRO.EQ.13.OR.IPRO.EQ.14) THEN
14116 S0 = EMMIN**2
14117 ELSEIF(IPRO.EQ.15.OR.IPRO.EQ.18.OR.IPRO.EQ.22.OR.IPRO.EQ.24.OR.
14118 & IPRO.EQ.50.OR.IPRO.EQ.53.OR.IPRO.EQ.55)THEN
14119 S0 = 4.D0*PTMIN**2
14120 ELSEIF (IPRO.EQ.17.OR.IPRO.EQ.51) THEN
14121 HQ = MOD(IPROC,100)
14122 S0 = 4.D0*(PTMIN**2+RMASS(HQ)**2)
14123 ELSEIF (IPRO.EQ.16.OR.IPRO.EQ.19.OR.
14124 & IPRO.EQ.25.OR.IPRO.EQ.26.OR.IPRO.EQ.27.OR.
14125 & IPRO.EQ.95) THEN
14126 S0 = MAX(2*RMASS(1),RMASS(201)-GAMMAX*GAMH)**2
14127 ELSEIF ((IPRO.EQ.31).OR.(IPRO.EQ.32)) THEN
14128 S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
14129 ELSEIF (IPRO.EQ.33) THEN
14130 IF((MOD(IPROC,10000).EQ.3350).OR.
14131 & (MOD(IPROC,10000).EQ.3355))THEN
14132 S0 = MAX(2*RMASS(1),RMASS(206))**2
14133 ELSEIF(MOD(IPROC,10000).EQ.3315)THEN
14134 S0 = MAX(2*RMASS(1),RMASS(206),RMASS(203))**2
14135 ELSEIF(MOD(IPROC,10000).EQ.3325)THEN
14136 S0 = MAX(2*RMASS(1),RMASS(206),RMASS(204))**2
14137 ELSEIF(MOD(IPROC,10000).EQ.3335)THEN
14138 S0 = MAX(2*RMASS(1),RMASS(206),RMASS(205))**2
14139 ELSEIF(MOD(IPROC,10000).EQ.3365)THEN
14140 S0 = MAX(2*RMASS(1),RMASS(205),RMASS(203))**2
14141 ELSEIF(MOD(IPROC,10000).EQ.3375)THEN
14142 S0 = MAX(2*RMASS(1),RMASS(205),RMASS(204))**2
14143 ELSE
14144 S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
14145 END IF
14146 ELSEIF ((IPRO.EQ.34).OR.(IPRO.EQ.35)) THEN
14147 S0 = MAX(RMASS(5),RMASS(201+IHIGGS))**2
14148 ELSEIF (IPRO.EQ.36.OR.IPRO.EQ.37) THEN
14149 S0 = MAX(2*RMASS(1),RMASS(201+IHIGGS))**2
14150 ELSEIF (IPRO.EQ.38) THEN
14151 IF((MOD(IPROC,10000).EQ.3839).OR.
14152 & (MOD(IPROC,10000).EQ.3869).OR.
14153 & (MOD(IPROC,10000).EQ.3899))THEN
14154 S0 = MAX(RMASS(6),RMASS(206))**2
14155 ELSE
14156 S0 = RMASS(201+IHIGGS)**2
14157 END IF
14158 ELSEIF (IPRO.EQ.23) THEN
14159 S0 = MAX(2*RMASS(1),RMASS(201)-GAMMAX*GAMH)**2
14160 S0 = (PTMIN+SQRT(PTMIN**2+S0))**2
14161 ELSEIF (IPRO.EQ.20) THEN
14162 S0 = RMASS(6)**2
14163 ELSEIF (IPRO.EQ.21) THEN
14164 S0 = (PTMIN+SQRT(PTMIN**2+RMASS(198)**2))**2
14165C--PR MOD 7/7/99
14166 ELSEIF (IPRO.EQ.30) THEN
14167 S0 = 4.0D0*(PTMIN**2+RMMNSS**2)
14168 ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
14169 HQ = MOD(IPROC,100)
14170 RPM(1) = RMMNSS
14171 RPM(2) = ZERO
14172 IF(HQ.GE.10.AND.HQ.LT.20) THEN
14173 RPM(1) = ABS(RMASS(450))
14174 IF(HQ.GT.10) RPM(1) = ABS(RMASS(449+MOD(HQ,10)))
14175 ELSEIF(HQ.GE.20.AND.HQ.LT.30) THEN
14176 RPM(1) = ABS(RMASS(454))
14177 IF(HQ.GT.20) RPM(1) = ABS(RMASS(453+MOD(HQ,20)))
14178 ELSEIF(HQ.EQ.30) THEN
14179 RPM(1) = RMASS(449)
14180 ELSEIF(HQ.EQ.40) THEN
14181 IF(IPRO.EQ.40) THEN
14182 RPM(1) = RMASS(425)
14183 DO I=1,5
14184 RPM(1) = MIN(RPM(1),RMASS(425+I))
14185 ENDDO
14186 ELSE
14187 RPM(1) = MIN(RMASS(405),RMASS(406))
14188 ENDIF
14189 RPM(2) = RMASS(198)
14190 ELSEIF(HQ.EQ.50) THEN
14191 IF(IPRO.EQ.40) THEN
14192 RPM(1) = RMASS(425)
14193 DO I=1,5
14194 RPM(1) = MIN(RPM(1),RMASS(425+I))
14195 ENDDO
14196 DO I=1,3
14197 RPM(2) = MIN(RPM(1),RMASS(433+2*I))
14198 ENDDO
14199 RPM(1) = MIN(RPM(1),RPM(2))
14200 RPM(2) = RMASS(203)
14201 DO I=1,2
14202 RPM(2) = MIN(RPM(2),RMASS(204+I))
14203 ENDDO
14204 ELSE
14205 RPM(1) = RMASS(401)
14206 RPM(2) = RMASS(413)
14207 DO I=1,5
14208 RPM(1) = MIN(RPM(1),RMASS(401+I))
14209 RPM(2) = MIN(RPM(2),RMASS(413+I))
14210 ENDDO
14211 RPM(1) = MIN(RPM(1),RPM(2))
14212 RPM(2) = RMASS(203)
14213 DO I=1,2
14214 RPM(2) = MIN(RPM(2),RMASS(204+I))
14215 ENDDO
14216 ENDIF
14217 RPM(2) = RMASS(203)
14218 DO I=1,2
14219 RPM(2) = MIN(RPM(2),RMASS(204+I))
14220 ENDDO
14221 ELSEIF(HQ.GE.60) THEN
14222 RPM(1) = ZERO
14223 ENDIF
14224 RPM(1) = RPM(1)**2
14225 RPM(2) = RPM(2)**2
14226 S0 = RPM(1)+RPM(2)+TWO*(PTMIN**2+
14227 & SQRT(RPM(1)*RPM(2)+PTMIN**2*(RPM(1)+RPM(2)+PTMIN**2)))
14228C--end of mod
14229C--PR MOD 9/9/00
14230 ELSEIF (IPRO.EQ.42) THEN
14231 S0 = EMMIN**2
14232 ELSEIF (IPRO.EQ.52) THEN
14233 HQ = MOD(IPROC,100)
14234 S0 = (PTMIN+SQRT(PTMIN**2+RMASS(HQ)**2))**2
14235 ELSEIF (IPRO.EQ.60) THEN
14236 HQ = MOD(IPROC,100)
14237 IF (HQ.EQ.0) THEN
14238 S0 = 4.D0*PTMIN**2
14239 ELSE
14240 IF (HQ.GT.6) HQ=2*HQ+107
14241 IF (HQ.EQ.127) HQ=198
14242 S0 = 4.D0*(PTMIN**2+RMASS(HQ)**2)
14243 ENDIF
14244 ELSEIF (IPRO.EQ.80) THEN
14245 S0 = WHMIN**2
14246 ELSEIF (IPRO.EQ.90) THEN
14247 S0 = Q2MIN
14248 ELSEIF (IPRO.EQ.91.OR.IPRO.EQ.92) THEN
14249 S0 = Q2MIN+4.D0*PTMIN**2
14250 HQ = MOD(IPROC,100)
14251 IF (HQ.GT.0) S0 = S0+4.D0*RMASS(HQ)**2
14252 IF (IPRO.EQ.91) S0 = MAX(S0,EMMIN**2)
14253 ELSE
14254 S0 = 0
14255 ENDIF
14256 END
14257CDECK ID>, HWEINI.
14258*CMZ :- -26/04/91 12.42.30 by Federico Carminati
14259*-- Author : Bryan Webber
14260C-----------------------------------------------------------------------
14261 SUBROUTINE HWEINI
14262C-----------------------------------------------------------------------
14263C INITIALISES ELEMENTARY PROCESS
14264C Modified 28/03/01 by BRW to handle negative weights
14265C-----------------------------------------------------------------------
c63d70bc 14266 INCLUDE 'herwig65.inc'
65767955 14267 DOUBLE PRECISION HWRSET,DUMMY,SAFETY
14268 EXTERNAL HWRSET
14269 PARAMETER (SAFETY=1.001)
14270 INTEGER NBSH,I
14271C---NO OF WEIGHT GENERATED
14272 NWGTS=0
14273 NNEGWT=0
14274C---ACCUMULATED WEIGHTS
14275 WGTSUM=ZERO
14276 ABWSUM=ZERO
14277C---ACCUMULATED WEIGHT-SQUARED
14278 WSQSUM=ZERO
14279C---CURRENT MAX WEIGHT
14280 WBIGST=ZERO
14281C---LAST VALUE OF SCALE
14282 EMLST=ZERO
14283C---NUMBER OF ERRORS REPORTED
14284 NUMER=0
14285C---NUMBER OF ERRORS UNREPORTED
14286 NUMERU=0
14287C---FIND MAXIMUM ABSOLUTE WEIGHT IN CASES WHERE THIS IS REQUIRED
14288 IF (NOWGT) THEN
14289 IF (WGTMAX.EQ.ZERO.AND.IPROC.GT.0) THEN
14290 NBSH=IBSH
14291 DUMMY = HWRSET(IBRN)
14292 WRITE(6,10) IPROC,IBRN,NBSH
14293 10 FORMAT(/10X,'INITIAL SEARCH FOR MAX WEIGHT'//
14294 & 10X,'PROCESS CODE IPROC = ',I11/
14295 & 10X,'RANDOM NO. SEED 1 = ',I11/
14296 & 10X,' SEED 2 = ',I11/
14297 & 10X,'NUMBER OF SHOTS = ',I11)
14298 NEVHEP=0
14299 DO 11 I=1,NBSH
14300 CALL HWEPRO
14301 11 CONTINUE
14302 WRITE(6,20)
14303 20 FORMAT(/10X,'INITIAL SEARCH FINISHED')
14304 IF (WBIGST*NWGTS.LT.SAFETY*WGTSUM)
14305 & WGTMAX=SAFETY*WBIGST
14306 CALL HWEFIN
14307 NWGTS=0
14308 NNEGWT=0
14309 WGTSUM=ZERO
14310 WSQSUM=ZERO
14311 ABWSUM=ZERO
14312 WBIGST=ZERO
14313 ELSE
14314 WRITE(6,21) AVWGT,WGTMAX
14315 21 FORMAT(/1P,10X,'INPUT EVT WEIGHT =',E12.4/
14316 & 10X,'INPUT MAX WEIGHT =',E12.4)
14317 ENDIF
14318 ENDIF
14319C---RESET RANDOM NUMBER
14320 DUMMY = HWRSET(NRN)
14321 ISTAT=5
14322 END
14323CDECK ID>, HWEISR.
14324*CMZ :- -01/04/99 19.55.17 by Mike Seymour
14325*-- Author : Mike Seymour
14326C-----------------------------------------------------------------------
14327 SUBROUTINE HWEISR(IHEP)
14328C-----------------------------------------------------------------------
14329C GENERATES AN ISR PHOTON FROM INCOMING E+, E-, MU+ OR MU-
14330C-----------------------------------------------------------------------
c63d70bc 14331 INCLUDE 'herwig65.inc'
65767955 14332 DOUBLE PRECISION CIRCKP(2)
14333 COMMON /HWCIR2/CIRCKP
14334 DOUBLE PRECISION HWRGEN,QSQMAX,QSQMIN,A,B,B1,B2,B3,B4,B5,B6,B7,B8,
14335 $ R,AA,T0,T1,C1,C2,T,Z(2),QSQ(2),PHI(2),C,NWID,NMASS
14336 INTEGER IHEP,I,J
14337 EXTERNAL HWRGEN
14338 SAVE Z,QSQ,PHI
14339C---IF ZMXISR IS ZERO, THERE CAN BE NO ISR
14340 IF (ZMXISR.EQ.ZERO.OR.(IPRO.GT.3.AND.IPRO.LT.6)
14341 & .OR.IPRO.GT.12.OR.IPROC.EQ.850) RETURN
14342C---CHECK CONSISTENCY OF TMNISR AND ZMXISR
14343 IF (ZMXISR**2.LT.TMNISR) CALL HWWARN('HWEISR',200)
14344C---CALCULATE VIRTUALITY LIMITS
14345 QSQMAX=4*PHEP(4,IHEP)**2
14346 QSQMIN=PHEP(5,IHEP)**2
14347C---AND THEREFORE THE Z DEPENDENCE
14348 A=ALPHEM/PIFAC
14349 B=A*(LOG(QSQMAX/QSQMIN)-1)
14350C---DECIDE HOW MUCH WEIGHT TO GIVE THE Z RESONANCE
14351 IF (IHEP.EQ.1) THEN
14352 IF (IPRO.EQ.1.OR.IPRO.EQ.6.OR.IPRO.EQ.8) THEN
14353 AA=10
14354 ELSEIF (IPRO.EQ.2) THEN
14355 AA=0
14356 ELSEIF (IPRO.EQ.3.OR.IPRO.EQ.7.OR.IPRO.EQ.10.OR.IPRO.EQ.11) THEN
14357 AA=1
14358 ELSEIF (IPRO.EQ.9) THEN
14359 AA=0
14360 IF((MOD(IPROC,10000).EQ.960).OR.
14361 & (MOD(IPROC,10000).EQ.970))THEN
14362 AA=1
14363 ELSE
14364 CONTINUE
14365 ENDIF
14366 ELSE
14367 RETURN
14368 ENDIF
14369C--set up the parameters for the resonance
14370 IF(IPRO.NE.8) THEN
14371C--first the standard parameters if smoothing the Z resonance
14372 T0=RMASS(200)**2/QSQMAX
14373 T1=GAMZ*RMASS(200)/QSQMAX
14374 ELSE
14375C--now the parameters for a resonant sneutrino in RPV
14376C--uses the average of the muon and tau sneutrino mass and either the
14377C--larger width or the difference in masses (whichever is larger)
14378 NMASS = HALF*(RMASS(428)+RMASS(430))
14379 NWID = MAX(HBAR/RLTIM(428),HBAR/RLTIM(430))
14380 NWID = MAX(NWID,ABS(RMASS(428)-RMASS(430)))
14381 T0 = NMASS**2/QSQMAX
14382 T1 = NWID*NMASS/QSQMAX
14383 ENDIF
14384 IF (T0.GT.ONE) THEN
14385 T0=0
14386 AA=0
14387 ENDIF
14388 AA=AA*(1-T0)
14389C---GENERATE A T VALUE BETWEEN TMNISR AND 1 ACCORDING TO:
14390C ( b**2*log(zmxisr**2/t)/t + 2*b*(1-(1-zmxisr)**b)*((1-t)**(2*b-1)+1/t
14391C +(1-t0)**(2b-1)*aa*t1/((t-t0)**2+t1**2)) ) *theta(zmxisr**2-t)
14392C +( 2*b*(1-zmxisr)**b*((1-t)**(b-1)+1/t
14393C +(1-t0)**(b-1)*aa*t1/((t-t0)**2+t1**2)) ) *theta(zmxisr-t)
14394C +( (1-zmxisr)**(2*b) ) *delta(1-t)
14395 B1=(1-ZMXISR)**(2*B)
14396 B2=B1+2*(1-ZMXISR)**B*((1-TMNISR)**B-(1-ZMXISR)**B)
14397 B3=B2+2*B*(1-ZMXISR)**B*LOG(ZMXISR/TMNISR)
14398 B4=B3+2*B*(1-ZMXISR)**B*AA*(1-T0)**(B-1)
14399 $ *(ATAN((ZMXISR-T0)/T1)-ATAN((TMNISR-T0)/T1))
14400 B5=B4+(1-(1-ZMXISR)**B)*((1-TMNISR)**(2*B)-(1-ZMXISR**2)**(2*B))
14401 B6=B5+2*B*(1-(1-ZMXISR)**B)*LOG(ZMXISR**2/TMNISR)
14402 B7=B6+B**2*LOG(ZMXISR**2/TMNISR)**2/2
14403 B8=B7+2*B*(1-(1-ZMXISR)**B)*AA*(1-T0)**(2*B-1)
14404 $ *(ATAN((ZMXISR**2-T0)/T1)-ATAN((TMNISR-T0)/T1))
14405 R=B8*HWRGEN(0)
14406 IF (R.LE.B1) THEN
14407C---NEITHER EMITS
14408 T=1
14409 GAMWT=GAMWT*B8/B1
14410 Z(1)=1
14411 ELSEIF (R.LE.B4) THEN
14412C---ONE EMITS
14413 IF (R.LE.B2) THEN
14414 R=(R-B1)/(B2-B1)
14415 T=1-(1-TMNISR)*(1-R*(1-((1-ZMXISR)/(1-TMNISR))**B))**(1/B)
14416 ELSEIF (R.LE.B3) THEN
14417 R=(R-B2)/(B3-B2)
14418 T=(TMNISR/ZMXISR)**R*ZMXISR
14419 ELSE
14420 R=(R-B3)/(B4-B3)
14421 T=T0+T1*TAN(
14422 $ ATAN((ZMXISR-T0)/T1)*R+ATAN((TMNISR-T0)/T1)*(1-R))
14423 ENDIF
14424 GAMWT=GAMWT*B8/(2*B*(1-ZMXISR)**B*((1-T)**(B-1)+1/T+
14425 $ (1-T0)**(B-1)*AA*T1/((T-T0)**2+T1**2)))
14426 Z(1)=1
14427 IF (HWRGEN(1).GT.HALF) Z(1)=T
14428 GAMWT=GAMWT*2
14429 ELSE
14430C---BOTH EMIT
14431 IF (R.LE.B5) THEN
14432 R=(R-B4)/(B5-B4)
14433 T=1-(1-TMNISR)*
14434 $ (1-R*(1-((1-ZMXISR**2)/(1-TMNISR))**(2*B)))**(.5/B)
14435 ELSEIF (R.LE.B6) THEN
14436 R=(R-B5)/(B6-B5)
14437 T=(TMNISR/ZMXISR**2)**R*ZMXISR**2
14438 ELSEIF (R.LE.B7) THEN
14439 R=(R-B6)/(B7-B6)
14440 T=(TMNISR/ZMXISR**2)**SQRT(R)*ZMXISR**2
14441 ELSE
14442 R=(R-B7)/(B8-B7)
14443 T=T0+T1*TAN(
14444 $ ATAN((ZMXISR**2-T0)/T1)*R+ATAN((TMNISR-T0)/T1)*(1-R))
14445 ENDIF
14446 GAMWT=GAMWT*B8/(B**2*LOG(ZMXISR**2/T)/T
14447 $ + 2*B*(1-(1-ZMXISR)**B)*((1-T)**(2*B-1)+1/T+
14448 $ (1-T0)**(B-1)*AA*T1/((T-T0)**2+T1**2)))
14449C---GENERATE A Z VALUE BETWEEN T/ZMXISR AND ZMXISR ACCORDING TO:
14450C 1/z+(1-z)**(b-1)+t/z**2*(1-t/z)**(b-1)
14451 C1=LOG(ZMXISR**2/T)
14452 C2=C1+2/B*((1-T/ZMXISR)**B-(1-ZMXISR)**B)
14453 IF (C2.GT.ZERO) THEN
14454 R=C2*HWRGEN(4)
14455 IF (R.LE.C1) THEN
14456 Z(1)=(T/ZMXISR**2)**HWRGEN(5)*ZMXISR
14457 ELSE
14458 Z(1)=1-(1-T/ZMXISR)*
14459 $ (1-HWRGEN(6)*(1-((1-ZMXISR)/(1-T/ZMXISR))**B))**(1/B)
14460 IF (2*R.LE.C2+C1) Z(1)=T/Z(1)
14461 ENDIF
14462 ELSE
14463 Z(1)=SQRT(T)
14464 ENDIF
14465 GAMWT=GAMWT*C2/Z(1)
14466 $ /(1/Z(1)+(1-Z(1))**(B-1)+T/Z(1)**2*(1-T/Z(1))**(B-1))
14467 ENDIF
14468C---INCLUDE DISTRIBUTION FUNCTIONS
14469 Z(2)=T/Z(1)
14470 DO 10 I=1,2
14471 IF (Z(I).GT.ZMXISR) THEN
14472 Z(I)=1
14473 CIRCKP(I)=(1-ZMXISR)**B*EXP(3*B/4)*(1-B**2*PIFAC**2/12)
14474 ELSE
14475 CIRCKP(I)=(B*(1-Z(I))**(B-1)*(1+Z(I)**2)/2
14476 $ *EXP(B*Z(I)/2*(1+Z(I)/2))*(1-B**2*PIFAC**2/12)
14477 $ +B**2/8*((1+Z(I))*((1+Z(I))**2+3*LOG(Z(I)))
14478 $ -4*LOG(Z(I))/(1-Z(I))))
14479 ENDIF
14480 GAMWT=GAMWT*CIRCKP(I)
14481 10 CONTINUE
14482C---CHOOSE BOTH QSQ VALUES
14483 DO 30 I=1,2
14484 IF (Z(I).GT.ZMXISR .OR. COLISR) THEN
14485 QSQ(I)=0
14486 ELSE
14487 J=3-I
14488C---ACCORDING TO 1/(QSQ+QSQMIN) FROM 0 TO (1-Z)*(T/(Z+T))*QSQMAX
14489 20 QSQ(I)=(((1-Z(I))*(T/(Z(I)+T))
14490 $ *QSQMAX/QSQMIN+1)**HWRGEN(7)-1)*QSQMIN
14491C---AND REJECT TO QSQ/(QSQ+QSQMIN)**2
14492 IF (HWRGEN(8)*(QSQ(I)+QSQMIN).GT.QSQ(I)) GOTO 20
14493 ENDIF
14494 30 CONTINUE
14495C---CHOOSE BOTH AZIMUTHS
14496 PHI(1)=HWRGEN(9)*2*PIFAC
14497 PHI(2)=HWRGEN(10)*2*PIFAC
14498C---USE S-HAT PRESCRIPTION TO MODIFY Z VALUES
14499 I=0
14500 IF ((1-Z(1))*QSQ(1).GT.(1-Z(2))*QSQ(2)) I=1
14501 IF ((1-Z(2))*QSQ(2).GT.(1-Z(1))*QSQ(1)) I=2
14502 IF (I.GT.0) THEN
14503 J=3-I
14504 Z(I)=Z(I)+QSQ(I)/QSQMAX
14505 IF (QSQ(J).GT.ZERO) THEN
14506 Z(J)=((QSQ(I)*QSQMAX+QSQ(J)*QSQMAX
14507 $ -QSQ(I)*QSQ(J))/QSQMAX**2+T)/Z(I)
14508 C=COS(PHI(1)-PHI(2))*SQRT(QSQ(1)*QSQ(2))/QSQMAX
14509 Z(J)=Z(J)+(-2*C**2*(1-Z(I))+2*C*SQRT((1-Z(I))
14510 $ *(C**2*(1-Z(I))+Z(I)**2*(1-Z(J)))))/Z(I)**2
14511 ENDIF
14512 ENDIF
14513 ELSEIF (IHEP.EQ.2) THEN
14514C---EVERYTHING WAS GENERATED LAST TIME
14515 ELSE
14516C---ROUTINE CALLED UNEXPECTEDLY
14517 CALL HWWARN('HWEISR',201)
14518 ENDIF
14519C---IF Z IS TOO LARGE THERE IS NO EMISSION
14520 IF (Z(IHEP).GT.ZMXISR) RETURN
14521C---PUT NEW LEPTON IN EVENT RECORD
14522 NHEP=NHEP+1
14523 IDHW(NHEP)=IDHW(IHEP)
14524 IDHEP(NHEP)=IDHEP(IHEP)
14525 ISTHEP(NHEP)=3
14526 JMOHEP(1,NHEP)=IHEP
14527 JMOHEP(2,NHEP)=0
14528 JDAHEP(1,NHEP)=0
14529 JDAHEP(2,NHEP)=0
14530 JDAHEP(1,IHEP)=NHEP
14531C---AND OUTGOING PHOTON
14532 NHEP=NHEP+1
14533 IDHW(NHEP)=59
14534 IDHEP(NHEP)=22
14535 ISTHEP(NHEP)=1
14536 JMOHEP(1,NHEP)=IHEP
14537 JMOHEP(2,NHEP)=0
14538 JDAHEP(1,NHEP)=0
14539 JDAHEP(2,NHEP)=0
14540 JDAHEP(2,IHEP)=NHEP
14541C---RECONSTRUCT PHOTON KINEMATICS (Z IS LIGHT-CONE MOMENTUM FRACTION)
14542 PHEP(1,NHEP)=SQRT(QSQ(IHEP)*(1-Z(IHEP)))*COS(PHI(IHEP))
14543 PHEP(2,NHEP)=SQRT(QSQ(IHEP)*(1-Z(IHEP)))*SIN(PHI(IHEP))
14544 PHEP(3,NHEP)=(1-Z(IHEP))*PHEP(4,IHEP)-QSQ(IHEP)/(4*PHEP(4,IHEP))
14545 IF (IHEP.EQ.2) PHEP(3,NHEP)=-PHEP(3,NHEP)
14546 PHEP(4,NHEP)=(1-Z(IHEP))*PHEP(4,IHEP)+QSQ(IHEP)/(4*PHEP(4,IHEP))
14547 PHEP(5,NHEP)=0
14548C---AND LEPTON
14549 CALL HWVDIF(4,PHEP(1,IHEP),PHEP(1,NHEP),PHEP(1,NHEP-1))
14550 CALL HWUMAS(PHEP(1,NHEP-1))
14551C---UPDATE OVERALL CM FRAME
14552 JMOHEP(IHEP,3)=NHEP-1
14553 CALL HWVDIF(4,PHEP(1,3),PHEP(1,IHEP),PHEP(1,3))
14554 CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,3),PHEP(1,3))
14555 CALL HWUMAS(PHEP(1,3))
14556 END
14557CDECK ID>, HWEONE.
14558*CMZ :- -26/04/91 11.11.55 by Bryan Webber
14559*-- Author : Bryan Webber
14560C-----------------------------------------------------------------------
14561 SUBROUTINE HWEONE
14562C-----------------------------------------------------------------------
14563C SETS UP 2->1 (COLOUR SINGLET) HARD SUBPROCESS
14564C-----------------------------------------------------------------------
c63d70bc 14565 INCLUDE 'herwig65.inc'
65767955 14566 DOUBLE PRECISION PA
14567 INTEGER ICMF,I,IBM,IHEP
14568C---INCOMING LINES
14569 ICMF=NHEP+3
14570 DO 15 I=1,2
14571 IBM=I
14572C---FIND BEAM AND TARGET
14573 IF (JDAHEP(1,I).NE.0) IBM=JDAHEP(1,I)
14574 IHEP=NHEP+I
14575 IDHW(IHEP)=IDN(I)
14576 IDHEP(IHEP)=IDPDG(IDN(I))
14577 ISTHEP(IHEP)=110+I
14578 JMOHEP(1,IHEP)=ICMF
14579 JMOHEP(I,ICMF)=IHEP
14580 JDAHEP(1,IHEP)=ICMF
14581C---SPECIAL - IF INCOMING PARTON IS INCOMING BEAM THEN COPY IT
14582 IF (XX(I).EQ.ONE.AND.IDHW(IBM).EQ.IDN(I)) THEN
14583 CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,IHEP))
14584 IF (I.EQ.2) PHEP(3,IHEP)=-PHEP(3,IHEP)
14585 ELSE
14586 PHEP(1,IHEP)=0.
14587 PHEP(2,IHEP)=0.
14588 PHEP(5,IHEP)=RMASS(IDN(I))
14589 PA=XX(I)*(PHEP(4,IBM)+ABS(PHEP(3,IBM)))
14590 PHEP(4,IHEP)=0.5*(PA+PHEP(5,IHEP)**2/PA)
14591 PHEP(3,IHEP)=PA-PHEP(4,IHEP)
14592 ENDIF
14593 15 CONTINUE
14594 PHEP(3,NHEP+2)=-PHEP(3,NHEP+2)
14595C---HARD CENTRE OF MASS
14596 IDHW(ICMF)=IDCMF
14597 IDHEP(ICMF)=IDPDG(IDCMF)
14598 ISTHEP(ICMF)=110
14599 CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
14600 CALL HWUMAS(PHEP(1,ICMF))
14601C---SET UP COLOUR STRUCTURE LABELS
14602 JMOHEP(2,NHEP+1)=NHEP+2
14603 JDAHEP(2,NHEP+1)=NHEP+2
14604 JMOHEP(2,NHEP+2)=NHEP+1
14605 JDAHEP(2,NHEP+2)=NHEP+1
14606 JDAHEP(1,NHEP+3)=NHEP+3
14607 JDAHEP(2,NHEP+3)=NHEP+3
14608 NHEP=NHEP+3
14609 END
14610CDECK ID>, HWEPRO.
14611*CMZ :- -15/07/02 17.56.53 by Peter Richardson
14612*-- Author : Bryan Webber
14613C-----------------------------------------------------------------------
14614 SUBROUTINE HWEPRO
14615C-----------------------------------------------------------------------
14616C WHEN NEVHEP=0, CHOOSES X VALUES AND FINDS WEIGHT FOR PROCESS IPROC
14617C OTHERWISE, CHOOSES AND LOADS ALL VARIABLES FOR HARD PROCESS
14618C modifications for Les Houches accord by PR (7/15/02)
14619C-----------------------------------------------------------------------
c63d70bc 14620 INCLUDE 'herwig65.inc'
65767955 14621 DOUBLE PRECISION CIRCKP(2)
14622 COMMON /HWCIR2/CIRCKP
14623 DOUBLE PRECISION Z1,Z2,C1,C2,B1,B2,CIRCEE,CIRCGG,RS,MISS,ETA,
14624 $ HWUGAU,HWECIR,QMX1,QMN1,QMX2,QMN2,TEST
14625 INTEGER IHAD
14626 SAVE MISS
14627 DOUBLE PRECISION HWRGEN
14628 EXTERNAL HWRGEN,HWECIR
14629C--Les Houches Common Block
14630 INTEGER MAXPUP
14631 PARAMETER(MAXPUP=100)
14632 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
14633 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
14634 COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
14635 & IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
14636 & XMAXUP(MAXPUP),LPRUP(MAXPUP)
14637 IF (IERROR.NE.0) RETURN
14638C--pick the type of event to generate if using Les Houches accord
14639C--first choice according to maxiumum weight
14640 IF(IPROC.LT.0) THEN
14641 IF(ABS(IDWTUP).EQ.1) THEN
14642 IF(ITYPLH.EQ.0) THEN
14643 TEST = HWRGEN(1)*LHMXSM
14644 DO ITYPLH=1,NPRUP
14645 IF(TEST.LE.ABS(LHXMAX(ITYPLH))) GOTO 5
14646 TEST = TEST-ABS(LHXMAX(ITYPLH))
14647 ENDDO
14648 5 WGTMAX = ABS(LHXMAX(ITYPLH))
14649 WBIGST = ABS(LHXMAX(ITYPLH))
14650 ENDIF
14651C--second choice according to cross section
14652 ELSEIF(ABS(IDWTUP).EQ.2) THEN
14653 IF(ITYPLH.EQ.0) THEN
14654 TEST = HWRGEN(1)*LHMXSM
14655 DO ITYPLH=1,NPRUP
14656 IF(TEST.LE.ABS(LHXSCT(ITYPLH))) GOTO 6
14657 TEST = TEST-ABS(LHXSCT(ITYPLH))
14658 ENDDO
14659 6 WGTMAX = ABS(LHXMAX(ITYPLH))
14660 WBIGST = ABS(LHXMAX(ITYPLH))
14661 ENDIF
14662 ELSE
14663 WGTMAX = 1.0D0
14664 WBIGST = 1.0D0
14665 ITYPLH = 1
14666 ENDIF
14667 ENDIF
14668C---ROUTINE LOOPS BACK TO HERE IF GENERATED WEIGHT WAS NOT ACCEPTED
14669 10 GENEV=.FALSE.
14670C---FSTWGT IS .TRUE. DURING FIRST CALL TO HARD PROCESS ROUTINE
14671 FSTWGT=NWGTS.EQ.0
14672C---FSTEVT IS .TRUE. THROUGHOUT THE FIRST EVENT
14673 FSTEVT=NEVHEP.EQ.1
14674C---SET COLOUR CORRECTION TO FALSE
14675 COLUPD = .FALSE.
14676 HRDCOL(1,1)=0
14677 HRDCOL(1,3)=0
14678C---SET UP INITIAL STATE
14679 NHEP=1
14680 ISTHEP(NHEP)=101
14681 PHEP(1,NHEP)=0.
14682 PHEP(2,NHEP)=0.
14683 PHEP(3,NHEP)=PBEAM1
14684 PHEP(4,NHEP)=EBEAM1
14685 PHEP(5,NHEP)=RMASS(IPART1)
14686 JMOHEP(1,NHEP)=0
14687 JMOHEP(2,NHEP)=0
14688 JDAHEP(1,NHEP)=0
14689 JDAHEP(2,NHEP)=0
14690 IDHW(NHEP)=IPART1
14691 IDHEP(NHEP)=IDPDG(IPART1)
14692 NHEP=NHEP+1
14693 ISTHEP(NHEP)=102
14694 PHEP(1,NHEP)=0.
14695 PHEP(2,NHEP)=0.
14696 PHEP(3,NHEP)=-PBEAM2
14697 PHEP(4,NHEP)=EBEAM2
14698 PHEP(5,NHEP)=RMASS(IPART2)
14699 JMOHEP(1,NHEP)=0
14700 JMOHEP(2,NHEP)=0
14701 JDAHEP(1,NHEP)=0
14702 JDAHEP(2,NHEP)=0
14703 IDHW(NHEP)=IPART2
14704 IDHEP(NHEP)=IDPDG(IPART2)
14705C---NEXT ENTRY IS OVERALL CM FRAME
14706 NHEP=NHEP+1
14707 IDHW(NHEP)=14
14708 IDHEP(NHEP)=0
14709 ISTHEP(NHEP)=103
14710 JMOHEP(1,NHEP)=NHEP-2
14711 JMOHEP(2,NHEP)=NHEP-1
14712 JDAHEP(1,NHEP)=0
14713 JDAHEP(2,NHEP)=0
14714 CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP-2),PHEP(1,NHEP))
14715 CALL HWUMAS(PHEP(1,NHEP))
14716C Select a primary interaction point
14717 IF (PIPSMR) THEN
14718 CALL HWRPIP
14719 ELSE
14720 CALL HWVZRO(4,VTXPIP)
14721 ENDIF
14722 CALL HWVEQU(3,VTXPIP,VHEP(1,NHEP))
14723 VHEP(4,NHEP)=0.0
14724C---GENERATE PHOTONS (WEIZSACKER-WILLIAMS APPROX)
14725C FOR HADRONIC PROCESSES WITH LEPTON BEAMS
14726 GAMWT=ONE
14727 IF (IPRO.GT.12.AND.IPRO.LT.90) THEN
14728 IF (CIRCOP.EQ.0) THEN
14729 IF (ABS(IDHEP(1)).EQ.11.OR.ABS(IDHEP(1)).EQ.13)
14730 & CALL HWEGAM(1,ZERO, ONE,.FALSE.)
14731 IF (ABS(IDHEP(2)).EQ.11.OR.ABS(IDHEP(2)).EQ.13)
14732 & CALL HWEGAM(2,ZERO, ONE,.FALSE.)
14733 ELSE
14734C---MODIFIED TO USE CIRCE FOR BEAMSTRAHLUNG EFFECTS
14735 IF (ABS(IDHEP(1)).NE.11.OR.IDHEP(1)+IDHEP(2).NE.0) STOP
14736 $ 'This version only works for e+e- annihilation'
14737 IF (FSTWGT) THEN
14738 RS=NINT(PHEP(5,3)*10)/1D1
14739 CALL CIRCES(ZERO,ZERO,RS,CIRCAC,CIRCVR,CIRCRV,CIRCCH)
14740 ENDIF
14741 CALL HWEGAM(1,ZERO, ONE,.TRUE.)
14742 CALL HWEGAM(2,ZERO, ONE,.TRUE.)
14743 Z1=PHEP(4,4)/PHEP(4,1)
14744 Z2=PHEP(4,6)/PHEP(4,2)
14745C---FACTORIZE THE DISTRIBUTIONS FROM CIRCE
14746 C1=CIRCGG(Z1,-1D0)/SQRT(CIRCGG(-1D0,-1D0))
14747 C2=CIRCGG(-1D0,Z2)/SQRT(CIRCGG(-1D0,-1D0))
14748C---REMOVE SPURIOUS WEIGHT GIVEN IN HWEGAM
14749 GAMWT=GAMWT/(.5*ALPHEM/PIFAC*(1+(1-Z1)**2)/Z1*
14750 $ LOG((ONE-Z1)/Z1*4*PHEP(4,1)*PHEP(4,2)/PHEP(5,1)**2))
14751 $ /(.5*ALPHEM/PIFAC*(1+(1-Z2)**2)/Z2*
14752 $ LOG((ONE-Z2)/Z2*4*PHEP(4,4)*PHEP(4,2)/PHEP(5,1)**2))
14753C---REPLACE IT BY THE SUM OF BEAM AND BREM STRAHLUNG
14754 QMX1=MIN(Q2WWMX,(Z1*PHEP(3,1))**2)
14755 QMN1=MAX(Q2WWMN,(PHEP(5,1)*Z1)**2/(1-Z1))
14756 QMX2=MIN(Q2WWMX,(Z2*PHEP(3,2))**2)
14757 QMN2=MAX(Q2WWMN,(PHEP(5,2)*Z2)**2/(1-Z2))
14758 B1=.5*ALPHEM/PIFAC*(1+(1-Z1)**2)/Z1*LOG(QMX1/QMN1)
14759 B2=.5*ALPHEM/PIFAC*(1+(1-Z2)**2)/Z2*LOG(QMX2/QMN2)
14760 IF (CIRCOP.EQ.1) THEN
14761 GAMWT=GAMWT*B1*B2
14762 ELSEIF (CIRCOP.EQ.2) THEN
14763 GAMWT=GAMWT*C1*C2
14764 ELSEIF (CIRCOP.EQ.3) THEN
14765 GAMWT=GAMWT*(C1+B1)*(C2+B2)
14766 ELSE
14767 STOP 'Illegal value of circop!'
14768 ENDIF
14769 ENDIF
14770 ELSEIF (IPRO.GE.90) THEN
14771 IF (CIRCOP.NE.0) STOP 'Circe not interfaced for DIS processes'
14772 IF (ABS(IDHEP(2)).EQ.11.OR.ABS(IDHEP(2)).EQ.13)
14773 & CALL HWEGAM(2,ZERO, ONE,.FALSE.)
14774 ENDIF
14775C---GENERATE ISR PHOTONS FOR LEPTONIC PROCESSES
14776 IF (IPRO.GT.0.AND.IPRO.LE.12) THEN
14777 IF (CIRCOP.EQ.0) THEN
14778 CALL HWEISR(1)
14779 CALL HWEISR(2)
14780 ELSE
14781C---MODIFIED TO USE CIRCE FOR BEAMSTRAHLUNG EFFECTS
14782 IF (ABS(IDHEP(1)).NE.11.OR.IDHEP(1)+IDHEP(2).NE.0) STOP
14783 $ 'This version only works for e+e- annihilation'
14784 IF (FSTWGT) THEN
14785 RS=NINT(PHEP(5,3)*10)/1D1
14786 CALL CIRCES(ZERO,ZERO,RS,CIRCAC,CIRCVR,CIRCRV,CIRCCH)
14787C---PRECALCULATE THE PART OF THE SPECTRUM MISSED BETWEEN ZMXISR AND 1
14788 ETA=0.6D0
14789 MISS=HWUGAU(HWECIR,1D-15**(1-ETA),(1-ZMXISR)**(1-ETA),1D-12)
14790 ENDIF
14791 COLISR=.TRUE.
14792 CALL HWEISR(1)
14793 CALL HWEISR(2)
14794 IHAD=1
14795 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
14796 Z1=PHEP(4,IHAD)/PHEP(4,1)
14797 IHAD=2
14798 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
14799 Z2=PHEP(4,IHAD)/PHEP(4,2)
14800C---FACTORIZE THE DISTRIBUTIONS FROM CIRCE
14801 C1=CIRCEE(Z1,-1D0)/SQRT(CIRCEE(-1D0,-1D0))
14802 C2=CIRCEE(-1D0,Z2)/SQRT(CIRCEE(-1D0,-1D0))
14803 IF (Z1.EQ.ONE) C1=C1+MISS
14804 IF (Z2.EQ.ONE) C2=C2+MISS
14805C---REMOVE WEIGHT GIVEN IN HWEISR
14806 B1=CIRCKP(1)
14807 B2=CIRCKP(2)
14808 GAMWT=GAMWT/(B1*B2)
14809C---REPLACE IT BY THE SUM OF BEAM AND BREM STRAHLUNG
14810 IF (CIRCOP.EQ.1) THEN
14811 GAMWT=GAMWT*B1*B2
14812 ELSEIF (CIRCOP.EQ.2) THEN
14813 GAMWT=GAMWT*C1*C2
14814 ELSEIF (CIRCOP.EQ.3) THEN
14815C---IN THE APPROXIMATION OF DOMINANCE BY THE DELTA-FUNCTION TERM
14816 IF (Z1.EQ.ONE) C1=C1-1
14817 IF (Z2.EQ.ONE) C2=C2-1
14818C---IF IT DOES NOT DOMINATE, ZMXISR SHOULD BE DECREASED
14819 IF (B1+C1.LT.ZERO) CALL HWWARN('HWEPRO',501)
14820 IF (B2+C2.LT.ZERO) CALL HWWARN('HWEPRO',502)
14821 GAMWT=GAMWT*(C1+B1)*(C2+B2)
14822 ELSE
14823 STOP 'Illegal value of circop!'
14824 ENDIF
14825 ENDIF
14826 ENDIF
14827C---IF USER LIMITS WERE TOO TIGHT, MIGHT NOT BE ANY PHASE-SPACE
14828 IF (GAMWT.LE.ZERO) GOTO 30
14829C---IF CMF HAS ACQUIRED A TRANSVERSE BOOST, OR USER REQUESTS IT ANYWAY,
14830C BOOST EVENT RECORD BACK TO CMF
14831 IF (PHEP(1,3)**2+PHEP(2,3)**2.GT.ZERO .OR. USECMF) CALL HWUBST(1)
14832C---ROUTINE LOOPS BACK TO HERE IF GENERATED WEIGHT WAS ACCEPTED
14833 20 CONTINUE
14834 IPRO=MOD(IPROC/100,100)
14835C---PROCESS GENERATED BY LES HOUCHES INTERFACE
14836 IF(IPRO.LE.0) THEN
14837 CALL HWHGUP
14838CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
14839 ELSEIF (IPRO.EQ.1) THEN
14840 IF (IPROC.LT.110.OR.IPROC.GE.120) THEN
14841C--- E+E- -> Q-QBAR OR L-LBAR
14842 CALL HWHEPA
14843 ELSE
14844C--- E+E- -> Q-QBAR-GLUON
14845 CALL HWHEPG
14846 ENDIF
14847 ELSEIF (IPRO.EQ.2) THEN
14848C--- E+E- -> W+ W-
14849 CALL HWHEWW
14850 ELSEIF (IPRO.EQ.3) THEN
14851C---E+E- -> Z H
14852 CALL HWHIGZ
14853 ELSEIF (IPRO.EQ.4) THEN
14854C---E+E- -> NUEB NUE H
14855 CALL HWHIGW
14856 ELSEIF (IPRO.EQ.5 .AND. IPROC.LT.550) THEN
14857C---EE -> EE GAMGAM -> EE FFBAR/WW
14858 CALL HWHEGG
14859 ELSEIF (IPRO.EQ.5) THEN
14860C---EE -> ENU GAMW -> ENU FF'BAR/WZ
14861 CALL HWHEGW
14862 ELSEIF (IPRO.EQ.6) THEN
14863C---EE -> FOUR JETS
14864 CALL HWH4JT
14865 ELSEIF(IPRO.EQ.7) THEN
14866C--EE -> SUSY PARTICLES(PAIR PRODUCTION)
14867 CALL HWHESP
14868 ELSEIF(IPRO.EQ.8) THEN
14869C--EE -> RPV SUSY PARTICLE PRODUCTION
14870 CALL HWHREP
14871 ELSEIF (IPRO.EQ.9) THEN
14872 IF((MOD(IPROC,10000).EQ.955).OR.
14873 & (MOD(IPROC,10000).EQ.965).OR.
14874 & (MOD(IPROC,10000).EQ.975))THEN
14875C---MSSM Higgs pair production in l+l-: H+ H- and A0 Higgs, Higgs=h0,H0.
14876 CALL HWHIHH
14877 ELSEIF((MOD(IPROC,10000).EQ.910).OR.
14878 & (MOD(IPROC,10000).EQ.920))THEN
14879C---MSSM scalar Higgs production from vector-vector fusion.
14880 CALL HWHIGW
14881 ELSEIF((MOD(IPROC,10000).EQ.960).OR.
14882 & (MOD(IPROC,10000).EQ.970))THEN
14883C---MSSM scalar Higgs production from Higgs-strahlung.
14884 CALL HWHIGZ
14885 END IF
14886 ELSEIF ((IPRO.EQ.10).OR.(IPRO.EQ.11)) THEN
14887C---SM/MSSM Higgs production with heavy quark flavours via e+e-.
14888 CALL HWHIGE
14889 ELSEIF (IPRO.EQ.13) THEN
14890C---GAMMA/Z0/Z' DRELL-YAN PROCESS
14891 CALL HWHDYP
14892 ELSEIF (IPRO.EQ.14) THEN
14893C---W+/- PRODUCTION VIA DRELL-YAN PROCESS
14894 CALL HWHWPR
14895 ELSEIF (IPRO.EQ.15) THEN
14896C---QCD HARD 2->2 PROCESSES
14897 CALL HWHQCD
14898 ELSEIF ((IPRO.EQ.16).OR.(IPRO.EQ.36)) THEN
14899C---SM/MSSM HIGGS PRODUCTION VIA QUARK/GLUON FUSION
14900 CALL HWHIGS
14901 ELSEIF (IPRO.EQ.17) THEN
14902C---QCD HEAVY FLAVOUR PRODUCTION
14903 CALL HWHHVY
14904 ELSEIF (IPRO.EQ.18) THEN
14905C---QCD DIRECT PHOTON + JET PRODUCTION
14906 CALL HWHPHO
14907 ELSEIF ((IPRO.EQ.19).OR.(IPRO.EQ.37)) THEN
14908C---SM/MSSM HIGGS PRODUCTION VIA W/Z FUSION
14909 CALL HWHIGW
14910 ELSEIF (IPRO.EQ.20) THEN
14911C---TOP PRODUCTION FROM W EXCHANGE
14912 CALL HWHWEX
14913 ELSEIF (IPRO.EQ.21) THEN
14914C---VECTOR BOSON + JET PRODUCTION
14915 CALL HWHV1J
14916 ELSEIF (IPRO.EQ.22) THEN
14917C QCD direct photon pair production
14918 CALL HWHPH2
14919 ELSEIF (IPRO.EQ.23) THEN
14920C QCD Higgs plus jet production
14921 CALL HWHIGJ
14922 ELSEIF (IPRO.EQ.24) THEN
14923C---COLOUR-SINGLET EXCHANGE
14924 CALL HWHSNG
14925 ELSEIF (IPRO.EQ.25) THEN
14926C---SM Higgs production with heavy quark flavours via qq and gg.
14927 CALL HWHIGQ
14928 ELSEIF ((IPRO.EQ.26).OR.(IPRO.EQ.27)) THEN
14929C---SM Higgs production with heavy gauge bosons via qq(').
14930 CALL HWHIGV
14931C---Gauge boson pair in hadron hadron
14932 ELSEIF (IPRO.EQ.28) THEN
14933 IF (MOD(IPROC,10000).LT.2850) THEN
14934 CALL HWHGBP
14935 ELSE
14936 CALL HWHVVJ
14937 ENDIF
14938C--Vector boson + two jets
14939 ELSEIF(IPRO.EQ.29) THEN
14940 CALL HWHV2J
14941 ELSEIF (IPRO.EQ.30) THEN
14942C---HADRON-HADRON SUSY PROCESSES
14943 CALL HWHSSP
14944 ELSEIF ((IPRO.EQ.31).OR.(IPRO.EQ.32)) THEN
14945C---MSSM charged/neutral Higgs production in association with squarks.
14946 CALL HWHISQ
14947 ELSEIF (IPRO.EQ.33) THEN
14948 IF(MOD(IPROC,10000).EQ.3350)THEN
14949C---MSSM charged Higgs production in association with W: W+H- + W-H+.
14950 CALL HWHIBK
14951 ELSEIF((MOD(IPROC,10000).EQ.3310).OR.
14952 & (MOD(IPROC,10000).EQ.3320).OR.
14953 & (MOD(IPROC,10000).EQ.3360).OR.
14954 & (MOD(IPROC,10000).EQ.3370))THEN
14955C---MSSM Higgs production with heavy gauge bosons via qq(').
14956 CALL HWHIGV
14957 ELSE
14958C---MSSM charged/neutral Higgs pair production.
14959 CALL HWHIGH
14960 END IF
14961 ELSEIF (IPRO.EQ.34) THEN
14962C---MSSM charged/neutral Higgs production via bg fusion.
14963 CALL HWHIBG
14964 ELSEIF (IPRO.EQ.35) THEN
14965C---MSSM charged Higgs production via bq fusion.
14966 CALL HWHIBQ
14967 ELSEIF (IPRO.EQ.38) THEN
14968C---MSSM charged/neutral Higgs production with heavy quarks via qq and gg.
14969 CALL HWHIGQ
14970 ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
14971C---HADRON-HADRON R-PARITY VIOLATING SUSY PROCESSES
14972 CALL HWHRSP
14973 ELSEIF (IPRO.EQ.42) THEN
14974C---SPIN-TWO RESONANCE
14975 CALL HWHGRV
14976 ELSEIF (IPRO.EQ.50) THEN
14977C Point-like photon two-jet production
14978 CALL HWHPPT
14979 ELSEIF (IPRO.EQ.51) THEN
14980C Point-like photon/QCD heavy flavour pair production
14981 CALL HWHPPH
14982 ELSEIF (IPRO.EQ.52) THEN
14983C Point-like photon/QCD heavy flavour single excitation
14984 CALL HWHPPE
14985 ELSEIF (IPRO.EQ.53) THEN
14986C Compton scattering of point-like photon and (anti)quark
14987 CALL HWHPQS
14988 ELSEIF (IPRO.EQ.55) THEN
14989C Point-like photon/higher twist meson production
14990 CALL HWHPPM
14991 ELSEIF (IPRO.EQ.60) THEN
14992C---QPM GAMMA-GAMMA-->QQBAR
14993 CALL HWHQPM
14994 ELSEIF (IPRO.GE.70.AND.IPRO.LE.79) THEN
14995C---BARYON-NUMBER VIOLATION, AND OTHER MULTI-W PRODUCTION PROCESSES
14996 CALL HVHBVI
14997 ELSEIF (IPRO.EQ.80) THEN
14998C---MINIMUM-BIAS: NO HARD SUBPROCESS
14999C FIND WEIGHT
15000 CALL HWMWGT
15001 ELSEIF (IPRO.EQ.90) THEN
15002C---DEEP INELASTIC
15003 CALL HWHDIS
15004 ELSEIF(IPRO.EQ.91) THEN
15005C---BOSON - GLUON(QUARK) FUSION --> ANTIQUARK(GLUON) + QUARK
15006 CALL HWHBGF
15007 ELSEIF(IPRO.EQ.92) THEN
15008C---DEEP INELASTIC WITH EXTRA JET: OBSOLETE PROCESS
15009 WRITE (6,40)
15010 40 FORMAT (1X,' IPROC=92** is no longer supported.'
15011 & /1X,' Please use IPROC=91** instead.')
15012 CALL HWWARN('HWEPRO',500)
15013 ELSEIF(IPRO.EQ.95) THEN
15014C---HIGGS PRODUCTION VIA W FUSION IN E P
15015 CALL HWHIGW
15016C !!!!!!!!! IPRO >=0 NOT USED BY LH INTERFACE
15017 ELSE
15018C---UNKNOWN PROCESS
15019 CALL HWWARN('HWEPRO',102)
15020 GOTO 999
15021 ENDIF
15022CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
15023C genev= false
15024 30 IF (GENEV) THEN
15025 IF (NOWGT) THEN
15026 IF (NEGWTS) THEN
15027 IF (EVWGT.LT.ZERO) THEN
15028 EVWGT=-AVABW
15029 ELSE
15030 EVWGT= AVABW
15031 ENDIF
15032 ELSE
15033 EVWGT=AVWGT
15034 ENDIF
15035 ENDIF
15036 ISTAT=10
15037C--New call spin correlation code if needed
15038 IF(SYSPIN.AND.(IPRO.EQ. 1.OR.IPRO.EQ.13.OR.IPRO.EQ.14.OR.
15039 & IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.20.OR.
15040 & IPRO.EQ. 7.OR.IPRO.EQ.30.OR.IPRO.EQ.40.OR.
15041 & IPRO.EQ.41.OR.IPRO.EQ.8)) CALL HWHSPN
15042C--generate additional photon radiation in top production
15043 IF(ITOPRD.EQ.1.AND.MOD(IPROC,10000).EQ.1706) CALL HWPHTT
15044 RETURN
15045 ELSE
15046C---IF AN EVENT IS CANCELLED BEFORE IT IS GENERATED, GIVE IT ZERO WEIGHT
15047 IF (IERROR.NE.0) THEN
15048 EVWGT=ZERO
15049 IERROR=0
15050 ENDIF
15051 EVWGT=EVWGT*GAMWT
15052 NWGTS=NWGTS+1
15053 ABWGT=ABS(EVWGT)
15054 IF (EVWGT.LT.ZERO) THEN
15055 IF (NEGWTS) THEN
15056 NNEGWT=NNEGWT+1
15057 ELSE
15058 IF (EVWGT.LT.-1.D-9) CALL HWWARN('HWEPRO',3)
15059 EVWGT=ZERO
15060 ABWGT=ZERO
15061 ENDIF
15062 ENDIF
15063 WGTSUM=WGTSUM+EVWGT
15064 WSQSUM=WSQSUM+EVWGT**2
15065 ABWSUM=ABWSUM+ABWGT
15066C--weight addition for Les Houches accord
15067 IF(IPROC.LE.0) THEN
15068 IF(ABS(IDWTUP).EQ.1) THEN
15069 LHWGT (ITYPLH) = LHWGT (ITYPLH)+EVWGT
15070 LHWGTS(ITYPLH) = LHWGTS(ITYPLH)+EVWGT**2
15071 LHIWGT(ITYPLH) = LHIWGT(ITYPLH)+1
15072 ENDIF
15073 ENDIF
15074 IF (ABWGT.GT.WBIGST) THEN
15075 WBIGST=ABWGT
15076 IF (NOWGT.AND.WBIGST.GT.WGTMAX) THEN
15077 IF (NEVHEP.NE.0) CALL HWWARN('HWEPRO',1)
15078 WGTMAX=WBIGST*1.1
15079 WRITE (6,99) WGTMAX
15080C--additional for Les Houche accord
15081 IF(IPROC.LE.0) THEN
15082 IF(ABS(IDWTUP).EQ.1)
15083 & LHMXSM = LHMXSM-LHXMAX(ITYPLH)+ABWGT
15084 LHXMAX(ITYPLH) = EVWGT
15085 ENDIF
15086 ENDIF
15087 ENDIF
15088 IF (NEVHEP.NE.0) THEN
15089C---LOW EFFICIENCY WARNINGS:
15090C WARN AT 10*EFFMIN, STOP AT EFFMIN
15091 IF (10*EFFMIN*NWGTS.GT.NEVHEP) THEN
15092 IF (EFFMIN*NWGTS.GT.NEVHEP) THEN
15093 WRITE (*,*) NWGTS
15094 CALL HWWARN('HWEPRO',200)
15095 ENDIF
15096 IF (EFFMIN.GT.ZERO) THEN
15097 IF (MOD(NWGTS,INT(10/EFFMIN)).EQ.0) THEN
15098 CALL HWWARN('HWEPRO',2)
15099 WRITE (6,98) WGTMAX
15100 ENDIF
15101 ENDIF
15102 ENDIF
15103 IF (NOWGT) THEN
15104 GENEV=ABWGT.GT.WGTMAX*HWRGEN(0)
15105 ELSE
15106 GENEV=ABWGT.NE.ZERO
15107 ENDIF
15108 IF (GENEV) GOTO 20
15109 GOTO 10
15110 ENDIF
15111 ENDIF
15112 98 FORMAT(10X,' MAXIMUM WEIGHT =',1PG24.16)
15113 99 FORMAT(10X,'NEW MAXIMUM WEIGHT =',1PG24.16)
15114 999 RETURN
15115 END
15116CDECK ID>, HWETWO.
15117*CMZ :- -26/04/91 11.11.55 by Bryan Webber
15118*-- Author : Bryan Webber
15119C-----------------------------------------------------------------------
15120 SUBROUTINE HWETWO(SMR3,SMR4)
15121C-----------------------------------------------------------------------
15122C SETS UP 2->2 HARD SUBPROCESS
15123c BRW change 18/8/04: BW smearing of mass i only if SMRi is true
15124C-----------------------------------------------------------------------
c63d70bc 15125 INCLUDE 'herwig65.inc'
65767955 15126 DOUBLE PRECISION HWUMBW,HWUPCM,PA,PCM
15127 INTEGER ICMF,IBM,I,J,K,IHEP,NTRY
15128 LOGICAL SMR3,SMR4
15129 EXTERNAL HWUPCM
15130C---INCOMING LINES
15131 ICMF=NHEP+3
15132 DO 15 I=1,2
15133 IBM=I
15134C---FIND BEAM AND TARGET
15135 IF (JDAHEP(1,I).NE.0) IBM=JDAHEP(1,I)
15136 IHEP=NHEP+I
15137 IDHW(IHEP)=IDN(I)
15138 IDHEP(IHEP)=IDPDG(IDN(I))
15139 ISTHEP(IHEP)=110+I
15140 JMOHEP(1,IHEP)=ICMF
15141 JMOHEP(I,ICMF)=IHEP
15142 JDAHEP(1,IHEP)=ICMF
15143C---SPECIAL - IF INCOMING PARTON IS INCOMING BEAM THEN COPY IT
15144 IF (XX(I).EQ.ONE.AND.IDHW(IBM).EQ.IDN(I)) THEN
15145 CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,IHEP))
15146 IF (I.EQ.2) PHEP(3,IHEP)=-PHEP(3,IHEP)
15147 ELSE
15148 PHEP(1,IHEP)=0.
15149 PHEP(2,IHEP)=0.
15150 PHEP(5,IHEP)=RMASS(IDN(I))
15151 PA=XX(I)*(PHEP(4,IBM)+ABS(PHEP(3,IBM)))
15152 PHEP(4,IHEP)=0.5*(PA+PHEP(5,IHEP)**2/PA)
15153 PHEP(3,IHEP)=PA-PHEP(4,IHEP)
15154 ENDIF
15155 15 CONTINUE
15156 PHEP(3,NHEP+2)=-PHEP(3,NHEP+2)
15157C---HARD CENTRE OF MASS
15158 IDHW(ICMF)=IDCMF
15159 IDHEP(ICMF)=IDPDG(IDCMF)
15160 ISTHEP(ICMF)=110
15161 CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
15162 CALL HWUMAS(PHEP(1,ICMF))
15163C---OUTGOING LINES
15164 NTRY=0
15165 DO 16 I=3,4
15166 IHEP=NHEP+I+1
15167 IDHW(IHEP)=IDN(I)
15168 IDHEP(IHEP)=IDPDG(IDN(I))
15169 ISTHEP(IHEP)=110+I
15170 JMOHEP(1,IHEP)=ICMF
15171 16 JDAHEP(I-2,ICMF)=IHEP
15172 19 CONTINUE
15173 IF (SMR3) THEN
15174 PHEP(5,NHEP+4)=HWUMBW(IDN(3))
15175 ELSE
15176 PHEP(5,NHEP+4)=RMASS(IDN(3))
15177 ENDIF
15178 IF (SMR4) THEN
15179 PHEP(5,NHEP+5)=HWUMBW(IDN(4))
15180 ELSE
15181 PHEP(5,NHEP+5)=RMASS(IDN(4))
15182 ENDIF
15183 PCM=HWUPCM(PHEP(5,NHEP+3),PHEP(5,NHEP+4),PHEP(5,NHEP+5))
15184 IF (PCM.LT.ZERO) THEN
15185 NTRY=NTRY+1
15186 IF (NTRY.LE.NETRY) GO TO 19
15187 CALL HWWARN('HWETWO',103)
15188 GOTO 999
15189 ENDIF
15190 IHEP=NHEP+4
15191 PHEP(4,IHEP)=SQRT(PCM**2+PHEP(5,IHEP)**2)
15192 PHEP(3,IHEP)=PCM*COSTH
15193 PHEP(1,IHEP)=SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
15194 CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
15195 CALL HWULOB(PHEP(1,NHEP+3),PHEP(1,IHEP),PHEP(1,IHEP))
15196 CALL HWVDIF(4,PHEP(1,NHEP+3),PHEP(1,IHEP),PHEP(1,NHEP+5))
15197C---SET UP COLOUR STRUCTURE LABELS
15198 DO 30 I=1,4
15199 J=I
15200 IF (J.GT.2) J=J+1
15201 K=ICO(I)
15202 IF (K.GT.2) K=K+1
15203 JMOHEP(2,NHEP+J)=NHEP+K
15204 30 JDAHEP(2,NHEP+K)=NHEP+J
15205 NHEP=NHEP+5
15206 999 RETURN
15207 END
15208CDECK ID>, HWH2BK.
15209*CMZ :- -26/11/00 17.21.55 by Bryan Webber
15210*-- Author : Stefano Moretti
15211C-----------------------------------------------------------------------
15212 SUBROUTINE HWH2BK(P1,P2,P3,P4,RMW,RMH,RES,RESL,REST)
15213C-----------------------------------------------------------------------
15214C...Matrix element for q(1) + q-bar(2) -> W+/-(3) + H-/+(4),
15215C...all masses retained.
15216C...It factorises (PIFAC*ALPHA/SWEIN/RMW/RMW/SQRT(2.))**2
15217C
15218C...First release: 1-APR-1998 by Stefano Moretti
15219C-----------------------------------------------------------------------
c63d70bc 15220 INCLUDE 'herwig65.inc'
65767955 15221 INTEGER I
15222 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
15223 DOUBLE PRECISION P(0:3)
15224 DOUBLE PRECISION RES,S,T,U,MB2,MT2,MW2,MHP2,MH02,MA02,MSH2,
15225 & MGAMH0,MGAMA0,MGAMSH,PT,NC,KT2,RESL,REST
15226 DOUBLE PRECISION TT,UU,KKT2,TL
15227 DOUBLE COMPLEX Z,PV,PA
15228 DOUBLE PRECISION RMB,RMT,RMW,RMH
15229 DOUBLE PRECISION RMH01,GAMH01,
15230 & RMH02,GAMH02,
15231 & RMH03,GAMH03
15232 DOUBLE PRECISION VP,CFC
15233 EQUIVALENCE (RMB ,RMASS( 5)),(RMT ,RMASS( 6))
15234 EQUIVALENCE (RMH01,RMASS(204)),
15235 & (RMH02,RMASS(203)),
15236 & (RMH03,RMASS(205))
15237 PARAMETER (Z=(0D0,1D0),NC=3)
15238C...Higgs widths.
15239 GAMH01=RMASS(204)/DKLTM(204)
15240 GAMH02=RMASS(203)/DKLTM(203)
15241 GAMH03=RMASS(205)/DKLTM(205)
15242C...constant terms.
15243 MB2=RMB*RMB
15244 MT2=RMT*RMT
15245 MW2=RMW*RMW
15246 MHP2=RMH *RMH
15247 MH02=RMH01*RMH01
15248 MA02=RMH03*RMH03
15249 MSH2=RMH02*RMH02
15250 MGAMH0=RMH01*GAMH01
15251 MGAMA0=RMH03*GAMH03
15252 MGAMSH=RMH02*GAMH02
15253C...Mandelstam invariants.
15254 S=(P1(0)+P2(0))**2
15255 T=(P1(0)-P3(0))**2
15256 U=(P1(0)-P4(0))**2
15257 DO I=1,3
15258 S=S-(P1(I)+P2(I))**2
15259 T=T-(P1(I)-P3(I))**2
15260 U=U-(P1(I)-P4(I))**2
15261 END DO
15262C...propagators and couplings.
15263 PV=(-SINA*COSBMA/(S-MSH2+Z*MGAMSH)
15264 & -COSA*SINBMA/(S-MH02+Z*MGAMH0) )/COSB
15265 PA= TANB/(S-MA02+Z*MGAMA0)
15266 PT= 1./(T-MT2)
15267 KT2=(U*T-MHP2*MW2)/S
15268C...Total ME.
15269 RES=S/NC*( MB2/2.*((S-MW2-MHP2)**2-4.*MW2*MHP2)*
15270 & DREAL(DCONJG(PV)*PV+DCONJG(PA)*PA)+
15271 & MB2*TANB*PT*(MW2*MHP2-S*KT2-T**2)*DREAL(PV-PA)+
15272 & PT**2*((MT2/TANB)**2*(2.*MW2+KT2)
15273 & +MB2*TANB**2*(2.*MW2*KT2+T**2)))
15274 & *2.
15275C...Extracts spin dependence.
15276 VP=SQRT(P3(1)**2+P3(2)**2+P3(3)**2)
15277 CFC=P3(0)/VP
15278 DO I=1,3
15279 P(I)=P3(I)*CFC
15280 END DO
15281 P(0)=VP**2/P3(0)*CFC
15282 TT=(P1(0)-P(0))**2
15283 UU=(P2(0)-P(0))**2
15284 DO I=1,3
15285 TT=TT-(P1(I)-P(I))**2
15286 UU=UU-(P2(I)-P(I))**2
15287 END DO
15288 KKT2=((MW2+TT)*(MW2+UU)+(MW2+MHP2-T-U)*MW2)/S
15289 TL=((TT+MW2)*(UU+MW2)*((S+U-MW2)*(TT+MW2)/(UU+MW2)-T)
15290 & +MW2*((MW2-T)*(MW2-U)-S*MW2))/S
15291C...Longitudinal ME (along V direction).
15292 RESL=S/NC*(MB2/2.*((S-MW2-MHP2)**2-4.*MW2*MHP2)*
15293 & DREAL(DCONJG(PV)*PV+DCONJG(PA)*PA)+
15294 & MB2*TANB*PT*(MW2*MHP2-S*KT2-T**2)*DREAL(PV-PA)+
15295 & PT**2*((MT2/TANB)**2*(KKT2)
15296 & +MB2*TANB**2*(TL)))
15297 & *2.
15298C...Transverse ME (perpendicular to V direction).
15299 REST=RES-RESL
15300 END
15301CDECK ID>, HWH2DD.
15302*CMZ :- -27/02/01 17:04:16 by Peter Richardson
15303*-- Author : Peter Richardson
15304C-----------------------------------------------------------------------
15305 FUNCTION HWH2DD(ND,I,J,K,L,Z1,Z2)
15306C-----------------------------------------------------------------------
15307C Returns the coefficient D1-10 from Nucl. Phys. B262 (1985) 235-262
15308C N.B. THE STRONG COUPLING AND GV+/-GA ARE INCLUDED IN THE CROSS
15309C SECTION ROUTINE
15310C I-L are the particles (all outgoing)
15311C Z1 and Z2 are the decay products of the Z
15312C-----------------------------------------------------------------------
c63d70bc 15313 INCLUDE 'herwig65.inc'
65767955 15314 INTEGER ND,I,J,K,L,Z1,Z2
15315 DOUBLE COMPLEX HWH2DD,ZI,S,D,F
15316 PARAMETER(ZI=(0.0D0,1.0D0))
15317 COMMON/HWHEWS/S(8,8,2),D(8,8)
15318 COMMON/HWHZBB/F(8,8)
15319 IF(ND.EQ.1) THEN
15320 HWH2DD = ZI
15321 ELSEIF(ND.EQ.2) THEN
15322 HWH2DD = ZI/F(J,K)/SQRT(TWO*D(I,K))
15323 ELSEIF(ND.EQ.3) THEN
15324 HWH2DD = -ZI/F(I,K)/SQRT(TWO*D(I,K))
15325 ELSEIF(ND.EQ.4) THEN
15326 HWH2DD = -ZI/F(K,L)/(F(Z1,I)+F(Z2,I)+F(Z1,Z2))
15327 ELSEIF(ND.EQ.5) THEN
15328 HWH2DD = ZI/F(K,L)/(F(Z1,J)+F(Z2,J)+F(Z1,Z2))
15329 ELSEIF(ND.EQ.6) THEN
15330 HWH2DD = ZI*HALF/F(J,L)/(F(J,L)+F(J,K)+F(K,L))/D(K,L)
15331 ELSEIF(ND.EQ.7) THEN
15332 HWH2DD = -ZI*HALF/F(I,K)/F(J,L)/D(K,L)
15333 ELSEIF(ND.EQ.8) THEN
15334 HWH2DD = ZI*HALF/F(I,K)/(F(I,K)+F(I,L)+F(K,L))/D(K,L)
15335 ELSEIF(ND.EQ.9) THEN
15336 HWH2DD = -ZI/F(K,L)/(F(J,K)+F(J,L)+F(K,L))
15337 ELSEIF(ND.EQ.10) THEN
15338 HWH2DD = ZI/F(K,L)/(F(I,K)+F(I,L)+F(K,L))
15339 ENDIF
15340 END
15341CDECK ID>, HWH2BH.
15342*CMZ :- -30/06/01 18.21.35 by Stefano Moretti
15343*-- Author : Kosuke Odagiri & Stefano Moretti
15344C-----------------------------------------------------------------------
15345 SUBROUTINE HWH2BH(P1,P2,P3,P4,P5,
15346 & EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,IFL,IRES,CKM,
15347 & GAMT,M2)
15348C-----------------------------------------------------------------------
15349C...Matrix element for b(1) + q(2) -> b(3) + q'(4) + H+/-(5) and C.C.,
15350C...q(q') massless incoming(outgoing) quark, all other masses retained.
15351C...It factorises 64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW.
15352C
15353C...First release: 01-APR-1998 by Kosuke Odagiri
15354C...First modified: 12-APR-1998 by Stefano Moretti
15355C-----------------------------------------------------------------------
c63d70bc 15356 INCLUDE 'herwig65.inc'
65767955 15357 INTEGER MU,IRES,IFL
15358 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
15359 DOUBLE PRECISION EMB,EMT,EMW,EMH,EMH01,EMH02,EMH03
15360 DOUBLE PRECISION GAMT,GAMWTMP,GAMH01,GAMH03,GAMH02,CKM
15361 DOUBLE PRECISION QW(0:3),QS(0:3)
15362 DOUBLE PRECISION N0,DOTHH,DOTSS,DOTWW,E1234
15363 DOUBLE PRECISION DOTTT,DOT12,DOT13,DOT14,DOT23
15364 DOUBLE PRECISION DOT24,DOT2H,DOT34,DOT3H,DOT4H
15365 DOUBLE PRECISION PT2,PV2,PA2
15366 DOUBLE PRECISION M2
15367 DOUBLE COMPLEX PV,PA,PT,PW,Z
15368 PARAMETER (GAMWTMP=0.D0,GAMH01=0.D0,GAMH03=0.D0,GAMH02=0.D0)
15369 PARAMETER (Z=(0.D0,1.D0))
15370 DOUBLE PRECISION SC,RICCI
15371 EXTERNAL SC,RICCI
15372C
15373 DO 670 MU=0,3
15374 QW(MU)=P2(MU)-P4(MU)
15375 QS(MU)=P1(MU)-P3(MU)
15376 670 CONTINUE
15377C
15378 DOTHH=EMH*EMH
15379 DOTSS=SC(QS,QS)
15380 DOTWW=SC(QW,QW)
15381 DOT13=EMB*EMB-DOTSS/2.D0
15382 DOT24=-DOTWW/2.D0
15383 DOT2H=SC(P2,P5)
15384 DOT4H=SC(P4,P5)
15385C
15386 IF(IFL.EQ.1)THEN
15387 DOT12=SC(P1,P2)
15388 DOT14=SC(P1,P4)
15389 DOT23=SC(P2,P3)
15390 DOT34=SC(P3,P4)
15391 DOT3H=SC(P3,P5)
15392 E1234=RICCI(P1,P2,P3,P4)
15393 ELSE IF(IFL.EQ.-1)THEN
15394 DOT12=-SC(P3,P2)
15395 DOT14=-SC(P3,P4)
15396 DOT23=-SC(P2,P1)
15397 DOT34=-SC(P1,P4)
15398 DOT3H=-SC(P1,P5)
15399 E1234=-RICCI(P1,P2,P3,P4)
15400 END IF
15401C
15402 DOTTT=DOTHH+EMB*EMB+2.D0*DOT3H
15403C
15404 PV=COSA*SINBMA/(DOTSS-EMH01*EMH01+Z*EMH01*GAMH01)+
15405 1 SINA*COSBMA/(DOTSS-EMH02*EMH02+Z*EMH02*GAMH02)
15406 PA=SINB/(DOTSS-EMH03*EMH03+Z*EMH03*GAMH03)
15407 PW=1./(DOTWW-EMW*EMW+Z*EMW*GAMWTMP)
15408C REMOVE TOP DIAGRAM.
15409 IF(IRES.EQ.1)PT=1./(DOTTT-EMT*EMT+Z*EMT*GAMT)
15410 IF(IRES.EQ.0)PT=(0.D0,0.D0)
15411 PT=PT*CKM
15412 PT2 =DREAL(DCONJG(PT)*PT)
15413 PV2 =DREAL(DCONJG(PV)*PV)
15414 PA2 =DREAL(DCONJG(PA)*PA)
15415C
15416 N0=ABS(PW)
15417C
15418 M2=N0*N0* ( EMB*EMB/COSB/COSB*(PV2+PA2)*DOT13*
15419 & (2.D0*DOT4H*DOT2H-DOT24*DOTHH)+
15420 T 2.D0*PT2*DOT12*
15421 O (EMB*EMB*TANB*TANB*(2.D0*DOT3H*DOT4H-DOT34*DOTHH)+
15422 P EMT*EMT/TANB/TANB*(EMT*EMT*DOT34))+
15423 & EMB*EMB*TANB/COSB*DREAL(PV+PA)*
15424 X (DREAL(PT)*(4.D0*DOT4H*DOT12*DOT13-
15425 T (2.D0*DOT4H+DOTHH)*(DOT12*DOT34+DOT13*DOT24-DOT14*DOT23))+
15426 M DIMAG(PT)*(2.D0*DOT4H+DOTHH)*E1234) )
15427 END
15428C
15429 DOUBLE PRECISION FUNCTION SC(A,B)
15430 IMPLICIT NONE
15431 DOUBLE PRECISION A(0:3),B(0:3)
15432 SC=A(0)*B(0)-A(1)*B(1)-A(2)*B(2)-A(3)*B(3)
15433 END
15434C
15435 DOUBLE PRECISION FUNCTION RICCI(A,B,C,D)
15436 IMPLICIT NONE
15437 DOUBLE PRECISION A(0:3),B(0:3),C(0:3),D(0:3)
15438 RICCI=
15439 & A(0)*B(1)*C(2)*D(3)+A(0)*B(2)*C(3)*D(1)+A(0)*B(3)*C(1)*D(2)-
15440 & A(0)*B(3)*C(2)*D(1)-A(0)*B(1)*C(3)*D(2)-A(0)*B(2)*C(1)*D(3)+
15441 & A(1)*B(0)*C(3)*D(2)+A(1)*B(2)*C(0)*D(3)+A(1)*B(3)*C(2)*D(0)-
15442 & A(1)*B(2)*C(3)*D(0)-A(1)*B(3)*C(0)*D(2)-A(1)*B(0)*C(2)*D(3)+
15443 & A(2)*B(3)*C(0)*D(1)+A(2)*B(0)*C(1)*D(3)+A(2)*B(1)*C(3)*D(0)-
15444 & A(2)*B(1)*C(0)*D(3)-A(2)*B(3)*C(1)*D(0)-A(2)*B(0)*C(3)*D(1)+
15445 & A(3)*B(2)*C(1)*D(0)+A(3)*B(0)*C(2)*D(1)+A(3)*B(1)*C(0)*D(2)-
15446 & A(3)*B(0)*C(1)*D(2)-A(3)*B(1)*C(2)*D(0)-A(3)*B(2)*C(0)*D(1)
15447 END
15448CDECK ID>, HWH2F1
15449*CMZ :- -27/02/01 17:04:16 by Peter Richardson
15450C-----------------------------------------------------------------------
15451 SUBROUTINE HWH2F1(NP,F,I,P,MQ)
15452C-----------------------------------------------------------------------
15453C Subroutine to implement the F function of Eijk and Kliess
15454C fixed first momenta and all second momenta
15455C-----------------------------------------------------------------------
c63d70bc 15456 INCLUDE 'herwig65.inc'
65767955 15457 DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS
15458 DOUBLE COMPLEX F(2,2,8),S,D,SIP(2),SJP(2)
15459 INTEGER I,J,NP
15460 EXTERNAL HWULDO
15461 COMMON/HWHEWS/S(8,8,2),D(8,8)
15462 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15463 PARAMETER(EPS=1D-10)
15464C--find the massless momentum we need
15465 PDOT = HWULDO(PCM(1,I),P)
15466 P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2
15467 IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN
15468 PDOT = HALF
15469 ELSE
15470 PDOT = HALF*P(5)/PDOT
15471 ENDIF
15472 DO J=1,4
15473 PM(J) = P(J)-PDOT*PCM(J,I)
15474 ENDDO
15475 IF(P(5).GT.ZERO) THEN
15476 P(5)=SQRT(P(5))
15477 ELSE
15478 P(5)=ZERO
15479 ENDIF
15480 PM(5) = ZERO
15481C--calculate its spinor product with the fixed momentum
15482 CALL HWH2SS(SIP,PCM(1,I),PM)
15483C--calculate the F functions
15484 DO J=1,NP
15485 CALL HWH2SS(SJP,PM,PCM(1,J))
15486 F(1,1,J) = SIP(1)*SJP(2)
15487 F(1,2,J) = MQ*S(I,J,1)
15488 F(2,1,J) = MQ*S(I,J,2)
15489 F(2,2,J) = SIP(2)*SJP(1)
15490 ENDDO
15491 END
15492CDECK ID>, HWH2F2
15493*CMZ :- -27/02/01 17:04:16 by Peter Richardson
15494C-----------------------------------------------------------------------
15495 SUBROUTINE HWH2F2(NP,F,I,P,MQ)
15496C-----------------------------------------------------------------------
15497C Subroutine to implement the F function of Eijk and Kliess
15498C fixed second momenta and all first momenta
15499C-----------------------------------------------------------------------
c63d70bc 15500 INCLUDE 'herwig65.inc'
65767955 15501 DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS
15502 DOUBLE COMPLEX F(2,2,8),S,D,SIP(2),SJP(2)
15503 INTEGER I,J,NP
15504 EXTERNAL HWULDO
15505 COMMON/HWHEWS/S(8,8,2),D(8,8)
15506 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15507 PARAMETER(EPS=1D-10)
15508C--find the massless momentum we need
15509 PDOT = HWULDO(PCM(1,I),P)
15510 P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2
15511 IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN
15512 PDOT = HALF
15513 ELSE
15514 PDOT = HALF*P(5)/PDOT
15515 ENDIF
15516 DO J=1,4
15517 PM(J) = P(J)-PDOT*PCM(J,I)
15518 ENDDO
15519 IF(P(5).GT.ZERO) THEN
15520 P(5)=SQRT(P(5))
15521 ELSE
15522 P(5)=ZERO
15523 ENDIF
15524 PM(5) = ZERO
15525C--calculate its spinor product with the fixed momentum
15526 CALL HWH2SS(SIP,PM,PCM(1,I))
15527C--calculate the F functions
15528 DO J=1,NP
15529 CALL HWH2SS(SJP,PCM(1,J),PM)
15530 F(1,1,J) = SIP(2)*SJP(1)
15531 F(1,2,J) = MQ*S(J,I,1)
15532 F(2,1,J) = MQ*S(J,I,2)
15533 F(2,2,J) = SIP(1)*SJP(2)
15534 ENDDO
15535 END
15536CDECK ID>, HWH2F3
15537*CMZ :- -27/02/01 17:04:16 by Peter Richardson
15538C-----------------------------------------------------------------------
15539 SUBROUTINE HWH2F3(NP,F,P,MQ)
15540C-----------------------------------------------------------------------
15541C Subroutine to implement the F function of Eijk and Kliess
15542C All first and second momenta
15543C-----------------------------------------------------------------------
c63d70bc 15544 INCLUDE 'herwig65.inc'
65767955 15545 DOUBLE PRECISION P(5),MQ,PM(5),XMASS,PLAB,PRW,PCM,HWULDO,PDOT,EPS
15546 DOUBLE COMPLEX F(2,2,8,8),SIP(2),SJP(2),S,D
15547 INTEGER I,J,NP
15548 COMMON/HWHEWS/S(8,8,2),D(8,8)
15549 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15550 EXTERNAL HWULDO
15551 PARAMETER(EPS=1D-10)
15552C--find the massless momentum we need
15553 DO I=1,NP
15554 PDOT = HWULDO(PCM(1,I),P)
15555 P(5) = P(4)**2-P(1)**2-P(2)**2-P(3)**2
15556 IF(ABS(PDOT).LT.EPS.AND.ABS(P(5)).LT.EPS) THEN
15557 PDOT = HALF
15558 ELSE
15559 PDOT = HALF*P(5)/PDOT
15560 ENDIF
15561 DO J=1,4
15562 PM(J) = P(J)-PDOT*PCM(J,I)
15563 ENDDO
15564 IF(P(5).GT.ZERO) THEN
15565 P(5)=SQRT(P(5))
15566 ELSE
15567 P(5)=ZERO
15568 ENDIF
15569 PM(5) = ZERO
15570C--calculate its spinor product with the fixed momentum
15571 CALL HWH2SS(SIP,PCM(1,I),PM)
15572C--calculate the F functions
15573 DO J=I,NP
15574 CALL HWH2SS(SJP,PM,PCM(1,J))
15575 F(1,1,I,J) = SIP(1)*SJP(2)
15576 F(1,2,I,J) = MQ*S(I,J,1)
15577 F(2,1,I,J) = MQ*S(I,J,2)
15578 F(2,2,I,J) = SIP(2)*SJP(1)
15579 ENDDO
15580 ENDDO
15581 DO I=1,NP
15582 DO J=I+1,NP
15583 F(1,1,J,I) = F(2,2,I,J)
15584 F(1,2,J,I) = -F(1,2,I,J)
15585 F(2,1,J,I) = -F(2,1,I,J)
15586 F(2,2,J,I) = F(1,1,I,J)
15587 ENDDO
15588 ENDDO
15589 END
15590CDECK ID>, HWH2HE.
15591*CMZ :- -13/10/02 09.43.05 by Peter Richardson
15592*-- Author : Kosuke Odagiri and Stefano Moretti
15593C-----------------------------------------------------------------------
15594 SUBROUTINE HWH2HE(FIRST,GAUGE,IFL,IH,HFC,HBC,
15595 & E,S2W,TANB,AL,RMW,S,Q3, P3,P4,P5,
15596 & RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,
15597 & RML,GAML,RMH,GAMH,RMA,GAMA,
15598 & RMZ,GAMZ,CFAC,RES)
15599C-----------------------------------------------------------------------
15600C MATRIX ELEMENT SQUARED FOR
15601C e-(1) e+(2) -> f(3) f(')bar(4) Higgs(5)
15602C (SAME QUARK MASSES IN YUKAWA AND KINEMATICS)
15603C-----------------------------------------------------------------------
15604 IMPLICIT NONE
15605 LOGICAL FIRST,GAUGE
15606 DOUBLE PRECISION HFC,HBC
15607 DOUBLE PRECISION CFAC
15608 DOUBLE PRECISION E,S2W,TANB,AL,RMW,S,Q3,RES
15609 DOUBLE PRECISION P3(0:3),P4(0:3),P5(0:3)
15610 DOUBLE PRECISION RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,RMZ,GAMZ
15611 DOUBLE PRECISION RML,GAML,RMH,GAMH,RMA,GAMA,Q2
15612 DOUBLE PRECISION XW,GE(-1:1),G3(-1:1),G4(-1:1),G5(-1:1)
15613 DOUBLE PRECISION RM(-1:1),RN1(-1:1),RN2(-1:1),RN3
15614 DOUBLE PRECISION SQS,TWOSQS,HLFSQS,P34,M34,PREFAC
15615 DOUBLE PRECISION RLE,RLLE,EP3(-1:1),EP4(-1:1),ZERO,ONE,TWO,HLF
15616 DOUBLE PRECISION BE,SA,CA,SB,CB
15617 INTEGER I,LE,L,IFL,IH
15618 DOUBLE COMPLEX PROPZ,PROP3(-1:1),PROP4(-1:1),PROP5,PROP6
15619 DOUBLE COMPLEX PROP7(-1:1)
15620 DOUBLE COMPLEX PP(-1:1),MM(-1:1),QQ(-1:1),ZP3,ZP4,ZP5
15621 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,HLF=.5D0)
15622 SAVE XW,GE,G3,G4,G5,RM,PREFAC
15623C QUANTITIES WHICH CAN BE COMPUTED ONLY ONCE
15624 IF(FIRST)THEN
15625C SOME COMMON INITIALISATIONS
15626 DO I=-1,1
15627 RM(I)=ZERO
15628 RN1(I)=ZERO
15629 RN2(I)=ZERO
15630 END DO
15631 RN3=ZERO
15632 XW=TWO*S2W
15633 GE( 0)=-ONE
15634 GE(+1)=-GE(0)*XW
15635 GE(-1)=-ONE+GE(1)
15636 IF(IH.LE.3)THEN
15637 G3( 0)=Q3
15638 G3(+1)=-G3(0)*XW
15639 G3(-1)=-ONE*(-Q3/ABS(Q3))+G3(1)
15640 G4( 0)=G3( 0)
15641 G4(+1)=G3(+1)
15642 G4(-1)=G3(-1)
15643 G5( 0)=ZERO
15644 G5(+1)=ONE
15645 G5(-1)=ONE
15646C HIGGS ANGLES
15647 BE=ATAN(TANB)
15648 SA=SIN(AL)
15649 CA=COS(AL)
15650 SB=SIN(BE)
15651 CB=COS(BE)
15652C MSSM SCALING FACTORS FOR COUPLINGS
15653 IF(IH.LE.2)THEN
15654 RM(-1)=+YM3/RMW*HFC
15655 RM(+1)=+YM4/RMW*HFC
15656 ELSE IF(IH.EQ.3)THEN
15657 RM(-1)=+YM3/RMW*HFC
15658 RM(+1)=-YM4/RMW*HFC
15659 END IF
15660 IF(IH.LE.2)THEN
15661 IF(IH.EQ.1)RN1(-1)=+YM3/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15662 & *(-SQRT(ABS(ONE-HBC**2)))
15663 IF(IH.EQ.1)RN1(+1)=-YM4/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15664 & *(-SQRT(ABS(ONE-HBC**2)))
15665 IF(IH.EQ.2)RN1(-1)=-YM3/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15666 & *(+SQRT(ABS(ONE-HBC**2)))
15667 IF(IH.EQ.2)RN1(+1)=+YM4/RMW*((2-IFL)*TANB+(IFL-1)/TANB)
15668 & *(+SQRT(ABS(ONE-HBC**2)))
15669 RN2(-1)=ZERO
15670 RN2(+1)=ZERO
15671 IF(IH.EQ.0)RN3=1.D0
15672 IF(IH.EQ.1)RN3=HBC
15673 IF(IH.EQ.2)RN3=HBC
15674 ELSE IF(IH.EQ.3)THEN
15675 RN1(-1)=+YM3/RMW*((2-IFL)*(-SA/CB)+(IFL-1)*(+CA/SB))
15676 & *COS(BE-AL)
15677 RN1(+1)=+YM4/RMW*((2-IFL)*(-SA/CB)+(IFL-1)*(+CA/SB))
15678 & *COS(BE-AL)
15679 RN2(-1)=+YM3/RMW*((2-IFL)*(+CA/CB)+(IFL-1)*(+SA/SB))
15680 & *SIN(BE-AL)
15681 RN2(+1)=+YM4/RMW*((2-IFL)*(+CA/CB)+(IFL-1)*(+SA/SB))
15682 & *SIN(BE-AL)
15683 RN3=ZERO
15684 END IF
15685 PREFAC=E**6/(XW*S)*CFAC/TWO
15686 ELSE
15687 G3( 0)=Q3
15688 G3(+1)=-G3(0)*XW
15689 G3(-1)=-ONE+G3(1)
15690 G4( 0)=ONE+G3(0)
15691 G4(+1)=-G4(0)*XW
15692 G4(-1)=ONE+G4(1)
15693 G5( 0)=ONE
15694 G5(+1)=ONE-XW
15695 G5(-1)=ONE-XW
15696 RM(-1)=YM3*TANB/RMW
15697 RM(+1)=YM4/TANB/RMW
15698 RN1(-1)=RM(-1)
15699 RN1(+1)=RM(+1)
15700 RN2(-1)=ZERO
15701 RN2(+1)=ZERO
15702 RN3=ZERO
15703 PREFAC=E**6/(XW*S)*CFAC
15704 END IF
15705 FIRST=.FALSE.
15706 END IF
15707C SOME ENERGY CONSTANTS
15708 SQS=DSQRT(S)
15709 TWOSQS=TWO*SQS
15710 HLFSQS=HLF*SQS
15711 PROPZ=S/(XW*(TWO-XW)*DCMPLX(S-RMZ**2,-RMZ*GAMZ))
15712C SOME KINEMATICS
15713 P34=P3(0)*P4(0)-P3(1)*P4(1)-P3(2)*P4(2)-P3(3)*P4(3)
15714 M34=RM3*RM4
15715 RES=ZERO
15716C FF(')-BAR PROPAGATOR
15717 Q2=RM3**2+RM4**2+TWO*P34
15718C CONSTRUCT AMPLITUDE
15719 DO LE=-1,1,2
15720 RLE=DFLOAT(LE)
15721 IF(IH.LE.2)THEN
15722 PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15723 & DCMPLX(Q2-RMA**2,-RMA*GAMA)
15724 PROP6=(0.D0,0.D0)
15725 ELSE IF(IH.EQ.3)THEN
15726 PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15727 & DCMPLX(Q2-RML**2,-RML*GAML)
15728 PROP6=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15729 & DCMPLX(Q2-RMH**2,-RMH*GAMH)
15730 ELSE
15731 PROP5=(GE(0)*G5(0)+GE(LE)*G5(-1)*PROPZ)/
15732 & DCMPLX(Q2-RM5**2,-RM5*GAM5)
15733 END IF
15734 ZP3=DCMPLX(P3(1),-RLE*P3(2))
15735 ZP4=DCMPLX(P4(1),-RLE*P4(2))
15736 ZP5=-ZP3-ZP4
15737 DO L=-1,1,2
15738 PROP3(L)=(GE(0)*G3(0)+GE(LE)*G3(L)*PROPZ)/
15739 & DCMPLX(S-TWOSQS*P3(0),-RM3*GAM3)
15740 PROP4(L)=(GE(0)*G4(0)+GE(LE)*G4(L)*PROPZ)/
15741 & DCMPLX(S-TWOSQS*P4(0),-RM4*GAM4)
15742 PROP7(L)=GE(LE)*G3(L)*PROPZ/DCMPLX(Q2-RMZ**2,-RMZ*GAMZ)
15743 END DO
15744 DO L=-1,1,2
15745 PP(L)=-RM(-L)*SQS*(PROP3(L)+PROP4(-L))
15746 MM(L)=RM3*RM(+L)*(PROP3(L)-PROP3(-L))
15747 & +RM4*RM(-L)*(PROP4(L)-PROP4(-L))
15748 & +TWO*RMZ**2/RMW*RN3*PROP7(L)
15749 IF(GAUGE)THEN
15750 ZP3=P3(0)-HLFSQS
15751 ZP4=P4(0)-HLFSQS
15752 ZP5=P5(0)-HLFSQS
15753 PP(L)=DCMPLX(ZERO,ZERO)
15754 MM(L)=MM(L)+PROPZ*GE(LE)*DFLOAT(L)/TWOSQS*
15755 & (RM3*RM(L)/ZP3-RM4*RM(-L)/ZP4)
15756 END IF
15757 QQ(L)=RM(L)*(PROP3(-L)*ZP3-PROP4(L)*ZP4)
15758 & +RN1(L)*PROP5*ZP5
15759 & -RN2(L)*PROP6*ZP5
15760 & +RM3/RMW*RN3*(PROP7(L)-PROP7(-L))*ZP5
15761 RLLE=DFLOAT(L*LE)
15762 EP3(L)=P3(0)+RLLE*P3(3)
15763 EP4(L)=P4(0)+RLLE*P4(3)
15764 END DO
15765 DO L=-1,1,2
15766 RES=RES+DREAL(
15767 & EP3(+L)*EP4(+L)*DCONJG(PP(+L))*PP(+L)+
15768 & EP3(+L)*EP4(-L)*DCONJG(MM(+L))*MM(+L)-
15769 & TWO*RM3*EP4(+L)*DCONJG(PP(+L))*MM(-L)-
15770 & TWO*RM4*EP3(+L)*DCONJG(PP(+L))*MM(+L)+
15771 & M34*(DCONJG(PP(-L))*PP(+L)+DCONJG(MM(-L))*MM(+L))
15772 & +TWO*DCONJG(QQ(-L))
15773 & *((RM3*MM(-L)-EP3(+L)*PP(+L))*ZP4-
15774 & (RM4*MM(+L)-EP4(+L)*PP(+L))*ZP3+
15775 & P34*QQ(-L)-M34*QQ(+L)))
15776 END DO
15777 END DO
15778 RES=PREFAC*RES
15779 END
15780CDECK ID>, HWH2M0.
15781*CMZ :- -14/03/01 09:03:25 by Peter Richardson
15782*-- Author : Peter Richardson
15783C-----------------------------------------------------------------------
15784 SUBROUTINE HWH2M0(IQ,IDZ,MG,MQ)
15785C-----------------------------------------------------------------------
15786C Massless matrix elements for gg-->qqZ and qq-->qqZ
15787C using the matrix elements given in Nucl. Phys. B262 (1985) 235-242
15788C-----------------------------------------------------------------------
c63d70bc 15789 INCLUDE 'herwig65.inc'
65767955 15790 INTEGER IQ,I,J,OZ(2,2),IDZ,P1,P2,P3,P4,IQI,ID(2),K
15791 DOUBLE PRECISION MG(2),MQ(2,5),G(12,2),FLOW(3,3),CQFC,CQIFC,
15792 & CGFC,CGIFC
15793 DOUBLE COMPLEX MQAMP(2),HWH2T1,HWH2T2,HWH2T3,HWH2T4,HWH2T5,
15794 & HWH2T6,HWH2T7,HWH2T8,HWH2T9,HWH2T0,DCF(8),HWH2DD,
15795 & MGAMP(2,2,2,2,2),TRPGL(2)
15796 EXTERNAL HWH2DD,HWH2T0,HWH2T1,HWH2T2,HWH2T3,HWH2T4,HWH2T5,HWH2T6,
15797 & HWH2T7,HWH2T8,HWH2T9
15798 PARAMETER(CQFC=2.0D0,CQIFC=-2.0D0/3.0D0,CGFC=16.0D0/3.0D0,
15799 & CGIFC=-2.0D0/3.0D0)
15800 COMMON /HWHZBC/G
15801 SAVE OZ,ID
15802 DATA OZ/6,5,5,6/
15803 DATA ID/1,2/
15804C--flavour of the final-state quark (1 is down-type and 2 is up-type)
15805 IQI = MOD(IQ,2)
15806 IF(IQI.EQ.0) IQI=2
15807C--calculate qqbar---> q'q'barZ
15808 DCF(1) = HWH2DD(4,2,1,3,4,5,6)
15809 DCF(2) = HWH2DD(5,2,1,3,4,5,6)
15810 DCF(3) = HWH2DD(4,3,4,2,1,5,6)
15811 DCF(4) = HWH2DD(5,3,4,2,1,5,6)
15812 DCF(5) = HWH2DD(4,3,1,2,4,5,6)
15813 DCF(6) = HWH2DD(5,3,1,2,4,5,6)
15814 DCF(7) = HWH2DD(4,2,4,3,1,5,6)
15815 DCF(8) = HWH2DD(5,2,4,3,1,5,6)
15816 DO I=1,3
15817 DO J=1,3
15818 FLOW(I,J) = ZERO
15819 ENDDO
15820 ENDDO
15821 DO I=1,2
15822C--calculate the matrix element, N.B. two possibe colour flows
15823 DO P1=1,2
15824 DO P2=1,2
15825 DO P3=1,2
15826 MQAMP(1)= G(IDZ,P3)*(
15827 & G(ID(I),P1)*(DCF(1)*HWH2T4(2,1,3,4,OZ(P3,1),OZ(P3,2),P1,P2)
15828 & +DCF(2)*HWH2T5(2,1,3,4,OZ(P3,1),OZ(P3,2),P1,P2))
15829 & +G(IQ,P2)*(DCF(3)*HWH2T4(3,4,2,1,OZ(P3,1),OZ(P3,2),P2,P1)
15830 & +DCF(4)*HWH2T5(3,4,2,1,OZ(P3,1),OZ(P3,2),P2,P1)))
15831 IF(ID(I).NE.IQI) THEN
15832 MQAMP(2)=ZERO
15833 ELSE
15834 MQAMP(2)= G(IDZ,P3)*(
15835 & G(IQ,P1)*(DCF(5)*HWH2T4(3,1,2,4,OZ(P3,1),OZ(P3,2),P1,P2)
15836 & +DCF(6)*HWH2T5(3,1,2,4,OZ(P3,1),OZ(P3,2),P1,P2))
15837 & +G(IQ,P2)*(DCF(7)*HWH2T4(2,4,3,1,OZ(P3,1),OZ(P3,2),P2,P1)
15838 & +DCF(8)*HWH2T5(2,4,3,1,OZ(P3,1),OZ(P3,2),P2,P1)))
15839 ENDIF
15840 FLOW(I,1) = FLOW(I,1)+DBLE(MQAMP(1)*DCONJG(MQAMP(1)))
15841 FLOW(I,2) = ZERO
15842 FLOW(I,3) = ZERO
15843 IF(IQI.EQ.ID(I)) THEN
15844 FLOW(3,1) = FLOW(3,1)+DBLE(MQAMP(1)*DCONJG(MQAMP(1)))
15845 FLOW(3,2) = FLOW(3,2)+DBLE(MQAMP(2)*DCONJG(MQAMP(2)))
15846 IF(P1.EQ.P2) FLOW(3,3) = FLOW(3,3)
15847 & -TWO*DBLE(MQAMP(1)*DCONJG(MQAMP(2)))
15848 ENDIF
15849 ENDDO
15850 ENDDO
15851 ENDDO
15852 ENDDO
15853 DO I=1,3
15854 FLOW(I,1) = CQFC*FLOW(I,1)
15855 FLOW(I,2) = CQFC*FLOW(I,2)
15856 FLOW(I,3) = CQIFC*FLOW(I,3)
15857 ENDDO
15858C--now find the matrix elements
15859 DO I=1,5
15860 K = MOD(I,2)
15861 IF(K.EQ.0) K=2
15862 IF(I.EQ.IQ) K=3
15863 DO J=1,2
15864 IF(FLOW(K,J).NE.ZERO) MQ(J,I) = FLOW(K,J)*
15865 & (ONE+FLOW(K,3)/(FLOW(K,1)+FLOW(K,2)))
15866 ENDDO
15867 ENDDO
15868C--calculate gg---> bbbarZ
15869C--coefficients for the diagrams
15870 DCF(1) = HWH2DD( 6,3,4,1,2,5,6)
15871 DCF(2) = HWH2DD( 7,3,4,1,2,5,6)
15872 DCF(3) = HWH2DD( 8,3,4,1,2,5,6)
15873 DCF(4) = HWH2DD( 6,3,4,2,1,5,6)
15874 DCF(5) = HWH2DD( 7,3,4,2,1,5,6)
15875 DCF(6) = HWH2DD( 8,3,4,2,1,5,6)
15876 DCF(7) = HWH2DD( 9,3,4,1,2,5,6)
15877 DCF(8) = HWH2DD(10,3,4,1,2,5,6)
15878C--helicity amplitudes
15879 DO P1=1,2
15880 DO P2=1,2
15881 DO P3=1,2
15882 DO P4=1,2
15883 TRPGL(1)=
15884 & DCF(7)*HWH2T9(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15885 & +DCF(8)*HWH2T0(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15886 TRPGL(2)=
15887 & DCF(7)*HWH2T9(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P2,P1)
15888 & +DCF(8)*HWH2T0(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P2,P1)
15889 MGAMP(1,P1,P2,P3,P4) = G(IDZ,P4)*G(IQ,P3)*(
15890 & TRPGL(1)
15891 & +DCF(1)*HWH2T6(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15892 & +DCF(2)*HWH2T7(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15893 & +DCF(3)*HWH2T8(3,4,1,2,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15894 & )
15895 MGAMP(2,P2,P1,P3,P4) = G(IDZ,P4)*G(IQ,P3)*(-TRPGL(2)
15896 & +DCF(4)*HWH2T6(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15897 & +DCF(5)*HWH2T7(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2)
15898 & +DCF(6)*HWH2T8(3,4,2,1,OZ(P4,1),OZ(P4,2),P3,P1,P2))
15899 ENDDO
15900 ENDDO
15901 ENDDO
15902 ENDDO
15903C--square to obtain the matrix element
15904 DO I=1,3
15905 FLOW(1,I) = ZERO
15906 ENDDO
15907 DO P1=1,2
15908 DO P2=1,2
15909 DO P3=1,2
15910 DO P4=1,2
15911 FLOW(1,1) = FLOW(1,1)+DBLE(MGAMP(1,P1,P2,P3,P4)*
15912 & DCONJG(MGAMP(1,P1,P2,P3,P4)))
15913 FLOW(1,2) = FLOW(1,2)+DBLE(MGAMP(2,P1,P2,P3,P4)*
15914 & DCONJG(MGAMP(2,P1,P2,P3,P4)))
15915 FLOW(1,3) = FLOW(1,3)+TWO*DBLE(MGAMP(1,P1,P2,P3,P4)*
15916 & DCONJG(MGAMP(2,P1,P2,P3,P4)))
15917 ENDDO
15918 ENDDO
15919 ENDDO
15920 ENDDO
15921 FLOW(1,1) = CGFC*FLOW(1,1)
15922 FLOW(1,2) = CGFC*FLOW(1,2)
15923 FLOW(1,3) = CGIFC*FLOW(1,3)
15924 DO I=1,2
15925 MG(I) = FLOW(1,I)*(ONE+FLOW(1,3)/(FLOW(1,1)+FLOW(1,2)))
15926 ENDDO
15927 END
15928CDECK ID>, HWH2MQ.
15929*CMZ :- -14/03/01 09:03:25 by Peter Richardson
15930*-- Author : Peter Richardson
15931C-----------------------------------------------------------------------
15932 SUBROUTINE HWH2MQ(IQ,IDZ,MG,MQ)
15933C-----------------------------------------------------------------------
15934C Massive matrix elements for gg --> qqbarZ and qqbar --> qqbarZ
15935C-----------------------------------------------------------------------
c63d70bc 15936 INCLUDE 'herwig65.inc'
65767955 15937 INTEGER IQ,I,IDZ,P1,P2,PL,PB,PBB,O(2),J,IQI
15938 DOUBLE PRECISION MG(2),MQ(2,5),G(12,2),CQFC,CQIFC,CGFC,CGIFC,
15939 & PTMP(5,10),XMASS,PLAB,PRW,PCM,HWULDO,QBL,QBBL,Q2B,Q1B,Q2BB,
15940 & Q1BB,QM2,FLOW(3,3),PG,PBQB,PBBQBB,QM,PQ,Q1L,Q2L,
15941 & Q1LB,Q2LB,MQB(2,3),QBB
15942 DOUBLE COMPLEX S,D,FBB(2,2,8),FBBB(2,2,8),FBLL(2,2,8,8),MQP(2),
15943 & FBBLL(2,2,8,8),F1B(2,2,8,8),F1BB(2,2,8,8),F2B(2,2,8,8),
15944 & F2BB(2,2,8,8),DL(2,2),DCF(8),MGAMP(3),MQAMP(3,2,2,2,2),
15945 & MQQAMP(2,2,2,2,2),F1LL(2,2,8,8),F2LL(2,2,8,8)
15946 COMMON/HWHZBC/G
15947 COMMON/HWHEWS/S(8,8,2),D(8,8)
15948 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
15949 PARAMETER(CQFC=2.0D0,CQIFC=-2.0D0/3.0D0,CGFC=16.0D0/3.0D0,
15950 & CGIFC=-2.0D0/3.0D0)
15951 EXTERNAL HWULDO
15952 SAVE DL,O
15953 DATA DL/(1.0D0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
15954 DATA O /2,1/
15955C--mass of the final-state quark
15956 QM = RMASS(IQ)
15957 QM2 = RMASS(IQ)**2
15958C--first calculate the F functions we will need
15959 DO I=1,4
15960 PTMP(I,1) = PCM(I,9)+PCM(I,5)+PCM(I,6)
15961 PTMP(I,2) = -PCM(I,10)-PCM(I,5)-PCM(I,6)
15962 PTMP(I,3) = PCM(I,9)-PCM(I,1)
15963 PTMP(I,4) = PCM(I,1)-PCM(I,10)
15964 PTMP(I,5) = PCM(I,9)-PCM(I,2)
15965 PTMP(I,6) = PCM(I,2)-PCM(I,10)
15966 PTMP(I,7) = PCM(I,9)
15967 PTMP(I,8) = -PCM(I,10)
15968 PTMP(I,9) = PCM(I,1)-PCM(I,5)-PCM(I,6)
15969 PTMP(I,10) =-PCM(I,2)+PCM(I,5)+PCM(I,6)
15970 ENDDO
15971 CALL HWH2F3(8,FBLL , PTMP(1, 1),QM)
15972 CALL HWH2F3(8,FBBLL, PTMP(1, 2),QM)
15973 CALL HWH2F3(8,F1B , PTMP(1, 3),QM)
15974 CALL HWH2F3(8,F1BB , PTMP(1, 4),QM)
15975 CALL HWH2F3(8,F2B , PTMP(1, 5),QM)
15976 CALL HWH2F3(8,F2BB , PTMP(1, 6),QM)
15977 CALL HWH2F1(8,FBB ,3,PTMP(1, 7),QM)
15978 CALL HWH2F2(8,FBBB ,4,PTMP(1, 8),QM)
15979 CALL HWH2F3(8,F1LL , PTMP(1, 9),QM)
15980 CALL HWH2F3(8,F2LL , PTMP(1,10),QM)
15981C--calculate the momenta squared for the denominators
15982 QBB = HALF/(QM2+HWULDO(PCM(1,9),PCM(1,10)))
15983 QBL = ONE/(HWULDO(PTMP(1,1),PTMP(1,1))-QM2)
15984 QBBL = ONE/(HWULDO(PTMP(1,2),PTMP(1,2))-QM2)
15985 Q1B = ONE/(HWULDO(PTMP(1,3),PTMP(1,3))-QM2)
15986 Q1BB = ONE/(HWULDO(PTMP(1,4),PTMP(1,4))-QM2)
15987 Q2B = ONE/(HWULDO(PTMP(1,5),PTMP(1,5))-QM2)
15988 Q2BB = ONE/(HWULDO(PTMP(1,6),PTMP(1,6))-QM2)
15989 Q1L = HWULDO(PTMP(1, 9),PTMP(1, 9))
15990 Q2L = HWULDO(PTMP(1,10),PTMP(1,10))
15991 Q1LB = ONE/(Q1L-QM2)
15992 Q2LB = ONE/(Q2L-QM2)
15993 Q1L = ONE/Q1L
15994 Q2L = ONE/Q2L
15995C--first construct the massless momenta
15996 PBQB = HWULDO(PCM(1,3),PCM(1,9))
15997 PBBQBB = HWULDO(PCM(1,4),PCM(1,10))
15998C--first gg --> q qbar Z
15999C--calculate the denominators due gluon polaizations and massive quarks
16000 PG = 0.25D0/(PBQB*PBBQBB*DREAL(D(1,2)*D(1,2)))
16001C--and the denominators
16002 DCF(1) = FOUR*QBL*Q2BB
16003 DCF(2) = FOUR*QBL*Q1BB
16004 DCF(3) = FOUR*Q1B*Q2BB
16005 DCF(4) = FOUR*Q2B*Q1BB
16006 DCF(5) = FOUR*Q1B*QBBL
16007 DCF(6) = FOUR*Q2B*QBBL
16008 DCF(7) = TWO*QBL/D(1,2)
16009 DCF(8) = TWO*QBBL/D(1,2)
16010C--now calculate the matrix elements we need
16011 DO I=1,3
16012 FLOW(1,I) = ZERO
16013 ENDDO
16014 DO P1=1,2
16015 DO P2=1,2
16016 DO PL=1,2
16017 DO PB=1,2
16018 DO PBB=1,2
16019C--first amplitude from notes
16020 MGAMP(1) = DCF(1)*(
16021 & ( G(IQ,O(PL))*FBB(PB, PL,6)*FBLL( PL ,P1,5,2)
16022 & +G(IQ, PL )*FBB(PB,O(PL),5)*FBLL(O(PL),P1,6,2))*
16023 & (F2BB( P1 , P2 ,1,1)*FBBB( P2 ,PBB,2)+
16024 & F2BB( P1 ,O(P2),1,2)*FBBB(O(P2),PBB,1))
16025 & +( G(IQ,O(PL))*FBB(PB, PL ,6)*FBLL( PL,O(P1),5,1)
16026 & +G(IQ, PL )*FBB(PB,O(PL),5)*FBLL(O(PL),O(P1),6,1))*
16027 & (F2BB(O(P1), P2 ,2,1)*FBBB( P2 ,PBB,2)+
16028 & F2BB(O(P1),O(P2),2,2)*FBBB(O(P2),PBB,1)))
16029C--second amplitude from notes (1st with gluons interchanged)
16030 MGAMP(2) = DCF(2)*(
16031 & ( G(IQ,O(PL))*FBB(PB, PL ,6)*FBLL( PL , P2 ,5,1)
16032 & +G(IQ, PL )*FBB(PB,O(PL),5)*FBLL(O(PL), P2 ,6,1))*
16033 & (F1BB( P2 , P1 ,2,2)*FBBB( P1 ,PBB,1)+
16034 & F1BB( P2 ,O(P1),2,1)*FBBB(O(P1),PBB,2))
16035 & +( G(IQ,O(PL))*FBB(PB, PL ,6)*FBLL( PL ,O(P2),5,2)
16036 & +G(IQ, PL )*FBB(PB,O(PL),5)*FBLL(O(PL),O(P2),6,2))*
16037 & (F1BB(O(P2), P1 ,1,2)*FBBB( P1 ,PBB,1)+
16038 & F1BB(O(P2),O(P1),1,1)*FBBB(O(P1),PBB,2)))
16039C--third amplitude from notes
16040 MGAMP(1) = MGAMP(1)+DCF(3)*(
16041 & G(IQ,O(PL))*( FBB(PB, P1 ,2)*F1B( P1 , PL ,1,6)
16042 & +FBB(PB,O(P1),1)*F1B(O(P1), PL ,2,6))*
16043 & (F2BB(PL, P2 ,5,1)*FBBB( P2 ,PBB,2)+
16044 & F2BB(PL,O(P2),5,2)*FBBB(O(P2),PBB,1))
16045 & +G(IQ, PL )*( FBB(PB, P1 ,2)*F1B( P1 ,O(PL),1,5)
16046 & +FBB(PB,O(P1),1)*F1B(O(P1),O(PL),2,5))*
16047 & (F2BB(O(PL), P2 ,6,1)*FBBB( P2 ,PBB,2)+
16048 & F2BB(O(PL),O(P2),6,2)*FBBB(O(P2),PBB,1)))
16049C--fourth amplitude from notes (3rd with gluons interchanged)
16050 MGAMP(2) = MGAMP(2)+DCF(4)*(
16051 & G(IQ,O(PL))*( FBB(PB, P2 ,1)*F2B( P2 , PL ,2,6)
16052 & +FBB(PB,O(P2),2)*F2B(O(P2), PL ,1,6))*
16053 & (F1BB( PL , P1 ,5,2)*FBBB( P1 ,PBB,1)+
16054 & F1BB( PL ,O(P1),5,1)*FBBB(O(P1),PBB,2))
16055 & +G(IQ, PL )*( FBB(PB, P2 ,1)*F2B( P2 ,O(PL),2,5)
16056 & +FBB(PB,O(P2),2)*F2B(O(P2),O(PL),1,5))*
16057 & ( F1BB(O(PL), P1 ,6,2)*FBBB( P1 ,PBB,1)
16058 & +F1BB(O(PL),O(P1),6,1)*FBBB(O(P1),PBB,2)))
16059C--fifth amplitude from notes
16060 MGAMP(1) = MGAMP(1)+DCF(5)*(
16061 & ( G(IQ,O(PL))*FBBLL( P2 , PL ,2,6)*FBBB( PL ,PBB,5)
16062 & +G(IQ, PL )*FBBLL( P2 ,O(PL),2,5)*FBBB(O(PL),PBB,6))*
16063 & ( FBB(PB, P1 ,2)*F1B( P1 , P2 ,1,1)
16064 & +FBB(PB,O(P1),1)*F1B(O(P1), P2 ,2,1))
16065 & +( G(IQ,O(PL))*FBBLL(O(P2), PL ,1,6)*FBBB( PL ,PBB,5)
16066 & +G(IQ, PL )*FBBLL(O(P2),O(PL),1,5)*FBBB(O(PL),PBB,6))*
16067 & ( FBB(PB, P1 ,2)*F1B( P1 ,O(P2),1,2)
16068 & +FBB(PB,O(P1),1)*F1B(O(P1),O(P2),2,2)))
16069C--sixth amplitude from notes (5th with gluons interchanged)
16070 MGAMP(2) = MGAMP(2)+DCF(6)*(
16071 & ( G(IQ,O(PL))*FBBLL( P1 , PL ,1,6)*FBBB( PL ,PBB,5)
16072 & +G(IQ, PL )*FBBLL( P1 ,O(PL),1,5)*FBBB(O(PL),PBB,6))*
16073 & ( FBB(PB, P2 ,1)*F2B( P2 , P1 ,2,2)
16074 & +FBB(PB,O(P2),2)*F2B(O(P2), P1 ,1,2))
16075 & +( G(IQ,O(PL))*FBBLL(O(P1), PL ,2,6)*FBBB( PL ,PBB,5)
16076 & +G(IQ, PL )*FBBLL(O(P1),O(PL),2,5)*FBBB(O(PL),PBB,6))*
16077 & ( FBB(PB, P2 ,1)*F2B( P2 ,O(P1),2,1)
16078 & +FBB(PB,O(P2),2)*F2B(O(P2),O(P1),1,1)))
16079C--seventh amplitude from notes (first non-Abelian one)
16080 MGAMP(3) = DCF(7)*DL(P1,P2)*S(1,2,P1)*S(1,2,O(P1))*(
16081 & G(IQ,O(PL))*FBB(PB, PL ,6)*
16082 & ( FBLL( PL ,1,5,1)*FBBB(1,PBB,1)
16083 & +FBLL( PL ,2,5,1)*FBBB(2,PBB,1)
16084 & -FBLL( PL ,1,5,2)*FBBB(1,PBB,2)
16085 & -FBLL( PL ,2,5,2)*FBBB(2,PBB,2))
16086 & +G(IQ, PL )*FBB(PB,O(PL),5)*
16087 & ( FBLL(O(PL),1,6,1)*FBBB(1,PBB,1)
16088 & +FBLL(O(PL),2,6,1)*FBBB(2,PBB,1)
16089 & -FBLL(O(PL),1,6,2)*FBBB(1,PBB,2)
16090 & -FBLL(O(PL),2,6,2)*FBBB(2,PBB,2)))
16091C--eighth amplitude from notes (second non-Abelian one)
16092C--bug fix 12/7/03 by PR (too many continuations for NAG)
16093 MGAMP(3) = MGAMP(3)
16094 & + DCF(8)*DL(P1,P2)*S(1,2,P1)*S(1,2,O(P1))*(
16095 & G(IQ,O(PL))*FBBB( PL ,PBB,5)*
16096 & ( FBB(PB,1,1)*FBBLL(1,PL,1,6)
16097 & +FBB(PB,2,1)*FBBLL(2,PL,1,6)
16098 & -FBB(PB,1,2)*FBBLL(1,PL,2,6)
16099 & -FBB(PB,2,2)*FBBLL(2,PL,2,6))
16100 & +G(IQ, PL )*FBBB(O(PL),PBB,6)*
16101 & ( FBB(PB,1,1)*FBBLL(1,O(PL),1,5)
16102 & +FBB(PB,2,1)*FBBLL(2,O(PL),1,5)
16103 & -FBB(PB,1,2)*FBBLL(1,O(PL),2,5)
16104 & -FBB(PB,2,2)*FBBLL(2,O(PL),2,5)))
16105 MGAMP(1) = G(IDZ,PL)*(MGAMP(1)+MGAMP(3))
16106 MGAMP(2) = G(IDZ,PL)*(MGAMP(2)-MGAMP(3))
16107C--now square them
16108 FLOW(1,1) = FLOW(1,1)+DREAL(MGAMP(1)*DCONJG(MGAMP(1)))
16109 FLOW(1,2) = FLOW(1,2)+DREAL(MGAMP(2)*DCONJG(MGAMP(2)))
16110 FLOW(1,3) = FLOW(1,3)+TWO*DREAL(MGAMP(1)*DCONJG(MGAMP(2)))
16111 ENDDO
16112 ENDDO
16113 ENDDO
16114 ENDDO
16115 ENDDO
16116C--add up the diagrams to obtain the amplitudes for the two colour flows
16117 FLOW(1,1) = CGFC*FLOW(1,1)
16118 FLOW(1,2) = CGFC*FLOW(1,2)
16119 FLOW(1,3) = CGIFC*FLOW(1,3)
16120 DO I=1,2
16121 IF(FLOW(1,3).NE.ZERO) THEN
16122 MG(I) = PG*FLOW(1,I)*(ONE+FLOW(1,3)/(FLOW(1,1)+FLOW(1,2)))
16123 ELSE
16124 MG(I) = PG*FLOW(1,I)
16125 ENDIF
16126 ENDDO
16127C--now q qbar --> q qbar Z
16128C--calculate the denominators
16129 DCF(1) = -TWO*QBL/D(1,2)
16130 DCF(2) = -TWO*QBBL/D(1,2)
16131 DCF(3) = -TWO*Q1L*QBB
16132 DCF(4) = +TWO*Q2L*QBB
16133 DCF(5) = TWO*Q1LB*Q2BB
16134 DCF(6) = -TWO*Q2LB*Q1B
16135 DCF(7) = TWO*QBL*Q2BB
16136 DCF(8) = -TWO*QBBL*Q1B
16137 PQ = ONE/PBQB/PBBQBB
16138 DO P1=1,2
16139 DO PL=1,2
16140 DO PB=1,2
16141 DO PBB=1,2
16142C--first the amplitudes for q qbar --> q' q'bar Z
16143C--the first two amplitudes have Z off the final state and therefore
16144C--the flavour of the incoming quarks doesn't matter
16145C--first amplitude from notes
16146 MQAMP(3,P1,PL,PB,PBB) = G(IDZ,PL)*(
16147 & DCF(1)*(G(IQ,O(PL))*FBB(O(PB), PL ,6)*
16148 & ( FBLL( PL , P1 ,5,1)*FBBB( P1 ,O(PBB),2)
16149 & +FBLL( PL ,O(P1),5,2)*FBBB(O(P1),O(PBB),1))
16150 & +G(IQ, PL )*FBB(O(PB),O(PL),5)*
16151 & ( FBLL(O(PL), P1 ,6,1)*FBBB( P1 ,O(PBB),2)
16152 & +FBLL(O(PL),O(P1),6,2)*FBBB(O(P1),O(PBB),1)))
16153C--second amplitide from notes
16154 & +DCF(2)*(G(IQ,O(PL))*FBBB( PL ,O(PBB),5)*
16155 & ( FBB(O(PB), P1 ,1)*FBBLL( P1 , PL ,2,6)
16156 & +FBB(O(PB),O(P1),2)*FBBLL(O(P1), PL ,1,6))
16157 & +G(IQ, PL )*FBBB(O(PL),O(PBB),6)*
16158 & ( FBB(O(PB), P1 ,1)*FBBLL( P1 ,O(PL),2,5)
16159 & +FBB(O(PB),O(P1),2)*FBBLL(O(P1),O(PL),1,5))))
16160C--third amplitide from notes
16161 DO I=1,2
16162 MQAMP(I,P1,PL,PB,PBB) =
16163 & DCF(3)*(G(I,O(PL))*DL(P1,O(PL))*S(5,1, PL )*(
16164 & S(1,6,O(PL))*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),2)
16165 & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
16166 & -S(5,6,O(PL))*( FBB(O(PB), P1 ,5)*FBBB( P1 ,O(PBB),2)
16167 & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),5)))
16168 & +G(I, PL )*DL(P1, PL )*S(6,1,O(PL))*(
16169 & S(1,5, PL )*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),2)
16170 & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
16171 & -S(6,5, PL )*( FBB(O(PB), P1 ,6)*FBBB( P1 ,O(PBB),2)
16172 & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),6))))
16173C--fourth amplitude from notes
16174 MQAMP(I,P1,PL,PB,PBB) = MQAMP(I,P1,PL,PB,PBB)
16175 & +DCF(4)*(G(I,O(PL))*DL(P1,O(PL))*S(2,6, P1 )*(
16176 & S(5,2, PL )*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),2)
16177 & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
16178 & -S(5,6, PL )*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),6)
16179 & +FBB(O(PB),O(P1),6)*FBBB(O(P1),O(PBB),1)))
16180 & +G(I, PL )*DL(P1, PL )*S(2,5, P1 )*(
16181 & S(6,2,O(PL))*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),2)
16182 & +FBB(O(PB),O(P1),2)*FBBB(O(P1),O(PBB),1))
16183 & -S(6,5,O(PL))*( FBB(O(PB), P1 ,1)*FBBB( P1 ,O(PBB),5)
16184 & +FBB(O(PB),O(P1),5)*FBBB(O(P1),O(PBB),1))))
16185 MQAMP(I,P1,PL,PB,PBB) = G(IDZ,PL)*MQAMP(I,P1,PL,PB,PBB)
16186 ENDDO
16187C--now the extra amplitudes for q qbar --> q qbar Z
16188 DO P2=1,2
16189C--first amplitude for notes
16190 MQQAMP(P1,P2,PL,PB,PBB) =
16191 & DCF(5)*(DL(P2,PBB)*S(8,4,PBB)*(
16192 & G(IQ,O(PL))*DL(P1,O(PL))*S(5,1, PL )*
16193 & ( FBB(O(PB), PBB,8)*F1LL( P2 , PL ,2,6)
16194 & +FBB(O(PB),O(P2),2)*F1LL(O(PBB), PL ,8,6))
16195 & +G(IQ, PL )*DL(P1, PL )*S(6,1,O(PL))*
16196 & ( FBB(O(PB), PBB ,8)*F1LL( P2 ,O(PL),2,5)
16197 & +FBB(O(PB),O(P2) ,2)*F1LL(O(PBB),O(PL),8,5)))
16198 & -QM*DL(P2,O(PBB))*(
16199 & G(IQ,O(PL))*DL(P1,O(PL))*S(5,1,PL)*
16200 & ( FBB(O(PB),O(PBB),8)*F1LL( P2 , PL ,2,6)
16201 & +FBB(O(PB),O(P2) ,2)*F1LL( PBB , PL ,8,6))
16202 & +G(IQ, PL )*DL(P1, PL )*S(6,1,O(PL))*
16203 & ( FBB(O(PB),O(PBB),8)*F1LL( P2 ,O(PL),2,5)
16204 & +FBB(O(PB), O(P2),2)*F1LL( PBB ,O(PL),8,5))))
16205C--second amplitude from notes
16206 MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB)
16207 & +DCF(6)*(DL(P1,PB)*S(3,7,O(PB))*(
16208 & G(IQ,O(PL))*DL(P2,O(PL))*S(2,6, P2 )*
16209 & ( F2LL( PL , P1 ,5,1)*FBBB( PB ,O(PBB),7)
16210 & +F2LL( PL ,O(PB),5,7)*FBBB(O(P1),O(PBB),1))
16211 & +G(IQ, PL )*DL(P2, PL )*S(2,5, P2 )*
16212 & ( F2LL(O(PL), P1 ,6,1)*FBBB( PB ,O(PBB),7)
16213 & +F2LL(O(PL),O(PB),6,7)*FBBB(O(P1),O(PBB),1)))
16214 & -QM*DL(P1,O(PB))*(
16215 & G(IQ,O(PL))*DL(P2,O(PL))*S(2,6, P2 )*
16216 & ( F2LL( PL , P1 ,5,1)*FBBB(O(PB),O(PBB),7)
16217 & +F2LL( PL , PB ,5,7)*FBBB(O(P1),O(PBB),1))
16218 & +G(IQ, PL )*DL(P2, PL )*S(2,5, P2 )*
16219 & ( F2LL(O(PL), P1 ,6,1)*FBBB(O(PB),O(PBB),7)
16220 & +F2LL(O(PL), PB ,6,7)*FBBB(O(P1),O(PBB),1))))
16221C--third amplitude from notes
16222 MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB)
16223 & +DCF(7)*(DL(P2,PBB)*S(8,4,PBB)*(
16224 & G(IQ,O(PL))*FBB(O(PB), PL ,6)*
16225 & ( DL(P2,O(P1) )*S(2,1, P2 )*FBLL( PL , PBB ,5,8)
16226 & +DL(P1,PBB )*S(8,1,O(PBB))*FBLL( PL ,O(P2),5,2))
16227 & +G(IQ, PL )*FBB(O(PB),O(PL),5)*
16228 & ( DL(P2,O(P1) )*S(2,1, P2 )*FBLL(O(PL), PBB ,6,8)
16229 & +DL(P1,PBB )*S(8,1,O(PBB))*FBLL(O(PL),O(P2),6,2)))
16230 & -QM*DL(P2,O(PBB))*(
16231 & G(IQ,O(PL))*FBB(O(PB),PL,6)*
16232 & ( DL(P2,O(P1) )*S(2,1, P2 )*FBLL( PL ,O(PBB),5,8)
16233 & +DL(P1,O(PBB))*S(8,1, PBB )*FBLL( PL ,O(P2) ,5,2))
16234 & +G(IQ, PL )*FBB(O(PB),O(PB),5)*
16235 & ( DL(P2,O(PL) )*S(2,1, P2 )*FBLL(O(PL),O(PBB),6,8)
16236 & +DL(P1,O(PBB))*S(8,1, PBB )*FBLL(O(PL),O(P2) ,6,2))))
16237C--fourth amplitude from notes
16238 MQQAMP(P1,P2,PL,PB,PBB) = MQQAMP(P1,P2,PL,PB,PBB)
16239 & +DCF(8)*(DL(P1,PB)*S(3,7,O(PB))*(
16240 & DL(P1,O(P2))*S(2,1,P2)*
16241 & ( G(IQ,O(PL))*FBBLL(PB, PL ,7,6)*FBBB( PL ,O(PBB),5)
16242 & +G(IQ, PL )*FBBLL(PB,O(PL),7,5)*FBBB(O(PL),O(PBB),6))
16243 & +DL(P2,PB)*S(2,7,P2)*
16244 & (G(IQ,O(PL))*FBBLL(O(P1), PL ,1,6)*FBBB( PL ,O(PBB),5)
16245 & +G(IQ, PL )*FBBLL(O(P1),O(PL),1,5)*FBBB(O(PL),O(PBB),6)))
16246 & +QM*DL(P1,O(PB))*(
16247 & DL(P2,O(P1))*S(2,1,P2)*
16248 & ( G(IQ,O(PL))*FBBLL(O(PB), PL ,3,6)*FBBB( PL ,O(PBB),5)
16249 & +G(IQ, PL )*FBBLL(O(PB),O(PL),3,5)*FBBB(O(PL),O(PBB),6))
16250 & +DL(P2,O(PB))*S(2,3,P2)*
16251 & ( G(IQ,O(PL))*FBBLL(O(P1), PL ,1,6)*FBBB( PL ,O(PBB),5)
16252 & +G(IQ, PL )*FBBLL(O(P1),O(PL),1,5)*FBBB(O(PL),O(PBB),6))))
16253 MQQAMP(P1,P2,PL,PB,PBB) = G(IDZ,PL)*MQQAMP(P1,P2,PL,PB,PBB)
16254 ENDDO
16255 ENDDO
16256 ENDDO
16257 ENDDO
16258 ENDDO
16259C--now obtain the matrix elements squared for the quarks
16260 DO I=1,3
16261 DO J=1,3
16262 FLOW(I,J) = ZERO
16263 ENDDO
16264 ENDDO
16265 IF(MOD(IQ,2).EQ.1) THEN
16266 IQI = 1
16267 ELSE
16268 IQI = 2
16269 ENDIF
16270 DO P1=1,2
16271 DO PL=1,2
16272 DO PB=1,2
16273 DO PBB=1,2
16274C--different quarks in inital and final states
16275 DO I=1,2
16276 MQP(I) = MQAMP(I,P1,PL,PB,PBB)+MQAMP(3,P1,PL,PB,PBB)
16277 FLOW(I,1) = FLOW(I,1)+DREAL(DCONJG(MQP(I))*MQP(I))
16278 ENDDO
16279C--same quark in inital and final state
16280 DO P2=1,2
16281 FLOW(3,2) = FLOW(3,2)+DREAL(
16282 & DCONJG(MQQAMP(P1,P2,PL,PB,PBB))*MQQAMP(P1,P2,PL,PB,PBB))
16283 IF(P1.EQ.P2) THEN
16284 FLOW(3,1) = FLOW(3,1)+DREAL(DCONJG(MQP(IQI))*MQP(IQI))
16285 FLOW(3,3) = FLOW(3,3)-TWO*
16286 & DREAL(DCONJG(MQP(IQI))*MQQAMP(P1,P2,PL,PB,PBB))
16287 ENDIF
16288 ENDDO
16289 ENDDO
16290 ENDDO
16291 ENDDO
16292 ENDDO
16293C--split up the non-planar pieces according to Kosuke's prescription
16294 DO I=1,3
16295 FLOW(I,1) = CQFC*FLOW(I,1)
16296 FLOW(I,2) = CQFC*FLOW(I,2)
16297 FLOW(I,3) = CQIFC*FLOW(I,3)
16298 DO J=1,2
16299 IF(FLOW(I,J).NE.ZERO) THEN
16300 MQB(J,I) = PQ*FLOW(I,J)*
16301 & (ONE+FLOW(I,3)/(FLOW(I,1)+FLOW(I,2)))
16302 ELSE
16303 MQB(J,I) = ZERO
16304 ENDIF
16305 ENDDO
16306 ENDDO
16307C--now set them
16308 DO I=1,5
16309 IF(I.EQ.IQ) THEN
16310 DO J=1,2
16311 MQ(J,I) = MQB(J,3)
16312 ENDDO
16313 ELSEIF(MOD(I,2).EQ.1) THEN
16314 DO J=1,2
16315 MQ(J,I) = MQB(J,1)
16316 ENDDO
16317 ELSE
16318 DO J=1,2
16319 MQ(J,I) = MQB(J,2)
16320 ENDDO
16321 ENDIF
16322 ENDDO
16323 END
16324CDECK ID>, HWH2PS.
16325*CMZ :- -14/03/01 09:03:25 by Peter Richardson
16326*-- Author : Peter Richardson
16327C-----------------------------------------------------------------------
16328 SUBROUTINE HWH2PS(WEIGHT,GEN,MQ,MQ2)
16329C-----------------------------------------------------------------------
16330C Phase Space for vector boson plus 2 jets
16331C-----------------------------------------------------------------------
c63d70bc 16332 INCLUDE 'herwig65.inc'
65767955 16333 DOUBLE PRECISION WEIGHT,XMASS,PLAB,PRW,PCM,Y(3),Y35,Y34,Y45,RAND,
16334 & HWRGEN,HWRUNI,M35,M35S,G(IMAXCH),DEM,MT(3),PT(3),MJAC,ETOT,
16335 & STOT,MQ(3),MQ2(3),PS35,HWUPCM,TWOPI2,MT35,PTJ(3),MT2(3),A,C,
16336 & PT2(3),YMIN,YMAX,EY(3),EY34,YJAC,YJJMAX,YJJMIN,EY35,PHI(3),
16337 & MT45,PS45,EY45,M45,M45S,M34,PS34,M34S,MT34,XJAC,SJAC,PST,TAU,
16338 & FLUX,ETMP,PZTMP,XT1,XT2,WI(IMAXCH)
16339 COMMON /HWPSOM/ WI
16340 INTEGER I,ICH,J
16341 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
16342 LOGICAL GEN
16343 EXTERNAL HWRGEN,HWRUNI,HWUPCM
16344 PARAMETER(YJJMIN=-8.0D0,YJJMAX=8.0D0)
16345 IF(IERROR.NE.0) RETURN
16346 TWOPI2 = FOUR*PIFAC**2
16347 WEIGHT = ZERO
16348 IF(OPTM) THEN
16349 DO I=1,IMAXCH
16350 WI(I) = ZERO
16351 ENDDO
16352 ENDIF
16353 GEN = .FALSE.
16354C--centre of mass energy
16355 ETOT = PHEP(5,3)
16356 STOT = ETOT**2
16357C--first select the channel to be used
16358 RAND=HWRGEN(0)
16359 DO ICH=1,IMAXCH
16360 IF(CHON(ICH)) THEN
16361 IF(CHNPRB(ICH).GT.RAND) GOTO 10
16362 RAND = RAND-CHNPRB(ICH)
16363 ENDIF
16364 ENDDO
16365 10 CONTINUE
16366C--generate the phase space according to the channel selected
16367C--FIRST CHANNEL
16368 IF(ICH.EQ.1) THEN
16369C--first generate the mass of 35
16370 CALL HWH2P1(2,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,(MQ(1)+MQ(3))**2)
16371 M35 = SQRT(M35S)
16372 PS35 = HWUPCM(M35,MQ(1),MQ(3))
16373 MJAC = HALF*MJAC*PS35/M35/TWOPI2
16374C--the generate the PT of 4
16375 CALL HWH2P2(2,PTJ(1),MT2(2),MQ2(2)+PTMAX**2,MQ2(2)+PTMIN**2)
16376 MT (2) = SQRT(MT2(2))
16377 PT2(2) = MT2(2)-MQ2(2)
16378 PT(2) = SQRT(PT2(2))
16379 MT35 = SQRT(M35S+PT2(2))
16380C--generate the rapidities of 4 and 35
16381 YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT35))
16382 YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT35))
16383 IF(YMAX.LT.YMIN) RETURN
16384 Y35 = HWRUNI(1,YMIN,YMAX)
16385 EY35 = EXP(Y35)
16386 YJAC = (YMAX-YMIN)
16387 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT35*EY35)/MT(2)))
16388 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT35/EY35)/MT(2)))
16389 IF(YMAX.LT.YMIN) RETURN
16390 Y(2) = HWRUNI(2,YMIN,YMAX)
16391 YJAC = (YMAX-YMIN)*YJAC
16392 EY(2) = EXP(Y(2))
16393C--generate the incoming quark momentum fractions
16394 XX(1) = (MT(2)*EY(2)+MT35*EY35)/ETOT
16395 XX(2) = (MT(2)/EY(2)+MT35/EY35)/ETOT
16396 STOT = XX(1)*XX(2)*STOT
16397C--azimuthal angle of 4 and 35
16398 PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC)
16399C--construct the momenta of 4 and 35
16400 PLAB(1,4) = PT(2)*SIN(PHI(1))
16401 PLAB(2,4) = PT(2)*COS(PHI(1))
16402 PLAB(3,4) = HALF*MT(2)*(EY(2)-ONE/EY(2))
16403 PLAB(4,4) = HALF*MT(2)*(EY(2)+ONE/EY(2))
16404 PLAB(5,4) = MQ(2)
16405 PLAB(1,6) =-PT(2)*SIN(PHI(1))
16406 PLAB(2,6) =-PT(2)*COS(PHI(1))
16407 PLAB(3,6) = HALF*MT35*(EY35-ONE/EY35)
16408 PLAB(4,6) = HALF*MT35*(EY35+ONE/EY35)
16409 PLAB(5,6) = M35
16410C--perform the decay 35 --> 3+5
16411 PLAB(5,3) = MQ(1)
16412 PLAB(5,5) = MQ(3)
16413 CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,5),PS35,TWO,.TRUE.)
16414C--phase space weight
16415 FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2
16416C--SECOND CHANNEL
16417 ELSEIF(ICH.EQ.2) THEN
16418C--first generate the pt's and azimuthal angles of 3 and 4
16419 DO I=1,2
16420 CALL HWH2P2(2,PTJ(I),MT2(I),MQ2(I)+PTMAX**2,MQ2(I)+PTMIN**2)
16421 PT2(I) = MT2(I)-MQ2(I)
16422 MT(I) = SQRT(MT2(I))
16423 PT(I) = SQRT(PT2(I))
16424 PHI(I) = HWRUNI(I,ZERO,TWO*PIFAC)
16425 ENDDO
16426C--find the pt and azimuth of 5 by conservation of transverse momentum
16427 A = PT(1)*SIN(PHI(1))+PT(2)*SIN(PHI(2))
16428 C = PT(1)*COS(PHI(1))+PT(2)*COS(PHI(2))
16429 PT(3) = A**2+C**2
16430 MT(3) = SQRT(PT(3)+MQ2(3))
16431 PT(3) = SQRT(PT(3))
16432 PHI(3) = -ACOS(-C/PT(3))
16433 IF(A.LT.ZERO) PHI(3)=-PHI(3)
16434C--generate the rapidities of 3,4 and 5
16435 XX(1) = ZERO
16436 XX(2) = ZERO
16437 YJAC = ONE
16438 DO I=1,3
16439 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-XX(1))/MT(I)))
16440 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-XX(2))/MT(I)))
16441 IF(YMAX.LT.YMIN) RETURN
16442 Y(I) = HWRUNI(I+2,YMIN,YMAX)
16443 EY(I) = EXP(Y(I))
16444 XX(1) = XX(1)+MT(I)*EY(I)
16445 XX(2) = XX(2)+MT(I)/EY(I)
16446 YJAC = YJAC*(YMAX-YMIN)
16447 ENDDO
16448C--generate the incoming quark momentum fractions
16449 XX(1) = XX(1)/PHEP(5,3)
16450 XX(2) = XX(2)/PHEP(5,3)
16451 IF(XX(1).GT.ONE.OR.XX(2).GT.ONE) RETURN
16452C--Construct the 4-momenta of the outgoing particles
16453 DO I=1,3
16454 PLAB(1,I+2) = PT(I)*SIN(PHI(I))
16455 PLAB(2,I+2) = PT(I)*COS(PHI(I))
16456 PLAB(3,I+2) = HALF*MT(I)*(EY(I)-ONE/EY(I))
16457 PLAB(4,I+2) = HALF*MT(I)*(EY(I)+ONE/EY(I))
16458 PLAB(5,I+2) = MQ(I)
16459 ENDDO
16460C--phase space weight
16461 STOT = XX(1)*XX(2)*STOT
16462 FLUX = YJAC*PTJ(1)*PTJ(2)/64.0D0/PIFAC/TWOPI2/STOT**2
16463C--THIRD CHANNEL
16464 ELSEIF(ICH.EQ.3) THEN
16465C--first generate the mass of 45
16466 CALL HWH2P1(2,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2)
16467 M45 = SQRT(M45S)
16468 PS45 = HWUPCM(M45,MQ(2),MQ(3))
16469 MJAC = HALF*MJAC*PS45/M45/TWOPI2
16470C--the generate the PT of 4
16471 CALL HWH2P2(2,PTJ(1),MT2(1),MQ2(1)+PTMAX**2,MQ2(1)+PTMIN**2)
16472 MT (1) = SQRT(MT2(1))
16473 PT2(1) = MT2(1)-MQ2(1)
16474 PT(1) = SQRT(PT2(1))
16475 MT45 = SQRT(M45S+PT2(1))
16476C--generate the rapidities of 3 and 45
16477 YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT45))
16478 YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT45))
16479 IF(YMAX.LT.YMIN) RETURN
16480 Y45 = HWRUNI(1,YMIN,YMAX)
16481 EY45 = EXP(Y45)
16482 YJAC = (YMAX-YMIN)
16483 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT45*EY45)/MT(1)))
16484 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT45/EY45)/MT(1)))
16485 IF(YMAX.LT.YMIN) RETURN
16486 Y(1) = HWRUNI(2,YMIN,YMAX)
16487 YJAC = (YMAX-YMIN)*YJAC
16488 EY(1) = EXP(Y(1))
16489C--generate the incoming quark momentum fractions
16490 XX(1) = (MT(1)*EY(1)+MT45*EY45)/ETOT
16491 XX(2) = (MT(1)/EY(1)+MT45/EY45)/ETOT
16492 STOT = XX(1)*XX(2)*STOT
16493C--azimuthal angle of 3 and 45
16494 PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC)
16495C--construct the momenta of 3 and 45
16496 PLAB(1,3) = PT(1)*SIN(PHI(1))
16497 PLAB(2,3) = PT(1)*COS(PHI(1))
16498 PLAB(3,3) = HALF*MT(1)*(EY(1)-ONE/EY(1))
16499 PLAB(4,3) = HALF*MT(1)*(EY(1)+ONE/EY(1))
16500 PLAB(5,3) = MQ(1)
16501 PLAB(1,6) =-PT(1)*SIN(PHI(1))
16502 PLAB(2,6) =-PT(1)*COS(PHI(1))
16503 PLAB(3,6) = HALF*MT45*(EY45-ONE/EY45)
16504 PLAB(4,6) = HALF*MT45*(EY45+ONE/EY45)
16505 PLAB(5,6) = M45
16506C--perform the decay 45 --> 4+5
16507 PLAB(5,4) = MQ(2)
16508 PLAB(5,5) = MQ(3)
16509 CALL HWDTWO(PLAB(1,6),PLAB(1,4),PLAB(1,5),PS45,TWO,.TRUE.)
16510C--phase space weight
16511 FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2
16512C--FOURTH CHANNEL
16513 ELSEIF(ICH.EQ.4) THEN
16514C--generate shat according to a power law
16515 CALL HWHGB1(1,2,200,SJAC,STOT,PHEP(5,3)**2,
16516 & (MQ(1)+MQ(2)+MQ(3))**2)
16517 ETOT = SQRT(STOT)
16518C--generate x1
16519 TAU = STOT/PHEP(5,3)**2
16520 XJAC = -LOG(TAU)
16521 XX(1) = EXP(HWRUNI(2,LOG(TAU),ZERO))
16522 XX(2) = TAU/XX(1)
16523C--generate m35
16524 CALL HWH2P1(2,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,
16525 & (MQ(1)+MQ(3))**2)
16526 M35 = SQRT(M35S)
16527 PS35 = HWUPCM(M35,MQ(1),MQ(3))
16528 MJAC = HALF*MJAC*PS35/M35/TWOPI2
16529C--generate the momenta of 4 and 35
16530 PST = HWUPCM(ETOT,M35,MQ(2))
16531 PLAB(1,7) = ZERO
16532 PLAB(2,7) = ZERO
16533 PLAB(3,7) = HALF*(XX(1)-XX(2))*PHEP(5,3)
16534 PLAB(4,7) = HALF*(XX(1)+XX(2))*PHEP(5,3)
16535 PLAB(5,7) = ETOT
16536 PLAB(5,3) = MQ(1)
16537 PLAB(5,6) = M35
16538 PLAB(5,4) = MQ(2)
16539 CALL HWDTWO(PLAB(1,7),PLAB(1,4),PLAB(1,6),PST,TWO,.TRUE.)
16540C--perform the decay 35 --> 3+5
16541 PLAB(5,4) = MQ(2)
16542 PLAB(5,5) = MQ(3)
16543 CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,5),PS35,TWO,.TRUE.)
16544C--phase space weight
16545 FLUX = SJAC*XJAC*MJAC*PST/ETOT/STOT**2/8.0D0/PIFAC
16546C--FIFTH CHANNEL
16547 ELSEIF(ICH.EQ.5) THEN
16548C--generate shat according to a power law
16549 CALL HWHGB1(1,2,200,SJAC,STOT,PHEP(5,3)**2,
16550 & (MQ(1)+MQ(2)+MQ(3))**2)
16551 ETOT = SQRT(STOT)
16552C--generate x1
16553 TAU = STOT/PHEP(5,3)**2
16554 XJAC = -LOG(TAU)
16555 XX(1) = EXP(HWRUNI(2,LOG(TAU),ZERO))
16556 XX(2) = TAU/XX(1)
16557C--generate m45
16558 CALL HWH2P1(2,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2)
16559 M45 = SQRT(M45S)
16560 PS45 = HWUPCM(M45,MQ(2),MQ(3))
16561 MJAC = HALF*MJAC*PS45/M45/TWOPI2
16562C--generate the momenta of 4 and 35
16563 PST = HWUPCM(ETOT,M45,MQ(1))
16564 PLAB(1,7) = ZERO
16565 PLAB(2,7) = ZERO
16566 PLAB(3,7) = HALF*(XX(1)-XX(2))*PHEP(5,3)
16567 PLAB(4,7) = HALF*(XX(1)+XX(2))*PHEP(5,3)
16568 PLAB(5,7) = ETOT
16569 PLAB(5,3) = MQ(1)
16570 PLAB(5,6) = M45
16571 CALL HWDTWO(PLAB(1,7),PLAB(1,3),PLAB(1,6),PST,TWO,.TRUE.)
16572C--perform the decay 45 --> 4+5
16573 PLAB(5,4) = MQ(2)
16574 PLAB(5,5) = MQ(3)
16575 CALL HWDTWO(PLAB(1,6),PLAB(1,4),PLAB(1,5),PS45,TWO,.TRUE.)
16576C--phase space weight
16577 FLUX = SJAC*XJAC*MJAC*PST/ETOT/STOT**2/8.0D0/PIFAC
16578C--SIXTH CHANNEL
16579 ELSEIF(ICH.EQ.6) THEN
16580C--first generate the mass of 34
16581 CALL HWH2P1(2,MJAC,ZERO,M34S,(ETOT-MQ(3))**2,MJJMIN**2)
16582 M34 = SQRT(M34S)
16583 PS34 = HWUPCM(M34,MQ(1),MQ(2))
16584 MJAC = HALF*MJAC*PS34/M34/TWOPI2
16585C--the generate the PT of 5
16586 CALL HWH2P2(2,PTJ(1),MT2(3),MQ2(3)+PTMAX**2,MQ2(3))
16587 MT (3) = SQRT(MT2(3))
16588 PT2(3) = MT2(3)-MQ2(3)
16589 PT(3) = SQRT(PT2(3))
16590 MT34 = SQRT(M34S+PT2(3))
16591C--generate the rapidities of 5 and 34
16592 YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT34))
16593 YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT34))
16594 IF(YMAX.LT.YMIN) RETURN
16595 Y34 = HWRUNI(1,YMIN,YMAX)
16596 EY34 = EXP(Y34)
16597 YJAC = (YMAX-YMIN)
16598 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT34*EY34)/MT(3)))
16599 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT34/EY34)/MT(3)))
16600 IF(YMAX.LT.YMIN) RETURN
16601 Y(3) = HWRUNI(2,YMIN,YMAX)
16602 YJAC = (YMAX-YMIN)*YJAC
16603 EY(3) = EXP(Y(3))
16604C--generate the incoming quark momentum fractions
16605 XX(1) = (MT(3)*EY(3)+MT34*EY34)/ETOT
16606 XX(2) = (MT(3)/EY(3)+MT34/EY34)/ETOT
16607 STOT = XX(1)*XX(2)*STOT
16608C--azimuthal angle of 3 and 45
16609 PHI(1) = HWRUNI(3,ZERO,TWO*PIFAC)
16610C--construct the momenta of 5 and 34
16611 PLAB(1,5) = PT(3)*SIN(PHI(1))
16612 PLAB(2,5) = PT(3)*COS(PHI(1))
16613 PLAB(3,5) = HALF*MT(3)*(EY(3)-ONE/EY(3))
16614 PLAB(4,5) = HALF*MT(3)*(EY(3)+ONE/EY(3))
16615 PLAB(5,5) = MQ(3)
16616 PLAB(1,6) =-PT(3)*SIN(PHI(1))
16617 PLAB(2,6) =-PT(3)*COS(PHI(1))
16618 PLAB(3,6) = HALF*MT34*(EY34-ONE/EY34)
16619 PLAB(4,6) = HALF*MT34*(EY34+ONE/EY34)
16620 PLAB(5,6) = M34
16621C--perform the decay 34 --> 3+4
16622 PLAB(5,3) = MQ(1)
16623 PLAB(5,4) = MQ(2)
16624 CALL HWDTWO(PLAB(1,6),PLAB(1,3),PLAB(1,4),PS34,TWO,.TRUE.)
16625C--phase space weight
16626 FLUX = MJAC*YJAC*PTJ(1)/16.0D0/PIFAC/STOT**2
16627 ELSE
16628 CALL HWWARN('HWH2PS',500)
16629 ENDIF
16630C--calculate the variables we need for the smoothing functions
16631C--pt,mt and y for outgoing particles
16632 DO I=1,3
16633 J=I+2
16634 PT2(I) = PLAB(1,J)**2+PLAB(2,J)**2
16635 PT(I) = SQRT(PT2(I))
16636 MT2(I) = MQ2(I)+PT2(I)
16637 MT(I) = SQRT(MT2(I))
16638 Y(I) = HALF*LOG((PLAB(4,J)+PLAB(3,J))/(PLAB(4,J)-PLAB(3,J)))
16639 EY(I) = EXP(Y(I))
16640 IF(I.LE.2.AND.(Y(I).LT.YJMIN.OR.Y(I).GT.YJMAX)) RETURN
16641 ENDDO
16642 IF(PT(1).LT.PTMIN.OR.PT(2).LT.PTMIN) RETURN
16643C--masses of composite particles
16644 M34S = (PLAB(4,3)+PLAB(4,4))**2
16645 M45S = (PLAB(4,4)+PLAB(4,5))**2
16646 M35S = (PLAB(4,3)+PLAB(4,5))**2
16647 DO I=1,3
16648 M34S = M34S-(PLAB(I,3)+PLAB(I,4))**2
16649 M45S = M45S-(PLAB(I,4)+PLAB(I,5))**2
16650 M35S = M35S-(PLAB(I,3)+PLAB(I,5))**2
16651 ENDDO
16652 M34 = SQRT(M34S)
16653 M45 = SQRT(M45S)
16654 M35 = SQRT(M35S)
16655 IF(M34.LT.MJJMIN) RETURN
16656C--tramsverse masses of the composite particles
16657 MT34 = ZERO
16658 MT35 = ZERO
16659 MT45 = ZERO
16660 DO I=1,2
16661 MT34 = MT34+(PLAB(I,3)+PLAB(I,4))**2
16662 MT35 = MT35+(PLAB(I,3)+PLAB(I,5))**2
16663 MT45 = MT45+(PLAB(I,4)+PLAB(I,5))**2
16664 ENDDO
16665 MT34 = SQRT(M34S+MT34)
16666 MT35 = SQRT(M35S+MT35)
16667 MT45 = SQRT(M45S+MT45)
16668C--final the momenta
16669 PS34 = HWUPCM(M34,MQ(1),MQ(2))
16670 PS35 = HWUPCM(M35,MQ(1),MQ(3))
16671 PS45 = HWUPCM(M45,MQ(2),MQ(3))
16672C--the rapidities of the composite particles
16673 ETMP = PLAB(4,3)+PLAB(4,4)
16674 PZTMP = PLAB(3,3)+PLAB(3,4)
16675 Y34 = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP))
16676 EY34 = EXP(Y34)
16677 ETMP = PLAB(4,3)+PLAB(4,5)
16678 PZTMP = PLAB(3,3)+PLAB(3,5)
16679 Y35 = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP))
16680 EY35 = EXP(Y35)
16681 ETMP = PLAB(4,4)+PLAB(4,5)
16682 PZTMP = PLAB(3,4)+PLAB(3,5)
16683 Y45 = HALF*LOG((ETMP+PZTMP)/(ETMP-PZTMP))
16684 EY45 = EXP(Y45)
16685C--find the pdf's and set the scale
16686 ETOT = SQRT(STOT)
16687 EMSCA = ETOT
16688 CALL HWSGEN(.FALSE.)
16689C--construct the incoming momenta
16690 DO I=1,2
16691 PLAB(1,I) = ZERO
16692 PLAB(2,I) = ZERO
16693 PLAB(3,I) = HALF*XX(I)*PHEP(5,3)
16694 PLAB(4,I) = HALF*XX(I)*PHEP(5,3)
16695 PLAB(5,I) = ZERO
16696 ENDDO
16697 PLAB(3,2) = -PLAB(3,2)
16698 TAU = XX(1)*XX(2)
16699C--find the smoothing functions for the different channels
16700C--function for first channel
16701 IF(CHON(1)) THEN
16702 CALL HWH2P1(1,MJAC,MQ2(1),M35S,(PHEP(5,3)-MQ(2))**2,
16703 & (MQ(1)+MQ(3))**2)
16704 MJAC = MJAC/PS35*M35
16705 CALL HWH2P2(1,PTJ(1),MT2(2),PTMAX**2+MQ2(2),MQ2(2)+PTMIN**2)
16706 YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT35))
16707 YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT35))
16708 YJAC = (YMAX-YMIN)
16709 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT35*EY35)/MT(2)))
16710 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT35/EY35)/MT(2)))
16711 YJAC = (YMAX-YMIN)*YJAC
16712 G(1) = 2.0D0*MJAC*PTJ(1)/YJAC
16713 ENDIF
16714C--function for second channel
16715 IF(CHON(2)) THEN
16716 DO I=1,2
16717 CALL HWH2P2(1,PTJ(I),MT2(I),PTMAX**2+MQ2(I),MQ2(I)+PTMIN**2)
16718 ENDDO
16719 XT1 = ZERO
16720 XT2 = ZERO
16721 YJAC = ONE
16722 DO I=1,3
16723 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-XT1)/MT(I)))
16724 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-XT2)/MT(I)))
16725 XT1 = XT1+MT(I)*EY(I)
16726 XT2 = XT2+MT(I)/EY(I)
16727 YJAC = YJAC*(YMAX-YMIN)
16728 ENDDO
16729 G(2) = 4.0D0*PTJ(1)*PTJ(2)/YJAC
16730 ENDIF
16731C--function for third channel
16732 IF(CHON(3)) THEN
16733 CALL HWH2P1(1,MJAC,MQ2(2),M45S,(PHEP(5,3)-MQ(1))**2,
16734 & (MQ(2)+MQ(3))**2)
16735 MJAC = MJAC/PS45*M45
16736 CALL HWH2P2(1,PTJ(1),MT2(1),PTMAX**2+MQ2(1),MQ2(1)+PTMIN**2)
16737 YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT45))
16738 YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT45))
16739 YJAC = (YMAX-YMIN)
16740 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT45*EY45)/MT(1)))
16741 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT45/EY45)/MT(1)))
16742 YJAC = (YMAX-YMIN)*YJAC
16743 G(3) = 2.0D0*MJAC*PTJ(1)/YJAC
16744 ENDIF
16745C--function for fourth channel
16746 IF(CHON(4)) THEN
16747 CALL HWHGB1(1,1,200,SJAC,STOT,PHEP(5,3)**2,
16748 & (MQ(1)+MQ(2)+MQ(3))**2)
16749 XJAC = -LOG(TAU)
16750 CALL HWH2P1(1,MJAC,MQ2(1),M35S,(ETOT-MQ(2))**2,(MQ(1)+MQ(3))**2)
16751 M35 = SQRT(M35S)
16752 MJAC = MJAC/PS35*M35
16753 PST = HWUPCM(ETOT,M35,MQ(2))
16754 G(4) = SJAC*MJAC/XJAC*ETOT/PST
16755 ENDIF
16756C--function for fifth channel
16757 IF(CHON(5)) THEN
16758 CALL HWHGB1(1,1,200,SJAC,STOT,PHEP(5,3)**2,
16759 & (MQ(1)+MQ(2)+MQ(3))**2)
16760 XJAC = -LOG(TAU)
16761 CALL HWH2P1(1,MJAC,MQ2(2),M45S,(ETOT-MQ(1))**2,(MQ(2)+MQ(3))**2)
16762 MJAC = MJAC/PS45*M45
16763 PST = HWUPCM(ETOT,M45,MQ(1))
16764 G(5) = SJAC/XJAC*MJAC/PST*ETOT
16765 ENDIF
16766C--function for sixth chaneel
16767 IF(CHON(6)) THEN
16768 CALL HWH2P1(1,MJAC,ZERO,M34S,(PHEP(5,3)-MQ(3))**2,MJJMIN**2)
16769 MJAC = MJAC/PS34*M34
16770 CALL HWH2P2(1,PTJ(1),MT2(3),MQ2(3)+PTMAX**2,MQ2(3))
16771 YMAX = MIN(YJJMAX, LOG(PHEP(5,3)/MT34))
16772 YMIN = MAX(YJJMIN,-LOG(PHEP(5,3)/MT34))
16773 YJAC = (YMAX-YMIN)
16774 YMAX = MIN(YJMAX, LOG((PHEP(5,3)-MT34*EY34)/MT(3)))
16775 YMIN = MAX(YJMIN,-LOG((PHEP(5,3)-MT34/EY34)/MT(3)))
16776 YJAC = (YMAX-YMIN)*YJAC
16777 G(6) = 2.0D0*MJAC/YJAC*PTJ(1)
16778 ENDIF
16779C--add them all up
16780 DEM = ZERO
16781 DO I=1,IMAXCH
16782 IF(CHON(I)) DEM = DEM+CHNPRB(I)*G(I)
16783 ENDDO
16784C--now the weight
16785 WEIGHT = FLUX*GEV2NB*G(ICH)/DEM
16786 GEN = .TRUE.
16787C--compute the weights for the different channels if optimizing
16788 IF(OPTM) THEN
16789 DO I=1,IMAXCH
16790 IF(CHON(I)) WI(I)=G(I)*WEIGHT**2/DEM
16791 ENDDO
16792 ENDIF
16793 END
16794CDECK ID>, HWH2P1.
16795*CMZ :- -02/04/01 12.11.55 by Peter Richardson
16796*-- Author : Peter Richardson
16797C-----------------------------------------------------------------------
16798 SUBROUTINE HWH2P1(IOPT,FJAC,MQ2,M2,MMX,MMN)
16799C-----------------------------------------------------------------------
16800C Subroutine to select virtual quark mass for HWH2PS
16801C IOPT=1 return the function at M2
16802C IOPT=2 calculate M2
16803C-----------------------------------------------------------------------
c63d70bc 16804 INCLUDE 'herwig65.inc'
65767955 16805 INTEGER IOPT
16806 DOUBLE PRECISION FJAC,MPOW,MMN,MQ2,M2,A1,A01,RPOW,QPOW,HWRGEN,MMX
16807 EXTERNAL HWRGEN
16808C--smooth a powerlaw
16809 IF(EMPOW.EQ.TWO) THEN
16810 A01 = LOG(MMN-MQ2)
16811 A1 = LOG(MMX-MQ2)-A01
16812 IF(IOPT.EQ.1) THEN
16813 FJAC = ONE/(M2-MQ2)/A1
16814 ELSE
16815 M2 = EXP(A01+A1*HWRGEN(2))
16816 FJAC = A1*M2
16817 M2 = M2+MQ2
16818 ENDIF
16819 ELSE
16820 MPOW = -EMPOW/TWO
16821 QPOW = ONE+MPOW
16822 RPOW = ONE/QPOW
16823 A01 = (MMN-MQ2)**QPOW
16824 A1 = (MMX-MQ2)**QPOW-A01
16825 IF(IOPT.EQ.1) THEN
16826 FJAC = QPOW*(M2-MQ2)**MPOW/A1
16827 ELSE
16828 M2 = (A01+A1*HWRGEN(2))**RPOW
16829 FJAC = A1*RPOW/M2**MPOW
16830 M2 = M2+MQ2
16831 ENDIF
16832 ENDIF
16833 END
16834CDECK ID>, HWH2P2.
16835*CMZ :- -02/04/01 12.11.55 by Peter Richardson
16836*-- Author : Peter Richardson
16837C-----------------------------------------------------------------------
16838 SUBROUTINE HWH2P2(IOPT,FJAC,PT2,PTMX2,PTMN2)
16839C-----------------------------------------------------------------------
16840C Subroutine to select virtual quark mass for HWH2PS
16841C IOPT=1 return the function at M2
16842C IOPT=2 calculate M2
16843C-----------------------------------------------------------------------
c63d70bc 16844 INCLUDE 'herwig65.inc'
65767955 16845 INTEGER IOPT
16846 DOUBLE PRECISION FJAC,MPOW,A1,A01,RPOW,QPOW,HWRGEN,PT2,
16847 & PPOW,PTMN2,PTMX2,Z
16848 EXTERNAL HWRGEN
16849C--smooth a powerlaw
16850 PPOW = HALF*PTPOW
16851 IF(PPOW.EQ.ONE) THEN
16852 A01 = LOG(PTMN2)
16853 A1 = LOG(PTMX2)-A01
16854 IF(IOPT.EQ.1) THEN
16855 FJAC = ONE/PT2/A1
16856 ELSE
16857 PT2 = EXP(A01+A1*HWRGEN(2))
16858 FJAC = A1*PT2
16859 ENDIF
16860 ELSE
16861 MPOW = -PPOW
16862 QPOW = ONE+MPOW
16863 RPOW = ONE/QPOW
16864 A01 = PTMN2**QPOW
16865 A1 = PTMX2**QPOW-A01
16866 IF(IOPT.EQ.1) THEN
16867 FJAC = QPOW*PT2**MPOW/A1
16868 ELSE
16869 Z = A01+A1*HWRGEN(2)
16870 PT2 = Z**RPOW
16871 FJAC = A1*RPOW/Z*PT2
16872 ENDIF
16873 ENDIF
16874 END
16875CDECK ID>, HWH2QH.
16876*CMZ :- -26/11/00 17.21.55 by Bryan Webber
16877*-- Author : Kosuke Odagiri
16878C-----------------------------------------------------------------------
16879 SUBROUTINE HWH2QH(SQS,P1,P2,P3,P4,P5,RM3,RM4,RM5,FACGPM,MGM3,
16880 & IGG,IQQ,GGQQHT,GGQQHU,GGQQHNP,QQQQH)
16881C-----------------------------------------------------------------------
16882C MATRIX ELEMENT SQUARED FOR THE PROCESS GG/QQ(BAR) -> QQ(BAR) HIGGS
16883C-----------------------------------------------------------------------
16884C NEEDS PREFACTOR G_S^4. COUPLINGS, E.G. FOR T(3)B(4)H-(5) ARE:
16885C FACGPM(1) = GW/SQRT(TWO) M_B / M_W * TANB
16886C FACGPM(2) = GW/SQRT(TWO) M_T / M_W / TANB
16887C MGM3 = (TOP MASS)*(TOP WIDTH)
16888C INITIAL STATE MOMENTA: P1=(SQS/2)(1,0,0,1), P2=(SQS/2)(1,0,0,-1)
16889C PREFACTORS:
16890C GGQQHTOT = (G_S**4)*(GGQQHT+GGQQHU-GGQQHNP/CAFAC**2)/(8.*CFFAC)
16891C QQQQHTOT = (G_S**4)*(QQQQH )*(1.-1./CAFAC**2)/4.
16892C N.B. SUBROUTINE CANNOT BE USED FOR PHOTON PHOTON -> ...
16893C-----------------------------------------------------------------------
16894 IMPLICIT NONE
16895C --- SUBPROCESS
16896 INTEGER IGG,IQQ
16897C --- CENTRE-OF-MASS ENERGY, FOUR-MOMENTA, MASSES AND WIDTHS
16898 DOUBLE PRECISION SQS,P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
16899 DOUBLE PRECISION K3(0:3),K4(0:3), Q3(0:3),Q4(0:3), R3(0:3),R4(0:3)
16900 DOUBLE PRECISION RM3,RM4,RM5, MGM3,MGM4, TWOSQS
16901C --- SPINORS
16902 DOUBLE COMPLEX U0(4), F3(4,2),F4(4,2), F3K(4,2),F4K(4,2)
16903 DOUBLE COMPLEX F3Q(4,2,2),F4Q(4,2,2), F3R(4,2,2),F4R(4,2,2)
16904C --- MOMENTUM PROJECTION OPERATORS
16905 DOUBLE COMPLEX P3PROJ(4,4),P4PROJ(4,4),K3PROJ(4,4),K4PROJ(4,4)
16906 DOUBLE COMPLEX Q3PROJ(4,4),Q4PROJ(4,4),R3PROJ(4,4),R4PROJ(4,4)
16907C --- SPINOR INDICES AND PERMUTATION MATRICES
16908 INTEGER I,J,K,L, PERM0(4), PL(4,2),PR(4,2), PERMU0(4)
16909C --- CHIRALITY PROJECTION OPERATORS: 1 = - , 2 = +
16910 DOUBLE PRECISION FACGPM(2),FACL(2,2),FACR(2,2),FAC0(2,2)
16911C --- GG AMPLITUDES
16912 DOUBLE COMPLEX AMPS1(2,2),AMPS2(2,2)
16913 DOUBLE COMPLEX AMPT1(2,2,2,2),AMPT2(2,2,2,2),AMPT3(2,2,2,2)
16914 DOUBLE COMPLEX AMPU1(2,2,2,2),AMPU2(2,2,2,2),AMPU3(2,2,2,2)
16915 DOUBLE COMPLEX AMPS, AMPT, AMPU, AMPST, AMPSU, AMPTU
16916 DOUBLE PRECISION AMPST2, AMPSU2, AMPTU2
16917 DOUBLE PRECISION GGQQHT,GGQQHU,GGQQHNP,QQQQH
16918C --- QQ AMPLITUDES
16919 DOUBLE PRECISION RM3452
16920 DOUBLE PRECISION S,PT32,PT42,PT52,GLAMBDA,LAMBDA,LAMBDAI,LA34,
16921 & PROP2,PROP3R,PROP3I,PROP4R,PROP4I,PROP34R,PT3452
16922 DOUBLE COMPLEX PROP3,PROP4,PROP
16923C --- CONSTANTS
16924 DOUBLE PRECISION ZERO,ONE,TWO,MONE,FAC
16925 DOUBLE COMPLEX CZERO,CONE
16926 INTEGER LEFT,RIGHT
16927C --- PARAMETER DEFINITIONS
16928 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,MONE=-ONE, LEFT=1,RIGHT=2)
16929 PARAMETER (CZERO=(0.D0,0.D0),CONE=(1.D0,0.D0))
16930 SAVE MGM4,PERM0,PL,FACL,PR,FACR,PERMU0,FAC0,U0
16931 DATA MGM4,U0,FAC0 /ZERO, 4*CONE , ONE,ZERO, ZERO, ONE /
16932 DATA PERM0 ,PERMU0 / 1,2, 3,4 , 1,0, 0,4 /
16933 DATA PL ,PR / 0,3, 0,1, 4,0, 2,0, 4,0, 2,0, 0,3, 0,1 /
16934 DATA FACL ,FACR /MONE, ONE, ONE,MONE, ONE,MONE, MONE, ONE /
16935C --- INITIALIZE
16936 GGQQHT=ZERO
16937 GGQQHU=ZERO
16938 GGQQHNP=ZERO
16939 QQQQH=ZERO
16940C --- GG ME.
16941 IF(IGG.EQ.0)GOTO 100
16942 TWOSQS = 0.5D0/SQS
16943 DO I = 0, 3
16944 Q3(I) = P3(I)-P1(I)
16945 Q4(I) = P4(I)-P2(I)
16946 R3(I) = P3(I)-P2(I)
16947 R4(I) = P4(I)-P1(I)
16948 K3(I) = P3(I)+P5(I)
16949 K4(I) = P4(I)+P5(I)
16950 END DO
16951 CALL HWUMPO(P3, RM3, (P3(0)-P3(3)) ,ZERO,P3PROJ, .FALSE.)
16952 CALL HWUMPO(P4,-RM4, (P4(0)+P4(3)) ,ZERO,P4PROJ, .FALSE.)
16953 CALL HWUMPO(Q3, RM3,-SQS*(P3(0)-P3(3)) ,ZERO,Q3PROJ, .FALSE.)
16954 CALL HWUMPO(Q4,-RM4,-SQS*(P4(0)+P4(3)) ,ZERO,Q4PROJ, .FALSE.)
16955 CALL HWUMPO(R3, RM3,-SQS*(P3(0)+P3(3)) ,ZERO,R3PROJ, .FALSE.)
16956 CALL HWUMPO(R4,-RM4,-SQS*(P4(0)-P4(3)) ,ZERO,R4PROJ, .FALSE.)
16957 CALL HWUMPO(K3, RM4,SQS*(SQS-2.D0*P4(0)),MGM4,K3PROJ, .TRUE.)
16958 CALL HWUMPO(K4,-RM3,SQS*(SQS-2.D0*P3(0)),MGM3,K4PROJ, .TRUE.)
16959 DO I=1,2
16960 CALL HWUMPP(P3PROJ,FAC0(1,I),PERMU0 ,U0 ,F3(1,I) , LEFT)
16961 CALL HWUMPP(K3PROJ,FACGPM ,PERM0 ,F3(1,I),F3K(1,I) , LEFT)
16962 CALL HWUMPP(P4PROJ,FAC0(1,I),PERMU0 ,U0 ,F4(1,I) , RIGHT)
16963 CALL HWUMPP(K4PROJ,FACGPM ,PERM0 ,F4(1,I),F4K(1,I) , RIGHT)
16964 DO J=1,2
16965 CALL HWUMPP(Q3PROJ,FACL(1,J),PL(1,J),F3(1,I),F3Q(1,I,J), LEFT)
16966 CALL HWUMPP(R3PROJ,FACL(1,J),PL(1,J),F3(1,I),F3R(1,I,J), LEFT)
16967 CALL HWUMPP(R4PROJ,FACR(1,J),PR(1,J),F4(1,I),F4R(1,I,J), RIGHT)
16968 CALL HWUMPP(Q4PROJ,FACR(1,J),PR(1,J),F4(1,I),F4Q(1,I,J), RIGHT)
16969 END DO
16970 END DO
16971 DO I=1,2
16972 DO J=1,2
16973 AMPS1(I,J)=( - F3K(1,I)* F4(3,J) + F3K(2,I)* F4(4,J)
16974 & + F3K(3,I)* F4(1,J) - F3K(4,I)* F4(2,J) ) * TWOSQS
16975 AMPS2(I,J)=( - F3(1,I)*F4K(3,J) + F3(2,I)*F4K(4,J)
16976 & + F3(3,I)*F4K(1,J) - F3(4,I)*F4K(2,J) ) * TWOSQS
16977 DO K=1,2
16978 AMPT1(1,K,I,J)= F3K(1,I)*F4Q(4,J,K)-F3K(3,I)*F4Q(2,J,K)
16979 AMPT1(2,K,I,J)=-F3K(2,I)*F4Q(3,J,K)+F3K(4,I)*F4Q(1,J,K)
16980 AMPT3(K,1,I,J)= F3Q(1,I,K)*F4K(4,J)-F3Q(3,I,K)*F4K(2,J)
16981 AMPT3(K,2,I,J)=-F3Q(2,I,K)*F4K(3,J)+F3Q(4,I,K)*F4K(1,J)
16982 AMPU1(K,1,I,J)= F3K(1,I)*F4R(4,J,K)-F3K(3,I)*F4R(2,J,K)
16983 AMPU1(K,2,I,J)=-F3K(2,I)*F4R(3,J,K)+F3K(4,I)*F4R(1,J,K)
16984 AMPU3(1,K,I,J)= F3R(1,I,K)*F4K(4,J)-F3R(3,I,K)*F4K(2,J)
16985 AMPU3(2,K,I,J)=-F3R(2,I,K)*F4K(3,J)+F3R(4,I,K)*F4K(1,J)
16986 DO L=1,2
16987 AMPT2(K,L,I,J)
16988 & = FACGPM(1)*( F3Q(1,I,K)*F4Q(1,J,L)+F3Q(2,I,K)*F4Q(2,J,L) )
16989 & + FACGPM(2)*( F3Q(3,I,K)*F4Q(3,J,L)+F3Q(4,I,K)*F4Q(4,J,L) )
16990 AMPU2(L,K,I,J)
16991 & = FACGPM(1)*( F3R(1,I,K)*F4R(1,J,L)+F3R(2,I,K)*F4R(2,J,L) )
16992 & + FACGPM(2)*( F3R(3,I,K)*F4R(3,J,L)+F3R(4,I,K)*F4R(4,J,L) )
16993 END DO
16994 END DO
16995 END DO
16996 END DO
16997 AMPST2 = ZERO
16998 AMPSU2 = ZERO
16999 AMPTU2 = ZERO
17000 DO I = 1, 2
17001 DO J = 1, 2
17002 DO K = 1, 2
17003 DO L = 1, 2
17004 IF (I.NE.J) THEN
17005 AMPS = AMPS1(K,L) - AMPS2(K,L)
17006 ELSE
17007 AMPS = CZERO
17008 END IF
17009 AMPT = AMPT1(I,J,K,L)+AMPT2(I,J,K,L)+AMPT3(I,J,K,L)
17010 AMPU = AMPU1(I,J,K,L)+AMPU2(I,J,K,L)+AMPU3(I,J,K,L)
17011 AMPST = AMPS - AMPT
17012 AMPSU = AMPS + AMPU
17013 AMPTU = AMPT + AMPU
17014 AMPST2 = AMPST2 + DREAL(DCONJG(AMPST)*AMPST)
17015 AMPSU2 = AMPSU2 + DREAL(DCONJG(AMPSU)*AMPSU)
17016 AMPTU2 = AMPTU2 + DREAL(DCONJG(AMPTU)*AMPTU)
17017 END DO
17018 END DO
17019 END DO
17020 END DO
17021 FAC = (P3(0)-P3(3))*(P4(0)+P4(3))
17022 GGQQHT = FAC*AMPST2
17023 GGQQHU = FAC*AMPSU2
17024 GGQQHNP = FAC*AMPTU2
17025 100 CONTINUE
17026C --- QQ ME.
17027 IF(IQQ.EQ.0)GOTO 200
17028 S = SQS**2
17029 PT32 = P3(1)**2+P3(2)**2
17030 PT42 = P4(1)**2+P4(2)**2
17031 PT52 = P5(1)**2+P5(2)**2
17032 PT3452 = (PT32+PT42-PT52)/TWO
17033 RM3452 = (RM3**2+RM4**2-RM5**2)/TWO
17034 GLAMBDA = FACGPM(1)**2+FACGPM(2)**2
17035 LAMBDA = TWO*FACGPM(1)*FACGPM(2)/GLAMBDA
17036 LAMBDAI = (FACGPM(2)**2-FACGPM(1)**2)/GLAMBDA
17037 LA34 = S/TWO-SQS*P5(0)-RM3452-LAMBDA*RM3*RM4
17038 PROP3 = ONE/DCMPLX(SQS*(SQS-TWO*P4(0)),ZERO)
17039 PROP4 = ONE/DCMPLX(SQS*(SQS-TWO*P3(0)),MGM3)
17040 PROP = PROP3+PROP4
17041 PROP2 = DREAL(DCONJG(PROP)*PROP)
17042 PROP3R = DREAL(DCONJG(PROP)*PROP3)
17043 PROP3I = DIMAG(DCONJG(PROP)*PROP3)
17044 PROP4R = DREAL(DCONJG(PROP)*PROP4)
17045 PROP4I = DIMAG(DCONJG(PROP)*PROP4)
17046 PROP34R = DREAL(DCONJG(PROP3)*PROP4)
17047 QQQQH = TWO*GLAMBDA/S*(S*PROP2*(PT3452+TWO*P3(0)*P4(0)-
17048 & LA34)+TWO*LA34*(PROP3R*PT42+PROP4R*PT32-PROP34R*PT52)-TWO*SQS*((
17049 & PROP3R*(P3(0)*PT42+P4(0)*PT3452)+PROP4R*(P4(0)*PT32+P3(0)*PT3452)
17050 & )-(PROP3I*P4(3)-PROP4I*P3(3))*LAMBDAI*(P3(1)*P4(2)-P3(2)*P4(1))))
17051 200 CONTINUE
17052 END
17053CDECK ID>, HWH2SH.
17054*CMZ :- -30/06/01 18.25.35 by Stefano Moretti
17055*-- Author : Kosuke Odagiri & Stefano Moretti
17056C-----------------------------------------------------------------------
17057 SUBROUTINE HWH2SH(SQS,P1,P2,P3,P4,P5,RM3,RM4,RM5,MGM3,MGM4,
17058 & IGG,IQQ,GGSQHT,GGSQHU,GGSQHN,QQSQH)
17059C-----------------------------------------------------------------------
17060C MATRIX ELEMENT SQUARED FOR THE PROCESS GG/QQ(BAR) -> SQ SQ* HIGGS
17061C-----------------------------------------------------------------------
17062C NEEDS PREFACTOR G_S^4 AND G_(HIGGS-SQ-SQ)^2
17063C MGM3, MGM4 = MASS * WIDTH
17064C INITIAL STATE MOMENTA: P1=(SQS/2)(1,0,0,1), P2=(SQS/2)(1,0,0,-1)
17065C PREFACTORS:
17066C GGSQHTOT =
17067C (G_S**4)*(G_HIGGS**2)*(GGSQHT+GGSQHU-GGSQHN/CAFAC**2)/(8.*CFFAC)
17068C QQSQHTOT =
17069C (G_S**4)*(G_HIGGS**2)*(QQSQH )*(1.-1./CAFAC**2)/4.
17070C N.B. SUBROUTINE CANNOT BE USED FOR PHOTON PHOTON -> ...
17071C
17072C...First release: 08-OCT-1999 by Kosuke Odagiri
17073C...First modified: 12-NOV-1999 by Stefano Moretti
17074C-----------------------------------------------------------------------
17075 IMPLICIT NONE
17076C --- SUBPROCESS
17077 INTEGER IGG,IQQ
17078C --- CENTRE-OF-MASS ENERGY, FOUR-MOMENTA, MASSES AND WIDTHS
17079 DOUBLE PRECISION SQS,P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
17080 DOUBLE PRECISION RM3,RM4,RM5, MGM3,MGM4
17081C --- POLARISATION INDICES, PROPAGATORS AND GG AMPLITUDES
17082 INTEGER I,J
17083 DOUBLE PRECISION G14,G24,G23,G13,MSQS, GGSQHT,GGSQHU,GGSQHN
17084 DOUBLE COMPLEX G35,G45, AMPT,AMPU,AMPS,AMPC, AMPST,AMPSU,AMPTU
17085C --- QQ AMPLITUDES
17086 DOUBLE PRECISION QQSQH
17087 DOUBLE PRECISION PT32,PT42,PT34
17088 DOUBLE COMPLEX PROP3,PROP4
17089C --- CONSTANT PARAMETERS
17090 DOUBLE PRECISION ZERO,ONE,TWO,SQTWO,MSQTWO
17091 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0)
17092 SQTWO=SQRT(TWO)
17093 MSQTWO=-SQTWO/4.D0
17094 GGSQHT = ZERO
17095 GGSQHU = ZERO
17096 GGSQHN = ZERO
17097 QQSQH = ZERO
17098 IF(IGG.EQ.0)GOTO 100
17099C -- GG SCATTERING.
17100 MSQS = -SQTWO/SQS
17101 G13 = MSQS/(P3(0)-P3(3))
17102 G23 = MSQS/(P3(0)+P3(3))
17103 G14 = MSQS/(P4(0)-P4(3))
17104 G24 = MSQS/(P4(0)+P4(3))
17105 G35 = SQTWO/CMPLX(SQS*(SQS-TWO*P4(0)),MGM4)
17106 G45 = SQTWO/CMPLX(SQS*(SQS-TWO*P3(0)),MGM3)
17107 AMPS = 0.5D0*MSQS*(P4(3)*G35-P3(3)*G45)
17108 AMPC = MSQTWO*(G35+G45)
17109 DO 10 I = 1,2
17110 DO 20 J = 1,2
17111 AMPT=P3(I)*P4(J)*G24*G13-P4(I)*P4(J)*G24*G35-P3(I)*P3(J)*G13*G45
17112 AMPU=P4(I)*P3(J)*G14*G23-P4(I)*P4(J)*G14*G35-P3(I)*P3(J)*G23*G45
17113 IF (I.EQ.J) THEN
17114 AMPST = AMPT-AMPS+AMPC
17115 AMPSU = AMPU+AMPS+AMPC
17116 ELSE
17117 AMPST = AMPT
17118 AMPSU = AMPU
17119 END IF
17120 AMPTU = AMPST+AMPSU
17121 GGSQHT = GGSQHT + DREAL(DCONJG(AMPST)*AMPST)
17122 GGSQHU = GGSQHU + DREAL(DCONJG(AMPSU)*AMPSU)
17123 GGSQHN = GGSQHN + DREAL(DCONJG(AMPTU)*AMPTU)
17124 20 CONTINUE
17125 10 CONTINUE
17126 100 CONTINUE
17127 IF(IQQ.EQ.0)GOTO 200
17128C -- QQ SCATTERING.
17129 PT32 = P3(1)**2+P3(2)**2
17130 PT42 = P4(1)**2+P4(2)**2
17131 PT34 = P3(1)*P4(1)+P3(2)*P4(2)
17132 PROP3 = ONE/CMPLX(SQS*(SQS-TWO*P3(0)),MGM3)
17133 PROP4 = ONE/CMPLX(SQS*(SQS-TWO*P4(0)),MGM4)
17134 QQSQH = TWO/SQS**2*DREAL(PT32*DCONJG(PROP3)*PROP3+
17135 & PT42*DCONJG(PROP4)*PROP4-TWO*PT34*DCONJG(PROP3)*PROP4)
17136 200 CONTINUE
17137 END
17138CDECK ID>, HWH2SS
17139*CMZ :- -27/02/01 17:04:16 by Peter Richardson
17140C-----------------------------------------------------------------------
17141 SUBROUTINE HWH2SS(S,K,KK)
17142C-----------------------------------------------------------------------
17143C Subroutine to calculate the spinor products in the notation of
17144C Kleiss and Strirling S(1) is S and S(2) is T
17145C-----------------------------------------------------------------------
c63d70bc 17146 INCLUDE 'herwig65.inc'
65767955 17147 DOUBLE PRECISION WRN(2),K(5),KK(5),P(5,2),Q1,Q2,EPS,QTI,PTI,
17148 & PT,QT,DPM,DMP,QP,QM,P1,P2,PP,PM
17149 DOUBLE COMPLEX S(2),ZI,Z1,ZT,ZQ,ZQS,ZPS,ZP,ZDPM,ZDMP
17150 INTEGER I,II,JJ
17151 EPS=0.0000001
17152 ZI=DCMPLX(ZERO,ONE)
17153 Z1=DCMPLX(ONE,ZERO)
17154C FOLLOWING DO LOOP IS TO CONVERT TO OUR STANDARD INDEXING
17155 DO I=1,4
17156 P(I,2) = K(I)
17157 P(I,1) = KK(I)
17158 ENDDO
17159 DO 2 II=1,2
17160 WRN(II)=ONE
17161 IF(P(4,II).LT.ZERO) WRN(II)=-ONE
17162 DO 2 JJ=1,4
17163 P(JJ,II)=WRN(II)*P(JJ,II)
17164 2 CONTINUE
17165C THE ABOVE CHECKS FOR MOMENTA WITH NEGATIVE ENERGY,INNER PRODUCTS
17166C ARE EXPRESSED DIFFERENTLY FOR DIFFERENT CASES
17167 Q1=P(4,1)+P(1,1)
17168 QP=ZERO
17169 IF(Q1.GT.EPS) QP=SQRT(Q1)
17170 Q2=P(4,1)-P(1,1)
17171 QM=0.0
17172 IF(Q2.GT.EPS)QM=SQRT(Q2)
17173 P1=P(4,2)+P(1,2)
17174 PP=ZERO
17175 IF(P1.GT.EPS)PP=SQRT(P1)
17176 P2=P(4,2)-P(1,2)
17177 PM=ZERO
17178 IF(P2.GT.EPS)PM=SQRT(P2)
17179 DMP=PM*QP
17180 ZDMP=DCMPLX(DMP,ZERO)
17181 DPM=PP*QM
17182 ZDPM=DCMPLX(DPM,ZERO)
17183C NOTE THAT IN OUR INNER PRODUCT NOTATION WE ARE COMPUTING <P,Q>
17184 PT=SQRT(P(2,2)**2+P(3,2)**2)
17185 QT=SQRT(P(2,1)**2+P(3,1)**2)
17186 IF(PT.GT.EPS) GOTO 99
17187 ZP=Z1
17188 GOTO 98
17189 99 PTI=ONE/PT
17190 ZP=DCMPLX(PTI*P(2,2),PTI*P(3,2))
17191 98 ZPS=DCONJG(ZP)
17192 IF(QT.GT.EPS) GOTO 89
17193 ZQ=Z1
17194 GOTO 88
17195 89 QTI=ONE/QT
17196 ZQ=DCMPLX(QTI*P(2,1),QTI*P(3,1))
17197 88 ZQS=DCONJG(ZQ)
17198 ZT=Z1
17199 IF(WRN(1).LT.ZERO) ZT=ZT*ZI
17200 IF(WRN(2).LT.ZERO) ZT=ZT*ZI
17201 S(2)=-(ZDMP*ZP-ZDPM*ZQ)*ZT
17202 S(1)=(ZDMP*ZPS-ZDPM*ZQS)*ZT
17203 END
17204CDECK ID>, HWH2T1.
17205*CMZ :- -27/02/01 17:04:16 by Peter Richardson
17206*-- Author : Peter Richardson
17207C-----------------------------------------------------------------------
17208 FUNCTION HWH2T1(I,J,K,L,Z1,Z2,P1)
17209C-----------------------------------------------------------------------
17210C Returns the amplitude T1 from Nucl. Phys. B262 (1985) 235-262
17211C I-L are the particles
17212C Z1 and Z2 are the decay products of the Z
17213C P1 is the polarization of the line I,J
17214C-----------------------------------------------------------------------
c63d70bc 17215 INCLUDE 'herwig65.inc'
65767955 17216 DOUBLE COMPLEX HWH2T1,S,D
17217 INTEGER I,J,K,L,Z1,Z2,P1
17218 COMMON/HWHEWS/S(8,8,2),D(8,8)
17219 IF(P1.EQ.1) THEN
17220 HWH2T1 = TWO*S(I,Z2,1)*S(Z1,J,2)
17221 ELSEIF(P1.EQ.2) THEN
17222 HWH2T1 = TWO*S(I,Z1,2)*S(Z2,J,1)
17223 ELSE
17224 CALL HWWARN('HWH2T1',500)
17225 ENDIF
17226 END
17227CDECK ID>, HWH2T2
17228*CMZ :- -27/02/01 17:04:16 by Peter Richardson
17229*-- Author : Peter Richardson
17230C-----------------------------------------------------------------------
17231 FUNCTION HWH2T2(I,J,K,L,Z1,Z2,P1,P2)
17232C-----------------------------------------------------------------------
17233C Returns the amplitude T2 from Nucl. Phys. B262 (1985) 235-262
17234C I-L are the particles
17235C Z1 and Z2 are the decay products of the Z
17236C P1 is the polarization of the line I,J
17237C P2 is the polarization of the gluon K
17238C-----------------------------------------------------------------------
c63d70bc 17239 INCLUDE 'herwig65.inc'
65767955 17240 DOUBLE COMPLEX HWH2T2,S,D
17241 INTEGER I,J,K,L,Z1,Z2,P1,P2
17242 DOUBLE PRECISION B(6)
17243 COMMON/HWHEWS/S(8,8,2),D(8,8)
17244 SAVE B
17245 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17246 IF(P1.EQ.1.AND.P2.EQ.1) THEN
17247 HWH2T2 = FOUR*B(J)*S(I,Z2,1)*S(Z1,J,2)*S(J,K,1)*S(I,J,2)
17248 ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
17249 HWH2T2 = FOUR*S(I,Z2,1)*S(K,J,2)*(B(J)*S(Z1,J,2)*S(J,I,1)
17250 & +B(K)*S(Z1,K,2)*S(K,I,1))
17251 ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
17252 HWH2T2 = FOUR*S(I,Z1,2)*S(K,J,1)*(B(J)*S(Z2,J,1)*S(J,I,2)
17253 & +B(K)*S(Z2,K,1)*S(K,I,2))
17254 ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
17255 HWH2T2 = FOUR*B(J)*S(I,Z1,2)*S(Z2,J,1)*S(J,K,2)*S(I,J,1)
17256 ELSE
17257 CALL HWWARN('HWH2T2',500)
17258 ENDIF
17259 END
17260CDECK ID>, HWH2T3.
17261*CMZ :- -27/02/01 17:04:16 by Peter Richardson
17262*-- Author : Peter Richardson
17263C-----------------------------------------------------------------------
17264 FUNCTION HWH2T3(I,J,K,L,Z1,Z2,P1,P2)
17265C-----------------------------------------------------------------------
17266C Returns the amplitude T3 from Nucl. Phys. B262 (1985) 235-262
17267C I-L are the particles
17268C Z1 and Z2 are the decay products of the Z
17269C P1 is the polarization of the line I,J
17270C P2 is the polarization of the gluon K
17271C-----------------------------------------------------------------------
c63d70bc 17272 INCLUDE 'herwig65.inc'
65767955 17273 DOUBLE COMPLEX HWH2T3,S,D
17274 INTEGER I,J,K,L,Z1,Z2,P1,P2
17275 DOUBLE PRECISION B(6)
17276 COMMON/HWHEWS/S(8,8,2),D(8,8)
17277 SAVE B
17278 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17279 IF(P1.EQ.1.AND.P2.EQ.1) THEN
17280 HWH2T3 = FOUR*B(K)*S(I,K,1)*S(I,K,2)*S(K,Z2,1)*S(Z1,J,2)
17281 ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
17282 HWH2T3 = ZERO
17283 ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
17284 HWH2T3 = ZERO
17285 ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
17286 HWH2T3 = FOUR*B(K)*S(I,K,2)*S(I,K,1)*S(K,Z1,2)*S(Z2,J,1)
17287 ELSE
17288 CALL HWWARN('HWH2T3',500)
17289 ENDIF
17290 END
17291CDECK ID>, HWH2T4
17292*CMZ :- -27/02/01 17:04:16 by Peter Richardson
17293*-- Author : Peter Richardson
17294C-----------------------------------------------------------------------
17295 FUNCTION HWH2T4(I,J,K,L,Z1,Z2,P1,P2)
17296C-----------------------------------------------------------------------
17297C Returns the amplitude T4 from Nucl. Phys. B262 (1985) 235-262
17298C I-L are the particles
17299C Z1 and Z2 are the decay products of the Z
17300C P1 is the polarization of the line I,J
17301C P2 is the polarization of the line K,L
17302C-----------------------------------------------------------------------
c63d70bc 17303 INCLUDE 'herwig65.inc'
65767955 17304 DOUBLE COMPLEX HWH2T4,AP,AM,S,D
17305 INTEGER I,J,K,L,Z1,Z2,J1,J2,J3,J4,P1,P2
17306 DOUBLE PRECISION B(6)
17307 COMMON/HWHEWS/S(8,8,2),D(8,8)
17308 SAVE B
17309 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17310 AP(J1,J2,J3,J4) = FOUR*S(J1,Z2,1)*S(J4,J2,2)*
17311 & (S(Z1,Z2,2)*S(Z2,J3,1)+B(J1)*S(Z1,J1,2)*S(J1,J3,1))
17312 AM(J1,J2,J3,J4) = FOUR*S(J1,Z1,2)*S(J4,J2,1)*
17313 & (S(Z2,Z1,1)*S(Z1,J3,2)+B(J1)*S(Z2,J1,1)*S(J1,J3,2))
17314 IF(P1.EQ.1.AND.P2.EQ.1) THEN
17315 HWH2T4 = AP(I,J,K,L)
17316 ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
17317 HWH2T4 = AP(I,J,L,K)
17318 ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
17319 HWH2T4 = AM(I,J,L,K)
17320 ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
17321 HWH2T4 = AM(I,J,K,L)
17322 ELSE
17323 CALL HWWARN('HWH2T4',500)
17324 ENDIF
17325 END
17326CDECK ID>, HWH2T5
17327*CMZ :- -27/02/01 17:04:16 by Peter Richardson
17328*-- Author : Peter Richardson
17329C-----------------------------------------------------------------------
17330 FUNCTION HWH2T5(I,J,K,L,Z1,Z2,P1,P2)
17331C-----------------------------------------------------------------------
17332C Returns the amplitude T5 from Nucl. Phys. B262 (1985) 235-262
17333C I-L are the particles
17334C Z1 and Z2 are the decay products of the Z
17335C P1 is the polarization of the line I,J
17336C P2 is the polarization of the line K,L
17337C-----------------------------------------------------------------------
c63d70bc 17338 INCLUDE 'herwig65.inc'
65767955 17339 DOUBLE COMPLEX HWH2T5,AP,AM,S,D
17340 INTEGER I,J,K,L,Z1,Z2,J1,J2,J3,J4,P1,P2
17341 DOUBLE PRECISION B(6)
17342 COMMON/HWHEWS/S(8,8,2),D(8,8)
17343 SAVE B
17344 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17345 AP(J1,J2,J3,J4) = FOUR*S(J1,Z2,1)*S(J4,J2,2)*
17346 & (S(Z1,Z2,2)*S(Z2,J3,1)+B(J1)*S(Z1,J1,2)*S(J1,J3,1))
17347 AM(J1,J2,J3,J4) = FOUR*S(J1,Z1,2)*S(J4,J2,1)*
17348 & (S(Z2,Z1,1)*S(Z1,J3,2)+B(J1)*S(Z2,J1,1)*S(J1,J3,2))
17349 IF(P1.EQ.1.AND.P2.EQ.1) THEN
17350 HWH2T5 = AM(J,I,L,K)
17351 ELSEIF(P1.EQ.1.AND.P2.EQ.2) THEN
17352 HWH2T5 = AM(J,I,K,L)
17353 ELSEIF(P1.EQ.2.AND.P2.EQ.1) THEN
17354 HWH2T5 = AP(J,I,K,L)
17355 ELSEIF(P1.EQ.2.AND.P2.EQ.2) THEN
17356 HWH2T5 = AP(J,I,L,K)
17357 ELSE
17358 CALL HWWARN('HWH2T5',500)
17359 ENDIF
17360 END
17361CDECK ID>, HWH2T6
17362*CMZ :- -27/02/01 17:04:16 by Peter Richardson
17363*-- Author : Peter Richardson
17364C-----------------------------------------------------------------------
17365 FUNCTION HWH2T6(I,J,K,L,Z1,Z2,P1,P2,P3)
17366C-----------------------------------------------------------------------
17367C Returns the amplitude T6 from Nucl. Phys. B262 (1985) 235-262
17368C I-L are the particles
17369C Z1 and Z2 are the decay products of the Z
17370C P1 is the polarization of the line I,J
17371C P2 is the polarization of the gluon K
17372C P3 is the polarization of the gluon L
17373C-----------------------------------------------------------------------
c63d70bc 17374 INCLUDE 'herwig65.inc'
65767955 17375 DOUBLE COMPLEX HWH2T6,S,D
17376 INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17377 DOUBLE PRECISION B(6)
17378 COMMON/HWHEWS/S(8,8,2),D(8,8)
17379 SAVE B
17380 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17381 IF(P1.EQ.1) THEN
17382 J1 = Z1
17383 J2 = Z2
17384 ELSE
17385 J1 = Z2
17386 J2 = Z1
17387 ENDIF
17388 IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR.
17389 & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN
17390 HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*D(L,J)*S(K,J,2)*
17391 & (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17392 ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR.
17393 & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN
17394 HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*S(L,J,2)*S(J,K,1)*S(L,J,2)*
17395 & (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17396 ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR.
17397 & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN
17398 HWH2T6 = 8.0D0*B(J)*S(I,J2,1)*S(K,J,2)*S(J,L,1)*S(K,J,2)*
17399 & (B(J)*S(J1,J,2)*S(J,L,1)+B(K)*S(J1,K,2)*S(K,L,1))
17400 ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR.
17401 & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN
17402 HWH2T6 = 8.0D0*S(I,J2,1)*S(L,J,2)*(B(J)*D(K,J)+B(L)*D(K,L))*
17403 & (B(J)*S(J1,J,2)*S(J,L,1)+B(K)*S(J1,K,2)*S(K,L,1))
17404 ELSE
17405 CALL HWWARN('HWH2T6',500)
17406 ENDIF
17407 IF(P1.EQ.2) HWH2T6 = DCONJG(HWH2T6)
17408 END
17409CDECK ID>, HWH2T7
17410*CMZ :- -27/02/01 17:04:16 by Peter Richardson
17411*-- Author : Peter Richardson
17412C-----------------------------------------------------------------------
17413 FUNCTION HWH2T7(I,J,K,L,Z1,Z2,P1,P2,P3)
17414C-----------------------------------------------------------------------
17415C Returns the amplitude T7 from Nucl. Phys. B262 (1985) 235-262
17416C I-L are the particles
17417C Z1 and Z2 are the decay products of the Z
17418C P1 is the polarization of the line I,J
17419C P2 is the polarization of the gluon K
17420C P3 is the polarization of the gluon L
17421C-----------------------------------------------------------------------
c63d70bc 17422 INCLUDE 'herwig65.inc'
65767955 17423 DOUBLE COMPLEX HWH2T7,S,D
17424 INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17425 DOUBLE PRECISION B(6)
17426 COMMON/HWHEWS/S(8,8,2),D(8,8)
17427 SAVE B
17428 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17429 IF(P1.EQ.1) THEN
17430 J1 = Z1
17431 J2 = Z2
17432 ELSE
17433 J1 = Z2
17434 J2 = Z1
17435 ENDIF
17436 IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR.
17437 & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN
17438 HWH2T7 = 8.0D0*B(J)*S(I,K,1)*S(J1,J,2)*S(J,L,1)*S(K,J,2)*
17439 & (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))
17440 ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR.
17441 & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN
17442 HWH2T7 = 8.0D0*S(I,K,1)*S(L,J,2)*
17443 & (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))*
17444 & (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17445 ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR.
17446 & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN
17447 HWH2T7 = 8.0D0*B(I)*B(J)*S(I,L,1)*S(K,I,2)*
17448 & S(I,J2,1)*S(J1,J,2)*S(J,L,1)*S(K,J,2)
17449 ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR.
17450 & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN
17451 HWH2T7 = 8.0D0*B(I)*S(I,L,1)*S(K,I,2)*S(I,J2,1)*S(L,J,2)*
17452 & (B(J)*S(J1,J,2)*S(J,K,1)+B(L)*S(J1,L,2)*S(L,K,1))
17453 ELSE
17454 CALL HWWARN('HWH2T7',500)
17455 ENDIF
17456 IF(P1.EQ.2) HWH2T7 = DCONJG(HWH2T7)
17457 END
17458CDECK ID>, HWH2T8
17459*CMZ :- -27/02/01 17:04:16 by Peter Richardson
17460*-- Author : Peter Richardson
17461C-----------------------------------------------------------------------
17462 FUNCTION HWH2T8(I,J,K,L,Z1,Z2,P1,P2,P3)
17463C-----------------------------------------------------------------------
17464C Returns the amplitude T8 from Nucl. Phys. B262 (1985) 235-262
17465C I-L are the particles
17466C Z1 and Z2 are the decay products of the Z
17467C P1 is the polarization of the line I,J
17468C P2 is the polarization of the gluon K
17469C P3 is the polarization of the gluon L
17470C-----------------------------------------------------------------------
c63d70bc 17471 INCLUDE 'herwig65.inc'
65767955 17472 DOUBLE COMPLEX HWH2T8,S,D
17473 INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17474 DOUBLE PRECISION B(6)
17475 COMMON/HWHEWS/S(8,8,2),D(8,8)
17476 SAVE B
17477 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17478 IF(P1.EQ.1) THEN
17479 J1 = Z1
17480 J2 = Z2
17481 ELSE
17482 J1 = Z2
17483 J2 = Z1
17484 ENDIF
17485 IF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.1).OR.
17486 & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.2)) THEN
17487 HWH2T8 = 8.0D0*S(I,K,1)*S(J1,J,2)*(B(I)*D(L,I)+B(K)*D(L,K))*
17488 & (B(I)*S(K,I,2)*S(I,J2,1)+B(L)*S(K,L,2)*S(L,J2,1))
17489 ELSEIF((P1.EQ.1.AND.P2.EQ.1.AND.P3.EQ.2).OR.
17490 & (P1.EQ.2.AND.P2.EQ.2.AND.P3.EQ.1)) THEN
17491 HWH2T8 = 8.0D0*B(I)*S(I,K,1)*S(L,I,2)*S(I,K,1)*S(J1,J,2)*
17492 & (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))
17493 ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.1).OR.
17494 & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.2)) THEN
17495 HWH2T8 = 8.0D0*B(I)*S(I,L,1)*S(K,I,2)*S(I,L,1)*S(J1,J,2)*
17496 & (B(I)*S(K,I,2)*S(I,J2,1)+B(L)*S(K,L,2)*S(L,J2,1))
17497 ELSEIF((P1.EQ.1.AND.P2.EQ.2.AND.P3.EQ.2).OR.
17498 & (P1.EQ.2.AND.P2.EQ.1.AND.P3.EQ.1)) THEN
17499 HWH2T8 = 8.0D0*B(I)*S(I,L,1)*D(I,K)*S(J1,J,2)*
17500 & (B(I)*S(L,I,2)*S(I,J2,1)+B(K)*S(L,K,2)*S(K,J2,1))
17501 ELSE
17502 CALL HWWARN('HWH2T8',500)
17503 ENDIF
17504 IF(P1.EQ.2) HWH2T8 = DCONJG(HWH2T8)
17505 END
17506CDECK ID>, HWH2T9
17507*CMZ :- -27/02/01 17:04:16 by Peter Richardson
17508*-- Author : Peter Richardson
17509C-----------------------------------------------------------------------
17510 FUNCTION HWH2T9(I,J,K,L,Z1,Z2,P1,P2,P3)
17511C-----------------------------------------------------------------------
17512C Returns the amplitude T9 from Nucl. Phys. B262 (1985) 235-262
17513C N.B. DELTA FUNCTION FOR THE GLUON POLARIZATIONS HERE
17514C I-L are the particles
17515C Z1 and Z2 are the decay products of the Z
17516C P1 is the polarization of the line I,J
17517C P2 is the polarization of the gluon K
17518C P3 is the polarization of the gluon L
17519C-----------------------------------------------------------------------
c63d70bc 17520 INCLUDE 'herwig65.inc'
65767955 17521 DOUBLE COMPLEX HWH2T9,S,D
17522 INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17523 DOUBLE PRECISION B(6)
17524 COMMON/HWHEWS/S(8,8,2),D(8,8)
17525 SAVE B
17526 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17527 IF(P2.NE.P3) THEN
17528 HWH2T9 = ZERO
17529 ELSE
17530 IF(P1.EQ.1) THEN
17531 J1 = Z1
17532 J2 = Z2
17533 ELSEIF(P1.EQ.2) THEN
17534 J1 = Z2
17535 J2 = Z1
17536 ENDIF
17537 HWH2T9 = TWO*S(I,J2,1)*(
17538 & B(K)*S(K,J,2)*(B(J)*S(J1,J,2)*S(J,K,1)
17539 & +B(L)*S(J1,L,2)*S(L,K,1))
17540 & -B(L)*S(L,J,2)*(B(J)*S(J1,J,2)*S(J,L,1)
17541 & +B(K)*S(J1,K,2)*S(K,L,1)))
17542 IF(P1.EQ.2) HWH2T9 = DCONJG(HWH2T9)
17543 ENDIF
17544 END
17545CDECK ID>, HWH2T0
17546*CMZ :- -27/02/01 17:04:16 by Peter Richardson
17547*-- Author : Peter Richardson
17548C-----------------------------------------------------------------------
17549 FUNCTION HWH2T0(I,J,K,L,Z1,Z2,P1,P2,P3)
17550C-----------------------------------------------------------------------
17551C Returns the amplitude T10 from Nucl. Phys. B262 (1985) 235-262
17552C N.B. DELTA FUNCTION FOR THE GLUON POLARIZATIONS HERE
17553C I-L are the particles
17554C Z1 and Z2 are the decay products of the Z
17555C P1 is the polarization of the line I,J
17556C P2 is the polarization of the gluon K
17557C P3 is the polarization of the gluon L
17558C-----------------------------------------------------------------------
c63d70bc 17559 INCLUDE 'herwig65.inc'
65767955 17560 DOUBLE COMPLEX HWH2T0,S,D
17561 INTEGER I,J,K,L,Z1,Z2,J1,J2,P1,P2,P3
17562 DOUBLE PRECISION B(6)
17563 COMMON/HWHEWS/S(8,8,2),D(8,8)
17564 SAVE B
17565 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
17566 IF(P2.NE.P3) THEN
17567 HWH2T0 = ZERO
17568 ELSE
17569 IF(P1.EQ.1) THEN
17570 J1 = Z1
17571 J2 = Z2
17572 ELSEIF(P1.EQ.2) THEN
17573 J1 = Z2
17574 J2 = Z1
17575 ENDIF
17576 HWH2T0 = TWO*S(J1,J,2)*(
17577 & B(K)*S(I,K,1)*(B(I)*S(K,I,2)*S(I,J2,1)
17578 & +B(L)*S(K,L,2)*S(L,J2,1))
17579 & -B(L)*S(I,L,1)*(B(I)*S(L,I,2)*S(I,J2,1)
17580 & +B(K)*S(L,K,2)*S(K,J2,1)))
17581 IF(P1.EQ.2) HWH2T0 = DCONJG(HWH2T0)
17582 ENDIF
17583 END
17584CDECK ID>, HWH2VH.
17585*CMZ :- -26/11/00 17.21.55 by Bryan Webber
17586*-- Author : Stefano Moretti
17587C-----------------------------------------------------------------------
17588 SUBROUTINE HWH2VH(P1,P2,P3,P4,RMV,RES,RESL,REST)
17589C-----------------------------------------------------------------------
17590C...Matrix element for q(1) + q(')-bar(2) -> V(3) + Higgs(4),
17591C...V=Z(W+/-), all masses retained (but no Yukawa couplings to quarks).
17592C...It factorises 64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW
17593C...times:
17594C... (VQ*VQ+AQ*AQ)/(1.-SWEIN)/(1.-SWEIN) if V=Z
17595C... VCKM(q,q') if V=W+/-
17596C
17597C...First release: 1-APR-1998 by Stefano Moretti
17598C-----------------------------------------------------------------------
17599 IMPLICIT NONE
17600 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
17601 DOUBLE PRECISION P(0:3)
17602 DOUBLE PRECISION RMV,GAMV,RES,RESL,REST
17603 INTEGER I
17604 DOUBLE PRECISION S,S12,S13,S23
17605 DOUBLE PRECISION T, T13,T23
17606 DOUBLE PRECISION PV,CFC
17607 PARAMETER (GAMV=0.D0)
17608 S=(P1(0)+P2(0))**2
17609 DO I=1,3
17610 S=S-(P1(I)+P2(I))**2
17611 END DO
17612 S12=P1(0)*P2(0)
17613 S13=P1(0)*P3(0)
17614 S23=P2(0)*P3(0)
17615 DO I=1,3
17616 S12=S12-P1(I)*P2(I)
17617 S13=S13-P1(I)*P3(I)
17618 S23=S23-P2(I)*P3(I)
17619 END DO
17620C...Total ME.
17621 RES=(S12+2.D0/RMV/RMV*(S13*S23))
17622 & /((S-RMV**2)**2+GAMV**2*RMV**2)
17623 & /12.D0
17624C...Extracts spin dependence.
17625 PV=SQRT(P3(1)**2+P3(2)**2+P3(3)**2)
17626 CFC=P3(0)/PV
17627 DO I=1,3
17628 P(I)=P3(I)*CFC
17629 END DO
17630 P(0)=PV**2/P3(0)*CFC
17631 T=P(0)**2
17632 DO I=1,3
17633 T=T-P(I)**2
17634 END DO
17635 T13=P1(0)*P(0)
17636 T23=P2(0)*P(0)
17637 DO I=1,3
17638 T13=T13-P1(I)*P(I)
17639 T23=T23-P2(I)*P(I)
17640 END DO
17641C...Longitudinal ME (along V direction).
17642 RESL=(2.D0/RMV/RMV*(T13*T23)-S12*T/RMV/RMV)
17643 & /((S-RMV**2)**2+GAMV**2*RMV**2)
17644 & /12.D0
17645C...Transverse ME (perpendicular to V direction).
17646 REST=RES-RESL
17647 END
17648CDECK ID>, HWH4JT.
17649*CMZ :- -01/04/99 19.47.55 by Mike Seymour
17650*-- Author : Ian Knowles
17651C-----------------------------------------------------------------------
17652 SUBROUTINE HWH4JT
17653C-----------------------------------------------------------------------
17654C Four jet production in e^+e^- annihilation: qqbar+gg & qqbar+qqbar
17655C IOP4JT controls the treatment of the colour flow interference term
17656C qqbar-gg case:
17657C IOP4JT(1)=0 neglect, =1 extreme 2341; =2 extreme 3421
17658C qqbar-qqbar (identical quark flavour) case:
17659C IOP4JT(2)=0 neglect, =1 extreme 4123; =2 extreme 2143
17660C
17661C Matrix elements based on Ellis Ross & Terrano and Catani & Seymour
17662C
17663C WARNING: Phase space factor inaccurate for JADE y_cut > 0.14.
17664C-----------------------------------------------------------------------
c63d70bc 17665 INCLUDE 'herwig65.inc'
65767955 17666 INTEGER LM,LP,IQK,I,J,IDMN,IDMX,ID1,ID2,IST(4)
17667 DOUBLE PRECISION HWRGEN,HWUALF,HWUAEM,HWULDO,HWH4J1,HWH4J2,
17668 & HWH4J4,HWH4J5,HWH4J6,HWH4J7,QNOW,Q2NOW,QLST,SCUT,PSFAC,FACT,
17669 & X12,X13,X14,X23,X24,X34,
17670 & COLA,COLB,COLC,CLF(7,6),P12,P13,P14,P23,P24,P34,FACTR,EP1,EP2,
17671 & EP3,EP4,GG1,GG2,GG12,GG3,GG13,GG23,GGINT,WTGG,QQ,QP,QQINT,QQ1,
17672 & QQ2,WTQQ,WTQP,HCS,WTAB,WTBA,WTOT,RCS,YLST
17673 $ ,EF,QF,E(4)
17674 LOGICAL INCLQG(6),INCLQQ(6,6),ORIENT
17675 EXTERNAL HWRGEN,HWUALF,HWUAEM,HWULDO,HWH4J1,HWH4J2,HWH4J4,
17676 & HWH4J5,HWH4J6,HWH4J7
17677 SAVE HCS,QLST,WTQP,WTQQ,WTGG,FACTR,COLA,COLB,COLC,IDMN,IDMX,
17678 & CLF,GG1,GG2,GGINT,INCLQG,INCLQQ,LM,LP,QQ1,QQ2,QQINT,FACT,ORIENT,
17679 & Q2NOW,SCUT,YLST
17680 SAVE IST
17681 DATA QLST,YLST,IST/-1D0,-1D0,113,114,114,114/
17682C
17683 IF (GENEV) THEN
17684 RCS=HCS*HWRGEN(0)
17685 ELSE
17686 IF (NHEP+5.GT.NMXHEP) THEN
17687 CALL HWWARN('HWH4JT',100)
17688 GOTO 999
17689 ENDIF
17690 QNOW=PHEP(5,3)
17691 IF (QNOW.NE.QLST.OR.Y4JT.NE.YLST) THEN
17692 QLST=QNOW
17693 YLST=Y4JT
17694 Q2NOW=QNOW**2
17695 SCUT=Y4JT*Q2NOW
17696C Calculate allowed fraction of Phase Space using parameterization
17697 IF (DURHAM) THEN
17698 PSFAC=(1.-6.*Y4JT)**5.50*(1.-173.3*Y4JT*(1.-247.3*Y4JT
17699 & *(1.+148.3*Y4JT*(1.+3.913*Y4JT))))
17700 & /(1.-8.352*Y4JT*(1.-1102.*Y4JT
17701 & *(1.+1603.*Y4JT*(1.+22.99*Y4JT))))
17702 ELSE
17703 PSFAC=(1.-6.*Y4JT)**4.62*(1.-44.72*Y4JT*(1.-176.0*Y4JT
17704 & *(1.+102.9*Y4JT*(1.-6.579*Y4JT))))
17705 & /(1.-3.392*Y4JT*(1.-946.5*Y4JT
17706 & *(1.+423.4*Y4JT*(1.-3.971*Y4JT))))
17707 ENDIF
17708 FACT=GEV2NB*HWUAEM(Q2NOW)**2*CFFAC*FLOAT(NCOLO)*PSFAC
17709 & /(THREE*16*PIFAC)
17710 COLA=CFFAC
17711 COLB=CFFAC-HALF*CAFAC
17712 COLC=HALF
17713 LM=1
17714 IF (JDAHEP(1,LM).NE.0) LM=JDAHEP(1,LM)
17715 LP=2
17716 IF (JDAHEP(1,LP).NE.0) LP=JDAHEP(1,LP)
17717 IQK=MOD(IPROC,10)
17718 IF (IQK.NE.0) THEN
17719 IDMN=IQK
17720 IDMX=IQK
17721 ELSE
17722 IDMN=1
17723 IDMX=6
17724 ENDIF
17725 DO 10 I=1,6
17726 CALL HWUCFF(11,I,Q2NOW,CLF(1,I))
17727 IF (QNOW.GT.TWO*(RMASS(I)+RMASS(13))) THEN
17728 INCLQG(I)=.TRUE.
17729 ELSE
17730 INCLQG(I)=.FALSE.
17731 ENDIF
17732 DO 10 J=I,6
17733 IF (QNOW.GT.TWO*(RMASS(I)+RMASS(J ))) THEN
17734 INCLQQ(I,J)=.TRUE.
17735 INCLQQ(J,I)=.TRUE.
17736 ELSE
17737 INCLQQ(I,J)=.FALSE.
17738 INCLQQ(J,I)=.FALSE.
17739 ENDIF
17740 10 CONTINUE
17741 IF (MOD(IPROC/10,10).EQ.5) THEN
17742 ORIENT=.FALSE.
17743 ELSE
17744 ORIENT=.TRUE.
17745 ENDIF
17746 ENDIF
17747C Generate phase space point and check it passes cuts
17748 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
17749 DO 20 I=2,5
17750 20 PHEP(5,NHEP+I)=0.
17751 30 CALL HWDFOR(PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3),
17752 & PHEP(1,NHEP+4),PHEP(1,NHEP+5))
17753 IF(IERROR.NE.0) RETURN
17754 IF (DURHAM) THEN
17755 P12=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
17756 X12=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+3),
17757 & PHEP(4,NHEP+3)/PHEP(4,NHEP+2))*P12
17758 IF (X12.GT.SCUT) THEN
17759 P13=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+4))
17760 X13=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+4),
17761 & PHEP(4,NHEP+4)/PHEP(4,NHEP+2))*P13
17762 IF (X13.GT.SCUT) THEN
17763 P14=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+5))
17764 X14=MIN(PHEP(4,NHEP+2)/PHEP(4,NHEP+5),
17765 & PHEP(4,NHEP+5)/PHEP(4,NHEP+2))*P14
17766 IF (X14.GT.SCUT) THEN
17767 P23=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+4))
17768 X23=MIN(PHEP(4,NHEP+3)/PHEP(4,NHEP+4),
17769 & PHEP(4,NHEP+4)/PHEP(4,NHEP+3))*P23
17770 IF (X23.GT.SCUT) THEN
17771 P24=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+5))
17772 X24=MIN(PHEP(4,NHEP+3)/PHEP(4,NHEP+5),
17773 & PHEP(4,NHEP+5)/PHEP(4,NHEP+3))*P24
17774 IF (X24.GT.SCUT) THEN
17775 P34=2*HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+5))
17776 X34=MIN(PHEP(4,NHEP+4)/PHEP(4,NHEP+5),
17777 & PHEP(4,NHEP+5)/PHEP(4,NHEP+4))*P34
17778 IF (X34.GT.SCUT) GOTO 40
17779 ENDIF
17780 ENDIF
17781 ENDIF
17782 ENDIF
17783 ENDIF
17784 ELSE
17785 P12=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
17786 IF (P12.GT.SCUT) THEN
17787 P13=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+4))
17788 IF (P13.GT.SCUT) THEN
17789 P14=2*HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+5))
17790 IF (P14.GT.SCUT) THEN
17791 P23=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+4))
17792 IF (P23.GT.SCUT) THEN
17793 P24=2*HWULDO(PHEP(1,NHEP+3),PHEP(1,NHEP+5))
17794 IF (P24.GT.SCUT) THEN
17795 P34=2*HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+5))
17796 IF (P34.GT.SCUT) GOTO 40
17797 ENDIF
17798 ENDIF
17799 ENDIF
17800 ENDIF
17801 ENDIF
17802 ENDIF
17803C Failed cuts retry
17804 GOTO 30
17805C Passed cuts: calculate contributions to Matrix Elements
17806 40 EMSCA=SQRT(MIN(P12,P13,P14,P23,P24,P34))
17807 IF (DURHAM) EMSCA=SQRT(MIN(X12,X13,X14,X23,X24,X34))
17808 IF (FIX4JT) EMSCA=SQRT(SCUT)
17809 FACTR=FACT*HWUALF(1,EMSCA)**2
17810 IF (ORIENT) THEN
17811 QF=HWULDO(PHEP(1,LP),PHEP(1,3))
17812 EF=Q2NOW/(2*SQRT(QF**2-HWULDO(PHEP(1,LP),PHEP(1,LP))*Q2NOW))
17813 QF=HALF-EF*QF/Q2NOW
17814 DO I=1,4
17815 E(I)=EF*PHEP(I,LP)+QF*PHEP(I,3)
17816 ENDDO
17817 EP1=HWULDO(E,PHEP(1,NHEP+2))
17818 EP2=HWULDO(E,PHEP(1,NHEP+3))
17819 EP3=HWULDO(E,PHEP(1,NHEP+4))
17820 EP4=HWULDO(E,PHEP(1,NHEP+5))
17821 ENDIF
17822C q-qbar-g-g
17823 GG1=HWH4J1(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17824 & +HWH4J1(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17825 GG2=HWH4J1(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
17826 & +HWH4J1(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
17827 GG12=HWH4J2(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17828 & +HWH4J2(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
17829 & +HWH4J2(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
17830 & +HWH4J2(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17831 GG3=HWH4J4(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17832 & +HWH4J4(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17833 GG13=GG3+HWH4J5(P12,P13,P14,P23,P24,P34,EP1,EP2,EP3,EP4,ORIENT)
17834 & +HWH4J5(P12,P24,P23,P14,P13,P34,EP2,EP1,EP4,EP3,ORIENT)
17835 GG23=GG3+HWH4J5(P12,P14,P13,P24,P23,P34,EP1,EP2,EP4,EP3,ORIENT)
17836 & +HWH4J5(P12,P23,P24,P13,P14,P34,EP2,EP1,EP3,EP4,ORIENT)
17837C Add up weights
17838 GG1 =COLA*(GG1 +GG13)
17839 GG2 =COLA*(GG2 +GG23)
17840 GGINT=COLB*(GG12-GG13-GG23)
17841 WTGG=FACTR*(GG1+GG2+GGINT)
17842C q-qbar-q-qbar
17843 QP=HWH4J6(P13,P12,P14,P23,P34,P24,EP1,EP3,EP2,EP4,ORIENT)
17844 & +HWH4J6(P24,P12,P23,P14,P34,P13,EP2,EP4,EP1,EP3,ORIENT)
17845 & +HWH4J6(P13,P34,P23,P14,P12,P24,EP3,EP1,EP4,EP2,ORIENT)
17846 & +HWH4J6(P24,P34,P14,P23,P12,P13,EP4,EP2,EP3,EP1,ORIENT)
17847 QQ=HWH4J6(P13,P23,P34,P12,P14,P24,EP3,EP1,EP2,EP4,ORIENT)
17848 & +HWH4J6(P24,P23,P12,P34,P14,P13,EP2,EP4,EP3,EP1,ORIENT)
17849 & +HWH4J6(P13,P14,P12,P34,P23,P24,EP1,EP3,EP4,EP2,ORIENT)
17850 & +HWH4J6(P24,P14,P34,P12,P23,P13,EP4,EP2,EP1,EP3,ORIENT)
17851 QQINT=HWH4J7(P13,P12,P14,P23,P34,P24,EP1,EP3,EP2,EP4,ORIENT)
17852 & +HWH4J7(P24,P12,P23,P14,P34,P13,EP2,EP4,EP1,EP3,ORIENT)
17853 & +HWH4J7(P13,P23,P34,P12,P14,P24,EP3,EP1,EP2,EP4,ORIENT)
17854 & +HWH4J7(P24,P23,P12,P34,P14,P13,EP2,EP4,EP3,EP1,ORIENT)
17855 & +HWH4J7(P13,P14,P12,P34,P23,P24,EP1,EP3,EP4,EP2,ORIENT)
17856 & +HWH4J7(P24,P14,P34,P12,P23,P13,EP4,EP2,EP1,EP3,ORIENT)
17857 & +HWH4J7(P13,P34,P23,P14,P12,P24,EP3,EP1,EP4,EP2,ORIENT)
17858 & +HWH4J7(P24,P34,P14,P23,P12,P13,EP4,EP2,EP3,EP1,ORIENT)
17859C Add up weights
17860 WTQP=FACTR*COLC*QP/TWO
17861 QQ1 =COLC*QP
17862 QQ2 =COLC*QQ
17863 QQINT=COLB*QQINT
17864 WTQQ=FACTR*(QQ1+QQ2+QQINT)/2
17865 ENDIF
17866C
17867 HCS=0.
17868 DO 60 ID1=IDMN,IDMX
17869 IF (INCLQG(ID1)) THEN
17870C Gluon channel
17871 HCS=HCS+CLF(1,ID1)*WTGG
17872 IF (GENEV.AND.HCS.GT.RCS) THEN
17873C Select colour flow
17874 WTAB=GG1
17875 WTBA=GG2
17876 IF (IOP4JT(1).EQ.1) THEN
17877 IF (GGINT.GE.ZERO) THEN
17878 WTAB=WTAB+GGINT
17879 ELSE
17880 WTBA=MAX(WTBA,WTBA+GGINT)
17881 ENDIF
17882 ELSEIF (IOP4JT(1).EQ.2) THEN
17883 IF (GGINT.GE.ZERO) THEN
17884 WTBA=WTBA+GGINT
17885 ELSE
17886 WTAB=MAX(WTAB,WTAB+GGINT)
17887 ENDIF
17888 ELSEIF (IOP4JT(1).NE.0) THEN
17889 CALL HWWARN('HWH4JT',101)
17890 GOTO 999
17891 ENDIF
17892 WTOT=WTAB+WTBA
17893 IF (WTAB.GT.HWRGEN(1)*WTOT) THEN
17894 CALL HWHQCP( 13, 13,3142,91)
17895 GOTO 99
17896 ELSE
17897 CALL HWHQCP( 13, 13,4123,92)
17898 GOTO 99
17899 ENDIF
17900 ENDIF
17901 ENDIF
17902C Quark channels
17903 DO 50 ID2=1,6
17904C Identical quark pairs
17905 IF (ID1.EQ.ID2.AND.INCLQQ(ID1,ID1)) THEN
17906 HCS=HCS+CLF(1,ID1)*WTQQ
17907 IF (GENEV.AND.HCS.GT.RCS) THEN
17908C Select colour flow
17909 WTAB=QQ1
17910 WTBA=QQ2
17911 IF (IOP4JT(2).EQ.1) THEN
17912 IF (QQINT.GE.ZERO) THEN
17913 WTAB=WTAB+QQINT
17914 ELSE
17915 WTBA=MAX(WTBA,WTBA+QQINT)
17916 ENDIF
17917 ELSEIF (IOP4JT(2).EQ.2) THEN
17918 IF (QQINT.GE.ZERO) THEN
17919 WTBA=WTBA+QQINT
17920 ELSE
17921 WTAB=MAX(WTAB,WTAB+QQINT)
17922 ENDIF
17923 ELSEIF (IOP4JT(2).NE.0) THEN
17924 CALL HWWARN('HWH4JT',102)
17925 GOTO 999
17926 ENDIF
17927 WTOT=WTAB+WTBA
17928 IF (WTAB.GT.HWRGEN(1)*WTOT) THEN
17929 CALL HWHQCP(ID1,ID1+6,4123,93)
17930 GOTO 99
17931 ELSE
17932 CALL HWHQCP(ID1,ID1+6,2143,94)
17933 GOTO 99
17934 ENDIF
17935 ENDIF
17936C Unlike quark pairs
17937 ELSEIF (INCLQQ(ID1,ID2)) THEN
17938 HCS=HCS+(CLF(1,ID1)+CLF(1,ID2))*WTQP
17939 IF (GENEV.AND.HCS.GT.RCS) THEN
17940 CALL HWHQCP(ID2,ID2+6,4123,95)
17941 GOTO 99
17942 ENDIF
17943 ENDIF
17944 50 CONTINUE
17945 60 CONTINUE
17946 EVWGT=HCS
17947 RETURN
17948C Set up labels for selected final state
17949 99 IDN(1)=ID1
17950 IDN(2)=ID1+6
17951 J=NHEP+1
17952 IDHW(J)=200
17953 IDHEP(J)=23
17954 ISTHEP(J)=110
17955 JMOHEP(1,J)=LM
17956 JMOHEP(2,J)=LP
17957 JDAHEP(1,J)=NHEP+2
17958 JDAHEP(2,J)=NHEP+5
17959 DO 100 I=1,4
17960 J=NHEP+1+I
17961 IDHW(J)=IDN(I)
17962 IDHEP(J)=IDPDG(IDN(I))
17963 ISTHEP(J)=IST(I)
17964 JMOHEP(1,J)=NHEP+1
17965 100 JDAHEP(1,J)=0
17966C And colour structure pointers
17967 DO 110 I=1,4
17968 J=ICO(I)
17969 JMOHEP(2,NHEP+1+I)=NHEP+1+J
17970 110 JDAHEP(2,NHEP+1+J)=NHEP+1+I
17971 NHEP=NHEP+5
17972 999 RETURN
17973 END
17974CDECK ID>, HWH4J1.
17975*CMZ :- -01/04/99 19.47.55 by Mike Seymour
17976*-- Author : Ian Knowles
17977*- Split in 6 files by M. Kirsanov.
17978C-----------------------------------------------------------------------
17979 FUNCTION HWH4J1(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
17980C-----------------------------------------------------------------------
17981C Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
17982C-----------------------------------------------------------------------
17983 IMPLICIT NONE
17984 DOUBLE PRECISION HWH4J1,
17985 & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4
17986 LOGICAL ORIENT
17987 S123=S12+S13+S23
17988 S124=S12+S14+S24
17989 S134=S13+S14+S34
17990 S234=S23+S24+S34
17991 S=S12+S13+S14+S23+S24+S34
17992 HWH4J1=(S12*((S12+S14+S23+S34)**2+S13*(S12+S14-S24)+S24*(S12+S23))
17993 & +(S14*S23-S12*S34-S13*S24)*(S14+S23+S34)/2)
17994 & /(S13*S24*S134*S234)
17995 & +((S12+S24)*(S13+S34)-S14*S23)/(S13*S134**2)
17996 & +2*S23*(S-S13)/(S13*S134*S24) + S34/(2*S13*S24)
17997 IF (ORIENT) THEN
17998 HWH4J1=HWH4J1
17999 & +4*((EP1*EP1*((S-S13)*(S23+S24)-S24*S34)
18000 & -EP1*EP2*(S12*(S123+S124)+(S+S12)*(S14+S23)+2*S14*S23
18001 & +S24*S134+S234*(S13+2*S234))
18002 & +EP1*EP3*(S*(S24-S12)+S12*S13+(S14+2*S234-S34)*S24)
18003 & -EP1*EP4*(S12*S124+S23*(S+S12+S14))
18004 & +EP2*EP2*((S-S24)*(S13+S14)+2*(S13+S34)*S234-S13*S34)
18005 & -EP2*EP3*((S+S23)*(S12+S14)+(S12+2*(S23+S234))*S234)
18006 & +EP2*EP4*(S12*(S24-S)+S13*(S+S23-S34)+2*(S13+S34-S234)*S234)
18007 & +EP3*EP3*(S14+2*S234)*S24
18008 & +EP3*EP4*(-S234*(2*(S12+S23)+S134)+S12*S34-S13*S24-S14*S23)
18009 & +EP4*EP4*S13*S23)*S134
18010 & +EP2*(EP1+EP3+EP4)*2*S14*S24*S234)/(S*S13*S24*S134**2*S234)
18011 ELSE
18012 HWH4J1=2*HWH4J1/3
18013 ENDIF
18014 END
18015CDECK ID>, HWH4J2.
18016*CMZ :- -01/04/99 19.47.55 by Mike Seymour
18017*-- Author : Ian Knowles
18018C-----------------------------------------------------------------------
18019 FUNCTION HWH4J2(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
18020C-----------------------------------------------------------------------
18021C Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
18022C-----------------------------------------------------------------------
18023 IMPLICIT NONE
18024 DOUBLE PRECISION HWH4J2,
18025 & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4
18026 LOGICAL ORIENT
18027 S123=S12+S13+S23
18028 S124=S12+S14+S24
18029 S134=S13+S14+S34
18030 S234=S23+S24+S34
18031 S=S12+S13+S14+S23+S24+S34
18032 HWH4J2=(S12*S14*(S24+S34)+S24*(S12*(S14+S34)+S13*(S14-S24)))
18033 & /(S14*S23*S13*S134)
18034 & +S12*(S+S34)*S124/(S24*S234*S14*S134)
18035 & -(S13*(2*(S12+S24)+S23)+S14**2)/(S134*S13*S14)
18036 & +S12*S123*S124/(2*S13*S24*S14*S23)
18037 IF (ORIENT) THEN
18038 HWH4J2=HWH4J2
18039 & +4*((EP1*EP1*(S12*S134*S234-4*S23*S24*S34)
18040 & +EP1*EP2*(2*(2*S13*S234+S14*S123)*S24-S12*S134*(S+S12+S34))
18041 & +EP1*EP3*(S12*(4*S24*S34-S134*(S12+S14-S24))
18042 & -4*(S13*S24-S14*S23)*S24)
18043 & +EP1*EP4*(4*(S13+S14)*S23*S24-S12*S134*(S12+S13-S23))
18044 & +EP2*EP2*(S12*S134-4*S13*S24)*S134
18045 & +EP2*EP3*(4*S13*(S12+S23+S24)*S24-S12*S134*(S12-S14+S24))
18046 & -EP2*EP4*(4*(S12*(S14+S134)+S13*(S134-S234))*S24
18047 & +S12*(S12-S13+S23)*S134)
18048 & -EP3*EP3*4*S12*S14*S24
18049 & -EP3*EP4*2*S12*(2*S14*S24+S12*S134))*S234
18050 & +(EP1*(EP1*(S23+S24)+EP2*(S134-2*S))
18051 & -(EP1+EP2)*(EP3+EP4)*S12+EP2*EP2*(S13+S14))*2*S14*S24*S123)
18052 & /(2*S*S13*S14*S234*S23*S24*S134)
18053 ELSE
18054 HWH4J2=2*HWH4J2/3
18055 ENDIF
18056 END
18057CDECK ID>, HWH4J4.
18058*CMZ :- -01/04/99 19.47.55 by Mike Seymour
18059*-- Author : Ian Knowles
18060C-----------------------------------------------------------------------
18061 FUNCTION HWH4J4(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
18062C-----------------------------------------------------------------------
18063C Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
18064C-----------------------------------------------------------------------
18065 IMPLICIT NONE
18066 DOUBLE PRECISION HWH4J4,
18067 & S12,S13,S14,S23,S24,S34,S134,S234,S,EP1,EP2,EP3,EP4
18068 LOGICAL ORIENT
18069 S134=S13+S14+S34
18070 S234=S23+S24+S34
18071 S=S12+S13+S14+S23+S24+S34
18072 HWH4J4=-(S12*(S34*(3*(S+S34)+S12)-S134*S234-2*(S13*S24+S14*S23))
18073 & +(S14*S23-S13*S24)*(S13-S14+S24-S23))/(2*S134*S234*S34**2)
18074 & -(S12*(S134**2/2+2*S13*S14+S34*(S13+S14-S34))
18075 & +S34*((S13+S14)*(S23+S24)+S14*S24+S13*S23)
18076 & +(S13*S24-S14*S23)*(S14-S13))/(S34*S134)**2
18077 IF (ORIENT) THEN
18078 HWH4J4=HWH4J4
18079 & +4*((-EP1*EP1*2*(S23+S24)*S34
18080 & -EP1*EP2*(S13*(S23+3*S24)+S14*(3*S23+S24)-(4*S12-S34)*S34)
18081 & +EP1*EP3*((2*S12-S24)*S34-(S13-S14)*S24)
18082 & +EP1*EP4*((2*S12-S23)*S34+(S13-S14)*S23)
18083 & -EP2*EP2*2*(S13+S14)*S34
18084 & +EP2*EP3*(2*S12*S34-S14*(S23-S24+S34))
18085 & +EP2*EP4*(2*S12*S34+S13*(S23-S24-S34))
18086 & +EP3*EP3*2*S14*S24
18087 & +EP3*EP4*2*(S12*S34-S13*S24-S14*S23)
18088 & +EP4*EP4*2*S13*S23)/(S*S134*S234*S34**2)
18089 & +(EP1*EP2*(S134*(S134+2*S34)+4*(S13*S14-S34**2))
18090 & +EP2*EP3*2*(2*S13*S34+S14*(S13-S14+S34))
18091 & +EP2*EP4*2*(2*S14*S34-S13*(S13-S14-S34)))
18092 & /(S*(S134*S34)**2))
18093 ELSE
18094 HWH4J4=2*HWH4J4/3
18095 ENDIF
18096 END
18097CDECK ID>, HWH4J5.
18098*CMZ :- -01/04/99 19.47.55 by Mike Seymour
18099*-- Author : Ian Knowles
18100C-----------------------------------------------------------------------
18101 FUNCTION HWH4J5(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
18102C-----------------------------------------------------------------------
18103C Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
18104C-----------------------------------------------------------------------
18105 IMPLICIT NONE
18106 DOUBLE PRECISION HWH4J5,
18107 & S12,S13,S14,S23,S24,S34,S134,S234,S,EP1,EP2,EP3,EP4,
18108 & SUM
18109 LOGICAL ORIENT
18110 S134=S13+S14+S34
18111 S234=S23+S24+S34
18112 S=S12+S13+S14+S23+S24+S34
18113 HWH4J5=(3*S12*S34**2-3*S13*S24*S34+3*S12*S24*S34+3*S14*S23*S34-
18114 $ S13*S24**2-S12*S23*S34+6*S12*S14*S34+2*S12*S13*S34-
18115 $ 2*S12**2*S34+S14*S23*S24-3*S13*S23*S24-2*S13*S14*S24+
18116 $ 4*S12*S14*S24+2*S12*S13*S24+3*S14*S23**2+2*S14**2*S23+
18117 $ 2*S14**2*S12+2*S12**2*S14+6*S12*S14*S23-2*S12*S13**2-
18118 $ 2*S12**2*S13)/(2*S13*S134*S234*S34)+
18119 $ (2*S12*S34**2-2*S13*S24*S34+S12*S24*S34+4*S13*S23*S34+
18120 $ 4*S12*S14*S34+2*S12*S13*S34+2*S12**2*S34-S13*S24**2+
18121 $ 3*S14*S23*S24+4*S13*S23*S24-2*S13*S14*S24+4*S12*S14*S24+
18122 $ 2*S12*S13*S24+2*S14*S23**2+4*S13*S23**2+2*S13*S14*S23+
18123 $ 2*S12*S14*S23+4*S12*S13*S23+2*S12*S14**2+4*S12**2*S13+
18124 $ 4*S12*S13*S14+2*S12**2*S14)/(2*S13*S134*S24*S34)-
18125 $ (S12*S34**2-2*S14*S24*S34-2*S13*S24*S34-S14*S23*S34+
18126 $ S13*S23*S34+S12*S14*S34+2*S12*S13*S34-2*S14**2*S24-
18127 $ 4*S13*S14*S24-4*S13**2*S24-S14**2*S23-S13**2*S23+
18128 $ S12*S13*S14-S12*S13**2)/(S13*S34*S134**2)
18129 IF (ORIENT) THEN
18130 SUM=
18131 & +EP1*EP1*((S13-S14+S23-3*S24)*S34+(S134+S14+2*S34)*S234)
18132 & *S24*S134
18133 & +EP1*EP2*((2*(S12-S24)+S34)*S134-S14*(4*S12+S14+3*S23)
18134 & +S13*(S13+S23)+S24*S34 )*S24*S134
18135 & -EP1*EP2*(((2*S12*S134+S13*(2*(S12+S14+S23)-S24+S34)
18136 & +S14*(S14-S23)+(2*S14-S34)*S234)*S234)*S134
18137 & + 4*S13**2*S24*S234)
18138 & +EP1*EP3*(S12*(2*S13-S134)+S13*(S24+2*S234)+S14*(3*S24-S234)
18139 & +S34*(S234-3*S24))*S24*S134
18140 & +EP1*EP4*((S12*(S13-S14+3*S34)-S23*(S13+3*S14-S34))*S24
18141 & -(S12*(S13+S134+2*S34)+2*S13*S24
18142 & +(S13-2*S14)*S23)*S234)*S134
18143 & +EP2*EP2*(S13*((2*S13+S34)*S234+S24*(S134-2*S34))
18144 & +2*S14*S134*(S24+S234))*S134
18145 SUM=SUM
18146 & -EP2*EP3*(((S12*(S13+2*S14-S34)+S14*(S+2*S23-S34))*S24
18147 & +(S12*(S13+S134)+(S13+S24+2*S234)*S14
18148 & +2*S13*(2*S23+S34))*S234)*S134
18149 & +4*S13**2*S24*S234)
18150 & +EP2*EP4*(((S12*(S13-2*S134)+S13*(S+2*S23-3*S34))*S24
18151 & -((S-3*S13+S23+2*S24)*S13+2*S12*S14
18152 & +2*S14*(S23+2*S24))*S234)*S134-4*S13**2*S24*S234)
18153 & +EP3*EP3*2*(S13*S234+S14*S24)*S24*S134
18154 & +EP3*EP4*(2*(S12*S34-S13*S24-S14*S23)*S24
18155 & -(S12*S134+2*S13*S23)*S234)*S134
18156 & +EP4*EP4*2*(S12*S234+S23*S24)*S13*S134
18157 HWH4J5=HWH4J5+4*SUM/(S*S234*S134**2*S13*S34*S24)
18158 ELSE
18159 HWH4J5=2*HWH4J5/3
18160 ENDIF
18161 END
18162CDECK ID>, HWH4J6.
18163*CMZ :- -01/04/99 19.47.55 by Mike Seymour
18164*-- Author : Ian Knowles
18165C-----------------------------------------------------------------------
18166 FUNCTION HWH4J6(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
18167C-----------------------------------------------------------------------
18168C Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
18169C-----------------------------------------------------------------------
18170 IMPLICIT NONE
18171 DOUBLE PRECISION HWH4J6,
18172 & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4
18173 LOGICAL ORIENT
18174 S123=S12+S13+S23
18175 S124=S12+S14+S24
18176 S134=S13+S14+S34
18177 S234=S23+S24+S34
18178 S=S12+S13+S14+S23+S24+S34
18179 HWH4J6=(S23*(S123*S234-S*S23)+S12*(S123*S124-S*S12))/(S13*S123)**2
18180 & -(S12*S34*(S234-2*S23)+S14*S23*(S234-2*S34)
18181 & -S13*S24*(S234+S13))/(S13**2*S123*S134)
18182 IF (ORIENT) THEN
18183 HWH4J6=HWH4J6
18184 & +4*(-EP1*EP1*2*S23*S34
18185 & +EP1*EP2*((S12-S23)*S34-S13*(S24-S34))
18186 & +(EP1*EP3+EP2*EP4)*2*(S12*S34-S13*S24+S14*S23)
18187 & -EP1*EP4*(S13*S24-(3*(S13+S14)+S34)*S23)
18188 & -(EP1+EP2+EP3)*EP4*2
18189 & *(S12*(S13+S23)+(S12+S13)*S23)*S134/S123
18190 & +EP2*EP2*S13*(S14+S34)
18191 & +EP2*EP3*(S13*(S14-S24)-(S12-S23)*S14)
18192 & -EP3*EP3*2*S12*S14
18193 & -EP3*EP4*(S13*S24-(3*(S13+S34)+S14)*S12)
18194 & +EP4*EP4*(S12+S23)*S13)/(S*S134*S123*S13**2)
18195 ELSE
18196 HWH4J6=2*HWH4J6/3
18197 ENDIF
18198 END
18199CDECK ID>, HWH4J7.
18200*CMZ :- -01/04/99 19.47.55 by Mike Seymour
18201*-- Author : Ian Knowles
18202C-----------------------------------------------------------------------
18203 FUNCTION HWH4J7(S12,S13,S14,S23,S24,S34,EP1,EP2,EP3,EP4,ORIENT)
18204C-----------------------------------------------------------------------
18205C Evaluate `ERT' functions A, B, C, D, E; S12=(p1+p2)^2 etc.
18206C-----------------------------------------------------------------------
18207 IMPLICIT NONE
18208 DOUBLE PRECISION HWH4J7,
18209 & S12,S13,S14,S23,S24,S34,S123,S124,S134,S234,S,EP1,EP2,EP3,EP4
18210 LOGICAL ORIENT
18211 S123=S12+S13+S23
18212 S124=S12+S14+S24
18213 S134=S13+S14+S34
18214 S234=S23+S24+S34
18215 S=S12+S13+S14+S23+S24+S34
18216 HWH4J7=((S12*S34+S13*S24-S14*S23)*(S13+S14+S23+S24)-2*S12*S24*S34)
18217 & /(S13*S134*S23*S123)
18218 & -S12*(S12*S-S123*S124)/(S123**2*S13*S23)
18219 & -(S13+S14)*(S23+S24)*S34/(S13*S134*S23*S234)
18220 IF (ORIENT) THEN
18221 HWH4J7=HWH4J7
18222 & +4*(+2*(EP1+EP2)*(S23*EP1-S13*EP2)*S34*S134
18223 & -EP1*EP2*2*S34**2*S123
18224 & +EP1*EP3*(S123*(S23+S24)*S34+2*S134*(S13*S24-S14*S23))
18225 & +EP1*EP4*(S123*(S23+S24)*S34+2*S12**2*S134*S234/S123
18226 & +2*S134*(S24*(S13-S12)-S23*(S12+S14)))
18227 & +EP2*EP3*(2*(S12*S34+S13*S24-S14*S23)*S134
18228 & +S123*(S13+S14)*S34)
18229 & +EP2*EP4*(S123*(S13+S14)*S34+2*S12**2*S234*S134/S123
18230 & -2*S134*(S12*S234-S13*S24+S14*S23))
18231 & -EP3*EP3*S12*(2*S24*S134+S123*S34)
18232 & +EP3*EP4*2*S12*(S134*(S23-S24)-S34*S123+S12*S134*S234/S123)
18233 & +EP4*EP4*S12*(2*S23*S134-S123*S34))
18234 & /(S*S13*S23*S123*S134*S234)
18235 ELSE
18236 HWH4J7=2*HWH4J7/3
18237 ENDIF
18238 END
18239CDECK ID>, HWHBGF.
18240*CMZ :- -26/04/91 11.11.55 by Bryan Webber
18241*-- Author : Giovanni Abbiendi & Luca Stanco
18242C-----------------------------------------------------------------------
18243 SUBROUTINE HWHBGF
18244C-----------------------------------------------------------------------
18245C Order Alpha_s processes in charged lepton-hadron collisions
18246C
18247C Process code IPROC has to be set in the Main Program
18248C the following codes IPROC may be selected
18249C
18250C 9100 : NC BOSON-GLUON FUSION
18251C 9100+IQK (IQK=1,...,6) : produced flavour is IQK
18252C 9107 : produced J/psi + gluon
18253C
18254C 9110 : NC QCD COMPTON
18255C 9110+IQK (IQK=1,...,12) : struck parton is IQK
18256C
18257C 9130 : NC order alpha_s processes (9100+9110)
18258C
18259C Select maximum and minimum generated flavour when IQK=0
18260C setting IFLMIN and IFLMAX in the Main Program
18261C (allowed values from 1 to 6), default are 1 and 5
18262C allowing d,u,s,c,b,dbar,ubar,sbar,cbar,bbar
18263C
18264C CHARGED CURRENT Boson-Gluon Fusion processes
18265C 9141 : CC s cbar (c sbar)
18266C 9142 : CC b cbar (c bbar)
18267C 9143 : CC s tbar (t cbar)
18268C 9144 : CC b tbar (t bbar)
18269C
18270C other inputs : Q2MIN,Q2MAX,YBMIN,YBMAX,PTMIN,EMMIN,EMMAX
18271C when IPROC=(1)9107 : as above but Q2WWMN, Q2WWMX substitute
18272C Q2MIN and Q2MAX (EPA is used); ZJMAX cut
18273C
18274C Add 10000 to suppress soft remnant fragmentation
18275C
18276C Mean EVWGT = cross section in nanoBarn
18277C
18278C-----------------------------------------------------------------------
c63d70bc 18279 INCLUDE 'herwig65.inc'
65767955 18280 DOUBLE PRECISION HWRGEN,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,
18281 & ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,FSIGMA(18),
18282 & SIGSUM,PROB,PRAN,PVRT(4),X
18283 INTEGER LEP
18284 INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,LEPFIN,ID1,ID2,I,IDD
18285 LOGICAL CHARGD,INCLUD(18),INSIDE(18),IFGO
18286 EXTERNAL HWRGEN
18287 SAVE LEPFIN,ID1,ID2,FSIGMA,SIGSUM
18288 COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
18289 & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
18290 & IPROO,CHARGD,INCLUD,INSIDE
18291C---Initialization
18292 IF (FSTWGT) THEN
18293C---LEP = 1 FOR LEPTONS, -1 FOR ANTILEPTONS
18294 LEP=0
18295 IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
18296 LEP=1
18297 ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
18298 LEP=-1
18299 ENDIF
18300 IF (LEP.EQ.0) CALL HWWARN('HWHBGF',500)
18301 IPROO=MOD(IPROC,100)/10
18302 IF (IPROO.EQ.0.OR.IPROO.EQ.4) THEN
18303 IQK=MOD(IPROC,10)
18304 IFL=IQK
18305 IF (IQK.EQ.7) IFL=164
18306 CHARGD=IPROO.EQ.4
18307 ELSEIF (IPROO.EQ.1.OR.IPROO.EQ.2) THEN
18308 IQK=MOD(IPROC,100)-10
18309 IFL=IQK+6
18310 CHARGD=.FALSE.
18311 ELSEIF (IPROO.EQ.3) THEN
18312 IQK=0
18313 IFL=0
18314 CHARGD=.FALSE.
18315 ELSE
18316 CALL HWWARN('HWHBGF',501)
18317 ENDIF
18318C
18319 LEPFIN = IDHW(1)
18320 IF(CHARGD) THEN
18321 LEPFIN = IDHW(1)+1
18322 IF (IQK.EQ.1) THEN
18323 IFLAVU=4
18324 IFLAVD=3
18325 ID1 = 3
18326 ID2 = 10
18327 ELSEIF (IQK.EQ.2) THEN
18328 IFLAVU=4
18329 IFLAVD=5
18330 ID1 = 5
18331 ID2 = 10
18332 ELSEIF (IQK.EQ.3) THEN
18333 IFLAVU=6
18334 IFLAVD=3
18335 ID1 = 3
18336 ID2 =12
18337 ELSE
18338 IFLAVU=6
18339 IFLAVD=5
18340 ID1 = 5
18341 ID2 =12
18342 ENDIF
18343 IF (LEP.EQ.-1) THEN
18344 IDD=ID1
18345 ID1=ID2-6
18346 ID2=IDD+6
18347 ENDIF
18348 ENDIF
18349C
18350 IF (IQK.EQ.0) THEN
18351 DO I=1,18
18352 INCLUD(I)=.TRUE.
18353 ENDDO
18354 IMIN=1
18355 IMAX=18
18356 DO I=1,6
18357 IF (I.LT.IFLMIN.OR.I.GT.IFLMAX) INCLUD(I)=.FALSE.
18358 ENDDO
18359 DO I=7,18
18360 IF (I.LE.12) THEN
18361 IF (I-6.LT.IFLMIN.OR.I-6.GT.IFLMAX) INCLUD(I)=.FALSE.
18362 ELSE
18363 IF (I-12.LT.IFLMIN.OR.I-12.GT.IFLMAX) INCLUD(I)=.FALSE.
18364 ENDIF
18365 ENDDO
18366 IF (IPROO.EQ.0) THEN
18367 DO I=7,18
18368 INCLUD(I)=.FALSE.
18369 ENDDO
18370 IMIN=IFLMIN
18371 IMAX=IFLMAX
18372 ELSEIF (IPROO.EQ.1.OR.IPROO.EQ.2) THEN
18373 DO I=1,6
18374 INCLUD(I)=.FALSE.
18375 ENDDO
18376 IMIN=IFLMIN+6
18377 IMAX=IFLMAX+12
18378 ELSEIF (IPROO.EQ.3) THEN
18379 IMIN=IFLMIN
18380 IMAX=IFLMAX+12
18381 ENDIF
18382 ELSEIF (IQK.NE.0 .AND. (.NOT.CHARGD)) THEN
18383 DO I=1,18
18384 INCLUD(I)=.FALSE.
18385 ENDDO
18386 IF (IFL.LE.18) THEN
18387 INCLUD(IFL)=.TRUE.
18388 IMIN=IFL
18389 IMAX=IFL
18390 ELSEIF (IFL.EQ.164) THEN
18391 INCLUD(7)=.TRUE.
18392 IMIN=7
18393 IMAX=7
18394 ENDIF
18395 ENDIF
18396 ENDIF
18397C---End of initialization
18398 IF(GENEV) THEN
18399 IF (.NOT.CHARGD) THEN
18400 IF (IQK.EQ.0) THEN
18401 PRAN= SIGSUM * HWRGEN(0)
18402 PROB=ZERO
18403 DO 10 IFL=IMIN,IMAX
18404 IF (.NOT.INSIDE(IFL)) GOTO 10
18405 PROB=PROB+FSIGMA(IFL)
18406 IF (PROB.GE.PRAN) GOTO 20
18407 10 CONTINUE
18408 ENDIF
18409C---at this point the subprocess has been selected (IFL)
18410 20 CONTINUE
18411 IF (IFL.LE.6) THEN
18412C---Boson-Gluon Fusion event
18413 IDHW(NHEP+1)=IDHW(1)
18414 IDHW(NHEP+2)=13
18415 IDHW(NHEP+3)=15
18416 IDHW(NHEP+4)=LEPFIN
18417 IDHW(NHEP+5)=IFL
18418 IDHW(NHEP+6)=IFL+6
18419 ELSEIF (IFL.GE.7.AND.IFL.LE.18) THEN
18420C---QCD_Compton event
18421 IDHW(NHEP+1)=IDHW(1)
18422 IDHW(NHEP+2)=IFL-6
18423 IDHW(NHEP+3)=15
18424 IDHW(NHEP+4)=LEPFIN
18425 IDHW(NHEP+5)=IFL-6
18426 IDHW(NHEP+6)=13
18427 ELSEIF (IFL.EQ.164) THEN
18428C---gamma+gluon-->J/Psi+gluon
18429 IDHW(NHEP+1)=IDHW(1)
18430 IDHW(NHEP+2)=13
18431 IDHW(NHEP+3)=15
18432 IDHW(NHEP+4)=LEPFIN
18433 IDHW(NHEP+5)=164
18434 IDHW(NHEP+6)=13
18435 ELSE
18436 CALL HWWARN('HWHBGF',503)
18437 ENDIF
18438 ELSE
18439C---Charged current event of specified flavours
18440 IDHW(NHEP+1)=IDHW(1)
18441 IDHW(NHEP+2)=13
18442 IDHW(NHEP+3)=15
18443 IDHW(NHEP+4)=LEPFIN
18444 IDHW(NHEP+5)=ID1
18445 IDHW(NHEP+6)=ID2
18446 ENDIF
18447C
18448 DO 1 I=NHEP+1,NHEP+6
18449 1 IDHEP(I)=IDPDG(IDHW(I))
18450C
18451C---Codes common for all processes
18452 ISTHEP(NHEP+1)=111
18453 ISTHEP(NHEP+2)=112
18454 ISTHEP(NHEP+3)=110
18455 ISTHEP(NHEP+4)=113
18456 ISTHEP(NHEP+5)=114
18457 ISTHEP(NHEP+6)=114
18458C
18459 DO I=NHEP+1,NHEP+6
18460 JMOHEP(1,I)=NHEP+3
18461 JDAHEP(1,I)=0
18462 ENDDO
18463C---Incoming lepton
18464 JMOHEP(2,NHEP+1)=NHEP+4
18465 JDAHEP(2,NHEP+1)=NHEP+4
18466C---Hard Process C.M.
18467 JMOHEP(1,NHEP+3)=NHEP+1
18468 JMOHEP(2,NHEP+3)=NHEP+2
18469 JDAHEP(1,NHEP+3)=NHEP+4
18470 JDAHEP(2,NHEP+3)=NHEP+6
18471C---Outgoing lepton
18472 JMOHEP(2,NHEP+4)=NHEP+1
18473 JDAHEP(2,NHEP+4)=NHEP+1
18474C
18475 IF (IFL.LE.6 .OR. CHARGD) THEN
18476C---Codes for boson-gluon fusion processes
18477C--- Incoming gluon
18478 JMOHEP(2,NHEP+2)=NHEP+6
18479 JDAHEP(2,NHEP+2)=NHEP+5
18480C--- Outgoing quark
18481 JMOHEP(2,NHEP+5)=NHEP+2
18482 JDAHEP(2,NHEP+5)=NHEP+6
18483C--- Outgoing antiquark
18484 JMOHEP(2,NHEP+6)=NHEP+5
18485 JDAHEP(2,NHEP+6)=NHEP+2
18486 ELSEIF (IFL.GE.7 .AND. IFL.LE.12) THEN
18487C---Codes for V+q --> q+g
18488C--- Incoming quark
18489 JMOHEP(2,NHEP+2)=NHEP+5
18490 JDAHEP(2,NHEP+2)=NHEP+6
18491C--- Outgoing quark
18492 JMOHEP(2,NHEP+5)=NHEP+6
18493 JDAHEP(2,NHEP+5)=NHEP+2
18494C--- Outgoing gluon
18495 JMOHEP(2,NHEP+6)=NHEP+2
18496 JDAHEP(2,NHEP+6)=NHEP+5
18497 ELSEIF (IFL.GE.13 .AND. IFL.LE.18) THEN
18498C---Codes for V+qbar --> qbar+g
18499C--- Incoming antiquark
18500 JMOHEP(2,NHEP+2)=NHEP+6
18501 JDAHEP(2,NHEP+2)=NHEP+5
18502C--- Outgoing antiquark
18503 JMOHEP(2,NHEP+5)=NHEP+2
18504 JDAHEP(2,NHEP+5)=NHEP+6
18505C--- Outgoing gluon
18506 JMOHEP(2,NHEP+6)=NHEP+5
18507 JDAHEP(2,NHEP+6)=NHEP+2
18508 ELSEIF (IFL.EQ.164) THEN
18509C---Codes for Gamma+gluon --> J/Psi+gluon
18510C--- Incoming gluon
18511 JMOHEP(2,NHEP+2)=NHEP+6
18512 JDAHEP(2,NHEP+2)=NHEP+6
18513C--- Outgoing J/Psi
18514 JMOHEP(2,NHEP+5)=NHEP+1
18515 JDAHEP(2,NHEP+5)=NHEP+1
18516C--- Outgoing gluon
18517 JMOHEP(2,NHEP+6)=NHEP+2
18518 JDAHEP(2,NHEP+6)=NHEP+2
18519 ENDIF
18520C---Computation of momenta in Laboratory frame of reference
18521 CALL HWHBKI
18522 NHEP=NHEP+6
18523C Decide which quark radiated and assign production vertices
18524 IF (IFL.LE.6) THEN
18525C Boson-Gluon fusion case
18526 IF (1-Z.LT.HWRGEN(0)) THEN
18527C Gluon splitting to quark
18528 CALL HWVZRO(4,VHEP(1,NHEP-1))
18529 CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
18530 CALL HWUDKL(IFL,PVRT,VHEP(1,NHEP))
18531 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
18532 ELSE
18533C Gluon splitting to antiquark
18534 CALL HWVZRO(4,VHEP(1,NHEP))
18535 CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP-1),PVRT)
18536 CALL HWUDKL(IFL,PVRT,VHEP(1,NHEP-1))
18537 CALL HWVEQU(4,VHEP(1,NHEP-1),VHEP(1,NHEP-4))
18538 ENDIF
18539 ELSEIF (IFL.GE.7.AND.IFL.LE.18) THEN
18540C QCD Compton case
18541 X=1/(1+SHAT/Q2)
18542 IF (1.LT.HWRGEN(0)*(1+(1-X-Z)**2+6*X*(1-X)*Z*(1-Z))) THEN
18543C Incoming quark radiated the gluon
18544 CALL HWVZRO(4,VHEP(1,NHEP-1))
18545 CALL HWVDIF(4,PHEP(1,NHEP-4),PHEP(1,NHEP),PVRT)
18546 CALL HWUDKL(IFL-6,PVRT,VHEP(1,NHEP))
18547 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-4))
18548 ELSE
18549C Outgoing quark radiated the gluon
18550 CALL HWVZRO(4,VHEP(1,NHEP-4))
18551 CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PVRT)
18552 CALL HWUDKL(IFL-6,PVRT,VHEP(1,NHEP))
18553 CALL HWVEQU(4,VHEP(1,NHEP),VHEP(1,NHEP-1))
18554 ENDIF
18555 ENDIF
18556C---HERWIG gets confused if lepton momentum is different from beam
18557C momentum, which it can be if incoming hadron has negative virtuality
18558C As a temporary fix, simply copy the momentum.
18559C Momentum conservation somehow gets taken care of HWBGEN!
18560 call hwvequ(5,phep(1,1),phep(1,nhep-5))
18561 ELSE
18562 EVWGT=ZERO
18563C---generation of the 5 variables Y,Q2,SHAT,Z,PHI and Jacobian computation
18564C---in the largest phase space avalaible for selected processes and
18565C---filling of logical vector INSIDE to tag contributing ones
18566 CALL HWHBRN (IFGO)
18567 IF(IFGO) GOTO 999
18568C---calculate differential cross section corresponding to the chosen
18569C---variables and the weight for MC generation
18570 IF (IQK.EQ.0) THEN
18571C---many subprocesses included
18572 DO I=1,18
18573 FSIGMA(I)=ZERO
18574 ENDDO
18575 SIGSUM=ZERO
18576 DO I=IMIN,IMAX
18577 IF (INSIDE(I)) THEN
18578 IFL=I
18579 DSIGMA=ZERO
18580 CALL HWHBSG
18581 FSIGMA(I)=DSIGMA
18582 SIGSUM=SIGSUM+DSIGMA
18583 ENDIF
18584 ENDDO
18585 EVWGT=SIGSUM * AJACOB
18586 ELSE
18587C---only one subprocess included
18588 CALL HWHBSG
18589 EVWGT= DSIGMA * AJACOB
18590 ENDIF
18591 IF (EVWGT.LT.ZERO) EVWGT=ZERO
18592 ENDIF
18593 999 RETURN
18594 END
18595CDECK ID>, HWHBKI.
18596*CMZ :- -26/04/91 13.19.32 by Federico Carminati
18597*-- Author : Giovanni Abbiendi & Luca Stanco
18598C----------------------------------------------------------------------
18599 SUBROUTINE HWHBKI
18600C----------------------------------------------------------------------
18601C gives the fourmomenta in the laboratory system for the particles
18602C of the hard 2-->3 subprocess, to match with HERWIG routines of
18603C jet evolution.
18604C----------------------------------------------------------------------
c63d70bc 18605 INCLUDE 'herwig65.inc'
65767955 18606 DOUBLE PRECISION HWUECM,HWUPCM,HWUSQR,Y,Q2,SHAT,Z,PHI,AJACOB,
18607 & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
18608 & PGAMMA(5),SG,MF1,MF2,EP,PP,EL,PL,E1,E2,Q1,COSBET,SINBET,COSTHE,
18609 & SINTHE,SINAZI,COSAZI,ROTAZI(3,3),EGAM,A,PPROT,MREMIN,PGAM,PEP(5),
18610 & COSPHI,SINPHI,ROT(3,3),EPROT,PROTON(5),MPART
18611 INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,I,IHAD,J,IS,ICMF,LEP
18612 LOGICAL CHARGD,INCLUD(18),INSIDE(18)
18613 EXTERNAL HWUECM,HWUPCM,HWUSQR
18614 COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
18615 & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
18616 & IPROO,CHARGD,INCLUD,INSIDE
18617C
18618 IHAD=2
18619 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
18620C---Set masses
18621 IF (CHARGD) THEN
18622 MPART=ZERO
18623 MF1=RMASS(IDHW(NHEP+5))
18624 MF2=RMASS(IDHW(NHEP+6))
18625 MREMIN=MP
18626 ELSE
18627 IS = IFL
18628 IF (IFL.EQ.164) IS=IQK
18629 MPART=ZERO
18630 IF (IFL.GE.7.AND.IFL.LE.18) MPART=RMASS(IFL-6)
18631 MF1=MFIN1(IS)
18632 MF2=MFIN2(IS)
18633 MREMIN = MREMIF(IS)
18634 ENDIF
18635C---Calculation of kinematical variables for the generated event
18636C in the center of mass frame of the incoming boson and parton
18637C with parton along +z
18638 EGAM = HWUECM (SHAT, -Q2, MPART**2)
18639 PGAM = SQRT( EGAM**2 + Q2 )
18640 EP = RSHAT-EGAM
18641 PP = PGAM
18642 A = (W2+Q2-MP**2)/TWO
18643 PPROT = (A*PGAM-EGAM*SQRT(A**2+MP**2*Q2))/Q2
18644 IF (PPROT.LT.ZERO) THEN
18645 CALL HWWARN('HWHBKI',101)
18646 GOTO 999
18647 ENDIF
18648 EPROT = SQRT(PPROT**2+MP**2)
18649 IF ((EPROT+PPROT).LT.(EP+PP)) THEN
18650 CALL HWWARN('HWHBKI',102)
18651 GOTO 999
18652 ENDIF
18653 EL = ( PGAM / PPROT * SMA - Q2 ) / TWO
18654 + / (EGAM + PGAM / PPROT * EPROT)
18655 IF (EL.GT.ME) THEN
18656 PL = SQRT ( EL**2 - ME**2 )
18657 ELSE
18658 CALL HWWARN ('HWHBKI',103)
18659 GOTO 999
18660 ENDIF
18661 COSBET = (TWO * EPROT * EL - SMA) / (TWO * PPROT * PL)
18662 IF ( ABS(COSBET) .GE. ONE ) THEN
18663 COSBET = SIGN (ONE,COSBET)
18664 SINBET = ZERO
18665 ELSE
18666 SINBET = SQRT (ONE - COSBET**2)
18667 ENDIF
18668 SG = ME**2 + MPART**2 + Q2 + TWO * RSHAT * EL
18669 IF (SG.LE.(RSHAT+ML)**2 .OR. SG.GE.(RS-MREMIN)**2) THEN
18670 CALL HWWARN ('HWHBKI',104)
18671 GOTO 999
18672 ENDIF
18673 Q1 = HWUPCM( RSHAT, MF1, MF2)
18674 E1 = SQRT(Q1**2+MF1**2)
18675 E2 = SQRT(Q1**2+MF2**2)
18676 IF (Q1 .GT. ZERO) THEN
18677 COSTHE=(TWO*EP*E1 - Z*(SHAT+Q2))/(TWO*PP*Q1)
18678 IF (ABS(COSTHE) .GT. ONE) THEN
18679 COSTHE=SIGN(ONE,COSTHE)
18680 SINTHE=ZERO
18681 ELSE
18682 SINTHE=SQRT(ONE-COSTHE**2)
18683 ENDIF
18684 ELSE
18685 COSTHE=ZERO
18686 SINTHE=ONE
18687 ENDIF
18688C---Initial lepton
18689 PHEP(1,NHEP+1)=PL*SINBET
18690 PHEP(2,NHEP+1)=ZERO
18691 PHEP(3,NHEP+1)=PL*COSBET
18692 PHEP(4,NHEP+1)=EL
18693 PHEP(5,NHEP+1)=RMASS(IDHW(1))
18694C---Initial Hadron
18695 PROTON(1)=ZERO
18696 PROTON(2)=ZERO
18697 PROTON(3)=PPROT
18698 PROTON(4)=EPROT
18699 CALL HWUMAS (PROTON)
18700C---Initial parton
18701 PHEP(1,NHEP+2)=ZERO
18702 PHEP(2,NHEP+2)=ZERO
18703 PHEP(3,NHEP+2)=PP
18704 PHEP(4,NHEP+2)=EP
18705 PHEP(5,NHEP+2)=MPART
18706C---HARD SUBPROCESS 2-->3 CENTRE OF MASS
18707 PHEP(1,NHEP+3)=PHEP(1,NHEP+1)+PHEP(1,NHEP+2)
18708 PHEP(2,NHEP+3)=PHEP(2,NHEP+1)+PHEP(2,NHEP+2)
18709 PHEP(3,NHEP+3)=PHEP(3,NHEP+1)+PHEP(3,NHEP+2)
18710 PHEP(4,NHEP+3)=PHEP(4,NHEP+1)+PHEP(4,NHEP+2)
18711 CALL HWUMAS ( PHEP(1,NHEP+3) )
18712C---Virtual boson
18713 PGAMMA(1)=ZERO
18714 PGAMMA(2)=ZERO
18715 PGAMMA(3)=-PGAM
18716 PGAMMA(4)=EGAM
18717 PGAMMA(5)=HWUSQR(Q2)
18718C---Scattered lepton
18719 PHEP(1,NHEP+4)=PHEP(1,NHEP+1)-PGAMMA(1)
18720 PHEP(2,NHEP+4)=PHEP(2,NHEP+1)-PGAMMA(2)
18721 PHEP(3,NHEP+4)=PHEP(3,NHEP+1)-PGAMMA(3)
18722 PHEP(4,NHEP+4)=PHEP(4,NHEP+1)-PGAMMA(4)
18723 PHEP(5,NHEP+4)=RMASS(IDHW(1))
18724 IF (CHARGD) PHEP(5,NHEP+4)=ZERO
18725C---First Final parton: quark (or J/psi) in Boson-Gluon Fusion
18726C--- quark or antiquark in QCD Compton
18727 PHEP(1,NHEP+5)=Q1*SINTHE*COS(PHI)
18728 PHEP(2,NHEP+5)=Q1*SINTHE*SIN(PHI)
18729 PHEP(3,NHEP+5)=Q1*COSTHE
18730 PHEP(4,NHEP+5)=E1
18731 PHEP(5,NHEP+5)=MF1
18732C---Second Final parton: antiquark in Boson-Gluon Fusion
18733C--- gluon in QCD Compton
18734 PHEP(1,NHEP+6)=-PHEP(1,NHEP+5)
18735 PHEP(2,NHEP+6)=-PHEP(2,NHEP+5)
18736 PHEP(3,NHEP+6)=-PHEP(3,NHEP+5)
18737 PHEP(4,NHEP+6)=E2
18738 PHEP(5,NHEP+6)=MF2
18739C---Boost to lepton-hadron CM frame
18740 PEP(1) = PHEP(1,NHEP+1)
18741 PEP(2) = PHEP(2,NHEP+1)
18742 PEP(3) = PHEP(3,NHEP+1) + PPROT
18743 PEP(4) = PHEP(4,NHEP+1) + EPROT
18744 CALL HWUMAS (PEP)
18745 DO I=1,6
18746 CALL HWULOF (PEP,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18747 ENDDO
18748 CALL HWULOF (PEP,PROTON,PROTON)
18749 CALL HWULOF (PEP,PGAMMA,PGAMMA)
18750C---Rotation around y-axis to align lepton beam with z-axis
18751 COSPHI = PHEP(3,NHEP+1) /
18752 & SQRT( PHEP(1,NHEP+1)**2 + PHEP(3,NHEP+1)**2 )
18753 SINPHI = PHEP(1,NHEP+1) /
18754 & SQRT( PHEP(1,NHEP+1)**2 + PHEP(3,NHEP+1)**2 )
18755 DO I=1,3
18756 DO J=1,3
18757 ROT(I,J)=ZERO
18758 ENDDO
18759 ENDDO
18760 ROT(1,1) = COSPHI
18761 ROT(1,3) = -SINPHI
18762 ROT(2,2) = ONE
18763 ROT(3,1) = SINPHI
18764 ROT(3,3) = COSPHI
18765 DO I=1,6
18766 CALL HWUROF (ROT,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18767 ENDDO
18768 CALL HWUROF (ROT,PROTON,PROTON)
18769 CALL HWUROF (ROT,PGAMMA,PGAMMA)
18770C---Boost to the LAB frame
18771 ICMF=3
18772 DO I=1,6
18773 CALL HWULOB (PHEP(1,ICMF),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18774 ENDDO
18775 CALL HWULOB (PHEP(1,ICMF),PROTON,PROTON)
18776 CALL HWULOB (PHEP(1,ICMF),PGAMMA,PGAMMA)
18777C---Random azimuthal rotation
18778 CALL HWRAZM (ONE,COSAZI,SINAZI)
18779 DO I=1,3
18780 DO J=1,3
18781 ROTAZI(I,J)=ZERO
18782 ENDDO
18783 ENDDO
18784 ROTAZI(1,1) = COSAZI
18785 ROTAZI(1,2) = SINAZI
18786 ROTAZI(2,1) = -SINAZI
18787 ROTAZI(2,2) = COSAZI
18788 ROTAZI(3,3) = ONE
18789 DO I=1,6
18790 CALL HWUROF (ROTAZI,PHEP(1,NHEP+I),PHEP(1,NHEP+I))
18791 ENDDO
18792 CALL HWUROF (ROTAZI,PROTON,PROTON)
18793 CALL HWUROF (ROTAZI,PGAMMA,PGAMMA)
18794 999 RETURN
18795 END
18796CDECK ID>, HWHBRN.
18797*CMZ :- -03/07/95 19.02.12 by Giovanni Abbiendi
18798*-- Author : Giovanni Abbiendi & Luca Stanco
18799C-----------------------------------------------------------------------
18800 SUBROUTINE HWHBRN (IFGO)
18801C----------------------------------------------------------------------
18802C Returns a point in the phase space (Y,Q2,SHAT,Z,PHI) and the
18803C corresponding Jacobian factor AJACOB
18804C Fill the logical vector INSIDE to tag contributing subprocesses
18805C to the cross-section
18806C-----------------------------------------------------------------------
c63d70bc 18807 INCLUDE 'herwig65.inc'
65767955 18808 LOGICAL IFGO
18809 DOUBLE PRECISION HWRUNI,HWRGEN,HWUPCM,Y,Q2,SHAT,Z,PHI,AJACOB,
18810 & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
18811 & MF1,MF2,YMIN,YMAX,YJAC,Q2INF,Q2SUP,Q2JAC,EMW2,ZMIN,ZMAX,ZJAC,
18812 & GAMMA2,LAMBDA,PHIJAC,ZINT,ZLMIN,ZL,EMW,TMIN,TMAX,EMLMIN,EMLMAX,
18813 & SHMIN,EMMIF(18),EMMAF(18),WMIF(18),WMIN,MREMIN,YMIF(18),Q1CM(18),
18814 & Q2MAF(18),EMMAWF(18),ZMIF(18),ZMAF(18),PLMAX,PINC,SHINF,SHSUP,
18815 & SHJAC,CTHLIM,Q1,DETDSH,SRY,SRY0,SRY1
18816 INTEGER LEP
18817 INTEGER IQK,IFLAVU,IFLAVD,I,IMIN,IMAX,IFL,IPROO,IHAD,NTRY,DEBUG
18818 LOGICAL CHARGD,INCLUD(18),INSIDE(18)
18819 EXTERNAL HWRUNI,HWRGEN,HWUPCM
18820 SAVE EMLMIN,EMLMAX,EMMIF,EMMAF,MREMIN,MF1,MF2,YMIF,
18821 & YMIN,YMAX,WMIN,WMIF
18822 COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
18823 & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
18824 & IPROO,CHARGD,INCLUD,INSIDE
18825 EQUIVALENCE (EMW,RMASS(198))
18826C
18827 IFGO = .FALSE.
18828 IHAD=2
18829 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
18830C---Initialization
18831 IF (FSTWGT.OR.IHAD.NE.2) THEN
18832 ME = RMASS(IDHW(1))
18833 MP = RMASS(IDHW(IHAD))
18834 RS = PHEP(5,3)
18835 SMA = RS**2-ME**2-MP**2
18836 PINC = HWUPCM(RS,ME,MP)
18837C---Charged current
18838 IF (CHARGD) THEN
18839 ML=RMASS(IDHW(1)+1)
18840 YMAX = ONE - TWO*ML*MP / SMA
18841 YMAX = MIN(YMAX,YBMAX)
18842 MREMIN=MP
18843 IF (LEP.EQ.1) THEN
18844 MF1=RMASS(IFLAVD)
18845 MF2=RMASS(IFLAVU)
18846 ELSE
18847 MF1=RMASS(IFLAVU)
18848 MF2=RMASS(IFLAVD)
18849 ENDIF
18850 SHMIN = MF1**2+MF2**2 + TWO * PTMIN**2 +
18851 + TWO * SQRT(PTMIN**2+MF1**2) * SQRT(PTMIN**2+MF2**2)
18852 EMLMIN=MAX(EMMIN,SQRT(SHMIN))
18853 EMLMAX=MIN(EMMAX,RS-ML-MREMIN)
18854 DEBUG=1
18855 IF (EMLMIN.GT.EMLMAX) GOTO 888
18856 WMIN=EMLMIN+MREMIN
18857 PLMAX=HWUPCM(RS,ML,WMIN)
18858 YMIN = ONE-TWO*(SQRT(PINC**2+MP**2)*SQRT(PLMAX**2+ML**2)+
18859 + PINC*PLMAX)/SMA
18860 YMIN = MAX(YMIN,YBMIN)
18861 DEBUG=2
18862 IF (YMIN.GT.YMAX) GOTO 888
18863 ELSE
18864C---Neutral current
18865 ML = ME
18866 YMAX = ONE - TWO*ML*MP / SMA
18867 YMAX = MIN(YMAX,YBMAX)
18868 DO I=1,18
18869 YMIF(I)=ZERO
18870 EMMIF(I)=ZERO
18871 EMMAF(I)=ZERO
18872 WMIF(I)=ZERO
18873 IF (I.LE.8) THEN
18874C---Boson-Gluon Fusion (also J/Psi) and QCD Compton with struck u or d
18875 MREMIF(I)=MP
18876 IF (I.LE.6) THEN
18877 MFIN1(I)=RMASS(I)
18878 MFIN2(I)=RMASS(I+6)
18879 ELSE
18880 MFIN1(I)=RMASS(I-6)
18881 MFIN2(I)=ZERO
18882 ENDIF
18883 ELSE
18884C---QCD Compton with struck non-valence parton
18885 MREMIF(I)=MP+RMASS(I-6)
18886 MFIN1(I)=RMASS(I-6)
18887 MFIN2(I)=ZERO
18888 ENDIF
18889 ENDDO
18890 IF (IFL.EQ.164) THEN
18891C---J/Psi
18892 MFIN1(7)=RMASS(164)
18893 MFIN2(7)=ZERO
18894 ENDIF
18895C---y boundaries for different flavours and processes
18896 DO 100 I=IMIN,IMAX
18897 IF (INCLUD(I)) THEN
18898 MF1=MFIN1(I)
18899 MF2=MFIN2(I)
18900 MREMIN=MREMIF(I)
18901 SHMIN = MF1**2+MF2**2 + TWO * PTMIN**2 +
18902 + TWO * SQRT(PTMIN**2+MF1**2) * SQRT(PTMIN**2+MF2**2)
18903 EMMIF(I) = MAX(EMMIN,SQRT(SHMIN))
18904 EMMAF(I) = MIN(EMMAX,RS-ML-MREMIN)
18905 IF (EMMIF(I).GT.EMMAF(I)) THEN
18906 INCLUD(I)=.FALSE.
18907 CALL HWWARN('HWHBRN',3)
18908 GOTO 100
18909 ENDIF
18910 WMIF(I) = EMMIF(I)+MREMIF(I)
18911 WMIN = WMIF(I)
18912 PLMAX = HWUPCM(RS,ML,WMIN)
18913 YMIF(I)=ONE-TWO*(SQRT(PINC**2+MP**2)*SQRT(PLMAX**2+ML**2)+
18914 + PINC*PLMAX)/SMA
18915 IF (YMIF(I).GT.YMAX) THEN
18916 INCLUD(I)=.FALSE.
18917 CALL HWWARN('HWHBRN',4)
18918 GOTO 100
18919 ENDIF
18920 ENDIF
18921 100 CONTINUE
18922C---considering the largest boundaries
18923 EMLMIN=EMMIF(IMIN)
18924 EMLMAX=EMMAF(IMIN)
18925 IF (IPROO.EQ.3) THEN
18926 EMLMIN=MIN(EMMIF(IMIN),EMMIF(IMIN+6))
18927 EMLMAX=MAX(EMMAF(IMIN),EMMAF(IMIN+6))
18928 ENDIF
18929 DEBUG=3
18930 IF (EMLMIN.GT.EMLMAX) GOTO 888
18931 YMIN=YMIF(IMIN)
18932 IF (IPROO.EQ.3) YMIN=MIN(YMIF(IMIN),YMIF(IMIN+6))
18933 YMIN = MAX(YMIN,YBMIN)
18934 DEBUG=4
18935 IF (YMIN.GT.YMAX) GOTO 888
18936 WMIN = WMIF(IMIN)
18937 MREMIN = MREMIF(IMIN)
18938 MF1=MFIN1(IMIN)
18939 MF2=MFIN2(IMIN)
18940 IF (IPROO.EQ.3) THEN
18941 WMIN = MIN(WMIF(IMIN),WMIF(IMIN+6))
18942 MREMIN = MIN(MREMIF(IMIN),MREMIF(IMIN+6))
18943 ENDIF
18944 ENDIF
18945 ENDIF
18946C---Random generation in largest phase space
18947 Y=ZERO
18948 Q2=ZERO
18949 SHAT=ZERO
18950 Z=ZERO
18951 PHI=ZERO
18952 AJACOB=ZERO
18953C---y generation
18954 IF (.NOT.CHARGD) THEN
18955 IF (IFL.LE.5.OR.(IFL.GE.7.AND.IFL.LE.18)) THEN
18956 SRY0 = SQRT(YMIN)
18957 SRY1 = SQRT(YMAX)
18958 SRY = HWRUNI(0,SRY0,SRY1)
18959 Y = SRY**2
18960 YJAC = TWO*SRY*(SRY1-SRY0)
18961 ELSEIF (IFL.EQ.6) THEN
18962 Y = SQRT(HWRUNI(0,YMIN**2,YMAX**2))
18963 YJAC = HALF * (YMAX**2-YMIN**2) / Y
18964 ELSEIF (IFL.EQ.164) THEN
18965C---in J/psi photoproduction Y and Q2 are given by the Equivalent Photon
18966C Approximation
18967 10 NTRY=0
18968 20 NTRY=NTRY+1
18969 IF (NTRY.GT.NETRY) THEN
18970 CALL HWWARN('HWHBRN',50)
18971 GOTO 10
18972 ENDIF
18973 Y = (YMIN/YMAX)**HWRGEN(1)*YMAX
18974 IF (ONE+(ONE-Y)**2.LT.TWO*HWRGEN(2)) GOTO 20
18975 YJAC=(TWO*LOG(YMAX/YMIN)-TWO*(YMAX-YMIN)
18976 & +HALF*(YMAX**2-YMIN**2))
18977 ENDIF
18978 ELSE
18979 IF (IPRO.EQ.5) THEN
18980 Y = EXP(HWRUNI(0,LOG(YMIN),LOG(YMAX)))
18981 YJAC = Y * LOG(YMAX/YMIN)
18982 ELSE
18983 Y = HWRUNI(0,YMIN,YMAX)
18984 YJAC = YMAX - YMIN
18985 ENDIF
18986 ENDIF
18987C---Q**2 generation
18988 Q2INF = ME**2*Y**2 / (ONE-Y)
18989 Q2SUP = MP**2 + SMA*Y - WMIN**2
18990 IF (IFL.EQ.164) THEN
18991 Q2INF = MAX(Q2INF,Q2WWMN)
18992 Q2SUP = MIN(Q2SUP,Q2WWMX)
18993 ELSE
18994 Q2INF = MAX(Q2INF,Q2MIN)
18995 Q2SUP = MIN(Q2SUP,Q2MAX)
18996 ENDIF
18997 DEBUG=5
18998 IF (Q2INF .GT. Q2SUP) GOTO 888
18999C
19000 IF (.NOT.CHARGD) THEN
19001 IF (IFL.EQ.164) THEN
19002 Q2 = EXP(HWRUNI(0,LOG(Q2INF),LOG(Q2SUP)))
19003 Q2JAC = LOG(Q2SUP/Q2INF)
19004 ELSEIF (Q2INF.LT.RMASS(4)**2) THEN
19005 Q2 = EXP(HWRUNI(0,LOG(Q2INF),LOG(Q2SUP)))
19006 Q2JAC = Q2 * LOG(Q2SUP/Q2INF)
19007 ELSE
19008 Q2 = Q2INF*Q2SUP/HWRUNI(0,Q2INF,Q2SUP)
19009 Q2JAC = Q2**2 * (Q2SUP-Q2INF)/(Q2SUP*Q2INF)
19010 ENDIF
19011 ELSE
19012 EMW2=EMW**2
19013 Q2=(Q2INF+EMW2)*(Q2SUP+EMW2)/(HWRUNI(0,Q2INF,Q2SUP)+EMW2)-EMW2
19014 Q2JAC=(Q2+EMW2)**2*(Q2SUP-Q2INF)/((Q2SUP+EMW2)*(Q2INF+EMW2))
19015 ENDIF
19016 W2 = MP**2 + SMA*Y - Q2
19017C---s_hat generation
19018 SHINF = EMLMIN **2
19019 SHSUP = (MIN(SQRT(W2)-MREMIN,EMLMAX))**2
19020 DEBUG=6
19021 IF (SHINF .GT. SHSUP) GOTO 888
19022C
19023 IF (IPRO.EQ.91) THEN
19024 IF (.NOT.CHARGD) THEN
19025 SHAT = SHINF*SHSUP/HWRUNI(0,SHINF,SHSUP)
19026 SHJAC = SHAT**2 * (SHSUP-SHINF)/(SHSUP*SHINF)
19027 ELSE
19028 SHAT = EXP(HWRUNI(0,LOG(SHINF),LOG(SHSUP)))
19029 SHJAC = SHAT*(LOG(SHSUP/SHINF))
19030 ENDIF
19031 ELSE
19032 EMW2=EMW**2
19033 IF (SHINF.GT.EMW2+10*GAMW*EMW) THEN
19034 SHAT = SHINF*SHSUP/HWRUNI(0,SHINF,SHSUP)
19035 SHJAC = SHAT**2 * (SHSUP-SHINF)/(SHSUP*SHINF)
19036 ELSEIF (SHSUP.LT.EMW2-10*EMW*GAMW) THEN
19037 SHAT = HWRUNI(0,SHINF,SHSUP)
19038 SHJAC = SHSUP-SHINF
19039 ELSE
19040 TMIN=ATAN((SHINF-EMW2)/(GAMW*EMW))
19041 TMAX=ATAN((SHSUP-EMW2)/(GAMW*EMW))
19042 SHAT = GAMW*EMW*TAN(HWRUNI(0,TMIN,TMAX))+EMW2
19043 SHJAC=((SHAT-EMW2)**2+(GAMW*EMW)**2)/(GAMW*EMW)*(TMAX-TMIN)
19044 ENDIF
19045 ENDIF
19046 DETDSH = ONE/SMA/Y
19047 SHJAC=SHJAC*DETDSH
19048 RSHAT = SQRT (SHAT)
19049C--- z generation
19050 ZMIN = 10E10
19051 ZMAX = -ONE
19052 IF (.NOT.CHARGD) THEN
19053 DO I=1,18
19054 Q1CM(I) = ZERO
19055 ZMIF(I) = ZERO
19056 ZMAF(I) = ZERO
19057 ENDDO
19058 DO 150 I=IMIN,IMAX
19059 IF (INCLUD(I)) THEN
19060 Q1CM(I) = HWUPCM( RSHAT, MFIN1(I), MFIN2(I) )
19061 IF (Q1CM(I) .LT. PTMIN) THEN
19062 ZMAF(I)=-ONE
19063 GOTO 150
19064 ENDIF
19065 CTHLIM = SQRT(ONE - (PTMIN / Q1CM(I))**2)
19066 GAMMA2 = SHAT + MFIN1(I)**2 - MFIN2(I)**2
19067 LAMBDA = (SHAT-MFIN1(I)**2-MFIN2(I)**2)**2 -
19068 + 4.D0*MFIN1(I)**2*MFIN2(I)**2
19069 ZMIF(I) = (GAMMA2 - SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
19070 ZMIF(I) = MAX(ZMIF(I),ZERO)
19071 ZMAF(I) = (GAMMA2 + SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
19072 ZMAF(I) = MIN(ZMAF(I),ONE)
19073 ZMIN = MIN( ZMIN, ZMIF(I) )
19074 ZMAX = MAX( ZMAX, ZMAF(I) )
19075 ENDIF
19076 150 CONTINUE
19077 IF (IFL.EQ.164) ZMAX=MIN(ZMAX,ZJMAX)
19078 ELSE
19079 Q1 = HWUPCM(RSHAT,MF1,MF2)
19080 DEBUG=7
19081 IF (Q1.LT.PTMIN) GOTO 888
19082 CTHLIM = SQRT(ONE-(PTMIN/Q1)**2)
19083 GAMMA2 = SHAT+MF1**2-MF2**2
19084 LAMBDA = (SHAT-MF1**2-MF2**2)**2-4.D0*MF1**2*MF2**2
19085 ZMIN = (GAMMA2-SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
19086 ZMIN = MAX(ZMIN,1D-6)
19087 ZMAX = (GAMMA2+SQRT(LAMBDA)*CTHLIM)/TWO/SHAT
19088 ZMAX = MIN(ZMAX,ONE-1D-6)
19089 ENDIF
19090 DEBUG=8
19091 IF (ZMIN .GT. ZMAX) GOTO 888
19092 ZLMIN = LOG(ZMIN/(ONE-ZMIN))
19093 ZINT = LOG(ZMAX/(ONE-ZMAX)) - LOG(ZMIN/(ONE-ZMIN))
19094 ZL = ZLMIN+HWRGEN(0)*ZINT
19095 Z = EXP(ZL)/(ONE+EXP(ZL))
19096 ZJAC = Z*(ONE-Z)*ZINT
19097C
19098 DEBUG=9
19099 IF ((Y.LT.YMIN.OR.Y.GT.YMAX).OR.(Q2.LT.Q2INF.OR.Q2.GT.Q2SUP).OR.
19100 + (SHAT.LT.SHINF.OR.SHAT.GT.SHSUP).OR.(Z.LT.ZMIN.OR.Z.GT.ZMAX))
19101 + GOTO 888
19102C---Phi generation
19103 PHI = HWRUNI(0,ZERO,2*PIFAC)
19104 PHIJAC = 2 * PIFAC
19105 IF (IFL.EQ.164) PHIJAC=ONE
19106C
19107 AJACOB = YJAC * Q2JAC * SHJAC * ZJAC * PHIJAC
19108C
19109 IF (IQK.NE.0.OR.IPRO.EQ.5) GOTO 999
19110C---contributing subprocesses: filling of logical vector INSIDE
19111 DO I=1,18
19112 INSIDE(I)=.FALSE.
19113 Q2MAF(I)=ZERO
19114 EMMAWF(I)=ZERO
19115 ENDDO
19116 DO 200 I=IMIN,IMAX
19117 IF (INCLUD(I)) THEN
19118 IF ( Y.LT.YMIF(I) ) GOTO 200
19119C
19120 Q2MAF(I) = MP**2 + SMA*Y - WMIF(I)**2
19121 Q2MAF(I) = MIN( Q2MAF(I), Q2MAX)
19122 IF (Q2INF .GT. Q2MAF(I)) GOTO 200
19123 IF (Q2.LT.Q2INF .OR. Q2.GT.Q2MAF(I)) GOTO 200
19124C
19125 EMMAWF(I) = SQRT(W2) - MREMIF(I)
19126 EMMAWF(I) = MIN( EMMAWF(I), EMLMAX )
19127C
19128 IF (EMMIF(I) .GT. EMMAWF(I)) GOTO 200
19129 IF (SHAT.LT.EMMIF(I)**2.OR.SHAT.GT.EMMAWF(I)**2) GOTO 200
19130C
19131 IF (ZMIF(I) .GT. ZMAF(I)) GOTO 200
19132 IF (Z.LT.ZMIF(I) .OR. Z.GT.ZMAF(I)) GOTO 200
19133 INSIDE(I)=.TRUE.
19134 ENDIF
19135 200 CONTINUE
19136 999 RETURN
19137 888 EVWGT=ZERO
19138C---UNCOMMENT THIS LINE TO GET A DEBUGGING WARNING FOR NO PHASE-SPACE
19139C CALL HWWARN('HWHBRN',DEBUG)
19140 IFGO = .TRUE.
19141 END
19142CDECK ID>, HWHBSG.
19143*CMZ :- -03/07/95 19.02.12 by Giovanni Abbiendi
19144*-- Author : Giovanni Abbiendi & Luca Stanco
19145C----------------------------------------------------------------------
19146 SUBROUTINE HWHBSG
19147C----------------------------------------------------------------------
19148C Returns differential cross section DSIGMA in (Y,Q2,ETA,Z,PHI)
19149C Scale for structure functions and alpha_s selected by BGSHAT
19150C----------------------------------------------------------------------
c63d70bc 19151 INCLUDE 'herwig65.inc'
65767955 19152 DOUBLE PRECISION HWUALF,HWUAEM,Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,
19153 & ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT,
19154 & SFUN(13),ALPHA,LDSIG,DLQ(7),SG,XG,MF1,MF2,MSUM,MDIF,MPRO,FFUN,
19155 & GFUN,H43,H41,H11,H12,H14,H16,H21,H22,G11,G12,G1A,G1B,G21,G22,G3,
19156 & GC,A11,A12,A44,ALPHAS,PDENS,AFACT,BFACT,CFACT,DFACT,GAMMA,S,T,U,
19157 & MREMIN,POL,CCOL,ETA
19158 INTEGER LEP
19159 INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,IHAD,ILEPT,IQ,IS
19160 LOGICAL CHARGD,INCLUD(18),INSIDE(18)
19161 EXTERNAL HWUALF,HWUAEM
19162 COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
19163 & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
19164 & IPROO,CHARGD,INCLUD,INSIDE
19165C
19166 IHAD=2
19167 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
19168C---set masses
19169 IF (CHARGD) THEN
19170 MREMIN=MP
19171 IF (LEP.EQ.1) THEN
19172 MF1=RMASS(IFLAVD)
19173 MF2=RMASS(IFLAVU)
19174 ELSE
19175 MF1=RMASS(IFLAVU)
19176 MF2=RMASS(IFLAVD)
19177 ENDIF
19178 ELSE
19179 IS=IFL
19180 IF (IFL.EQ.164) IS=IQK
19181 MREMIN = MREMIF(IS)
19182 MF1 = MFIN1(IS)
19183 MF2 = MFIN2(IS)
19184 ENDIF
19185C---choose subprocess scale
19186 IF (BGSHAT) THEN
19187 EMSCA = RSHAT
19188 ELSE
19189 S=SHAT+Q2
19190 IF (IFL.GE.7.AND.IFL.LE.18) S=SHAT+Q2-MF1**2
19191 T=-S*Z
19192 U=-S-T
19193 IF (IFL.GE.7.AND.IFL.LE.18) U=-S-T-2*MF1**2
19194 EMSCA = SQRT(TWO*S*T*U/(S**2+T**2+U**2))
19195 IF (IFL.EQ.164) EMSCA=SQRT(-U)
19196 ENDIF
19197 ALPHAS = HWUALF(1,EMSCA)
19198 IF (ALPHAS.GE.ONE.OR.ALPHAS.LE.ZERO) THEN
19199 CALL HWWARN('HWHBSG',51)
19200 GOTO 888
19201 ENDIF
19202C---structure functions
19203 ETA = (SHAT+Q2)/SMA/Y
19204 IF (ETA.GT.ONE) ETA=ONE
19205 CALL HWSFUN (ETA,EMSCA,IDHW(IHAD),NSTRU,SFUN,2)
19206 XG = Q2/(SHAT + Q2)
19207 SG = ETA*SMA
19208 IF (SG.LE.(RSHAT+ML)**2.OR.SG.GE.(RS-MREMIN)**2) GOTO 888
19209C
19210 IF (IFL.EQ.164) GOTO 200
19211C
19212C---Electroweak couplings
19213 ALPHA=HWUAEM(-Q2)
19214 IF (CHARGD) THEN
19215 POL = PPOLN(3) - EPOLN(3)
19216 DLQ(1)=.0625*VCKM(IFLAVU/2,(IFLAVD+1)/2)/SWEIN**2 *
19217 + Q2**2/((Q2+RMASS(198)**2)**2+(RMASS(198)*GAMW)**2) *
19218 + (ONE + POL)
19219 DLQ(2)=ZERO
19220 DLQ(3)=DLQ(1)
19221 ELSE
19222 IQ=MOD(IFL-1,6)+1
19223 ILEPT=MOD(IDHW(1)-121,6)+11
19224 CALL HWUCFF(ILEPT,IQ,-Q2,DLQ(1))
19225 ENDIF
19226C
19227 IF (IFL.LE.6) THEN
19228C---For Boson-Gluon Fusion
19229 PDENS = SFUN(13)/ETA
19230 CCOL = HALF
19231 MSUM = (MF1**2 + MF2**2) / (Y*SG)
19232 MDIF = (MF1**2 - MF2**2) / (Y*SG)
19233 MPRO = MF1*MF2 / (Y*SG)
19234C
19235 FFUN = (1.D0-XG)*Z*(1.D0-Z) + (MDIF*(2.D0*Z-1.D0)-MSUM)/2.D0
19236 GFUN = (1.D0-XG)*(1.D0-Z) + XG*Z + MDIF
19237 IF ( FFUN .LT. ZERO ) FFUN = ZERO
19238 H43 = (8.D0*(2.D0*Z**2*XG-Z**2-2.D0*Z*XG+2.D0*Z*MDIF+Z-MDIF
19239 & -MSUM)) / (Z*(1.D0-Z))**2
19240C
19241 H41 = (8.D0*(Z**2-Z*XG+Z*MDIF-MDIF-MSUM)) / (Z**2*(1.D0-Z))
19242C
19243 H11 = (4.D0*(2.D0*Z**4-4.D0*Z**3+2.D0*Z**2*MSUM*XG
19244 & -2.D0*Z**2*MSUM+2.D0*Z**2*XG**2-2.D0*Z**2*XG+3.D0*Z**2
19245 & +2.D0*Z*MDIF*MSUM+2.D0*Z*MDIF*XG-2.D0*Z*MSUM*XG
19246 & +2.D0*Z*MSUM-2.D0*Z*XG**2+2.D0*Z*XG-Z-MDIF*MSUM-MDIF*XG
19247 & -MSUM**2-MSUM*XG)) / (Z*(1.D0-Z))**2
19248C
19249 H12 = (16.D0*(-Z*MDIF+Z*XG+MDIF+MSUM))/(Z**2*(1.D0-Z))
19250C
19251 H14 = (16.D0*(-2.D0*Z**2*XG-2.D0*Z*MDIF+2.D0*Z*XG+MDIF+MSUM))
19252 & / (Z*(1.D0-Z))**2
19253C
19254 H16 = (32.D0*(Z*MDIF-Z*XG-MDIF-MSUM)) / (Z**2*(1.D0-Z))
19255C
19256 H21 = (8.D0*MPRO*(-2.D0*Z**2*XG+2.D0*Z**2-2.D0*Z*MDIF+2.D0*Z*XG
19257 + -2.D0*Z+MDIF+MSUM)) / (Z*(1.D0-Z))**2
19258C
19259 H22 = (-32.D0*MPRO) / (Z*(1.D0-Z))
19260C
19261 G11 = -2.D0*H11 + FFUN*H14
19262 G12 = 2.D0*XG*FFUN*H14 + H12 + GFUN * ( H16+GFUN*H14 )
19263 G1A = SQRT( XG*FFUN ) * ( H16 + 2.D0*GFUN*H14 )
19264 G1B = FFUN*H14
19265 G21 = -2.D0*H21
19266 G22 = H22
19267 G3 = H41 - GFUN*H43
19268 GC = SQRT( XG*FFUN ) * (-2.D0*XG*H43 )
19269 ELSE
19270C---for QCD Compton, massless matrix element
19271 PDENS = SFUN(IFL-6)/ETA
19272 CCOL = CFFAC
19273 FFUN = XG*(ONE-XG)*Z*(ONE-Z)
19274 GFUN = (ONE-XG)*(ONE-Z)+XG*Z
19275 G11 = 8.D0*((Z**2+XG**2)/(ONE-XG)/(ONE-Z)+TWO*(XG*Z+ONE))
19276 G12 = 64.D0*XG**2*Z+TWO*XG*G11
19277 G1A = 32.D0*XG*GFUN*SQRT(FFUN)/((ONE-XG)*(ONE-Z))
19278 G1B = 16.D0*XG*Z
19279 G3 = -16.D0*(ONE-XG)*(ONE-Z)+G11
19280 GC = -16.D0*XG*SQRT(FFUN)*(ONE-Z-XG)/((ONE-XG)*(ONE-Z))
19281 G21 = ZERO
19282 G22 = ZERO
19283 ENDIF
19284C
19285 A11 = XG * Y**2 * G11 + (1.D0-Y) * G12
19286 & - (2.D0-Y) * SQRT( 1.D0-Y ) * G1A * COS( PHI )
19287 & + 2.D0 * XG * (1.D0-Y) * G1B * COS( 2.D0*PHI )
19288C
19289 A12 = XG * Y**2 * G21 + (1.D0-Y) * G22
19290C
19291 A44 = XG * Y * (2.D0-Y) * G3
19292 & - 2.D0 * Y * SQRT( 1.D0-Y ) * GC * COS( PHI )
19293C
19294 IF ( Y*Q2**2 .LT. 1D-38 ) THEN
19295C---prevent numerical uncertainties in DSIGMA computation
19296 DSIGMA = PDENS*ALPHA**2*ALPHAS*GEV2NB*CCOL/(16.D0*PIFAC)
19297 & *(DLQ(1)*A11 + DLQ(2)*A12 + FLOAT(LEP)*DLQ(3)*A44)
19298 IF ( DSIGMA .LE. ZERO ) GOTO 888
19299 LDSIG = LOG (DSIGMA) - LOG (Y) - 2.D0 * LOG (Q2)
19300 DSIGMA = EXP (LDSIG)
19301 ELSE
19302 DSIGMA = PDENS*ALPHA**2*ALPHAS*GEV2NB*CCOL
19303 & * (DLQ(1)*A11 + DLQ(2)*A12 + FLOAT(LEP)*DLQ(3)*A44)
19304 & / (16.D0*PIFAC*Y*Q2**2)
19305 ENDIF
19306 IF (DSIGMA.LT.ZERO) GOTO 888
19307 RETURN
19308C
19309 200 CONTINUE
19310C--- J/psi production
19311 ALPHA = HWUAEM(-Q2)
19312 GAMMA = 4.8D-6
19313 PDENS = SFUN(13)/ETA
19314 AFACT = (8.D0*PIFAC*ALPHAS**2*RMASS(164)**3*GAMMA)/(3.D0*ALPHA)
19315 BFACT = ONE/(Y*SG*Z**2*((Z-ONE)*Y*SG-RMASS(164)**2)**2)
19316 CFACT = (RMASS(164)**2-Z*Y*SG)**2/(Y*SG*(ONE-XG)**2*
19317 & ((ONE-XG)*Y*SG-RMASS(164)**2)**2*
19318 & ((Z-ONE)*Y*SG-RMASS(164)**2)**2)
19319 DFACT = ((Z-ONE)*Y*SG)**2/(Y*SG*(ONE-XG)**2*
19320 & ((ONE-XG)*Y*SG-RMASS(164)**2)**2*(Z*Y*SG)**2)
19321 DSIGMA = GEV2NB*ALPHA/(TWO*PIFAC)*AFACT*(BFACT+CFACT+DFACT)*PDENS
19322 IF (DSIGMA.LT.ZERO ) GOTO 888
19323 RETURN
19324 888 DSIGMA=ZERO
19325 END
19326CDECK ID>, HWHDIS.
19327*CMZ :- -26/04/91 14.55.44 by Federico Carminati
19328*-- Author : Giovanni Abbiendi & Luca Stanco
19329C----------------------------------------------------------------------
19330 SUBROUTINE HWHDIS
19331C----------------------------------------------------------------------
19332C DEEP INELASTIC LEPTON-HADRON SCATTERING: MEAN EVWGT = SIGMA IN NB
19333C----------------------------------------------------------------------
c63d70bc 19334 INCLUDE 'herwig65.inc'
65767955 19335 DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,PRAN,PROB,SAMP,SIG,Q2,
19336 & XBJ,Y,W,S,MLEP,MHAD,MLSCAT,YMIN,YMAX,XXMAX,Q2JAC,XXJAC,
19337 & JACOBI,A1,A2,A3,B1,B2,PCM,PCMEP,PCMLW,PCMEQ,PCMLQ,COSPHI,PA,
19338 & EQ,PZQ,SHAT,PROP,DLEFT,DRGHT,DUP,DWN,FACT,EFACT,OMY2,YPLUS,
19339 & YMNUS,SIGMA,AF(7,12),SMA,Q2SUP,HWUAEM,DCHRG,DNEUT
19340 INTEGER I,IQK,IQKIN,IQKOUT,IDSCAT,IHAD,ILEPT,LEP
19341 LOGICAL CHARGD
19342 EXTERNAL HWRGEN,HWRUNI,HWUPCM
19343 SAVE MLEP,MHAD,S,SMA,PCM,MLSCAT,A1,A2,A3,B1,B2,DLEFT,DRGHT,Q2,
19344 & AF,XBJ,Y,YPLUS,YMNUS,OMY2,FACT,EFACT,SIGMA,IDSCAT,CHARGD,
19345 & ILEPT,DCHRG,DNEUT,LEP
19346 IQK=MOD(IPROC,10)
19347 IHAD=2
19348 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
19349 IF (FSTWGT.OR.IHAD.NE.2) THEN
19350C---INITIALISE PROCESS (MUST BE DONE EVERY TIME IF S VARIES)
19351C---LEPTON AND HADRON MASSES, INVARIANT MASS, MOMENTUM IN C.M. FRAME
19352 MLEP=PHEP(5,1)
19353 MHAD=PHEP(5,IHAD)
19354 S=PHEP(5,3)**2
19355 SMA=S-MLEP**2-MHAD**2
19356 PCM=HWUPCM(SQRT(S),MLEP,MHAD)
19357C---LEP = 1 FOR LEPTONS, -1 FOR ANTILEPTONS
19358 IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
19359 LEP=1
19360 ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
19361 LEP=-1
19362 ELSE
19363 CALL HWWARN('HWHDIS',500)
19364 ENDIF
19365 DCHRG=FLOAT(MOD(IDHW(1) ,2))
19366 DNEUT=FLOAT(MOD(IDHW(1)+1,2))
19367 ILEPT=MOD(IDHW(1)-121,6)+11
19368C---DLEFT,DRIGHT = 1,0 for leptons; = 0,1 for anti-leptons
19369 DLEFT=MAX(LEP,0)
19370 DRGHT=MAX(-LEP,0)
19371 CHARGD=MOD(IPROC,100)/10.EQ.1
19372C---Evaluate constant factor in cross section and
19373C find and store scattered lepton identity
19374 IF (CHARGD) THEN
19375 IF ((EPOLN(3)-PPOLN(3)).EQ.ONE) THEN
19376 WRITE(6,5)
19377 CALL HWWARN('HWHDIS',501)
19378 5 FORMAT(1X,'WARNING: Cross-section is zero for the',
19379 & ' specified lepton helicity')
19380 ENDIF
19381 FACT=GEV2NB*(ONE-(EPOLN(3)-PPOLN(3)))*.25D0*PIFAC
19382 & /(SWEIN*RMASS(198)**2)**2
19383 IDSCAT=IDHW(1)+NINT(DCHRG-DNEUT)
19384 ELSE
19385 FACT=GEV2NB*TWO*PIFAC
19386 IDSCAT=IDHW(1)
19387 ENDIF
19388 MLSCAT=RMASS(IDSCAT)
19389C---PARAMETERS USED FOR THE WEIGHT GENERATION IN NEUTRAL CURRENT
19390C PROCESSES. ASSUME D(SIGMA)/D(Q**2) GOES LIKE A1+A2/Q**2+A3/Q**4
19391C AND D(SIGMA)/D(X) LIKE B1+B2/X
19392 A1=0.5
19393 A2=0.5
19394 A3=1.
19395 B1=0.1
19396 B2=1.
19397 ENDIF
19398 IF (GENEV) THEN
19399C---GENERATE EVENT (KINEMATICAL VARIABLES AND STRUCTURE FUNCTION
19400C ALREADY FOUND)
19401 PRAN=SIGMA*HWRGEN(0)
19402 IF (CHARGD) THEN
19403C---CHARGED CURRENT PROCESS
19404 IF (IQK.EQ.0) THEN
19405C---FIND FLAVOUR OF THE STRUCK QUARK (IF NOT SELECTED BY THE USER)
19406 PROB=ZERO
19407 DO 10 I=1,6
19408 DUP=MOD(I+1,2)
19409 DWN=MOD(I ,2)
19410 PROB=PROB+EFACT*
19411 & ((DCHRG*(DLEFT*DUP+DRGHT*DWN*OMY2)
19412 & +DNEUT*(DLEFT*DWN+DRGHT*DUP*OMY2))*DISF(I ,1)
19413 & +(DCHRG*(DLEFT*DWN*OMY2+DRGHT*DUP)
19414 & +DNEUT*(DLEFT*DUP*OMY2+DRGHT*DWN))*DISF(I+6,1))
19415 IF (PROB.GE.PRAN) GOTO 20
19416 10 CONTINUE
19417 I=6
19418 20 IQK=I
19419 ENDIF
19420 DUP=MOD(IQK+1,2)
19421 DWN=MOD(IQK ,2)
19422 IQKIN=IQK
19423 IF ((LEP.EQ. 1.AND.MOD(IQK+IDHW(1),2).EQ.0)
19424 & .OR.(LEP.EQ.-1.AND.MOD(IQK+IDHW(1),2).EQ.1)) IQKIN=IQK+6
19425C---FIND FLAVOUR OF THE OUTGOING QUARK
19426 PRAN=HWRGEN(0)
19427 PROB=ZERO
19428 IF (DUP.EQ.ONE) THEN
19429 DO 30 I=1,3
19430 PROB=PROB+VCKM(IQK/2,I)
19431 IF (PROB.GE.PRAN) GOTO 40
19432 30 CONTINUE
19433 I=3
19434 40 IQKOUT=2*I-1
19435 IF (IQKIN.GT.6) IQKOUT=IQKOUT+6
19436 ELSE
19437 DO 50 I=1,3
19438 PROB=PROB+VCKM(I,(IQK+1)/2)
19439 IF (PROB.GE.PRAN) GOTO 60
19440 50 CONTINUE
19441 I=3
19442 60 IQKOUT=2*I
19443 IF (IQKIN.GT.6) IQKOUT=IQKOUT+6
19444 ENDIF
19445 ELSE
19446C---NEUTRAL CURRENT PROCESS
19447 IF (IQK.NE.0) THEN
19448 IQKIN=IQK
19449 PROB=EFACT*(AF(1,IQK)*YPLUS*DISF(IQK,1)+
19450 & FLOAT(LEP)*AF(3,IQK)*YMNUS*DISF(IQK,1))
19451 IF (PROB.LT.PRAN) IQKIN=IQK+6
19452 ELSE
19453C---FIND FLAVOUR OF THE STRUCK QUARK (IF NOT SELECTED BY THE USER)
19454 PROB=ZERO
19455 SIG=ONE
19456 DO 70 I=1,12
19457 IF (I.GT.6) SIG=-ONE
19458 PROB=PROB+EFACT*(AF(1,I)*YPLUS*DISF(I,1)+
19459 & FLOAT(LEP)*SIG*AF(3,I)*YMNUS*DISF(I,1))
19460 IF (PROB.GE.PRAN) GOTO 80
19461 70 CONTINUE
19462 I=12
19463 80 IQKIN=I
19464 ENDIF
19465 IQKOUT=IQKIN
19466 ENDIF
19467 IDN(1)=IDHW(1)
19468 IDN(2)=IQKIN
19469 IDN(3)=IDSCAT
19470 IDN(4)=IQKOUT
19471 ICO(1)=1
19472 ICO(2)=4
19473 ICO(3)=3
19474 ICO(4)=2
19475 XX(1)=1.
19476 XX(2)=XBJ
19477C---CHECK PHASE SPACE WITH THE SELECTED FLAVOUR. IF OUTSIDE THE
19478C EVENT IS KILLED.
19479 PA=XBJ*(PHEP(4,IHAD)+ABS(PHEP(3,IHAD)))
19480 EQ=HALF*(PA+RMASS(IDN(2))**2/PA)
19481 PZQ=-(PA-EQ)
19482 SHAT=(PHEP(4,1)+EQ)**2-(PHEP(3,1)+PZQ)**2
19483 PCMEQ=HWUPCM(SQRT(SHAT),MLEP,RMASS(IDN(2)))
19484 PCMLQ=HWUPCM(SQRT(SHAT),MLSCAT,RMASS(IDN(4)))
19485 IF (PCMLQ.LT.ZERO) THEN
19486 CALL HWWARN('HWHDIS',101)
19487 GOTO 999
19488 ELSEIF (PCMLQ.EQ.ZERO) THEN
19489 COSTH=ZERO
19490 ELSE
19491 COSTH=(TWO*SQRT(PCMEQ**2+MLEP**2)*SQRT(PCMLQ**2+MLSCAT**2)
19492 & -(Q2+MLEP**2+MLSCAT**2))/(TWO*PCMEQ*PCMLQ)
19493 ENDIF
19494 IF (ABS(COSTH).GT.ONE) THEN
19495 CALL HWWARN('HWHDIS',102)
19496 GOTO 999
19497 ENDIF
19498 IDCMF=15
19499 CALL HWETWO(.TRUE.,.TRUE.)
19500 ELSE
19501 EVWGT=ZERO
19502 IF (CHARGD) THEN
19503C---CHOOSE X,Y (CC PROCESS)
19504 YMIN=MAX(YBMIN,Q2MIN/SMA)
19505 YMAX=MIN(YBMAX,ONE)
19506 IF (YMIN.GT.YMAX) GOTO 999
19507 Y=HWRUNI(0,YMIN,YMAX)
19508 XXMIN=Q2MIN/S/Y
19509 XXMAX=MIN(Q2MAX/SMA/Y,ONE)
19510 IF (XXMIN.GT.XXMAX) GOTO 999
19511 XBJ=HWRUNI(0,XXMIN,XXMAX)
19512 Q2=XBJ*Y*(S-MLEP**2-MHAD**2)
19513 JACOBI=(YMAX-YMIN)*(XXMAX-XXMIN)*(S-MLEP**2-MHAD**2)*XBJ
19514 ELSE
19515C---CHOOSE X,Q**2 (NC PROCESS)
19516 Q2SUP=MIN(Q2MAX,SMA*YBMAX)
19517 IF (Q2MIN.GT.Q2SUP) GOTO 999
19518 SAMP=(A1+A2+A3)*HWRGEN(0)
19519 IF (SAMP.LE.A1) THEN
19520 Q2=HWRUNI(0,Q2MIN,Q2SUP)
19521 ELSEIF (SAMP.LE.(A1+A2)) THEN
19522 Q2=EXP(HWRUNI(0,LOG(Q2MIN),LOG(Q2SUP)))
19523 ELSE
19524 Q2=-ONE/HWRUNI(0,-ONE/Q2MIN,-ONE/Q2SUP)
19525 ENDIF
19526 Q2JAC=(A1+A2+A3)/
19527 & (A1/(Q2SUP-Q2MIN)
19528 & +A2/LOG(Q2SUP/Q2MIN)/Q2
19529 & +A3*Q2MIN*Q2SUP/(Q2SUP-Q2MIN)/Q2**2)
19530 XXMIN=Q2/SMA/YBMAX
19531 XXMAX=ONE
19532 IF (YBMIN.GT.ZERO) XXMAX=MIN(Q2/SMA/YBMIN,ONE)
19533 IF (XXMIN.GT.XXMAX) GOTO 999
19534 SAMP=(B1+B2)*HWRGEN(0)
19535 IF (SAMP.LE.B1) THEN
19536 XBJ=HWRUNI(0,XXMIN,XXMAX)
19537 ELSE
19538 XBJ=EXP(HWRUNI(0,LOG(XXMIN),LOG(XXMAX)))
19539 ENDIF
19540 XXJAC=(B1+B2)/(B1/(XXMAX-XXMIN)+B2/LOG(XXMAX/XXMIN)/XBJ)
19541 Y=Q2/(S-MLEP**2-MHAD**2)/XBJ
19542 JACOBI=Q2JAC*XXJAC
19543 ENDIF
19544C---CHECK IF THE GENERATED POINT IS INSIDE PHASE SPACE. IF NOT
19545C RETURN WITH WEIGHT EQUAL TO ZERO.
19546 W=SQRT(MHAD**2+Q2*(ONE-XBJ)/XBJ)
19547 IF (W.LT.WHMIN) RETURN
19548 PCMEP=PCM
19549 PCMLW=HWUPCM(SQRT(S),MLSCAT,W)
19550 IF (PCMLW.LT.ZERO) THEN
19551 EVWGT=ZERO
19552 RETURN
19553 ELSEIF (PCMLW.EQ.ZERO) THEN
19554 COSPHI=ZERO
19555 ELSE
19556 COSPHI=
19557 & (TWO*SQRT(PCMEP**2+MLEP**2)*SQRT(PCMLW**2+MLSCAT**2)
19558 & -(Q2+MLEP**2+MLSCAT**2))/(TWO*PCMEP*PCMLW)
19559 ENDIF
19560 IF (ABS(COSPHI).GT.ONE) THEN
19561 EVWGT=ZERO
19562 RETURN
19563 ENDIF
19564C---SET SCALE EQUAL Q. EVALUATE STRUCTURE FUNCTIONS.
19565 EMSCA=SQRT(Q2)
19566 CALL HWSFUN(XBJ,EMSCA,IDHW(IHAD),NSTRU,DISF,2)
19567C---SWITCH OFF ANY FLAVOURS THAT ARE BELOW THRESHOLD
19568 DO 90 I=1,12
19569 90 IF (W.LT.2*RMASS(I)) DISF(I,1)=0
19570C---EVALUATE DIFFERENTIAL CROSS SECTION
19571 IF (CHARGD) THEN
19572 PROP=RMASS(198)**2/(Q2+RMASS(198)**2)
19573 EFACT=FACT*(HWUAEM(-Q2)*PROP)**2/XBJ
19574 OMY2=(ONE-Y)**2
19575 SIGMA=ZERO
19576 DO 100 I=1,6
19577 DUP=MOD(I+1,2)
19578 DWN=MOD(I ,2)
19579 IF (IQK.NE.0.AND.IQK.NE.I) GOTO 100
19580 SIGMA=SIGMA+EFACT*
19581 & ((DCHRG*(DLEFT*DUP+DRGHT*DWN*OMY2)
19582 & +DNEUT*(DLEFT*DWN+DRGHT*DUP*OMY2))*DISF(I ,1)
19583 & +(DCHRG*(DLEFT*DWN*OMY2+DRGHT*DUP)
19584 & +DNEUT*(DLEFT*DUP*OMY2+DRGHT*DWN))*DISF(I+6,1))
19585 100 CONTINUE
19586 ELSE
19587 EFACT=FACT/XBJ*(HWUAEM(-Q2)/Q2)**2
19588 YPLUS=ONE+(ONE-Y)**2
19589 YMNUS=ONE-(ONE-Y)**2
19590 DO 110 I=1,6
19591 CALL HWUCFF(ILEPT,I,-Q2,AF(1,I))
19592 AF(1,I+6)=AF(1,I)
19593 AF(3,I+6)=AF(3,I)
19594 110 CONTINUE
19595 SIGMA=ZERO
19596 DO 200 I=1,6
19597 IF (IQK.NE.0.AND.IQK.NE.I) GOTO 200
19598 SIGMA=SIGMA+EFACT*(AF(1,I)*YPLUS*(DISF(I,1)+DISF(I+6,1))+
19599 & FLOAT(LEP)*AF(3,I)*YMNUS*(DISF(I,1)-DISF(I+6,1)))
19600 200 CONTINUE
19601 ENDIF
19602C---FIND WEIGHT: DIFFERENTIAL CROSS SECTION TIME THE JACOBIAN FACTOR
19603 EVWGT=SIGMA*JACOBI
19604 IF (EVWGT.LT.ZERO) EVWGT=ZERO
19605 ENDIF
19606 999 RETURN
19607 END
19608CDECK ID>, HWHDYP.
19609*CMZ :- -18/05/99 12.41.07 by Mike Seymour
19610*-- Author : Bryan Webber, Ian Knowles and Mike Seymour
19611C-----------------------------------------------------------------------
19612 SUBROUTINE HWHDYP
19613C-----------------------------------------------------------------------
19614C Drell-Yan Production of fermion pairs via photon, Z0 & (if ZPRIME)
19615C Z' exchange. Lepton universality is assumed for photon and Z, and
19616C for Z' if no lepton flavour is specified.
19617C MEAN EVWGT = SIGMA IN NB
19618C
19619C Modified 16/01/01 by BRW to implement Peter Richardson's
19620C fix for bug in lepton mass effects on branching ratio
19621C-----------------------------------------------------------------------
c63d70bc 19622 INCLUDE 'herwig65.inc'
65767955 19623 DOUBLE PRECISION HWRGEN,HWRUNI,HWUAEM,EPS,C1,C2,C3,EMSQZ,EMGMZ,
19624 & EMSQZP,EMGMZP,CQF(7,6,16),QPOW,RPOW,A01,A1,A02,A2,A03,A3,CRAN,
19625 & EMJ1,EMJ2,EMJ3,EMJAC,FACT,QSQ,HCS,FACTR,RCS,EXTRA,PMAX,PTHETA
19626 INTEGER IMODE,JQMN,JQMX,JQ,JLMN,JLMX,JL,IQ,I,IADD(2,2),ID1,ID2,
19627 & ID3,ID4,JF
19628 EXTERNAL HWRGEN,HWRUNI,HWUAEM
19629 SAVE HCS,JQMN,JQMX,JLMN,JLMX,C1,C2,C3,QPOW,RPOW,EMSQZ,EMGMZ,
19630 & A1,A01,A2,A02,A3,A03,EMSQZP,EMGMZP,FACT,CQF
19631 PARAMETER (EPS=1.D-9)
19632 SAVE IADD
19633 DATA IADD/0,6,6,0/
19634 IF (GENEV) THEN
19635 RCS=HCS*HWRGEN(0)
19636 ELSE
19637 IF (FSTWGT) THEN
19638C Set limits for which particles to include
19639 JLMN=1
19640 JLMX=0
19641 JQMN=1
19642 JQMX=0
19643 IMODE=MOD(IPROC,100)
19644 IF (IMODE.EQ.0) THEN
19645 JQMN=1
19646 JQMX=6
19647 ELSEIF (IMODE.LE.10) THEN
19648 JQMN=IMODE
19649 JQMX=IMODE
19650 ELSEIF (IMODE.EQ.50) THEN
19651 JLMN=11
19652 JLMX=16
19653 ELSEIF (IMODE.GE.50.AND.IMODE.LE.60) THEN
19654 JLMN=IMODE-40
19655 JLMX=IMODE-40
19656 ELSEIF (IMODE.EQ.99) THEN
19657 JQMN=1
19658 JQMX=6
19659 JLMN=11
19660 JLMX=16
19661 ELSE
19662 CALL HWWARN('HWHDYP',500)
19663 ENDIF
19664C Set up parameters for importance sampling:
19665C sum of power law and two Breit-Wigners (relative weights C1,C2,C3)
19666 C1=ONE
19667 C2=ONE
19668 C3=ZERO
19669 IF (ZPRIME) C3=ONE
19670 IF (EMPOW.EQ.ONE) CALL HWWARN('HWHDYP',501)
19671 IF (C2.EQ.ZERO) CALL HWWARN('HWHDYP',502)
19672 IF (C3.EQ.ZERO.AND.ZPRIME) CALL HWWARN('HWHDYP',503)
19673 QPOW=-EMPOW+1
19674 RPOW=1/QPOW
19675 EMSQZ=RMASS(200)**2
19676 EMGMZ=RMASS(200)*GAMZ
19677 A01=EMMIN**QPOW
19678 A1=(EMMAX**QPOW-A01)/C1
19679 A02=ATAN((EMMIN**2-EMSQZ)/EMGMZ)
19680 A2=(ATAN((EMMAX**2-EMSQZ)/EMGMZ)-A02)/C2
19681 IF (C3.GT.ZERO) THEN
19682 EMSQZP=RMASS(202)**2
19683 EMGMZP=RMASS(202)*GAMZP
19684 A03=ATAN((EMMIN**2-EMSQZP)/EMGMZP)
19685 A3=(ATAN((EMMAX**2-EMSQZP)/EMGMZP)-A03)/C3
19686 ENDIF
19687 ENDIF
19688 EVWGT=0.
19689C Select a mass for the produced pair
19690 CRAN=(C1+C2+C3)*HWRGEN(1)
19691 IF (CRAN.LT.C1) THEN
19692C Use power law
19693 EMSCA=(A01+A1*CRAN)**RPOW
19694 QSQ=EMSCA**2
19695 ELSEIF (CRAN.LT.C1+C2) THEN
19696C Use Z Breit-Wigner
19697 CRAN=CRAN-C1
19698 QSQ=EMSQZ+EMGMZ*TAN(A02+A2*CRAN)
19699 EMSCA=SQRT(QSQ)
19700 ELSE
19701C Use Z' Breit-Wigner
19702 CRAN=CRAN-C1-C2
19703 QSQ=EMSQZP+EMGMZP*TAN(A03+A3*CRAN)
19704 EMSCA=SQRT(QSQ)
19705 ENDIF
19706 EMJ1=EMSCA**EMPOW/(1-EMPOW)*A1
19707 EMJ2=((QSQ-EMSQZ)**2+EMGMZ**2)/(2*EMSCA*EMGMZ)*A2
19708 IF (C3.GT.ZERO) THEN
19709 EMJ3=((QSQ-EMSQZP)**2+EMGMZP**2)/(2*EMSCA*EMGMZP)*A3
19710 EMJAC=(C1+C2+C3)/(1/EMJ1+1/EMJ2+1/EMJ3)
19711 ELSE
19712 EMJAC=(C1+C2)/(1/EMJ1+1/EMJ2)
19713 ENDIF
19714C Select initial momentum fractions
19715 XXMIN=QSQ/PHEP(5,3)**2
19716 XLMIN=LOG(XXMIN)
19717 CALL HWSGEN(.TRUE.)
19718 FACT=-GEV2NB*HWUAEM(QSQ)**2*PIFAC*8*EMJAC*XLMIN
19719 $ /(3*NCOLO*EMSCA**3)
19720C Store cross-section coefficients
19721 DO 50 IQ=1,6
19722 DO 30 JQ=JQMN,JQMX
19723 IF (EMSCA.GT.2.*RMASS(JQ)) THEN
19724 CALL HWUCFF(IQ,JQ,QSQ,CQF(1,IQ,JQ))
19725 ELSE
19726 CALL HWVZRO(7,CQF(1,IQ,JQ))
19727 ENDIF
19728 30 CONTINUE
19729 DO 40 JL=JLMN,JLMX
19730 IF (EMSCA.GT.2.*RMASS(JL+110)) THEN
19731 CALL HWUCFF(IQ,JL,QSQ,CQF(1,IQ,JL))
19732 ELSE
19733 CALL HWVZRO(7,CQF(1,IQ,JL))
19734 ENDIF
19735 40 CONTINUE
19736 50 CONTINUE
19737 ENDIF
19738C
19739 HCS=0.
19740 DO 90 I=1,2
19741C I=1 quark first, I=2 anti-quark first
19742 DO 80 IQ=1,6
19743 ID1=IQ+IADD(1,I)
19744 ID2=IQ+IADD(2,I)
19745 IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 80
19746 FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
19747C Quark final states
19748 DO 60 JQ=JQMN,JQMX
19749 ID3=JQ
19750 ID4=JQ+6
19751 IF (IQ.EQ.JQ) THEN
19752 HCS=HCS+FACTR*(CQF(1,IQ,JQ)*FLOAT(NCOLO)+3*HALF*QFCH(IQ)**4)
19753 IF (GENEV.AND.HCS.GT.RCS) THEN
19754 CALL HWHQCP(ID3,ID4,2143,50)
19755 GOTO 99
19756 ENDIF
19757 ELSE
19758 HCS=HCS+FACTR*CQF(1,IQ,JQ)*FLOAT(NCOLO)
19759 IF (GENEV.AND.HCS.GT.RCS) THEN
19760 CALL HWHQCP(ID3,ID4,2143,50)
19761 GOTO 99
19762 ENDIF
19763 ENDIF
19764 60 CONTINUE
19765C Lepton final states
19766 DO 70 JL=JLMN,JLMX
19767 ID3=110+JL
19768 ID4=ID3+6
19769 HCS=HCS+FACTR*CQF(1,IQ,JL)
19770 IF (GENEV.AND.HCS.GT.RCS) THEN
19771 CALL HWHQCP(ID3,ID4,2134,50)
19772 GOTO 99
19773 ENDIF
19774 70 CONTINUE
19775 80 CONTINUE
19776 90 CONTINUE
19777 EVWGT=HCS
19778 RETURN
19779C Generate event
19780 99 IDN(1)=ID1
19781 IDN(2)=ID2
19782 IDCMF=200
19783 IF (ID3.LE.6) THEN
19784 JF=JQ
19785 ELSE
19786 JF=JL
19787 ENDIF
19788C Select polar angle from distribution:
19789C CQF(1,IQ,JF)*(ONE+COSTH**2)+CQF(3,IQ,JF)*COSTH+EXTRA*(ONE+COSTH)
19790 IF (ID1.EQ.ID3.OR.ID2.EQ.ID3) THEN
19791 EXTRA=TWO*QFCH(ID3)**4/NCOLO
19792 ELSE
19793 EXTRA=0
19794 ENDIF
19795 PMAX=2.*(CQF(1,IQ,JF)+EXTRA)+ABS(CQF(3,IQ,JF))
19796 100 COSTH=HWRUNI(0,-ONE,ONE)
19797 PTHETA=CQF(1,IQ,JF)*(ONE+COSTH**2)+TWO*CQF(3,IQ,JF)*COSTH
19798 & +EXTRA*(ONE+COSTH)
19799 IF (PTHETA.LT.PMAX*HWRGEN(1)) GOTO 100
19800 IF (ID1.GT.ID2) COSTH=-COSTH
19801 IDCMF=200
19802 CALL HWETWO(.TRUE.,.TRUE.)
19803 END
19804CDECK ID>, HWHDYQ.
19805*CMZ :- -14/03/01 09:03:25 by Peter Richardson
19806*-- Author : Peter Richardson
19807C-----------------------------------------------------------------------
19808 SUBROUTINE HWHDYQ(FSTCLL,HCS,IFLOW,IDP,ORD,IQ,MASS)
19809C-----------------------------------------------------------------------
19810C Drell-Yan production with a q qbar pair
19811C-----------------------------------------------------------------------
c63d70bc 19812 INCLUDE 'herwig65.inc'
65767955 19813 INTEGER I,MAP(12),ORD,IFL,IDP(6),IFLOW,QCFL(2,2),GCFL(2),IDZ,IQ
19814 DOUBLE PRECISION HCS,RCS,MQ(2,5),HWRGEN,G(12,2),DIST(2),MG(2)
19815 LOGICAL FSTCLL,MASS
19816 EXTERNAL HWRGEN
19817 COMMON/HWHZBC/G
19818 SAVE MQ,MG
19819 SAVE MAP,QCFL,GCFL
19820 DATA MAP/1,2,3,4,5,6,11,12,13,14,15,16/
19821 DATA QCFL/2413,3142,4123,2341/
19822 DATA GCFL/2413,4123/
19823 IF(GENEV) THEN
19824 RCS = HCS*HWRGEN(1)
19825 ELSE
19826C--to the initalisation
19827 IF(FSTCLL) THEN
19828C--G(I,1) is the right charge and G(I,2) is the left charge
19829 DO I=1,12
19830 G(I,1) = VFCH(MAP(I),1)-AFCH(MAP(I),1)
19831 G(I,2) = VFCH(MAP(I),1)+AFCH(MAP(I),1)
19832 ENDDO
19833 FSTCLL = .FALSE.
19834 ENDIF
19835C--identify the Z decay product
19836 IDZ = IDP(5)
19837 IF(IDZ.GT.6) IDZ = IDZ-114
19838C--calculate the matrix elements
19839 IF(MASS) THEN
19840C--massive case
19841 CALL HWH2MQ(IQ,IDZ,MG,MQ)
19842 ELSE
19843C--massless case
19844 CALL HWH2M0(IQ,IDZ,MG,MQ)
19845 ENDIF
19846 ENDIF
19847C--multiply the matrix elements by the PDF's to obtain the cross section
19848 HCS = ZERO
19849 IDP(3) = IQ
19850 IDP(4) = IQ+6
19851C--first the qqbar initial states
19852 DO I=1,5
19853 IDP(1) = I
19854 IDP(2) = IDP(1)+6
19855 DIST(1) = DISF(IDP(1),1)*DISF(IDP(2),2)
19856 DIST(2) = DISF(IDP(1),2)*DISF(IDP(2),1)
19857 DO ORD=1,2
19858 DO IFL=1,2
19859 IFLOW = QCFL(IFL,ORD)
19860 HCS = HCS+DIST(ORD)*MQ(IFL,IDP(1))/36.0D0
19861 IF(GENEV.AND.HCS.GT.RCS) RETURN
19862 ENDDO
19863 ENDDO
19864 ENDDO
19865C--then the gluon gluon inital state
19866 IDP(1) = 13
19867 IDP(2) = 13
19868 DIST(1) = DISF(IDP(1),1)*DISF(IDP(1),2)
19869 DO IFL=1,2
19870 IFLOW = GCFL(IFL)
19871 HCS = HCS+DIST(1)*MG(IFL)/256.0D0
19872 IF(GENEV.AND.HCS.GT.RCS) RETURN
19873 ENDDO
19874 END
19875CDECK ID>, HWHEGG.
19876*CMZ :- -19/03/92 10.13.56 by Mike Seymour
19877*-- Author : Mike Seymour
19878C-----------------------------------------------------------------------
19879 SUBROUTINE HWHEGG
19880C----------------------------------------------------------------------
19881C HARD PROCESS: EE --> EEGAMGAM --> EEFFBAR/WW
19882C MEAN EVENT WEIGHT = CROSS-SECTION IN NB
19883C AFTER CUTS ON PT AND MASS OF CENTRE-OF-MASS SYSTEM
19884C AND COS(THETA) IN CENTRE-OF-MASS SYSTEM
19885C AND TIMES BRANCHING FRACTION IF WW
19886C-----------------------------------------------------------------------
c63d70bc 19887 INCLUDE 'herwig65.inc'
65767955 19888 DOUBLE PRECISION HWRGEN,HWULDO,EMSQ,BETA,S,T,U,TMIN,TMAX,TRAT,
19889 & DSDT,PROB,X,Z(2),ZMIN,ZMAX,PCMIN,PCMAX,PCFAC,PLOGMI,PLOGMA,PTCMF,
19890 & Q,PC,BLOG,EMCMIN,EMCMAX,EMLMIN,EMLMAX,WGT(6),RWGT,CV,CA,BR,QT(2),
19891 & QX(2),QY(2),PX,PY,ROOTS,DOT,A,B,C,SHAT,PCF(2),PCM(2),PCMAC,ZZ(2),
19892 & COLFAC
19893 INTEGER I,IGAM,ID,IDL,ID1,ID2,IHEP,JHEP,NADD,NTRY,NQ,JGAM
19894 LOGICAL HWRLOG
19895 EXTERNAL HWRGEN,HWULDO,HWRLOG
19896 SAVE S,BETA,X,ID,NQ,WGT,EMLMIN,EMLMAX,PCFAC,PLOGMA,PLOGMI,SHAT,
19897 & PCF,PCM,Z,PCMAC,NADD
19898 IF (IERROR.NE.0) RETURN
19899C---INITIALIZE LOCAL COPIES OF EMMIN,EMMAX
19900 IF (FSTWGT) THEN
19901 EMLMIN=EMMIN
19902 EMLMAX=EMMAX
19903 ENDIF
19904 IF (.NOT.GENEV) THEN
19905C---CHOOSE Z1,Z2 AND CALCULATE SUB-PROCESS CROSS-SECTION
19906 EVWGT=0
19907C-----FIND FINAL STATE PARTICLES
19908 IHPRO=MOD(IPROC,100)
19909 IF (IHPRO.EQ.0) THEN
19910 ID=1
19911 NQ=6
19912 COLFAC=FLOAT(NCOLO)
19913 NADD=6
19914 ELSEIF (IHPRO.LE.6) THEN
19915 ID=IHPRO
19916 NQ=1
19917 COLFAC=FLOAT(NCOLO)
19918 NADD=6
19919 Q=QFCH(ID)
19920 ELSEIF (IHPRO.LE.9) THEN
19921 ID=119+2*(IHPRO-6)
19922 NQ=1
19923 COLFAC=1.
19924 NADD=6
19925 Q=QFCH(ID-110)
19926 ELSEIF (IHPRO.LE.10) THEN
19927 ID=198
19928 NQ=1
19929 NADD=1
19930 ELSE
19931 CALL HWWARN('HWHEGG',200)
19932 ENDIF
19933C-----SPLIT ELECTRONS TO PHOTONS
19934 NHEP=3
19935 GAMWT=1
19936 S=2*HWULDO(PHEP(1,1),PHEP(1,2))
19937 ROOTS=SQRT(S)
19938 EMCMIN=MAX(EMLMIN,MAX(2*RMASS(ID),PTMIN))
19939 EMCMAX=MIN(EMLMAX,ROOTS)
19940 IF (EMCMIN.GT.EMCMAX) RETURN
19941 ZMIN=EMCMIN**2/S
19942 ZMAX=1-PHEP(5,1)/PHEP(4,1)
19943 IF (ZMIN.GT.ZMAX) RETURN
19944 CALL HWEGAM(1,ZMIN,ZMAX,.TRUE.)
19945 Z(1)=PHEP(4,NHEP-1)/PHEP(4,1)
19946 ZMIN=EMCMIN**2/(Z(1)*S)
19947 ZMAX=MIN(EMCMAX**2/(Z(1)*S), ONE-PHEP(5,2)/PHEP(4,2))
19948 IF (ZMIN.GT.ZMAX) RETURN
19949 CALL HWEGAM(2,ZMIN,ZMAX,.TRUE.)
19950 Z(2)=PHEP(4,NHEP-1)/PHEP(4,2)
19951 EMSCA=PHEP(5,3)
19952 SHAT=EMSCA**2
19953C-----REMOVE LOG TERMS FROM WEIGHT, CALCULATE NEW ONES FROM PT LIMITS
19954 GAMWT=GAMWT/(0.5*LOG((1-Z(1))*S/(Z(1)*PHEP(5,1)**2))
19955 & *0.5*LOG((1-Z(2))*Z(1)*S/(Z(2)*PHEP(5,2)**2)))
19956 PCF(1)=Z(1)*PHEP(5,1)
19957 PCF(2)=Z(2)*PHEP(5,2)
19958 PCFAC=SQRT(PCF(1)*PCF(2))
19959 PCM(1)=(1-Z(1))*PHEP(4,1)
19960 PCM(2)=(1-Z(2))*PHEP(4,2)
19961 PCMAC=SQRT(PCM(1)*PCM(2))
19962 PCMIN=MAX(PTMIN,MAX(PCF(1),PCF(2)))
19963 PCMAX=MIN( MIN(PTMAX,PHEP(5,3)) , MIN(PCM(1),PCM(2)) )
19964 IF (PCMIN.GT.PCMAX) RETURN
19965 PLOGMI=(LOG(PCMIN/PCFAC))**2
19966 PLOGMA=(LOG(PCMAX/PCFAC))**2
19967 GAMWT=GAMWT*(PLOGMA-PLOGMI)
19968C-----CALCULATE CROSS-SECTION
19969 DO 10 IDL=1,NQ
19970 WGT(IDL)=EVWGT
19971 IF (IHPRO.EQ.0) THEN
19972 ID=IDL
19973 Q=QFCH(ID)
19974 ENDIF
19975 EMSQ=RMASS(ID)**2
19976 X=4*EMSQ/SHAT
19977 IF (X.GT.ONE) GOTO 10
19978 BETA=SQRT(1-X)
19979 BLOG=LOG((1+BETA*CTMAX)/(1-BETA*CTMAX))/BETA
19980 IF (IHPRO.LE.9) THEN
19981 EVWGT=EVWGT+GEV2NB*4*PIFAC*COLFAC*Q**4*ALPHEM**2*BETA
19982 & /SHAT * GAMWT * ( (1+X-0.5*X**2)*BLOG
19983 & - CTMAX*(1+X**2/(CTMAX**2*(X-1)+1)) )
19984 WGT(IDL)=EVWGT
19985 ELSE
19986 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
19987 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
19988 EVWGT=EVWGT + GEV2NB*6*PIFAC*ALPHEM**2*BETA/SHAT*BR
19989 & * GAMWT * (-( X-0.5*X**2)*BLOG
19990 & + CTMAX*(1+(X**2+16/3.)/(CTMAX**2*(X-1)+1)) )
19991 ENDIF
19992 10 CONTINUE
19993C-----GAMWT MUST BE RESET TO ONE, SINCE IT IS REAPPLIED LATER!
19994 GAMWT=ONE
19995 ELSE
19996C---GENERATE EVENT
19997C-----CHOOSE PT OF THE CMF
19998 PTCMF=PCFAC*EXP(SQRT(HWRGEN(0)*(PLOGMA-PLOGMI)+PLOGMI))
19999C-----CHOOSE WHICH PHOTON USUALLY HAS SMALLER PT
20000 NTRY=0
20001 20 IGAM=1
20002 IF (LOG(PCM(1)/PCF(1)).LT.HWRGEN(1)*2*LOG(PCMAC/PCFAC)) IGAM=2
20003 JGAM=3-IGAM
20004C-----CHOOSE ITS PT
20005 30 NTRY=NTRY+1
20006 IF (NTRY.GT.NBTRY) THEN
20007 CALL HWWARN('HWHEGG',100)
20008 GOTO 999
20009 ENDIF
20010 QT(IGAM)=(PCM(IGAM)/PCF(IGAM))**HWRGEN(2)
20011 PROB=(QT(IGAM)**2/(QT(IGAM)**2+1))**2
20012 QT(IGAM)=QT(IGAM)*PCF(IGAM)
20013 IF (HWRLOG(1-PROB)) GOTO 30
20014C-----CHOOSE ITS DIRECTION
20015 CALL HWRAZM(QT(IGAM),QX(IGAM),QY(IGAM))
20016C-----CALCULATE THE OTHER PHOTON'S PT
20017 QX(JGAM)=PTCMF-QX(IGAM)
20018 QY(JGAM)= -QY(IGAM)
20019 QT(JGAM)=SQRT(QX(JGAM)**2+QY(JGAM)**2)
20020 IF (QT(JGAM).LT.PCF(JGAM).OR.QT(JGAM).GT.PCM(JGAM)) GOTO 20
20021C-----APPLY A RANDOM ROTATION AROUND THE BEAM AXIS
20022 CALL HWRAZM(ONE,PX,PY)
20023 IF (PX.EQ.ZERO) PX=1D-20
20024 QX(1)=(QX(1)*PX -QY(1)*PY)
20025 QY(1)=(QY(1) +QX(1)*PY)/PX
20026 QX(2)=(QX(2)*PX -QY(2)*PY)
20027 QY(2)=(QY(2) +QX(2)*PY)/PX
20028C-----RECONSTRUCT MOMENTA
20029 IF (QT(IGAM).GT.QT(JGAM)) THEN
20030 IGAM=3-IGAM
20031 JGAM=3-JGAM
20032 ENDIF
20033 DOT=-Z(JGAM)*S+SHAT+2*(QX(1)*QX(2)+QY(1)*QY(2))
20034C-------SOLVE QUADRATIC IN Z(IGAM) TO FIND ELECTRON ENERGIES
20035 A=S*(S*Z(JGAM)+QT(JGAM)**2)
20036 B=S*DOT*(1+Z(JGAM))
20037 C=DOT**2+S*QT(IGAM)**2*(1-Z(JGAM))**2-4*QT(IGAM)**2*QT(JGAM)**2
20038 IF (B**2.LT.4*A*C) GOTO 20
20039 ZZ(IGAM)=(-B+SQRT(B**2-4*A*C))/(2*A)
20040 IF (ZZ(IGAM).LT.ZERO .OR. ZZ(IGAM).GT.ONE-Z(IGAM)) GOTO 20
20041 ZZ(JGAM)=1-Z(JGAM)
20042C-------REJECT AGAINST PHOTON DISTRIBUTION FUNCTION
20043 PROB=((1+ZZ(IGAM)**2)/(1-ZZ(IGAM)))/((1+(1-Z(IGAM))**2)/Z(IGAM))
20044 & *((1+ZZ(JGAM)**2)/(1-ZZ(JGAM)))/((1+(1-Z(JGAM))**2)/Z(JGAM))
20045 IF (HWRLOG(1-PROB)) GOTO 20
20046C-------RECONSTRUCT ALL OTHER VARIABLES
20047 DO 40 I=1,2
20048 IGAM=2*I+3
20049 PHEP(1,IGAM)=QX(I)
20050 PHEP(2,IGAM)=QY(I)
20051 PHEP(4,IGAM)=ZZ(I)*PHEP(4,I)
20052 PHEP(5,IGAM)=RMASS(IDHW(IGAM))
20053C---------IF MOMENTUM CANNOT BE CONSERVED TRY AGAIN
20054 IF (PHEP(4,IGAM)**2-PHEP(5,IGAM)**2-QT(I)**2 .LT. 0) GOTO 20
20055 PHEP(3,IGAM)=SIGN(SQRT(PHEP(4,IGAM)**2-PHEP(5,IGAM)**2-
20056 & QT(I)**2),PHEP(3,IGAM))
20057 CALL HWVDIF(4,PHEP(1,I),PHEP(1,IGAM),PHEP(1,IGAM-1))
20058 CALL HWUMAS(PHEP(1,IGAM-1))
20059 40 CONTINUE
20060C-----TIDY UP EVENT RECORD
20061 NHEP=NHEP+1
20062 IDHW(NHEP)=IDHW(3)
20063 IDHEP(NHEP)=IDHEP(3)
20064 ISTHEP(NHEP)=110
20065 CALL HWVSUM(4,PHEP(1,4),PHEP(1,6),PHEP(1,NHEP))
20066 CALL HWVSUM(4,PHEP(1,1),PHEP(1,2),PHEP(1,3))
20067 CALL HWUMAS(PHEP(1,NHEP))
20068 CALL HWUMAS(PHEP(1,3))
20069 JMOHEP(1,NHEP)=4
20070 JMOHEP(2,NHEP)=6
20071 JMOHEP(1,3)=0
20072 JMOHEP(2,3)=0
20073C-----CHOOSE FINAL STATE QUARK
20074 IF (IHPRO.EQ.0) THEN
20075 RWGT=HWRGEN(2)*EVWGT
20076 ID=1
20077 DO 50 IDL=1,NQ
20078 IF (RWGT.GT.WGT(IDL)) ID=IDL+1
20079 50 CONTINUE
20080 EMSQ=RMASS(ID)**2
20081 X=4*EMSQ/SHAT
20082 BETA=SQRT(1-X)
20083 ENDIF
20084C-----CHOOSE T (WHERE T = MANDELSTAM_T - EMSQ)
20085 TMIN=-SHAT/2
20086 TMAX=-SHAT/2*(1-BETA*CTMAX)
20087 TRAT=TMAX/TMIN
20088 NTRY=0
20089 IF (IHPRO.LE.9) THEN
20090C-------FOR FFBAR, CHOOSE T ACCORDING TO -SHAT/T
20091 60 NTRY=NTRY+1
20092 IF (NTRY.GT.NBTRY) THEN
20093 CALL HWWARN('HWHEGG',101)
20094 GOTO 999
20095 ENDIF
20096 T=TRAT**HWRGEN(3)*TMIN
20097 U=-T-SHAT
20098C-------REWEIGHT TO CORRECT DISTRIBUTION
20099 DSDT=(T*U-2*EMSQ*(T+2*EMSQ))/T**2
20100 & +( 2*EMSQ*(SHAT-4*EMSQ))/(T*U)
20101 & +(T*U-2*EMSQ*(U+2*EMSQ))/U**2
20102 PROB=-DSDT*T/SHAT / (1 + 2*X - 2*X**2)
20103 IF (HWRLOG(1-PROB)) GOTO 60
20104 ELSE
20105C-------FOR WW, CHOOSE T ACCORDING TO (SHAT/T)**2
20106 70 NTRY=NTRY+1
20107 IF (NTRY.GT.NBTRY) THEN
20108 CALL HWWARN('HWHEGG',102)
20109 GOTO 999
20110 ENDIF
20111 T=TMAX/(1-(1-TRAT)*HWRGEN(4))
20112 U=-T-SHAT
20113C-------REWEIGHT TO CORRECT DISTRIBUTION
20114 DSDT=( 3*(T*U)**2 - SHAT*T*U*(4*SHAT+6*EMSQ)
20115 & + SHAT**2*(2*SHAT**2+6*EMSQ**2) ) / (T*U)**2
20116 PROB=DSDT*(T/SHAT)**2 / (4.75 - 1.5*X + 1.5*X**2)
20117 IF (HWRLOG(1-PROB)) GOTO 70
20118 ENDIF
20119C-----SYMMETRIZE IN T,U
20120 IF (HWRLOG(HALF)) T=U
20121C-----FILL EVENT RECORD
20122 COSTH=(1+2*T/SHAT)/BETA
20123 PC=0.5*BETA*PHEP(5,NHEP)
20124 PHEP(5,NHEP+1)=RMASS(ID)
20125 PHEP(5,NHEP+2)=RMASS(ID)
20126 CALL HWDTWO(PHEP(1,NHEP),PHEP(1,NHEP+1),PHEP(1,NHEP+2),
20127 & PC,COSTH,.TRUE.)
20128 DO 80 I=1,2
20129 IHEP=NHEP+I
20130 JHEP=NHEP+3-I
20131 ISTHEP(IHEP)=190
20132 IF (IHPRO.LE.6) ISTHEP(IHEP)=112+I
20133 IDHW(IHEP)=ID+NADD*(I-1)
20134 IDHEP(IHEP)=IDPDG(IDHW(IHEP))
20135 JDAHEP(I,NHEP)=IHEP
20136 JMOHEP(1,IHEP)=NHEP
20137 JMOHEP(2,IHEP)=JHEP
20138 JDAHEP(2,IHEP)=JHEP
20139 IF (IHPRO.EQ.10) THEN
20140 RHOHEP(1,IHEP)=0.3333
20141 RHOHEP(2,IHEP)=0.3333
20142 RHOHEP(3,IHEP)=0.3333
20143 ENDIF
20144 80 CONTINUE
20145 NHEP=NHEP+2
20146 ENDIF
20147 999 RETURN
20148 END
20149CDECK ID>, HWHEGW.
20150*CMZ :- -26/04/91 10.18.56 by Bryan Webber
20151*-- Author : Mike Seymour
20152C-----------------------------------------------------------------------
20153 SUBROUTINE HWHEGW
20154C----------------------------------------------------------------------
20155C W + GAMMA --> FF'BAR : MEAN EVWGT = CROSS SECTION IN NANOBARN
20156C BASED ON BOSON GLUON FUSION OF ABBIENDI AND STANCO
20157C-----------------------------------------------------------------------
c63d70bc 20158 INCLUDE 'herwig65.inc'
65767955 20159 DOUBLE PRECISION HWRGEN,GMASS,EV(3),RV,Y,Q2,SHAT,Z,PHI,AJACOB,
20160 & DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,RSHAT
20161 INTEGER LEP
20162 INTEGER LEPFIN,ID1,ID2,I,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO
20163 LOGICAL CHARGD,INCLUD(18),INSIDE(18),IFGO
20164 EXTERNAL HWRGEN
20165 SAVE LEPFIN,ID1,ID2
20166 COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
20167 & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
20168 & IPROO,CHARGD,INCLUD,INSIDE
20169 IQK=MOD(IPROC,10)
20170 CHARGD=.TRUE.
20171 IF(GENEV) THEN
20172C
20173 IDHW(4)=IDHW(1)
20174 IDHW(5)=59
20175 IDHW(6)=15
20176 IDHW(7)=LEPFIN
20177 IDHW(8)=ID1
20178 IDHW(9)=ID2
20179 DO 1 I=4,9
20180 1 IDHEP(I)=IDPDG(IDHW(I))
20181C
20182 IFLAVD=ID1
20183 IFLAVU=ID2-6
20184C
20185 ISTHEP(4)=111
20186 ISTHEP(5)=112
20187 ISTHEP(6)=110
20188 ISTHEP(7)=113
20189 ISTHEP(8)=114
20190 ISTHEP(9)=114
20191C
20192 JMOHEP(1,4)=6
20193 JMOHEP(2,4)=7
20194 JMOHEP(1,5)=6
20195 JMOHEP(2,5)=5
20196 JMOHEP(1,6)=4
20197 JMOHEP(2,6)=5
20198 JMOHEP(1,7)=6
20199 JMOHEP(2,7)=4
20200 JMOHEP(1,8)=6
20201 JMOHEP(2,8)=9
20202 JMOHEP(1,9)=6
20203 JMOHEP(2,9)=8
20204 JDAHEP(1,4)=0
20205 JDAHEP(2,4)=7
20206 JDAHEP(1,5)=0
20207 JDAHEP(2,5)=5
20208 JDAHEP(1,6)=7
20209 JDAHEP(2,6)=9
20210 JDAHEP(1,7)=0
20211 JDAHEP(2,7)=4
20212 JDAHEP(1,8)=0
20213 JDAHEP(2,8)=9
20214 JDAHEP(1,9)=0
20215 JDAHEP(2,9)=8
20216C---COMPUTATION OF MOMENTA IN LABORATORY FRAME OF REFERENCE
20217C---Persuade HWHBKI that the gluon is actually a photon...
20218 GMASS=RMASS(13)
20219 RMASS(13)=0
20220 CALL HWHBKI
20221 RMASS(13)=GMASS
20222C---put the other outgoing lepton in as well
20223 IDHW(10)=IDHW(2)
20224 IDHEP(10)=IDPDG(IDHW(10))
20225 ISTHEP(10)=1
20226 JMOHEP(1,10)=2
20227 JMOHEP(2,10)=0
20228 JDAHEP(1,10)=0
20229 JDAHEP(2,10)=0
20230 JDAHEP(1,2)=5
20231 JDAHEP(2,2)=10
20232 CALL HWVDIF(4,PHEP(1,2),PHEP(1,5),PHEP(1,10))
20233 CALL HWUMAS(PHEP(1,10))
20234 NHEP=10
20235C
20236C---if antilepton was first, do charge conjugation
20237 IF (LEP.EQ.-1) THEN
20238 DO 27 I=7,9
20239 IF (IDHEP(I).NE.0 .AND. ABS(IDHEP(I)).LT.20) THEN
20240 IDHW(I)=IDHW(I) + 6*SIGN(1,IDHEP(I))
20241 IDHEP(I)=-IDHEP(I)
20242 ENDIF
20243 27 CONTINUE
20244 ENDIF
20245C
20246C---half the time, do charge conjugation and parity flip
20247 IF (HWRGEN(0).GT.HALF) THEN
20248 DO 2 I=4,10
20249 IF (IDHEP(I).NE.0 .AND. ABS(IDHEP(I)).LT.20) THEN
20250 IDHW(I)=IDHW(I) + 6*SIGN(1,IDHEP(I))
20251 IDHEP(I)=-IDHEP(I)
20252 ENDIF
20253 PHEP(1,I)=-PHEP(1,I)
20254 PHEP(2,I)=-PHEP(2,I)
20255 PHEP(3,I)=-PHEP(3,I)
20256 2 CONTINUE
20257 JMOHEP(1,10)=3-JMOHEP(1,10)
20258 ENDIF
20259C
20260 ELSE
20261C
20262 EVWGT=ZERO
20263C---LEP = 1 IF TRACK 1 IS A LEPTON, -1 FOR ANTILEPTON
20264 LEP=0
20265 IF (IDHW(1).GE.121.AND.IDHW(1).LE.126) THEN
20266 LEP=1
20267 ELSEIF (IDHW(1).GE.127.AND.IDHW(1).LE.132) THEN
20268 LEP=-1
20269 ENDIF
20270 IF (LEP.EQ.0) CALL HWWARN('HWHEGW',500)
20271C---program only works if beam and target are charge conjugates
20272 IF (LEP*(IDHW(2)-IDHW(1)).NE.6) CALL HWWARN('HWHEGW',501)
20273C---program only works for equal energy beams colliding
20274 IF (PHEP(3,3).NE.ZERO) CALL HWWARN('HWHEGW',503)
20275C
20276C---FINAL STATE IS ALWAYS SET UP AS IF PARTICLE IS BEFORE ANTI-PARTICLE
20277C AND THEN INVERTED IF NECESSARY
20278 LEPFIN = MIN(IDHW(1),IDHW(2))+1
20279 IF (IQK.LE.2) THEN
20280 IFLAVU=2
20281 IFLAVD=1
20282 ID1 = 1
20283 ID2 = 8
20284 ELSEIF (IQK.LE.4) THEN
20285 IFLAVU=4
20286 IFLAVD=3
20287 ID1 = 3
20288 ID2 =10
20289 ELSEIF (IQK.LE.6) THEN
20290 IFLAVU=6
20291 IFLAVD=5
20292 ID1 = 5
20293 ID2 =12
20294 ELSEIF (IQK.EQ.7) THEN
20295 IFLAVU=122
20296 IFLAVD=121
20297 ID1 = 121
20298 ID2 = 128
20299C---INTERFERENCE TERMS IN EE -> EE NUE NUEB NEGLECTED: SIGMA UNRELIABLE
20300 IF (FSTWGT) CALL HWWARN('HWHEGW',1)
20301 ELSEIF (IQK.EQ.8) THEN
20302 IFLAVU=124
20303 IFLAVD=123
20304 ID1 = 123
20305 ID2 = 130
20306 ELSEIF (IQK.EQ.9) THEN
20307 IFLAVU=126
20308 IFLAVD=125
20309 ID1 = 125
20310 ID2 = 132
20311 ELSE
20312 CALL HWWARN('HWHEGW',504)
20313 ENDIF
20314 IF (IQK.GT.0) THEN
20315 IF (IQK.LE.6) IQK=0
20316 CALL HWHBRN(IFGO)
20317 IF(IFGO) GOTO 999
20318 CALL HWHEGX
20319 EVWGT = 2 * DSIGMA * AJACOB
20320 IF (EVWGT.LT.ZERO) EVWGT=ZERO
20321 ELSE
20322C---SUM OVER QUARK FLAVOURS
20323 CALL HWHBRN(IFGO)
20324 IF(IFGO) GOTO 999
20325 DO 3 I=1,3
20326 IF (SHAT.GT.(RMASS(IFLAVD)+RMASS(IFLAVU))**2) THEN
20327 CALL HWHEGX
20328 EV(I) = 2 * DSIGMA * AJACOB
20329 IF (EV(I).LT.ZERO) EV(I)=ZERO
20330 ELSE
20331 EV(I)=ZERO
20332 ENDIF
20333 EVWGT=EVWGT+EV(I)
20334 EV(I)=EVWGT
20335 IFLAVU=IFLAVU+2
20336 IFLAVD=IFLAVD+2
20337 3 CONTINUE
20338C---CHOOSE QUARK FLAVOUR
20339 RV=EV(3)*HWRGEN(1)
20340 IF (RV.LT.EV(1)) THEN
20341 ID1 = 1
20342 ID2 = 8
20343 ELSEIF (RV.LT.EV(2)) THEN
20344 ID1 = 3
20345 ID2 =10
20346 ELSE
20347 ID1 = 5
20348 ID2 =12
20349 ENDIF
20350 ENDIF
20351 ENDIF
20352 999 RETURN
20353 END
20354CDECK ID>, HWHEGX.
20355*CMZ :- -17/07/92 16.42.56 by Mike Seymour
20356*-- Author : Mike Seymour
20357C-----------------------------------------------------------------------
20358 SUBROUTINE HWHEGX
20359C-----------------------------------------------------------------------
20360C COMPUTES DIFFERENTIAL CROSS SECTION DSIGMA IN (Y,Q2,ETA,Z,PHI)
20361C-----------------------------------------------------------------------
c63d70bc 20362 INCLUDE 'herwig65.inc'
65767955 20363 DOUBLE PRECISION TMAX,TMIN,A1,A2,B1,B2,I0,I1,I2,I3,I4,I5,MUSQ,
20364 & MDSQ,ETA,Q1,COSTHE,S,G,T,U,C1,C2,D1,D2,F1,F2,COSBET,WPROP,D(4,4),
20365 & C(4,4),QU,QD,QE,QW,PHOTON,EMWSQ,EMSSQ,CFAC,Y,Q2,SHAT,Z,PHI,
20366 & AJACOB,DSIGMA,ME,MP,ML,MREMIF(18),MFIN1(18),MFIN2(18),RS,SMA,W2,
20367 & RSHAT
20368 INTEGER IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,IPROO,I,J,LEP
20369 LOGICAL CHARGD,INCLUD(18),INSIDE(18)
20370 COMMON /HWAREA/ Y,Q2,SHAT,Z,PHI,AJACOB,DSIGMA,ME,MP,ML,MREMIF,
20371 & MFIN1,MFIN2,RS,SMA,W2,RSHAT,IQK,IFLAVU,IFLAVD,IMIN,IMAX,IFL,LEP,
20372 & IPROO,CHARGD,INCLUD,INSIDE
20373C---INPUT VARIABLES
20374 IF (IERROR.NE.0) RETURN
20375 DSIGMA=0
20376 IF (IFLAVU.LE.12) THEN
20377 QU=QFCH(MOD(IFLAVU-1,6)+1)
20378 QD=QFCH(MOD(IFLAVD-1,6)+1)
20379 CFAC=CAFAC
20380 ELSE
20381 QU=QFCH(MOD(IFLAVU-1,6)+11)
20382 QD=QFCH(MOD(IFLAVD-1,6)+11)
20383 CFAC=1
20384 ENDIF
20385 QE=QFCH(11)
20386 QW=+1
20387 EMWSQ=RMASS(198)**2
20388 EMSCA=PHEP(5,3)
20389 EMSSQ=EMSCA**2
20390 MUSQ=RMASS(IFLAVU)**2
20391 MDSQ=RMASS(IFLAVD)**2
20392 ETA=(SHAT+Q2)/EMSSQ/Y
20393 IF (ETA.GT.ONE) RETURN
20394C---CALCULATE KINEMATIC TERMS
20395 G=0.5*(ETA*EMSSQ*Y-Q2) -0.5*(MUSQ+MDSQ)
20396 S=0.5*ETA*EMSSQ
20397 T=0.5*ETA*EMSSQ*(1-Y)
20398 U=0.5*Q2
20399 C1=0.5*ETA*EMSSQ*Y*Z
20400 C2=0.5*ETA*EMSSQ*Y*(1-Z)
20401 COSBET=(-ETA*EMSSQ*Y+Q2*(2-Y))/(Y*(ETA*EMSSQ-Q2))
20402 IF (SHAT.LE.(RMASS(IFLAVU)+RMASS(IFLAVD))**2) RETURN
20403 Q1=SQRT((SHAT**2+MUSQ**2+MDSQ**2
20404 & -2*SHAT*MUSQ-2*SHAT*MDSQ-2*MUSQ*MDSQ)/SHAT**2)
20405 COSTHE=(1+(MDSQ-MUSQ)/SHAT-2*Z)/Q1
20406 IF (ABS(COSTHE).GE.ONE .OR. ABS(COSBET).GE.ONE) RETURN
20407 D1=0.25*(ETA*EMSSQ-Q2)*(1+(MDSQ-MUSQ)/SHAT-Q1*
20408 & (COSTHE*COSBET+SQRT((1-COSTHE**2)*(1-COSBET**2))*COS(PHI)))
20409 D2=S-U-D1
20410 F1=D1+C1-G -MDSQ
20411 F2=U+T-F1
20412C---CALCULATE TRACE TERMS
20413 CALL HWVZRO(16,D)
20414 CALL HWVZRO(16,C)
20415 D(1,1)=2*F1*C2*S
20416 D(2,2)=2*C1*D2*T
20417 D(3,3)=-D1*(2*F2*G-D2*(F1+2*U))
20418 & -D2*F1*(F2+U-D2+F1)
20419 & +2*F1*F2*U
20420 & -G*(-2*D1*(F1+F2+U)-F1*(D2+2*U)+2*D2*(U-F2)+2*U*(F2-U+G))
20421 D(4,4)=2*F1*C2*S
20422 D(1,2)=(D1+U-F2)*(D1*F2-F1*D2)-G*(D1*(F2+U)+U*(U-F2-G)+F1*D2)
20423 D(1,3)=D1*F2*(-2*F1+U-F2+D1)
20424 & +F1*(F2*(D2-2*U)+F1*D2)
20425 & +G*(-D1*(2*F1+F2+U)-F1*(D2+2*U)+U*(F2-U+G))
20426 D(1,4)=-2*F1*(D1+U)*(F2+G)
20427 D(2,3)=D1*(D2*(F1+2*(U-F2))+F2*(F2-U-D1))
20428 & +F1*D2**2
20429 & +G*(D1*(F2+U)+D2*(F1-2*(U-F2))+U*(U-F2-G))
20430 D(2,4)=-D1*F2*(U-F2+D1)
20431 & -F1*D2*(U-D1-G-F2)
20432 & -G*(U*(F2-U+G)-D1*(F2+U))
20433 D(3,4)=D1*(F1*(D2+2*F2)+F2*(F2-U-D1))
20434 & +F1*(2*F2*U-D2*(U+F1))
20435 & +G*(D1*(2*F1+F2+U)+U*(2*F1-F2+U-G))
20436C---REGULATE PROPAGATORS
20437 TMAX=EMSSQ-2*G
20438 TMIN=PHEP(5,2)**2
20439 A1=2*C1+MDSQ*(G+U)/G
20440 A2=2*C2+MUSQ*(G+U)/G
20441 B1=(2*U+MUSQ)/(2*G+2*U)
20442 B2=(2*U+MDSQ)/(2*G+2*U)
20443 I0=LOG(TMAX/TMIN)
20444 I1=1/A1*(I0-LOG((A1+B1*TMAX)/(A1+B1*TMIN)))
20445 I2=1/A2*(I0-LOG((A2+B2*TMAX)/(A2+B2*TMIN)))
20446 I3=(B1*I1-B2*I2)/(B1*A2-B2*A1)
20447 I4=1/A1*(I1+1/(A1+B1*TMAX)-1/(A1+B1*TMIN))
20448 I5=1/A2*(I2+1/(A2+B2*TMAX)-1/(A2+B2*TMIN))
20449 WPROP=1/((2*G-EMWSQ)**2+GAMW**2*EMWSQ)
20450C---CALCULATE COEFFICIENTS
20451 C(1,1)= QU**2/(2*U+EMWSQ)**2 *I5
20452 C(2,2)= QD**2/(2*U+EMWSQ)**2 *I4
20453 C(3,3)= QW**2/(2*U+EMWSQ)**2 *WPROP *I0
20454 C(4,4)= QE**2/(2*S)**2 *WPROP *I0
20455 C(1,2)= 2*QU*QD/(2*U+EMWSQ)**2 *I3
20456 C(1,3)= 2*QW*QU/(2*U+EMWSQ)**2 *WPROP*(2*G-EMWSQ) *I2
20457 C(1,4)= 2*QU*QE/(2*S*(2*U+EMWSQ)) *WPROP*(2*G-EMWSQ) *I2
20458 C(2,3)= 2*QW*QD/(2*U+EMWSQ)**2 *WPROP*(2*G-EMWSQ) *I1
20459 C(2,4)= 2*QD*QE/(2*S*(2*U+EMWSQ)) *WPROP*(2*G-EMWSQ) *I1
20460 C(3,4)= 2*QW*QE/(2*S*(2*U+EMWSQ)) *WPROP *I0
20461C---CALCULATE PHOTON STRUCTURE FUNCTION
20462 PHOTON=ALPHEM * (1+(1-ETA)**2) / (2*PIFAC*ETA)
20463C---SUM ALL TENSOR CONTRIBUTIONS
20464 DO 10 I=1,4
20465 DO 10 J=1,4
20466 10 DSIGMA=DSIGMA + C(I,J)*D(I,J)
20467C---CALCULATE TOTAL SUMMED AND AVERAGED MATRIX ELEMENT SQUARED
20468 DSIGMA = DSIGMA * 2*CFAC*(4*PIFAC*ALPHEM)**3/SWEIN**2
20469C---CALCULATE DIFFERENTIAL CROSS-SECTION
20470 DSIGMA = DSIGMA * GEV2NB*PHOTON/(512*PIFAC**4*ETA*EMSSQ)
20471 END
20472CDECK ID>, HWHEPA.
20473*CMZ :- -12/10/01 10.05.16 by Peter Richardson
20474*-- Author : Bryan Webber and Ian Knowles
20475C-----------------------------------------------------------------------
20476 SUBROUTINE HWHEPA
20477C-----------------------------------------------------------------------
20478C (Initially polarised) e+e- --> ffbar (f=quark, mu or tau)
20479C If IPROC=107: --> gg, distributed as sum of light quarks.
20480C If fermion flavour specified mass effects fully included.
20481C EVWGT=sig(e+e- --> ffbar) in nb
20482C-----------------------------------------------------------------------
c63d70bc 20483 INCLUDE 'herwig65.inc'
65767955 20484 DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWUAEM,Q2NOW,Q2LST,FACTR,
20485 & VF2,VF,CLF(7),PRAN,PQWT,PMAX,PTHETA,SINTH2,CPHI,SPHI,C2PHI,S2PHI,
20486 & PPHI,SINTH,PCM,PP(5),EWGT
20487 INTEGER ID1,ID2,IDF,IQ,IQ1,I
20488 EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUAEM
20489 SAVE Q2LST,FACTR,ID1,ID2,VF2,VF,CLF,EWGT
20490 DATA Q2LST/0.D0/
20491 IF (GENEV) THEN
20492 IF (ID2.EQ.0) THEN
20493C Choose quark flavour
20494 PRAN=TQWT*HWRGEN(0)
20495 PQWT=0.
20496 DO 10 IQ=1,MAXFL
20497 PQWT=PQWT+CLQ(1,IQ)
20498 IF (PQWT.GT.PRAN) GOTO 11
20499 10 CONTINUE
20500 IQ=MAXFL
20501 11 IQ1=MAPQ(IQ)
20502 DO 20 I=1,7
20503 20 CLF(I)=CLQ(I,IQ)
20504 ELSE
20505 IQ1=ID1
20506 ENDIF
20507C Label particles, assign outgoing particle masses
20508 IDHW(NHEP+1)=200
20509 IDHEP(NHEP+1)=23
20510 ISTHEP(NHEP+1)=110
20511 IF (ID1.EQ.7) THEN
20512 IDHW(NHEP+2)=13
20513 IDHW(NHEP+3)=13
20514 IDHEP(NHEP+2)=21
20515 IDHEP(NHEP+3)=21
20516 PHEP(5,NHEP+2)=RMASS(13)
20517 PHEP(5,NHEP+3)=RMASS(13)
20518 ELSE
20519 IDHW(NHEP+2)=IQ1
20520 IDHW(NHEP+3)=IQ1+6
20521 IDHEP(NHEP+2)=IDPDG(IQ1)
20522 IDHEP(NHEP+3)=-IDHEP(NHEP+2)
20523 PHEP(5,NHEP+2)=RMASS(IQ1)
20524 PHEP(5,NHEP+3)=RMASS(IQ1)
20525 ENDIF
20526 ISTHEP(NHEP+2)=113
20527 ISTHEP(NHEP+3)=114
20528 JMOHEP(1,NHEP+1)=1
20529 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
20530 JMOHEP(2,NHEP+1)=2
20531 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
20532 JMOHEP(1,NHEP+2)=NHEP+1
20533 JMOHEP(2,NHEP+2)=NHEP+3
20534 JMOHEP(1,NHEP+3)=NHEP+1
20535 JMOHEP(2,NHEP+3)=NHEP+2
20536 JDAHEP(1,NHEP+1)=NHEP+2
20537 JDAHEP(2,NHEP+1)=NHEP+3
20538 JDAHEP(1,NHEP+2)=0
20539 JDAHEP(2,NHEP+2)=NHEP+3
20540 JDAHEP(1,NHEP+3)=0
20541 JDAHEP(2,NHEP+3)=NHEP+2
20542C Generate polar and azimuthal angular distributions:
20543C CLF(1)*(1+(VF*COSTH)**2)+CLF(2)*(1-VF**2)+CLF(3)*2.*VF*COSTH
20544C +(VF*SINTH)**2*(CLF(4)*COS(2*PHI-PHI1-PHI2)
20545C +CLF(6)*SIN(2*PHI-PHI1-PHI2))
20546 PMAX=CLF(1)*(1.+VF2)+CLF(2)*(1.-VF2)+ABS(CLF(3))*2.*VF
20547 30 COSTH=HWRUNI(0,-ONE, ONE)
20548 PTHETA=CLF(1)*(1.+VF2*COSTH**2)+CLF(2)*(1.-VF2)
20549 & +CLF(3)*2.*VF*COSTH
20550 IF (PTHETA.LT.PMAX*HWRGEN(1)) GOTO 30
20551 IF (IDHW(1).GT.IDHW(2)) COSTH=-COSTH
20552 SINTH2=1.-COSTH**2
20553 IF (TPOL) THEN
20554 PMAX=PTHETA+VF2*SINTH2*SQRT(CLF(4)**2+CLF(6)**2)
20555 40 CALL HWRAZM(ONE,CPHI,SPHI)
20556 C2PHI=2.*CPHI**2-1.
20557 S2PHI=2.*CPHI*SPHI
20558 PPHI=PTHETA+(CLF(4)*(C2PHI*COSS+S2PHI*SINS)
20559 & +CLF(6)*(S2PHI*COSS-C2PHI*SINS))*VF2*SINTH2
20560 IF (PPHI.LT.PMAX*HWRGEN(1)) GOTO 40
20561 ELSE
20562 CALL HWRAZM(ONE,CPHI,SPHI)
20563 ENDIF
20564C Construct final state 4-mommenta
20565 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20566 PCM=HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
20567C PP is momentum of track NHEP+2 in CoM (track NHEP+1) frame
20568 SINTH=SQRT(SINTH2)
20569 PP(5)=PHEP(5,NHEP+2)
20570 PP(1)=PCM*SINTH*CPHI
20571 PP(2)=PCM*SINTH*SPHI
20572 PP(3)=PCM*COSTH
20573 PP(4)=SQRT(PCM**2+PP(5)**2)
20574 CALL HWULOB(PHEP(1,NHEP+1),PP(1),PHEP(1,NHEP+2))
20575 CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3))
20576C Set production vertices
20577 CALL HWVZRO(4,VHEP(1,NHEP+2))
20578 CALL HWVEQU(4,VHEP(1,NHEP+2),VHEP(1,NHEP+3))
20579 NHEP=NHEP+3
20580 ELSE
20581 EMSCA=PHEP(5,3)
20582 Q2NOW=EMSCA**2
20583 IF (Q2NOW.NE.Q2LST) THEN
20584C Calculate coefficients for cross-section
20585 EMSCA=PHEP(5,3)
20586 Q2LST=Q2NOW
20587 FACTR=PIFAC*GEV2NB*HWUAEM(Q2NOW)**2/Q2NOW
20588 ID1=MOD(IPROC,10)
20589 ID2=MOD(ID1,7)
20590 IF (ID2.EQ.0) THEN
20591 CALL HWUEEC(1)
20592 VF2=1.
20593 VF=1.
20594 EWGT=FACTR*FLOAT(NCOLO)*TQWT*4./3.
20595 ELSE
20596 IF (IPROC.LT.150) THEN
20597 IDF=ID1
20598 FACTR=FACTR*FLOAT(NCOLO)
20599 ELSE
20600 ID1=2*ID1+119
20601 IDF=ID1-110
20602 ENDIF
20603 IF (EMSCA.LE.2.*RMASS(ID1)) THEN
20604 EWGT=0.
20605 ELSE
20606 CALL HWUCFF(11,IDF,Q2NOW,CLF(1))
20607 VF2=1.-4.*RMASS(ID1)**2/Q2NOW
20608 VF=SQRT(VF2)
20609 EWGT=FACTR*VF*(CLF(1)*(1.+VF2/3.)+CLF(2)*(1.-VF2))
20610 ENDIF
20611 ENDIF
20612 ENDIF
20613 EVWGT=EWGT
20614 ENDIF
20615 END
20616CDECK ID>, HWHEPG.
20617*CMZ :- -02/05/91 10.57.27 by Federico Carminati
20618*-- Author : Bryan Webber and Ian Knowles
20619C-----------------------------------------------------------------------
20620 SUBROUTINE HWHEPG
20621C-----------------------------------------------------------------------
20622C (Initially polarised) e-e+ --> qqbar g with parton thrust < THMAX,
20623C equivalent to: maximum parton energy < THMAX*EMSCA/2; or a JADE E0
20624c scheme, y_cut=1.-THMAX.
20625C If flavour specified mass effects fully included.
20626C EVWGT=sig(e^-e^+ --> qqbar g) in nb
20627C-----------------------------------------------------------------------
c63d70bc 20628 INCLUDE 'herwig65.inc'
65767955 20629 DOUBLE PRECISION HWRGEN,HWUALF,HWUAEM,HWULDO,HWDPWT,Q2NOW,Q2LST,
20630 & PHASP,QGMAX,QGMIN,FACTR,QM2,CLF(7),ORDER,PRAN,PQWT,QQG,QBG,SUM,
20631 & RUT,QQLM,QQLP,QBLM,QBLP,DYN1,DYN2,DYN3,DYN4,DYN5,DYN6,XQ2,X2SUM,
20632 & PVRT(4)
20633 INTEGER ID1,IQ,I,LM,LP,IQ1
20634 LOGICAL MASS
20635 EXTERNAL HWRGEN,HWUALF,HWUAEM,HWULDO,HWDPWT
20636 SAVE Q2NOW,Q2LST,QGMAX,QGMIN,FACTR,ORDER,ID1,MASS,QM2,CLF,LM,LP,
20637 & IQ1,QQG,QBG,SUM
20638 DATA Q2LST/0.D0/
20639 IF (GENEV) THEN
20640C Label produced partons and calculate gluon spin
20641 IDHW(NHEP+1)=200
20642 IDHW(NHEP+2)=IQ1
20643 IDHW(NHEP+3)=13
20644 IDHW(NHEP+4)=IQ1+6
20645 IDHEP(NHEP+1)=23
20646 IDHEP(NHEP+2)=IQ1
20647 IDHEP(NHEP+3)=21
20648 IDHEP(NHEP+4)=-IQ1
20649 ISTHEP(NHEP+1)=110
20650 ISTHEP(NHEP+2)=113
20651 ISTHEP(NHEP+3)=114
20652 ISTHEP(NHEP+4)=114
20653 JMOHEP(1,NHEP+1)=LM
20654 JMOHEP(2,NHEP+1)=LP
20655 JMOHEP(1,NHEP+2)=NHEP+1
20656 JMOHEP(2,NHEP+2)=NHEP+3
20657 JMOHEP(1,NHEP+3)=NHEP+1
20658 JMOHEP(2,NHEP+3)=NHEP+4
20659 JMOHEP(1,NHEP+4)=NHEP+1
20660 JMOHEP(2,NHEP+4)=NHEP+2
20661 JDAHEP(1,NHEP+1)=NHEP+2
20662 JDAHEP(2,NHEP+1)=NHEP+4
20663 JDAHEP(1,NHEP+2)=0
20664 JDAHEP(2,NHEP+2)=NHEP+4
20665 JDAHEP(1,NHEP+3)=0
20666 JDAHEP(2,NHEP+3)=NHEP+2
20667 JDAHEP(1,NHEP+4)=0
20668 JDAHEP(2,NHEP+4)=NHEP+3
20669C Decide which quark radiated and assign production vertices
20670 XQ2=(Q2NOW-2.*QBG)**2
20671 X2SUM=XQ2+(Q2NOW-2.*QQG)**2
20672 IF (XQ2.LT.HWRGEN(0)*X2SUM) THEN
20673C Quark radiated the gluon
20674 CALL HWVZRO(4,VHEP(1,NHEP+4))
20675 CALL HWVSUM(4,PHEP(1,NHEP+2),PHEP(1,NHEP+3),PVRT)
20676 CALL HWUDKL(IQ1,PVRT,VHEP(1,NHEP+3))
20677 CALL HWVEQU(4,VHEP(1,NHEP+3),VHEP(1,NHEP+2))
20678 ELSE
20679C Anti-quark radiated the gluon
20680 CALL HWVZRO(4,VHEP(1,NHEP+2))
20681 CALL HWVSUM(4,PHEP(1,NHEP+4),PHEP(1,NHEP+3),PVRT)
20682 CALL HWUDKL(IQ1,PVRT,VHEP(1,NHEP+3))
20683 CALL HWVEQU(4,VHEP(1,NHEP+3),VHEP(1,NHEP+4))
20684 ENDIF
20685 IF (AZSPIN) THEN
20686C Calculate the transverse polarisation of the gluon
20687C Correlation with leptons presently neglected
20688 GPOLN=(QQG**2+QBG**2)/((Q2NOW-2.*SUM)*Q2NOW)
20689 GPOLN=2./(2.+GPOLN)
20690 ENDIF
20691 NHEP=NHEP+4
20692 ELSE
20693 EMSCA=PHEP(5,3)
20694 Q2NOW=EMSCA**2
20695 IF (Q2NOW.NE.Q2LST) THEN
20696 Q2LST=Q2NOW
20697 PHASP=3.*THMAX-2.
20698 IF (PHASP.LE.ZERO) CALL HWWARN('HWHEPG',400)
20699 QGMAX=.5*Q2NOW*THMAX
20700 QGMIN=.5*Q2NOW*(1.-THMAX)
20701 FACTR=GEV2NB*FLOAT(NCOLO)*CFFAC*HWUALF(1,EMSCA)
20702 & *.5*(HWUAEM(Q2NOW)*PHASP)**2/Q2NOW
20703 LM=1
20704 IF (JDAHEP(1,LM).NE.0) LM=JDAHEP(1,LM)
20705 LP=2
20706 IF (JDAHEP(1,LP).NE.0) LP=JDAHEP(1,LP)
20707 ORDER=1.
20708 IF (IDHW(1).GT.IDHW(2)) ORDER=-ORDER
20709 ID1=MOD(IPROC,10)
20710 IF (ID1.NE.0) THEN
20711 MASS=.TRUE.
20712 QM2=RMASS(ID1)**2
20713 CALL HWUCFF(11,ID1,Q2NOW,CLF(1))
20714 FACTR=FACTR*CLF(1)
20715 ELSE
20716 MASS=.FALSE.
20717 CALL HWUEEC(1)
20718 FACTR=FACTR*TQWT
20719 ENDIF
20720 ENDIF
20721 IF (ID1.EQ.0) THEN
20722C Select quark flavour
20723 PRAN=TQWT*HWRGEN(1)
20724 PQWT=0.
20725 DO 10 IQ=1,MAXFL
20726 PQWT=PQWT+CLQ(1,IQ)
20727 IF (PQWT.GT.PRAN) GOTO 11
20728 10 CONTINUE
20729 IQ=MAXFL
20730 11 IQ1=MAPQ(IQ)
20731 DO 20 I=1,7
20732 20 CLF(I)=CLQ(I,IQ)
20733 ELSEIF (Q2NOW.GT.4*QM2/(2*THMAX-1)) THEN
20734 IQ1=ID1
20735 ELSE
20736 EVWGT=0.
20737 RETURN
20738 ENDIF
20739C Select final state momentum configuration
20740 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20741 PHEP(5,NHEP+2)=RMASS(IQ1)
20742 PHEP(5,NHEP+3)=RMASS(13)
20743 PHEP(5,NHEP+4)=RMASS(IQ1)
20744 30 CALL HWDTHR(PHEP(1,NHEP+1),PHEP(1,NHEP+2),
20745 & PHEP(1,NHEP+3),PHEP(1,NHEP+4),HWDPWT)
20746 QQG=HWULDO(PHEP(1,NHEP+2),PHEP(1,NHEP+3))
20747 IF (QQG.LT.QGMIN) GOTO 30
20748 QBG=HWULDO(PHEP(1,NHEP+4),PHEP(1,NHEP+3))
20749 SUM=QQG+QBG
20750 IF (QBG.LT.QGMIN.OR.SUM.GT.QGMAX) GOTO 30
20751 QQLM=HWULDO(PHEP(1,NHEP+2),PHEP(1,LM))
20752 QQLP=HWULDO(PHEP(1,NHEP+2),PHEP(1,LP))
20753 QBLM=HWULDO(PHEP(1,NHEP+4),PHEP(1,LM))
20754 QBLP=HWULDO(PHEP(1,NHEP+4),PHEP(1,LP))
20755 DYN1=QQLM**2+QQLP**2+QBLM**2+QBLP**2
20756 DYN2=0.
20757 DYN3=DYN1-2.*(QQLM**2+QBLP**2)
20758 IF (MASS) THEN
20759 RUT=1./QQG+1./QBG
20760 DYN1=DYN1+8.*QM2*(1.-.25*Q2NOW*RUT
20761 & +QQLM*QQLP/(Q2NOW*QBG)+QBLM*QBLP/(Q2NOW*QQG))
20762 DYN2=QM2*(Q2NOW-SUM*(2.+QM2*RUT)
20763 & -4.*HWULDO(PHEP(1,NHEP+3),PHEP(1,LM))
20764 & *HWULDO(PHEP(1,NHEP+3),PHEP(1,LP))/Q2NOW)
20765 DYN3=DYN3+QM2*2.*RUT*(QBG*(QBLP-QBLM)-QQG*(QQLP-QQLM))
20766 ENDIF
20767 EVWGT=CLF(1)*DYN1+CLF(2)*DYN2+ORDER*CLF(3)*DYN3
20768 IF (TPOL) THEN
20769C Include event plane azimuthal angle
20770 DYN4=.5*Q2NOW
20771 DYN5=DYN4
20772 DYN6=0.
20773 IF (MASS) THEN
20774 DYN4=DYN4-QM2*SUM/QBG
20775 DYN5=DYN5-QM2*SUM/QQG
20776 DYN6=QM2
20777 ENDIF
20778 EVWGT=EVWGT
20779 & +(CLF(4)*COSS-CLF(6)*SINS)
20780 & *(DYN4*(PHEP(1,NHEP+2)**2-PHEP(2,NHEP+2)**2)
20781 & +DYN5*(PHEP(1,NHEP+4)**2-PHEP(2,NHEP+4)**2))
20782 & +(CLF(4)*SINS+CLF(6)*COSS)*2.
20783 & *(DYN4*PHEP(1,NHEP+2)*PHEP(2,NHEP+2)
20784 & +DYN5*PHEP(1,NHEP+4)*PHEP(2,NHEP+4))
20785 & +(CLF(5)*COSS-CLF(7)*SINS)*DYN6
20786 & *(PHEP(1,NHEP+3)**2-PHEP(2,NHEP+3)**2)
20787 & +(CLF(5)*SINS+CLF(7)*COSS)*DYN6*2.
20788 & *PHEP(1,NHEP+3)*PHEP(2,NHEP+3)
20789 ENDIF
20790C Assign event weight
20791 EVWGT=EVWGT*FACTR/(QQG*QBG*CLF(1))
20792 ENDIF
20793 END
20794CDECK ID>, HWHESL.
20795*CMZ :- -17/10/00 17:43:25 by Peter Richardson
20796*-- Author : Kosuke Odagiri & Peter Richardson
20797C-----------------------------------------------------------------------
20798 SUBROUTINE HWHESL
20799C-----------------------------------------------------------------------
20800C SUSY E+E- -> 2 SLEPTON PROCESSES
20801C-----------------------------------------------------------------------
c63d70bc 20802 INCLUDE 'herwig65.inc'
65767955 20803 DOUBLE PRECISION HWRGEN,HWUAEM,EPS,HCS,RCS,S,PF,QPE,HWUPCM,PCM,
20804 & FACTR,SN2TH,MZ,ME2(2,2,6),EMSC2,HWUMBW,HWRUNI,T,SQPE
20805 INTEGER ID1,ID2,IL,IL1,IL2,I,J,IG,IG1,IHEP,NTRY,IDL,ILP,IDLR(2),
20806 & IDSLP(2)
20807 INTEGER SSNU, SSCH
20808 PARAMETER (SSNU = 449, SSCH = 453)
20809 EXTERNAL HWRGEN, HWUAEM,HWUMBW,HWUPCM,HWRUNI
20810 SAVE HCS,ME2,IDLR,IDSLP
20811 PARAMETER (EPS = 1.D-9)
20812 DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
20813 DOUBLE PRECISION F,FACT0
20814 PARAMETER (Z = (0.D0,1.D0))
20815 EQUIVALENCE (MZ, RMASS(200))
20816C
20817 S = PHEP(5,3)**2
20818 EMSC2 = S
20819 EMSCA = SQRT(EMSC2)
20820 IF(FSTWGT) THEN
20821 IL = MOD((IPROC-740),5)
20822 IF(IPROC.EQ.700.OR.IPROC.EQ.740) THEN
20823 IDLR(1) = 0
20824 IDLR(2) = 0
20825 IDSLP(1) = 1
20826 IDSLP(2) = 6
20827 ELSE
20828 IF(IL.EQ.0) THEN
20829 IDLR(1) = 1
20830 IDLR(2) = 1
20831 IDSLP(1) = 2*(IPROC-740)/5
20832 ELSEIF(IL.EQ.1) THEN
20833 IDLR(1) = 0
20834 IDLR(2) = 0
20835 IDSLP(1) = 2*(IPROC-741)/5+1
20836 ELSEIF(IL.EQ.2) THEN
20837 IDLR(1) = 1
20838 IDLR(2) = 1
20839 IDSLP(1) = 2*(IPROC-742)/5+1
20840 ELSEIF(IL.EQ.3) THEN
20841 IDLR(1) = 1
20842 IDLR(2) = 2
20843 IDSLP(1) = 2*(IPROC-743)/5+1
20844 ELSEIF(IL.EQ.4) THEN
20845 IDLR(1) = 2
20846 IDLR(2) = 2
20847 IDSLP(1) = 2*(IPROC-744)/5+1
20848 ENDIF
20849 IDSLP(2) = IDSLP(1)
20850 ENDIF
20851 ENDIF
20852 IF (GENEV) THEN
20853 RCS = HCS*HWRGEN(0)
20854 ELSE
20855 IDL = ABS(IDHEP(1))
20856 ILP = IDL-10
20857 COSTH = HWRUNI(1,-ONE,ONE)
20858 SN2TH = 0.25D0 - 0.25D0*COSTH**2
20859 FACT0 = GEV2NB*PIFAC*HWUAEM(EMSC2)**2/S
20860 FACTR = FACT0*SN2TH
20861 GZ = (S-MZ**2+Z*S*GAMZ/MZ)/S
20862c ~ ~*
20863c e+ e- -> l l
20864c
20865 DO IL=1,6
20866 DO I=1,2
20867 DO J=1,2
20868 ME2(I,J,IL) = ZERO
20869 ENDDO
20870 ENDDO
20871 ENDDO
20872 DO IL = IDSLP(1),IDSLP(2)
20873 DO I = 1,2
20874 DO J = 1,2
20875 IF ((I.EQ.2.OR.J.EQ.2).AND.(((IL/2)*2).EQ.IL).OR.
20876 & (IDLR(1).NE.0.AND.(IDLR(1).NE.I.OR.IDLR(2).NE.J)
20877 & .AND.(IDLR(1).NE.J.OR.IDLR(2).NE.I))) THEN
20878 QPE = -1.
20879 ELSE
20880 ID1 = 412 + I*12 + IL
20881 ID2 = 412 + J*12 + IL
20882 IL1 = IL + 10
20883 QPE = S-(RMASS(ID1)+RMASS(ID2))**2
20884 ENDIF
20885 IF (QPE.GT.ZERO) THEN
20886 SQPE = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))
20887 PF = SQPE/S
20888 IF ((IL.NE.ILP).OR.(I.EQ.J)) THEN
20889 A = QFCH(IL1)*QFCH(IDL)
20890 BL = LFCH(IL1)/GZ
20891 BR = RFCH(IL1)/GZ
20892 CL = LMIXSS(IL,1,I)*LMIXSS(IL,1,J)
20893 CR = LMIXSS(IL,2,I)*LMIXSS(IL,2,J)
20894 D = (A+BL*LFCH(IDL))*CL+(A+BR*LFCH(IDL))*CR
20895 E = (A+BL*RFCH(IDL))*CL+(A+BR*RFCH(IDL))*CR
20896 IF (IL.EQ.ILP+1.OR.IL.EQ.ILP) THEN
20897 F = ZERO
20898 T = HALF*(SQPE*COSTH-S+RMASS(ID1)**2+RMASS(ID2)**2)
20899 IF (IL.EQ.ILP) THEN
20900 IF (I.EQ.J) THEN
20901 IF (I.EQ.1) THEN
20902 DO IG = 1,4
20903 IG1 = SSNU+IG
20904 F = F + SLFCH(IL1,IG)**2/(T-RMASS(IG1)**2)
20905 ENDDO
20906 D = D + F*S
20907 ELSE
20908 DO IG=1,4
20909 IG1 = SSNU+IG
20910 F = F +SRFCH(IL1,IG)**2/(T-RMASS(IG1)**2)
20911 ENDDO
20912 E = E + F*S
20913 ENDIF
20914 ELSE
20915 ENDIF
20916 ELSE
20917 DO IG = 1,2
20918 IG1 = SSCH+IG
20919 F = F + WMXVSS(IG,1)**2/(T-RMASS(IG1)**2)
20920 ENDDO
20921 D = D + F*S/(TWO*SWEIN)
20922 ENDIF
20923 ENDIF
20924 ME2(I,J,IL)=FACTR*PF**3*DREAL(
20925 & (ONE-EPOLN(3))*(ONE+PPOLN(3))*DCONJG(D)*D
20926 & +(ONE+EPOLN(3))*(ONE-PPOLN(3))*DCONJG(E)*E)
20927 ELSE
20928 F = ZERO
20929 T = HALF*(SQPE*COSTH-S+RMASS(ID1)**2+RMASS(ID2)**2)
20930 DO IG = 1,4
20931 IG1 = SSNU+IG
20932 F = F + SLFCH(IL1,IG)*SRFCH(IL1,IG)*
20933 & ZSGNSS(IG)*RMASS(IG1)/(T-RMASS(IG1)**2)
20934 ENDDO
20935C--production of el- er+
20936 IF(I.EQ.1.AND.J.EQ.2) THEN
20937 ME2(I,J,IL)=FACT0*PF*F**2*S*
20938 & (ONE-EPOLN(3))*(ONE-PPOLN(3))
20939 ELSE
20940C--production of er- el+
20941 ME2(I,J,IL)=FACT0*PF*F**2*S*
20942 & (ONE+EPOLN(3))*(ONE+PPOLN(3))
20943 ENDIF
20944 ENDIF
20945 ELSE
20946 ME2(I,J,IL)=ZERO
20947 ENDIF
20948 ENDDO
20949 ENDDO
20950 ENDDO
20951 ENDIF
20952 HCS = ZERO
20953C
20954 DO IL = 1,6
20955 DO I = 1,2
20956 DO J = 1,2
20957 IL1 = IL+I*12+412
20958 IL2 = IL+J*12+418
20959 HCS = HCS + ME2(I,J,IL)
20960 IF (GENEV.AND.HCS.GT.RCS) GOTO 100
20961 ENDDO
20962 ENDDO
20963 ENDDO
20964C---GENERATE EVENT
20965 100 IF(GENEV) THEN
20966C--change sign of COSTH if antiparticle first
20967 IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH
20968 IDHW(NHEP+1) = 15
20969 IDHEP(NHEP+1) = 0
20970 ISTHEP(NHEP+1) = 110
20971 IDHW(NHEP+2) = IL1
20972 IDHW(NHEP+3) = IL2
20973 IDHEP(NHEP+2) = IDPDG(IL1)
20974 IDHEP(NHEP+3) = IDPDG(IL2)
20975C--select the particle masses and momenta
20976 NTRY = 0
20977 110 NTRY = NTRY+1
20978 PHEP(5,NHEP+2) = HWUMBW(IL1)
20979 PHEP(5,NHEP+3) = HWUMBW(IL2)
20980 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
20981 PCM = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
20982 IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
20983 GOTO 110
20984 ELSEIF(PCM.LT.ZERO) THEN
20985 CALL HWWARN('HWHESL',100)
20986 GOTO 999
20987 ENDIF
20988C--Set up the colours etc
20989 ISTHEP(NHEP+2) = 113
20990 ISTHEP(NHEP+3) = 114
20991 JMOHEP(1,NHEP+1) = 1
20992 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
20993 JMOHEP(2,NHEP+1) = 2
20994 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
20995 JMOHEP(1,NHEP+2) = NHEP+1
20996 JMOHEP(2,NHEP+2) = NHEP+2
20997 JMOHEP(1,NHEP+3) = NHEP+1
20998 JMOHEP(2,NHEP+3) = NHEP+3
20999 JDAHEP(1,NHEP+1) = NHEP+2
21000 JDAHEP(2,NHEP+1) = NHEP+3
21001 JDAHEP(1,NHEP+2) = 0
21002 JDAHEP(2,NHEP+2) = NHEP+2
21003 JDAHEP(1,NHEP+3) = 0
21004 JDAHEP(2,NHEP+3) = NHEP+3
21005C--Set up the momenta
21006 IHEP = NHEP+2
21007 IHEP = NHEP+2
21008 PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
21009 PHEP(3,IHEP) = PCM*COSTH
21010 PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
21011 PHEP(2,IHEP) = ZERO
21012 CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
21013 CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
21014 CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
21015 NHEP = NHEP+3
21016 ELSE
21017 EVWGT = HCS
21018 ENDIF
21019 999 RETURN
21020 END
21021CDECK ID>, HWHESG.
21022*CMZ :- -18/10/00 13:46:47 by Peter Richardson
21023*-- Author : Kosuke Odagiri & Peter Richardson
21024C-----------------------------------------------------------------------
21025 SUBROUTINE HWHESG
21026C-----------------------------------------------------------------------
21027C SUSY E+E- -> 2 GAUGINO PROCESSES
21028C-----------------------------------------------------------------------
c63d70bc 21029 INCLUDE 'herwig65.inc'
65767955 21030 DOUBLE PRECISION HWRGEN,HWUAEM,HCS,RCS,MNU(4),MNU2(4),HWRUNI,
21031 & FACA,M1(4,4),S2W,XC(4),XD(4),MSNU,
21032 & MZ,HWHSS2,U,T,QPE,SQPE,MSL,MSL2,MSR,MSR2,
21033 & SGN,S,SM,DM,PF,PCM,HWUPCM,XW,S22W,
21034 & MSNU2,MCH(2),MCH2(2),DAB,M2(2,2),HWUMBW
21035 INTEGER I,IQ1,IQ2,SSNU,NTID(2),CHID(2),IG1,IG2,IHEP,SSCH,ISL,ISR,
21036 & ISN,IDL,NTRY
21037 LOGICAL NEUT,CHAR
21038 SAVE HCS,M1,M2,NTID,ISL,ISR,ISN,IDL,CHID,NEUT,CHAR
21039 EXTERNAL HWRGEN,HWUAEM,HWRUNI,HWHSS2,HWUPCM,HWUMBW
21040 DOUBLE COMPLEX Z, Z0, Z1, C1, C2, C3,GZ, CLL, CLR, CRL, CRR
21041 PARAMETER (Z = (0.D0,1.D0), Z0 = (0.D0,0.D0), Z1 = (1.D0,0.D0))
21042 PARAMETER (SSNU=449,SSCH = 453)
21043 EQUIVALENCE (MZ, RMASS(200))
21044 EQUIVALENCE (XC(1), ZMIXSS(1,3)), (XC(2), ZMIXSS(2,3))
21045 EQUIVALENCE (XC(3), ZMIXSS(3,3)), (XC(4), ZMIXSS(4,3))
21046 EQUIVALENCE (XD(1), ZMIXSS(1,4)), (XD(2), ZMIXSS(2,4))
21047 EQUIVALENCE (XD(3), ZMIXSS(3,4)), (XD(4), ZMIXSS(4,4))
21048C--Start of the code
21049 IF(GENEV) THEN
21050 RCS = HCS*HWRGEN(0)
21051 ELSE
21052C--Decide which processes to generate
21053 IF(FSTWGT) THEN
21054 NEUT = .TRUE.
21055 CHAR = .TRUE.
21056C--neutralino pair production
21057 IF(IPROC.GE.710.AND.IPROC.LE.726) THEN
21058 CHAR = .FALSE.
21059 IF(IPROC.EQ.710) THEN
21060 NTID(1) = 0
21061 NTID(2) = 0
21062 ELSE
21063 NTID(1) = INT((IPROC-707)/4)
21064 NTID(2) = MOD((IPROC-711),4)+1
21065 ENDIF
21066C--chargino pair production
21067 ELSEIF(IPROC.GE.730.AND.IPROC.LE.734) THEN
21068 NEUT = .FALSE.
21069 IF(IPROC.EQ.730) THEN
21070 CHID(1) = 0
21071 CHID(2) = 0
21072 ELSE
21073 CHID(1) = INT((IPROC-729)/2)
21074 CHID(2) = MOD((IPROC-731),2)+1
21075 ENDIF
21076 ELSEIF(IPROC.NE.700) THEN
21077 CALL HWWARN('HWHESG',500)
21078 ENDIF
21079C--check the particles in the beam
21080 IF(ABS(IDHEP(1)).EQ.11) THEN
21081C--electron beams
21082 ISL = 425
21083 ISR = 437
21084 ISN = 426
21085 ELSEIF(ABS(IDHEP(1)).EQ.13) THEN
21086C--muon beams
21087 ISL = 427
21088 ISR = 439
21089 ISN = 428
21090 ELSE
21091 CALL HWWARN('HWHESG',501)
21092 ENDIF
21093 IDL=ABS(IDHEP(1))
21094 ENDIF
21095 DO I=1,4
21096 MNU(I) = RMASS(SSNU+I)
21097 MNU2(I) = MNU(I)**2
21098 ENDDO
21099 DO IG1 = 1,2
21100 MCH(IG1) = RMASS(IG1+SSCH)
21101 MCH2(IG1) = MCH(IG1)**2
21102 ENDDO
21103 COSTH = HWRUNI(1,-ONE,ONE)
21104 XW = TWO * SWEIN
21105 S22W = XW * (TWO - XW)
21106 S2W = SQRT(S22W)
21107 S = PHEP(5,3)**2
21108 EMSCA = PHEP(5,3)
21109 FACA = HWUAEM(S)**2
21110 GZ = S-MZ**2+Z*S/MZ*GAMZ
21111 MSL = RMASS(ISL)
21112 MSR = RMASS(ISR)
21113 MSL2 = MSL**2
21114 MSR2 = MSR**2
21115 MSNU = RMASS(ISN)
21116 MSNU2 = MSNU**2
21117C--neutralino pair production
21118 IF(.NOT.NEUT) THEN
21119 DO IQ1=1,4
21120 DO IQ2=1,4
21121 M1(IQ1,IQ2) = ZERO
21122 ENDDO
21123 ENDDO
21124 GOTO 100
21125 ENDIF
21126 DO IQ1=1,4
21127 DO IQ2=1,4
21128 SM = MNU(IQ1) + MNU(IQ2)
21129 QPE = S - SM**2
21130 IF(QPE.GE.ZERO.AND.
21131 & (NTID(1).EQ.0.OR.(IQ1.EQ.NTID(1).AND.IQ2.EQ.NTID(2))
21132 & .OR.(IQ1.EQ.NTID(2).AND.IQ2.EQ.NTID(1)))) THEN
21133 DM = MNU(IQ1) - MNU(IQ2)
21134 SQPE = SQRT(QPE*(S-DM**2))
21135 PF = SQPE/S
21136 T = HALF*(SQPE*COSTH - S + MNU2(IQ1) + MNU2(IQ2))
21137 U = - T - S + MNU2(IQ1) + MNU2(IQ2)
21138 C1 = (XD(IQ1)*XD(IQ2)-XC(IQ1)*XC(IQ2))/S2W/GZ
21139 C2 = - C1
21140 SGN = ZSGNSS(IQ1)*ZSGNSS(IQ2)
21141 CLL = LFCH(IDL)*C1+SLFCH(IDL,IQ1)*SLFCH(IDL,IQ2)/(U-MSL2)
21142 CLR = LFCH(IDL)*C2-SLFCH(IDL,IQ1)*SLFCH(IDL,IQ2)/(T-MSL2)
21143 CRL = RFCH(IDL)*C1-SRFCH(IDL,IQ1)*SRFCH(IDL,IQ2)/(T-MSR2)
21144 CRR = RFCH(IDL)*C2+SRFCH(IDL,IQ1)*SRFCH(IDL,IQ2)/(U-MSR2)
21145C--modified to include beam polarization PR 10/10/01
21146 M1(IQ1,IQ2) = FACA*PF*GEV2NB*PIFAC/S*HALF*
21147 & HWHSS2(S,T,U,MNU(IQ1),MNU(IQ2),SGN,CLL,CLR,CRL,CRR)
21148 ELSE
21149 M1(IQ1,IQ2) = ZERO
21150 ENDIF
21151 ENDDO
21152 ENDDO
21153C--chargino pair production
21154 100 IF(.NOT.CHAR) THEN
21155 DO IG1=1,2
21156 DO IG2=1,2
21157 M2(IG1,IG2) = ZERO
21158 ENDDO
21159 ENDDO
21160 GOTO 200
21161 ENDIF
21162 DO IG1 = 1,2
21163 DO IG2 = 1,2
21164 SM = MCH(IG1) + MCH(IG2)
21165 QPE = S - SM**2
21166 IF (QPE.GE.ZERO.AND.
21167 & (CHID(1).EQ.0.OR.(CHID(1).EQ.IG1.AND.CHID(2).EQ.IG2)
21168 & .OR.(CHID(1).EQ.IG2.AND.CHID(2).EQ.IG1))) THEN
21169 DM = MCH(IG1) - MCH(IG2)
21170 SQPE = SQRT(QPE*(S-DM**2))
21171 PF = SQPE/S
21172 T = HALF*(SQPE*COSTH - S + MCH2(IG1) + MCH2(IG2))
21173 U = - T - S + MCH2(IG1) + MCH2(IG2)
21174 DAB = ABS(FLOAT(IG1+IG2-3))
21175 C1 = (-WMXVSS(IG1,2)*WMXVSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
21176 C2 = (-WMXUSS(IG1,2)*WMXUSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
21177 SGN = WSGNSS(IG1)*WSGNSS(IG2)
21178 C3 = -DAB*QFCH(IDL)/S
21179 CLL = C3- LFCH(IDL)*C1
21180 & +WMXVSS(IG1,1)*WMXVSS(IG2,1)/((U-MSNU2)*XW)
21181 CLR = C3- LFCH(IDL)*C2
21182 CRL = C3- RFCH(IDL)*C1
21183 CRR = C3- RFCH(IDL)*C2
21184C--modified to include beam polarization PR 10/10/01
21185 M2(IG1,IG2)=FACA*PF*GEV2NB*PIFAC/S*
21186 & HWHSS2(S,T,U,MCH(IG1),MCH(IG2),SGN,CLL,CLR,CRL,CRR)
21187 ELSE
21188 M2(IG1,IG2) = ZERO
21189 ENDIF
21190 ENDDO
21191 ENDDO
21192 ENDIF
21193C--Add up the weights now
21194 200 HCS = ZERO
21195 IF(.NOT.NEUT) GOTO 250
21196 DO IQ1=1,4
21197 IG1 = SSNU+IQ1
21198 DO IQ2=1,4
21199 IG2 = SSNU+IQ2
21200 HCS = HCS+M1(IQ1,IQ2)
21201 IF(GENEV.AND.HCS.GT.RCS) GOTO 900
21202 ENDDO
21203 ENDDO
21204 250 IF(.NOT.CHAR) GOTO 900
21205 DO IQ1 = 1,2
21206 IG1 = SSCH+IQ1
21207 DO IQ2 = 1,2
21208 IG2 = SSCH+IQ2+2
21209 HCS = HCS + M2(IQ1,IQ2)
21210 IF (GENEV.AND.HCS.GT.RCS) GOTO 900
21211 ENDDO
21212 ENDDO
21213 900 IF(GENEV) THEN
21214C--change sign of COSTH if antiparticle first
21215 IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH
21216C-Set up the particle types
21217 IDHW(NHEP+1) = 15
21218 IDHEP(NHEP+1) = 0
21219 ISTHEP(NHEP+1) = 110
21220 IDHW(NHEP+2) = IG1
21221 IDHW(NHEP+3) = IG2
21222 IDHEP(NHEP+2) = IDPDG(IG1)
21223 IDHEP(NHEP+3) = IDPDG(IG2)
21224C--select the particle masses and momenta
21225 NTRY = 0
21226 910 NTRY = NTRY+1
21227 PHEP(5,NHEP+2) = HWUMBW(IG1)
21228 PHEP(5,NHEP+3) = HWUMBW(IG2)
21229 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
21230 PCM = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
21231 IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
21232 GOTO 910
21233 ELSEIF(PCM.LT.ZERO) THEN
21234 CALL HWWARN('HWHESG',100)
21235 GOTO 999
21236 ENDIF
21237C--Set up the colours etc
21238 ISTHEP(NHEP+2) = 113
21239 ISTHEP(NHEP+3) = 114
21240 JMOHEP(1,NHEP+1) = 1
21241C--PR Bug fix 10/10/01
21242 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
21243 JMOHEP(2,NHEP+1) = 2
21244 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
21245 JMOHEP(1,NHEP+2) = NHEP+1
21246 JMOHEP(2,NHEP+2) = NHEP+2
21247 JMOHEP(1,NHEP+3) = NHEP+1
21248 JMOHEP(2,NHEP+3) = NHEP+3
21249 JDAHEP(1,NHEP+1) = NHEP+2
21250 JDAHEP(2,NHEP+1) = NHEP+3
21251 JDAHEP(1,NHEP+2) = 0
21252 JDAHEP(2,NHEP+2) = NHEP+3
21253 JDAHEP(1,NHEP+3) = 0
21254 JDAHEP(2,NHEP+3) = NHEP+2
21255C--Set up the momenta
21256 IHEP = NHEP+2
21257 PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
21258 PHEP(3,IHEP) = PCM*COSTH
21259 PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
21260 PHEP(2,IHEP) = ZERO
21261 CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
21262 CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
21263 CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
21264 NHEP = NHEP+3
21265 ELSE
21266 EVWGT = HCS
21267 ENDIF
21268 999 RETURN
21269 END
21270CDECK ID>, HWHESP.
21271*CMZ :- -18/10/00 13:46:47 by Peter Richardson
21272*-- Author : Kosuke Odagiri & Peter Richardson
21273C-----------------------------------------------------------------------
21274 SUBROUTINE HWHESP
21275C-----------------------------------------------------------------------
21276C SUSY E+E- -> 2 SPARTICLE PROCESSES
21277C-----------------------------------------------------------------------
c63d70bc 21278 INCLUDE 'herwig65.inc'
65767955 21279 DOUBLE PRECISION SAVWT(3),RANWT,HWRGEN
21280 EXTERNAL HWRGEN
21281 SAVE SAVWT
21282 IF(IPROC.EQ.700) THEN
21283 IF(GENEV) THEN
21284 RANWT = SAVWT(3)*HWRGEN(0)
21285 IF(RANWT.LT.SAVWT(1)) THEN
21286 CALL HWHESG
21287 ELSEIF(RANWT.LT.SAVWT(2)) THEN
21288 CALL HWHESL
21289 ELSEIF(RANWT.LT.SAVWT(3)) THEN
21290 CALL HWHESQ
21291 ENDIF
21292 ELSE
21293 CALL HWHESG
21294 SAVWT(1) = EVWGT
21295 CALL HWHESL
21296 SAVWT(2) = SAVWT(1)+EVWGT
21297 CALL HWHESQ
21298 SAVWT(3) = SAVWT(2)+EVWGT
21299 EVWGT = SAVWT(3)
21300 ENDIF
21301 ELSEIF(IPROC.LT.740) THEN
21302 CALL HWHESG
21303 ELSEIF(IPROC.LT.760) THEN
21304 CALL HWHESL
21305 ELSEIF(IPROC.LT.790) THEN
21306 CALL HWHESQ
21307 ELSE
21308C---UNRECOGNIZED PROCESS
21309 CALL HWWARN('HWHESP',500)
21310 ENDIF
21311 END
21312CDECK ID>, HWHESQ.
21313*CMZ :- -16/10/00 15:34:113 by Peter Richardson
21314*-- Author : Kosuke Odagiri & Peter Richardson
21315C-----------------------------------------------------------------------
21316 SUBROUTINE HWHESQ
21317C-----------------------------------------------------------------------
21318C SUSY E+E- -> 2 SQUARK PROCESSES
21319C-----------------------------------------------------------------------
c63d70bc 21320 INCLUDE 'herwig65.inc'
65767955 21321 DOUBLE PRECISION HWRGEN,HWUAEM,EPS,HCS,RCS,S,PF,QPE,HWUPCM,PCM,
21322 & FACTR,SN2TH,MZ,ME2(2,2,6),EMSC2,HWUMBW,HWRUNI,SQPE
21323 INTEGER ID1,ID2,IQ,IQ1,IQ2,I,J,IHEP,IDL,IDLR(2),IDSQU(2),NTRY
21324 EXTERNAL HWRGEN,HWUAEM,HWUMBW,HWUPCM,HWRUNI
21325 SAVE HCS,ME2,IDLR,IDSQU
21326 PARAMETER (EPS = 1.D-9)
21327 DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
21328 PARAMETER (Z = (0.D0,1.D0))
21329 EQUIVALENCE (MZ, RMASS(200))
21330C
21331 S = PHEP(5,3)**2
21332 EMSC2 = S
21333 EMSCA = SQRT(EMSC2)
21334 IF(FSTWGT) THEN
21335 IF(IPROC.EQ.700.OR.IPROC.EQ.760) THEN
21336 IDLR(1) = 0
21337 IDLR(2) = 0
21338 IDSQU(1) = 1
21339 IDSQU(2) = 6
21340 ELSEIF(IPROC.GT.760.AND.IPROC.LE.784) THEN
21341 IQ = MOD((IPROC-761),4)
21342 IF(IQ.EQ.0) THEN
21343 IDLR(1) = 0
21344 IDLR(2) = 0
21345 ELSEIF(IQ.EQ.1) THEN
21346 IDLR(1) = 1
21347 IDLR(2) = 1
21348 ELSEIF(IQ.EQ.2) THEN
21349 IDLR(1) = 1
21350 IDLR(2) = 2
21351 ELSEIF(IQ.EQ.3) THEN
21352 IDLR(1) = 2
21353 IDLR(2) = 2
21354 ENDIF
21355 IDSQU(1) = (IPROC-761)/4+1
21356 IDSQU(2) = IDSQU(1)
21357 ELSE
21358 CALL HWWARN('HWHESQ',500)
21359 ENDIF
21360 ENDIF
21361 IF (GENEV) THEN
21362 RCS = HCS*HWRGEN(0)
21363 ELSE
21364 COSTH = HWRUNI(1,-ONE,ONE)
21365 SN2TH = 0.25D0 - 0.25D0*COSTH**2
21366 FACTR = CAFAC*GEV2NB*PIFAC*HWUAEM(EMSC2)**2*SN2TH/S
21367 GZ = (S-MZ**2+Z*S*GAMZ/MZ)/S
21368 IDL = ABS(IDHEP(1))
21369c ~ ~*
21370c e+ e- -> q q
21371c
21372 DO IQ=1,6
21373 DO I=1,2
21374 DO J=1,2
21375 ME2(I,J,IQ) = ZERO
21376 ENDDO
21377 ENDDO
21378 ENDDO
21379 DO IQ = IDSQU(1),IDSQU(2)
21380 DO I = 1,2
21381 DO J = 1,2
21382 IF ((I.NE.J).AND.(IQ.LT.5).OR.
21383 & (IDLR(1).NE.0.AND.(IDLR(1).NE.I.OR.IDLR(2).NE.J)
21384 & .AND.(IDLR(1).NE.J.OR.IDLR(2).NE.I))) THEN
21385 QPE = -1.
21386 ELSE
21387 ID1 = 388 + I*12 + IQ
21388 ID2 = 388 + J*12 + IQ
21389 QPE = S-(RMASS(ID1)+RMASS(ID2))**2
21390 ENDIF
21391 IF (QPE.GT.ZERO) THEN
21392 SQPE = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))
21393 PF = SQPE/S
21394 A = QFCH(IQ)*QFCH(IDL)
21395 BL = LFCH(IQ)/GZ
21396 BR = RFCH(IQ)/GZ
21397 CL = QMIXSS(IQ,1,I)*QMIXSS(IQ,1,J)
21398 CR = QMIXSS(IQ,2,I)*QMIXSS(IQ,2,J)
21399 D = (A+BL*LFCH(IDL))*CL+(A+BR*LFCH(IDL))*CR
21400 E = (A+BL*RFCH(IDL))*CL+(A+BR*RFCH(IDL))*CR
21401 ME2(I,J,IQ)=FACTR*PF**3*DREAL(
21402 & (ONE-EPOLN(3))*(ONE+PPOLN(3))*DCONJG(D)*D
21403 & +(ONE+EPOLN(3))*(ONE-PPOLN(3))*DCONJG(E)*E)
21404 ELSE
21405 ME2(I,J,IQ)=ZERO
21406 ENDIF
21407 ENDDO
21408 ENDDO
21409 ENDDO
21410 ENDIF
21411 HCS = ZERO
21412C
21413 DO IQ = 1,6
21414 DO I = 1,2
21415 DO J = 1,2
21416 IQ1 = IQ+I*12+388
21417 IQ2 = IQ+J*12+394
21418 HCS = HCS + ME2(I,J,IQ)
21419 IF (GENEV.AND.HCS.GT.RCS) GOTO 100
21420 ENDDO
21421 ENDDO
21422 ENDDO
21423C---GENERATE EVENT
21424 100 IF(GENEV) THEN
21425 IDHW(NHEP+1) = 15
21426 IDHEP(NHEP+1) = 0
21427 ISTHEP(NHEP+1) = 110
21428 IDHW(NHEP+2) = IQ1
21429 IDHW(NHEP+3) = IQ2
21430 IDHEP(NHEP+2) = IDPDG(IQ1)
21431 IDHEP(NHEP+3) = IDPDG(IQ2)
21432C--Select the particle masses and momenta
21433 110 NTRY = NTRY+1
21434 PHEP(5,NHEP+2) = HWUMBW(IQ1)
21435 PHEP(5,NHEP+3) = HWUMBW(IQ2)
21436 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
21437 PCM = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
21438 IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
21439 GOTO 110
21440 ELSEIF(PCM.LT.ZERO) THEN
21441 CALL HWWARN('HWHESQ',100)
21442 GOTO 999
21443 ENDIF
21444C--Set up the colours etc
21445 ISTHEP(NHEP+2) = 113
21446 ISTHEP(NHEP+3) = 114
21447 JMOHEP(1,NHEP+1) = 1
21448 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
21449 JMOHEP(2,NHEP+1) = 2
21450 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
21451 JMOHEP(1,NHEP+2) = NHEP+1
21452 JMOHEP(2,NHEP+2) = NHEP+3
21453 JMOHEP(1,NHEP+3) = NHEP+1
21454 JMOHEP(2,NHEP+3) = NHEP+2
21455 JDAHEP(1,NHEP+1) = NHEP+2
21456 JDAHEP(2,NHEP+1) = NHEP+3
21457 JDAHEP(1,NHEP+2) = 0
21458 JDAHEP(2,NHEP+2) = NHEP+3
21459 JDAHEP(1,NHEP+3) = 0
21460 JDAHEP(2,NHEP+3) = NHEP+2
21461C--Set up the momenta
21462 IHEP = NHEP+2
21463 PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
21464 PHEP(3,IHEP) = PCM*COSTH
21465 PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
21466 CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
21467 CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
21468 CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
21469 NHEP = NHEP+3
21470 ELSE
21471 EVWGT = HCS
21472 ENDIF
21473 999 RETURN
21474 END
21475CDECK ID>, HWHEW0.
21476*CMZ :- -26/04/91 11.11.55 by Bryan Webber
21477*-- Author : Zoltan Kunszt, modified by Bryan Webber & Mike Seymour
21478C-----------------------------------------------------------------------
21479 SUBROUTINE HWHEW0(IP,ETOT,XM,PR,WEIGHT,CR)
21480C-----------------------------------------------------------------------
c63d70bc 21481 INCLUDE 'herwig65.inc'
65767955 21482 DOUBLE PRECISION HWRGEN,ETOT,XM(2),PR(5,2),WEIGHT,CR,XM1,XM2,S,
21483 & D1,PABS,D,CX,C,E,F,SC,G
21484 INTEGER IP,I
21485 EXTERNAL HWRGEN
21486 WEIGHT=ZERO
21487 XM1=XM(1)**2
21488 XM2=XM(2)**2
21489 S=ETOT*ETOT
21490 D1=S-XM1-XM2
21491 PABS=D1*D1-4.*XM1*XM2
21492 IF (PABS.LE.ZERO) RETURN
21493 PABS=SQRT(PABS)
21494 D=D1/PABS
21495 IF(IP.EQ.2)GOTO3
21496 CX=CR
21497 C=D-(D+CX)*((D-CR)/(D+CX))**HWRGEN(2)
21498 GOTO 4
214993 E=((D+ONE)/(D-ONE))*(TWO*HWRGEN(3)-ONE)
21500 C=D*((E-ONE)/(E+ONE))
215014 F=2D0*PIFAC*HWRGEN(4)
21502 SC=SQRT(ONE-C*C)
21503 PR(4,1)=(S+XM1-XM2)/(TWO*ETOT)
21504 PR(5,1)=PR(4,1)*PR(4,1)-XM1
21505 IF (PR(5,1).LE.ZERO) RETURN
21506 PR(5,1)=SQRT(PR(5,1))
21507 PR(4,2)=ETOT-PR(4,1)
21508 PR(3,1)=PR(5,1)*C
21509 PR(5,2)=PR(5,1)
21510 PR(2,1)=PR(5,1)*SC*COS(F)
21511 PR(1,1)=PR(5,1)*SC*SIN(F)
21512 DO 7 I=1,3
215137 PR(I,2)=-PR(I,1)
21514 G=0.
21515 IF(IP.EQ.1)G=(D-C)*LOG((D+CX)/(D-CR))
21516 IF(IP.EQ.2)G=(D*D-C*C)/D*LOG((D+ONE)/(D-ONE))
21517 WEIGHT=PIFAC*G*PR(5,1)/ETOT*HALF
21518 END
21519CDECK ID>, HWHEW1.
21520*CMZ :- -26/04/91 11.11.55 by Bryan Webber
21521*-- Author : Zoltan Kunszt, modified by Bryan Webber
21522C-----------------------------------------------------------------------
21523 SUBROUTINE HWHEW1(NPART)
21524C-----------------------------------------------------------------------
21525 IMPLICIT NONE
21526 DOUBLE PRECISION P(4,7),XMASS,PLAB,PRW,PCM
21527 INTEGER NPART,I,J,K
21528 COMMON/HWHEWP/ XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
21529 DO 10 I=1,NPART
21530 P(1,I)=PLAB(3,I)
21531 P(2,I)=PLAB(1,I)
21532 P(3,I)=PLAB(2,I)
21533 P(4,I)=PLAB(4,I)
21534 10 CONTINUE
21535 DO 20 J=1,4
21536 DO 30 K=1,(NPART-2)
21537 30 PCM(J,K)=P(J,K+2)
21538 PCM(J,NPART-1)=-P(J,1)
21539 PCM(J,NPART)=-P(J,2)
21540 20 CONTINUE
21541 END
21542CDECK ID>, HWHEW2.
21543*CMZ :- -26/04/91 13.22.25 by Federico Carminati
21544*-- Author : Zoltan Kunszt, modified by Bryan Webber
21545C-----------------------------------------------------------------------
21546 SUBROUTINE HWHEW2(NPART,PPCM,H,CH,D)
21547C-----------------------------------------------------------------------
21548C PCM SHOULD BE DEFINED SUCH THAT ALL 4-MOMENTA ARE OUTGOING.
21549C CONVENTION FOR PCM AND P IS THAT DIRECTION 1 =BEAM, COMPONENT
21550C 4 = ENERGY AND COMPONENT 2 AND 3 ARE TRANSVERSE COMPONENTS.
21551C THUS INCOMING MOMENTA SHOULD CORRESPOND TO OUTGOING MOMENTA
21552C OF NEGATIVE ENERGY.
21553C PCM IS FILLED BY PHASE SPACE MONTE CARLO.
21554C I1-I7 HERE REFER TO HOW PCM INDEXING IS MAPPED TO OUR STANDARD
21555C 1-6=GLUON,GLUON,Q,QBAR,QP,QPBAR ORDERING `
21556C-----------------------------------------------------------------------
21557 IMPLICIT NONE
21558 DOUBLE COMPLEX PT5,ZT,Z1,ZI,ZP,ZQ,ZD,ZPS,ZQS,ZDPM,ZDMP,H(8,8),
21559 & CH(8,8),D(8,8)
21560 DOUBLE PRECISION ZERO,ONE,PPCM(5,8),P(5,8),WRN(8),EPS,Q1,Q2,QP,QM,
21561 & P1,P2,PP,PM,DMP,DPM,PT,QT,PTI,QTI,HALF
21562 INTEGER J,L,IJ,II,JJ,I,NPART,IP1,IPP1
21563 PARAMETER (ZERO=0.D0,ONE=1.D0,HALF=0.5D0)
21564 EPS=0.0000001
21565 ZI=DCMPLX(ZERO,ONE)
21566 Z1=DCMPLX(ONE,ZERO)
21567C FOLLOWING DO LOOP IS TO CONVERT TO OUR STANDARD INDEXING
21568 DO 1 L=1,NPART
21569 DO 1 IJ=1,4
215701 P(IJ,L)=PPCM(IJ,L)
21571 DO 2 II=1,8
21572 WRN(II)=ONE
21573 IF(P(4,II).LT.ZERO) WRN(II)=-ONE
21574 DO 2 JJ=1,4
21575 P(JJ,II)=WRN(II)*P(JJ,II)
21576 2 CONTINUE
21577C THE ABOVE CHECKS FOR MOMENTA WITH NEGATIVE ENERGY,INNER PRODUCTS
21578C ARE EXPRESSED DIFFERENTLY FOR DIFFERENT CASES
21579 DO 11 I=1,NPART-1
21580 IP1=I+1
21581 DO 11 J=IP1,NPART
21582 Q1=P(4,I)+P(1,I)
21583 QP=0.0
21584 IF(Q1.GT.EPS)QP=SQRT(Q1)
21585 Q2=P(4,I)-P(1,I)
21586 QM=0.0
21587 IF(Q2.GT.EPS)QM=SQRT(Q2)
21588 P1=P(4,J)+P(1,J)
21589 PP=0.
21590 IF(P1.GT.EPS)PP=SQRT(P1)
21591 P2=P(4,J)-P(1,J)
21592 PM=0.
21593 IF(P2.GT.EPS)PM=SQRT(P2)
21594 DMP=PM*QP
21595 ZDMP=DCMPLX(DMP,ZERO)
21596 DPM=PP*QM
21597 ZDPM=DCMPLX(DPM,ZERO)
21598C NOTE THAT IN OUR INNER PRODUCT NOTATION WE ARE COMPUTING <P,Q>
21599 PT=SQRT(P(2,J)**2+P(3,J)**2)
21600 QT=SQRT(P(2,I)**2+P(3,I)**2)
21601 IF(PT.GT.EPS) GOTO 99
21602 ZP=Z1
21603 GOTO 98
21604 99 PTI=ONE/PT
21605 ZP=DCMPLX(PTI*P(2,J),PTI*P(3,J))
21606 98 ZPS=DCONJG(ZP)
21607 IF(QT.GT.EPS) GOTO 89
21608 ZQ=Z1
21609 GOTO 88
21610 89 QTI=ONE/QT
21611 ZQ=DCMPLX(QTI*P(2,I),QTI*P(3,I))
21612 88 ZQS=DCONJG(ZQ)
21613 ZT=Z1
21614 IF(WRN(I).LT.ZERO) ZT=ZT*ZI
21615 IF(WRN(J).LT.ZERO) ZT=ZT*ZI
21616 H(J,I)=(ZDMP*ZP-ZDPM*ZQ)*ZT
21617 CH(J,I)=(ZDMP*ZPS-ZDPM*ZQS)*ZT
21618 ZD=H(J,I)*CH(J,I)
21619 PT5=DCMPLX(HALF,ZERO)
21620 D(J,I)=PT5*ZD
21621 11 CONTINUE
21622 DO 60 I=1,NPART-1
21623 IPP1=I+1
21624 DO 60 J=IPP1,NPART
21625 H(I,J)=-H(J,I)
21626 CH(I,J)=-CH(J,I)
21627 60 D(I,J)=D(J,I)
21628 END
21629CDECK ID>, HWHEW3.
21630*CMZ :- -27/03/92 19.48.55 by Mike Seymour
21631*-- Author : Zoltan Kunszt, modified by Bryan Webber
21632C-----------------------------------------------------------------------
21633 SUBROUTINE HWHEW3(N1,N2,N3,N4,N5,N6,AMPWW)
21634C-----------------------------------------------------------------------
21635C RECALL THAT N1,N3,N5 MUST BE OUTGOING FERMIONS, AND N2,N4,N6 MUST BE
21636C OUTGOING ANTI-FERMIONS; 3,4 FOR W-, 5,6 FOR W+
21637C
21638C EQ1 AND T31 ARE FOR OUTOING INITIAL QUARK
21639C CHOOSE APPROPRIATE CASE ACCORDING TO NUPDN
21640C NUPDN=1 FOR UUBAR COLLISIONS, NUPDN=2 FOR DDBAR COLLISIONS
21641C NFINAL CHOOSES THE FINAL DECAYS, 1 FOR DOUBLE LEPTON, 2 FOR 1 FLAVOR
21642C LEPTON+2FAMILIES OF QUARKS, 3 THE SAME, 4 FOR DOUBLE 2FAM3COLOR QUARKS
21643C
21644C NOTE: EXTERNAL FACTOR OF COLOR AVERAGE AND SPIN AVERAGE AND
21645C COUPLING (E**8/4/9) MUST BE INCLUDED AS WELL AS COMPENSATION
21646C FOR ON POLE APPROXIMATION AS DESIRED.
21647C-----------------------------------------------------------------------
c63d70bc 21648 INCLUDE 'herwig65.inc'
65767955 21649 DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD,ZAMP1,ZAMP3,DWW,CWW,BWW,AWW,
21650 & AWWM,AWWP,AMPTEM,ZTWO,ZHALF
21651 DOUBLE PRECISION XW,ZMASS,T3,EQ1,RR,RL,ZM2,AMP2,RKW,COLFAC(4),
21652 & AMPWW(4)
21653 INTEGER I,N1,N2,N3,N4,N5,N6
21654 EXTERNAL HWHEW4
21655 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21656 EQUIVALENCE (XW,SWEIN),(ZMASS,RMASS(200))
21657 SAVE COLFAC,ZTWO,ZHALF
21658 DATA COLFAC/1.D0,3.D0,3.D0,9.D0/
21659 DATA ZTWO,ZHALF/(2.0D0,0.0D0),(0.5D0,0.0D0)/
21660 T3=-1.D0
21661 EQ1=-1.D0
21662 RR=-2.D0*EQ1*XW
21663 RL=T3+RR
21664 ZM2=ZMASS*ZMASS
21665 ZAMP1=DCMPLX(ZM2)/(ZTWO*ZD(N1,N2))
21666 & /(ZTWO*ZD(N1,N2)+DCMPLX(-ZM2,GAMZ*ZMASS))
21667 ZAMP3=ZHALF/(ZD(N1,N5)+ZD(N1,N6)+ZD(N5,N6))
21668 DWW=DCMPLX(RL)*ZAMP1+T3/(ZTWO*ZD(N1,N2))
21669 CWW=DCMPLX(RR)*ZAMP1
21670 AWW=DWW
21671 BWW=DWW-ZAMP3
21672 AWWM=AWW*HWHEW4(N1,N2,N3,N4,N5,N6)-BWW*HWHEW4(N1,N2,N5,N6,N3,N4)
21673 AWWP=CWW*(HWHEW4(N2,N1,N5,N6,N3,N4)-HWHEW4(N2,N1,N3,N4,N5,N6))
21674 AMPTEM=AWWM*DCONJG(AWWM)+AWWP*DCONJG(AWWP)
21675 AMP2=DREAL(AMPTEM)
21676C AMP2 DOES NOT INCLUDE COLOR OR FLAVOR SUMS OR AVERAGES YET
21677C NOR DOES IT INCLUDE TO THIS POINT KWW**2
21678C 1 LEPTON FLAVOR IF APPROPRIATE FOR NFINAL CHOICE
21679 RKW=0.25D0/XW**2
21680 DO 6 I=1,4
216816 AMPWW(I)=AMP2*COLFAC(I)*RKW*RKW
21682 END
21683CDECK ID>, HWHEW4.
21684*CMZ :- -26/04/91 10.18.57 by Bryan Webber
21685*-- Author : Zoltan Kunszt, modified by Bryan Webber
21686C-----------------------------------------------------------------------
21687 FUNCTION HWHEW4(N1,N2,N3,N4,N5,N6)
21688C-----------------------------------------------------------------------
21689 IMPLICIT NONE
21690 DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD
21691 INTEGER N1,N2,N3,N4,N5,N6
21692 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21693 HWHEW4=4*ZH(N1,N3)*ZCH(N2,N6)*(ZH(N1,N5)*ZCH(N1,N4)
21694 X +ZH(N3,N5)*ZCH(N3,N4))
21695 END
21696CDECK ID>, HWHEW5.
21697*CMZ : 20/08/91 22.09.33 by Federico Carminati
21698*-- Author : Zoltan Kunszt, modified by Mike Seymour
21699C-----------------------------------------------------------------------
21700 SUBROUTINE HWHEW5(N1,N2,N3,N4,N5,N6,HELSUM,HELCTY,ID1,ID2)
21701C-----------------------------------------------------------------------
21702C RECALL THAT N1,N3,N5 MUST BE OUTGOING FERMIONS, AND N2,N4,N6 MUST BE
21703C OUTGOING ANTI-FERMIONS; 3,4 FOR Z0, 5,6 FOR Z0
21704C
21705C EQ1 AND T31 ARE FOR OUTOING INITIAL QUARK
21706C CHOOSE APPROPRIATE CASE ACCORDING TO NUPDN
21707C NUPDN=1 FOR UUBAR COLLISIONS, NUPDN=2 FOR DDBAR COLLISIONS
21708C NFINAL CHOOSES THE FINAL DECAYS, 1 FOR DOUBLE LEPTON, 2 FOR 1 FLAVOR
21709C LEPTON+2FAMILIES OF QUARKS, 3 THE SAME, 4 FOR DOUBLE 2FAM3COLOR QUARKS
21710C
21711C NOTE: EXTERNAL FACTOR OF COLOR AVERAGE AND SPIN AVERAGE AND
21712C COUPLING (E**8/4/9) MUST BE INCLUDED AS WELL AS COMPENSATION
21713C FOR ON POLE APPROXIMATION AS DESIRED.
21714C
21715C---SLIGHTLY MODIFIED BY MHS, SO THAT HELCTY REFERS TO THE FINAL STATE
21716C INDICATED BY ID1,ID2
21717C-----------------------------------------------------------------------
21718 IMPLICIT NONE
21719 DOUBLE COMPLEX HWHEW4,ZH,ZCH,ZD,ZAMM(8),ZS134,ZS156,ZS234,ZS256,
21720 & ZTWO
21721 DOUBLE PRECISION CPFAC,CPALL,HELSUM,HELCTY,AMM
21722 INTEGER N1,N2,N3,N4,N5,N6,ID1,ID2,I
21723 EXTERNAL HWHEW4
21724 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21725 COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8)
21726 SAVE ZTWO
21727 DATA ZTWO/(2.0D0,0.0D0)/
21728C THE MATRIX ELEMENT DEPENDS ON
21729 ZS134=(ZD(N1,N3)+ZD(N1,N4)+ZD(N3,N4))*ZTWO
21730 ZS156=(ZD(N1,N5)+ZD(N1,N6)+ZD(N5,N6))*ZTWO
21731 ZS234=(ZD(N2,N3)+ZD(N2,N4)+ZD(N3,N4))*ZTWO
21732 ZS256=(ZD(N2,N5)+ZD(N2,N6)+ZD(N5,N6))*ZTWO
21733 ZAMM(1)=HWHEW4(N1,N2,N3,N4,N5,N6)/ZS134+
21734 > HWHEW4(N1,N2,N5,N6,N3,N4)/ZS156
21735 ZAMM(2)=HWHEW4(N1,N2,N4,N3,N5,N6)/ZS134+
21736 > HWHEW4(N1,N2,N5,N6,N4,N3)/ZS156
21737 ZAMM(3)=HWHEW4(N1,N2,N3,N4,N6,N5)/ZS134+
21738 > HWHEW4(N1,N2,N6,N5,N3,N4)/ZS156
21739 ZAMM(4)=HWHEW4(N1,N2,N4,N3,N6,N5)/ZS134+
21740 > HWHEW4(N1,N2,N6,N5,N4,N3)/ZS156
21741 ZAMM(5)=HWHEW4(N2,N1,N3,N4,N5,N6)/ZS234+
21742 > HWHEW4(N2,N1,N5,N6,N3,N4)/ZS256
21743 ZAMM(6)=HWHEW4(N2,N1,N4,N3,N5,N6)/ZS234+
21744 > HWHEW4(N2,N1,N5,N6,N4,N3)/ZS256
21745 ZAMM(7)=HWHEW4(N2,N1,N3,N4,N6,N5)/ZS234+
21746 > HWHEW4(N2,N1,N6,N5,N3,N4)/ZS256
21747 ZAMM(8)=HWHEW4(N2,N1,N4,N3,N6,N5)/ZS234+
21748 > HWHEW4(N2,N1,N6,N5,N4,N3)/ZS256
21749 HELSUM=0.0
21750 HELCTY=0.0
21751 DO 1 I=1,8
21752 AMM=DREAL(ZAMM(I)*DCONJG(ZAMM(I)))
21753 HELSUM=HELSUM+CPALL(I)*AMM
21754 HELCTY=HELCTY+CPFAC(ID1,ID2,I)*AMM
21755 1 CONTINUE
21756 END
21757CDECK ID>, HWHEWW.
21758*CMZ :- -02/05/91 10.58.29 by Federico Carminati
21759*-- Author : Zoltan Kunszt, modified by Bryan Webber
21760C-----------------------------------------------------------------------
21761 SUBROUTINE HWHEWW
21762C-----------------------------------------------------------------------
21763C E+E- -> W+W-/Z0Z0 (BASED ON ZOLTAN KUNSZT'S PROGRAM)
21764C-----------------------------------------------------------------------
c63d70bc 21765 INCLUDE 'herwig65.inc'
65767955 21766 DOUBLE COMPLEX ZH,ZCH,ZD
21767 DOUBLE PRECISION HWUAEM,HWRGEN,HWUPCM,ETOT,STOT,FLUXW,GAMM,GIMM,
21768 & WM2,WXMIN,WX1MAX,WX2MAX,FJAC1,FJAC2,WX1,WX2,WMM1,WMM2,XXM,W2BO,
21769 & PST,WEIGHT,TOTSIG,WMASS,WWIDTH,ELST,CV,CA,BR,XMASS,PLAB,PRW,PCM,
21770 & AMPWW(4),CCC,HELSUM,HELCTY,BRZED(12),BRTOT,CPFAC,CPALL,RLL(12),
21771 & RRL(12),DIST(4)
21772 INTEGER IB,IBOS,I,ID1,ID2,NTRY,IDP(10),IDBOS(2),J1,J2,IPRC,ILST,
21773 & IDZOLT(16),MAP(12),NEWHEP
21774 LOGICAL EISBM1,HWRLOG
21775 EXTERNAL HWUAEM,HWRGEN,HWUPCM
21776 SAVE IDP,STOT,FLUXW,GAMM,GIMM,WM2,WXMIN,WX1MAX,FJAC1,ELST,ILST,
21777 & IDBOS,WMASS,WWIDTH,BRZED
21778 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
21779 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21780 COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8)
21781 SAVE IDZOLT,MAP
21782 DATA ELST,ILST/0.D0,0/
21783 DATA IDZOLT/4,3,8,7,12,11,4*0,2,1,6,5,10,9/
21784 DATA MAP/12,11,2,1,14,13,4,3,16,15,6,5/
21785 IF (IERROR.NE.0) RETURN
21786 EISBM1=IDHW(1).LT.IDHW(2)
21787 IF (GENEV) THEN
21788 NEWHEP=NHEP
21789 NHEP=NHEP+2
21790 DO 20 IB=1,2
21791 IBOS=IB+NEWHEP
21792 CALL HWVEQU(5,PRW(1,IB),PHEP(1,IBOS))
21793 IF (EISBM1) PHEP(3,IBOS)=-PHEP(3,IBOS)
21794 CALL HWVZRO(4,VHEP(1,IBOS))
21795 CALL HWUDKL(IDBOS(IB),PHEP(1,IBOS),DIST)
21796 CALL HWVSUM(4,VHEP(1,IBOS),DIST,DIST)
21797 IDHW(IBOS)=IDBOS(IB)
21798 IDHEP(IBOS)=IDPDG(IDBOS(IB))
21799 JMOHEP(1,IBOS)=1
21800 JMOHEP(2,IBOS)=2
21801 ISTHEP(IBOS)=110
21802 DO 10 I=1,2
21803 CALL HWVEQU(5,PLAB(1,2*IB+I),PHEP(1,NHEP+I))
21804 IF (EISBM1) PHEP(3,NHEP+I)=-PHEP(3,NHEP+I)
21805 CALL HWVEQU(4,DIST,VHEP(1,NHEP+I))
21806C---STATUS, IDs AND POINTERS
21807 ISTHEP(NHEP+I)=112+I
21808 IDHW(NHEP+I)=IDP(2*IB+I)
21809 IDHEP(NHEP+I)=IDPDG(IDP(2*IB+I))
21810 JDAHEP(I,IBOS)=NHEP+I
21811 JMOHEP(1,NHEP+I)=IBOS
21812 JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS)
21813 10 CONTINUE
21814 NHEP=NHEP+2
21815 JMOHEP(2,NHEP)=NHEP-1
21816 JDAHEP(2,NHEP)=NHEP-1
21817 JMOHEP(2,NHEP-1)=NHEP
21818 JDAHEP(2,NHEP-1)=NHEP
21819 20 CONTINUE
21820 ELSE
21821 EMSCA=PHEP(5,3)
21822 ETOT=EMSCA
21823 IPRC=MOD(IPROC,100)
21824 IF (ETOT.NE.ELST .OR. IPRC.NE.ILST) THEN
21825 STOT=ETOT*ETOT
21826 FLUXW=GEV2NB*.125*(HWUAEM(STOT)/PIFAC)**4/STOT
21827 IF (IPRC.EQ.0) THEN
21828 WMASS=RMASS(198)
21829 WWIDTH=GAMW
21830 IDBOS(1)=198
21831 IDBOS(2)=199
21832 ELSEIF (IPRC.EQ.50) THEN
21833 WMASS=RMASS(200)
21834 WWIDTH=GAMZ
21835 IDBOS(1)=200
21836 IDBOS(2)=200
21837C---LOAD FERMION COUPLINGS TO Z
21838 DO 30 I=1,12
21839 RLL(I)=VFCH(MAP(I),1)+AFCH(MAP(I),1)
21840 RRL(I)=VFCH(MAP(I),1)-AFCH(MAP(I),1)
21841 30 CONTINUE
21842 RLL(11)=0
21843 RRL(11)=0
21844 BRTOT=0
21845 DO 60 J1=1,12
21846 BRZED(J1)=0
21847 DO 50 J2=1,12
21848 CCC=1
21849 IF (MOD(J1-1,4).GE.2) CCC=CCC*CAFAC
21850 IF (MOD(J2-1,4).GE.2) CCC=CCC*CAFAC
21851 CPFAC(J1,J2,1)=CCC*(RLL(2)**2*RLL(J1)*RLL(J2))**2
21852 CPFAC(J1,J2,2)=CCC*(RLL(2)**2*RRL(J1)*RLL(J2))**2
21853 CPFAC(J1,J2,3)=CCC*(RLL(2)**2*RLL(J1)*RRL(J2))**2
21854 CPFAC(J1,J2,4)=CCC*(RLL(2)**2*RRL(J1)*RRL(J2))**2
21855 CPFAC(J1,J2,5)=CCC*(RRL(2)**2*RLL(J1)*RLL(J2))**2
21856 CPFAC(J1,J2,6)=CCC*(RRL(2)**2*RRL(J1)*RLL(J2))**2
21857 CPFAC(J1,J2,7)=CCC*(RRL(2)**2*RLL(J1)*RRL(J2))**2
21858 CPFAC(J1,J2,8)=CCC*(RRL(2)**2*RRL(J1)*RRL(J2))**2
21859 DO 40 I=1,8
21860 IF (J1.EQ.1.AND.J2.EQ.1) CPALL(I)=0
21861 CPALL(I)=CPALL(I)+CPFAC(J1,J2,I)
21862 BRZED(J1)=BRZED(J1)+CPFAC(J1,J2,I)
21863 BRTOT=BRTOT+CPFAC(J1,J2,I)
21864 40 CONTINUE
21865 50 CONTINUE
21866 60 CONTINUE
21867 DO 70 I=1,12
21868 70 BRZED(I)=BRZED(I)/BRTOT
21869 ELSE
21870 CALL HWWARN('HWHEWW',500)
21871 ENDIF
21872 GAMM=WMASS*WWIDTH
21873 GIMM=1.D0/GAMM
21874 WM2=WMASS*WMASS
21875 WXMIN=ATAN(-WMASS/WWIDTH)
21876 WX1MAX=ATAN((STOT-WM2)*GIMM)
21877 FJAC1=WX1MAX-WXMIN
21878 ILST=IPRC
21879 ELST=ETOT
21880 ENDIF
21881 EVWGT=0
21882C---CHOOSE W MASSES
21883 WX1=WXMIN+FJAC1*HWRGEN(1)
21884 WMM1=GAMM*TAN(WX1)+WM2
21885 IF (WMM1.LE.0) RETURN
21886 XMASS(1)=SQRT(WMM1)
21887 WX2MAX=ATAN(((ETOT-XMASS(1))**2-WM2)*GIMM)
21888 FJAC2=WX2MAX-WXMIN
21889 WX2=WXMIN+FJAC2*HWRGEN(2)
21890 WMM2=GAMM*TAN(WX2)+WM2
21891 IF (WMM2.LE.0) RETURN
21892 XMASS(2)=SQRT(WMM2)
21893 IF (HWRLOG(HALF))THEN
21894 XXM=XMASS(1)
21895 XMASS(1)=XMASS(2)
21896 XMASS(2)=XXM
21897 ENDIF
21898C---CTMAX=ANGULAR CUT ON COS W-ANGLE
21899 CALL HWHEW0(1,ETOT,XMASS(1),PRW(1,1),W2BO,CTMAX)
21900 IF (W2BO.EQ.ZERO) RETURN
21901C---FOR ZZ EVENTS, FORCE BOSE STATISTICS, BY KILLING EVENTS WITH COS1<0
21902 IF (IPRC.NE.0) THEN
21903 IF (PRW(3,1).LT.ZERO) RETURN
21904C---AND THEN SYMMETRIZE (THIS PROCEDURE VASTLY IMPROVES EFFICIENCY)
21905 IF (HWRLOG(HALF)) THEN
21906 PRW(3,1)=-PRW(3,1)
21907 PRW(3,2)=-PRW(3,2)
21908 ENDIF
21909 ENDIF
21910 PLAB(3,1)=0.5*ETOT
21911 PLAB(4,1)=PLAB(3,1)
21912 PLAB(3,2)=-PLAB(3,1)
21913 PLAB(4,2)=PLAB(3,1)
21914C
21915C---LET THE W BOSONS DECAY
21916 NTRY=0
21917 80 NTRY=NTRY+1
21918 DO 90 IB=1,2
21919 CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,1)
21920 PST=HWUPCM(XMASS(IB),RMASS(ID1),RMASS(ID2))
21921 IF (PST.LT.ZERO) THEN
21922 CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,2)
21923 IF (NTRY.LE.NBTRY) GOTO 80
21924C CALL HWWARN('HWHEWW',1)
21925 RETURN
21926 ENDIF
21927 PRW(5,IB)=XMASS(IB)
21928 IDP(2*IB+1)=ID1
21929 IDP(2*IB+2)=ID2
21930 PLAB(5,2*IB+1)=RMASS(ID1)
21931 PLAB(5,2*IB+2)=RMASS(ID2)
21932 CALL HWDTWO(PRW(1,IB),PLAB(1,2*IB+1),PLAB(1,2*IB+2),
21933 & PST,TWO,.TRUE.)
21934 90 CONTINUE
21935 WEIGHT=FLUXW*W2BO*FJAC1*FJAC2*(0.5D0*PIFAC*GIMM)**2
21936 CALL HWHEW1(6)
21937 CALL HWHEW2(6,PCM(1,1),ZH,ZCH,ZD)
21938 IF (IPRC.EQ.0) THEN
21939 CALL HWHEW3(5,6,3,4,1,2,AMPWW)
21940 TOTSIG=9.*AMPWW(1)+6.*(AMPWW(2)+AMPWW(3))+4.*AMPWW(4)
21941 EVWGT=TOTSIG*WEIGHT*BR
21942 ELSE
21943 ID1=IDZOLT(IDPDG(IDP(3)))
21944 ID2=IDZOLT(IDPDG(IDP(5)))
21945 CALL HWHEW5(5,6,3,4,1,2,HELSUM,HELCTY,ID1,ID2)
21946 EVWGT=HELCTY*WEIGHT*BR/(BRZED(ID1)*BRZED(ID2))
21947 ENDIF
21948 ENDIF
21949 END
21950CDECK ID>, HWHGBP.
21951*CMZ :- -02/04/01 12.11.55 by Peter Richardson
21952*-- Author : Peter Richardson
21953C-----------------------------------------------------------------------
21954 SUBROUTINE HWHGBP
21955C-----------------------------------------------------------------------
21956C Hadron-Hadron to WW/WZ/ZZ (BASED ON ZOLTAN KUNSZT'S PROGRAM)
21957C-----------------------------------------------------------------------
c63d70bc 21958 INCLUDE 'herwig65.inc'
65767955 21959 DOUBLE COMPLEX ZH,ZCH,ZD
21960 DOUBLE PRECISION HWUAEM,HWRGEN,HWUPCM,FLUXW,CSW,XMASS,
21961 & PLAB,PRW,PCM,HWRUNI,P(5,10),AMPWW,DIST(4),MW2,CFAC1,AMP,
21962 & MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),FPI4
21963 INTEGER IB,IBOS,I,IDP,IDBOS,IPRC,NEWHEP,J,ICMF,IHEP,IBRAD,K,IOPT,
21964 & MAP(4),IDRES
21965 LOGICAL PHOTON,GEN
21966 EXTERNAL HWUAEM,HWRGEN,HWUPCM,HWRUNI
21967 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
21968 COMMON/HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
21969 COMMON /HWBOSN/XMASS(2),PLAB(5,10),PRW(5,2),PCM(5,10),IDBOS(2),
21970 & IDRES,IDP(10),IOPT
21971 SAVE AMPWW,IPRC,PHOTON
21972 PARAMETER(FPI4=24936.72731D0)
21973 DOUBLE PRECISION WI(IMAXCH)
21974 COMMON /HWPSOM/ WI
21975 SAVE MAP
21976 DATA MAP/1,2,11,12/
21977 IF (IERROR.NE.0) RETURN
21978 IF (GENEV) THEN
21979 IF (IPRC.EQ.0) THEN
21980 CALL HWHGB2(AMPWW,IDP,PHOTON)
21981 ELSEIF(IPRC.EQ.10) THEN
21982 CALL HWHGB3(AMPWW,IDP,PHOTON)
21983 ELSEIF(IPRC.EQ.20) THEN
21984 CALL HWHGB4(AMPWW,IDP,PHOTON)
21985 IF((IDP(1).LE.6.AND.MOD(IDP(1),2).EQ.1).OR.
21986 & (IDP(2).LE.6.AND.MOD(IDP(2),2).EQ.1)) THEN
21987 IDBOS(1)=199
21988 IDP(3) = IDP(3)+6
21989 IDP(4) = IDP(4)-6
21990 ENDIF
21991 ENDIF
21992C--change the sign of the z component (in CMF) if particle first
21993 IF(IDP(1).LT.IDP(2)) THEN
21994 DO IB=1,2
21995 PRW(3,IB) = -PRW(3,IB)
21996 DO I=1,2
21997 PLAB(3,2*IB+I)=-PLAB(3,2*IB+I)
21998 ENDDO
21999 ENDDO
22000 ENDIF
22001C--boost particles back to the lab frame from the centre of mass frame
22002 DO IB=1,2
22003 CALL HWULOB(PLAB(1,7),PRW(1,IB),PRW(1,IB))
22004 ENDDO
22005 DO I=1,6
22006 CALL HWULOB(PLAB(1,7),PLAB(1,I),PLAB(1,I))
22007 ENDDO
22008C--put the particles in the event record
22009C--first the incoming quarks
22010 ICMF = NHEP+3
22011 DO I=1,2
22012 IHEP = NHEP+I
22013 CALL HWVEQU(5,PLAB(1,I),PHEP(1,IHEP))
22014 IDHW(IHEP) = IDP(I)
22015 IDHEP(IHEP)=IDPDG(IDP(I))
22016 ISTHEP(IHEP)=110+I
22017 JMOHEP(1,IHEP)=ICMF
22018 JMOHEP(I,ICMF)=IHEP
22019 JDAHEP(1,IHEP)=ICMF
22020 ENDDO
22021 JMOHEP(2,NHEP+1) = NHEP+2
22022 JMOHEP(2,NHEP+2) = NHEP+1
22023 JDAHEP(2,NHEP+1) = NHEP+2
22024 JDAHEP(2,NHEP+2) = NHEP+1
22025C--Centre-of-mass energy
22026 ICMF = NHEP+3
22027C--new for spin correlations
22028 IF(SYSPIN) THEN
22029 IDSPN(1) = ICMF
22030 ISNHEP(ICMF) = 1
22031 JMOSPN(1) = 0
22032 JDASPN(1,1) = 2
22033 JDASPN(2,1) = 5
22034 DECSPN(1) = .FALSE.
22035 ENDIF
22036 IDHW(ICMF)=15
22037 IDHEP(ICMF)=IDPDG(15)
22038 ISTHEP(ICMF)=110
22039 CALL HWVEQU(5,PLAB(1,7),PHEP(1,ICMF))
22040 CALL HWUMAS(PHEP(1,ICMF))
22041 JDAHEP(1,ICMF) = ICMF+1
22042 JDAHEP(2,ICMF) = ICMF+2
22043 NHEP = NHEP+3
22044 NEWHEP = NHEP
22045 NHEP = NHEP+2
22046C--Now the bosons
22047 DO IB=1,2
22048 IBOS=IB+NEWHEP
22049 CALL HWVEQU(5,PRW(1,IB),PHEP(1,IBOS))
22050 CALL HWVZRO(4,VHEP(1,IBOS))
22051 CALL HWUDKL(IDBOS(IB),PHEP(1,IBOS),DIST)
22052 CALL HWVSUM(4,VHEP(1,IBOS),DIST,DIST)
22053 IDHW(IBOS)=IDBOS(IB)
22054 IDHEP(IBOS)=IDPDG(IDBOS(IB))
22055 JMOHEP(1,IBOS)=ICMF
22056 JMOHEP(2,IBOS)=ICMF
22057 JDAHEP(2,IBOS)=IBOS
22058 ISTHEP(IBOS)=112+IB
22059 ENDDO
22060C--now generate the initial state shower
22061 CALL HWBGEN
22062 IF(IERROR.NE.0) RETURN
22063C--now add the outgoing fermions to the event record
22064 DO 20 IB=1,2
22065 IBOS=IB+NEWHEP
22066 IBRAD = JDAHEP(1,IBOS)
22067 ISTHEP(IBRAD) = 195
22068 DO 10 I=1,2
22069 CALL HWVEQU(5,PLAB(1,2*IB+I),PHEP(1,NHEP+I))
22070 CALL HWVEQU(4,DIST,VHEP(1,NHEP+I))
22071C--Boost the fermion momenta to the rest frame of the original W
22072 CALL HWULOF(PRW(1,IB),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
22073C--Now boost back to the lab from rest frame of the W after radiation
22074 CALL HWULOB(PHEP(1,IBRAD),PHEP(1,NHEP+I),PHEP(1,NHEP+I))
22075C--Set the status and pointers
22076 ISTHEP(NHEP+I)=112+I
22077 IDHW(NHEP+I)=IDP(2*IB+I)
22078 IDHEP(NHEP+I)=IDPDG(IDP(2*IB+I))
22079 JDAHEP(I,IBRAD)=NHEP+I
22080 JMOHEP(1,NHEP+I)=IBRAD
22081C--New for spin correlations
22082 IF(SYSPIN) THEN
22083 ISNHEP(NHEP+I) = 2*IB+I-1
22084 IDSPN(2*IB+I-1) = NHEP+I
22085 JMOSPN(2*IB+I-1) = 1
22086 DECSPN(2*IB+I-1) = .FALSE.
22087 RHOSPN(1,1,2*IB+I-1) = HALF
22088 RHOSPN(1,2,2*IB+I-1) = ZERO
22089 RHOSPN(2,1,2*IB+I-1) = ZERO
22090 RHOSPN(2,2,2*IB+I-1) = HALF
22091 NSPN = NSPN+1
22092 ENDIF
22093 10 CONTINUE
22094 NHEP=NHEP+2
22095 JMOHEP(2,NHEP)=NHEP-1
22096 JDAHEP(2,NHEP)=NHEP-1
22097 JMOHEP(2,NHEP-1)=NHEP
22098 JDAHEP(2,NHEP-1)=NHEP
22099 20 CONTINUE
22100 ELSE
22101 IF(FSTWGT) THEN
22102 IPRC=MOD(IPROC,100)
22103 IF(MOD(IPRC,5).EQ.0.AND.MOD(IPRC,10).NE.0) THEN
22104 PHOTON = .FALSE.
22105 IPRC = IPRC-5
22106 ELSE
22107 PHOTON = .TRUE.
22108 ENDIF
22109 IOPT=1
22110 IF (IPRC.EQ.0) THEN
22111C--WW production
22112 IDBOS(1)=199
22113 IDBOS(2)=198
22114 IDRES =200
22115C--ZZ production
22116 ELSEIF (IPRC.EQ.10) THEN
22117 IDBOS(1)=200
22118 IDBOS(2)=200
22119 IDRES =200
22120 ELSEIF(IPRC.EQ.20) THEN
22121C--WZ production
22122 IDBOS(1)=198
22123 IDBOS(2)=200
22124 IDRES =198
22125 IOPT = 0
22126 ELSE
22127 CALL HWWARN('HWHGBP',500)
22128 ENDIF
22129C--calculate the couplings etc
22130 MW2 = RMASS(198)**2
22131 GMW = RMASS(198)*GAMW
22132 MZ2 = RMASS(200)**2
22133 GMZ = RMASS(200)*GAMZ
22134C--couplings to Z and photon
22135 DO I=1,4
22136 G(I,1) = VFCH(MAP(I),1)+AFCH(MAP(I),1)
22137 G(I,2) = VFCH(MAP(I),1)-AFCH(MAP(I),1)
22138 EE(I) = QFCH(MAP(I))
22139 ENDDO
22140C--elements of the CKM matrix for the various decay modes of the W
22141 DO I=1,3
22142 DO J=1,3
22143C**Bug fix 2/7/01 by BRW (unsquare)
22144 CKM2(3*I-3+J) = VCKM(J,I)
22145C**End bug fix
22146 ENDDO
22147 CKM2(9+I) = ONE
22148 ENDDO
22149C--couplings of the up and down
22150 TAUI(1) = -ONE
22151 TAUI(2) = ONE
22152 DO I=1,2
22153 RF(I) = -TWO*QFCH(I)*SWEIN
22154 LF(I) = TAUI(I)+RF(I)
22155 ENDDO
22156 CFAC1 = ONE/THREE
22157 CSW = SQRT((ONE-SWEIN)/SWEIN)
22158 ENDIF
22159 EVWGT=ZERO
22160C--find the momenta and the phase space weight
22161 CALL HWHGBS(FLUXW,GEN)
22162 IF(.NOT.GEN) RETURN
22163C--couplings
22164 AMP = FPI4*HWUAEM(EMSCA**2)**4
22165C--copy the momenta and change the sign of the beam
22166 DO I=1,6
22167 P(1,I)=PLAB(3,I)
22168 P(2,I)=PLAB(1,I)
22169 P(3,I)=PLAB(2,I)
22170 P(4,I)=PLAB(4,I)
22171 ENDDO
22172 DO 120 J=1,4
22173 DO 130 K=3,6
22174 130 PCM(J,K)=P(J,K)
22175 PCM(J,1)=-P(J,1)
22176 PCM(J,2)=-P(J,2)
22177 120 CONTINUE
22178C--use the e+e- code to calulate the spinor products
22179 CALL HWHEW2(6,PCM(1,1),ZH,ZCH,ZD)
22180C--calculate the matrix elements
22181 IF (IPRC.EQ.0) THEN
22182C--WW matrix element
22183 CALL HWHGB2(AMPWW,IDP,PHOTON)
22184 ELSEIF(IPRC.EQ.10) THEN
22185C--ZZ matrix element
22186 CALL HWHGB3(AMPWW,IDP,PHOTON)
22187 ELSEIF(IPRC.EQ.20) THEN
22188C--WZ matrix element
22189 CALL HWHGB4(AMPWW,IDP,PHOTON)
22190 ENDIF
22191C--Now calculate the cross section
22192 EVWGT = AMPWW*FLUXW*AMP
22193 IF(OPTM) THEN
22194 DO I=1,IMAXCH
22195 IF(CHON(I)) WI(I) = WI(I)*AMPWW**2*AMP**2
22196 ENDDO
22197 ENDIF
22198 ENDIF
22199 END
22200CDECK ID>, HWHGBS.
22201*CMZ :- -02/04/01 12.11.55 by Peter Richardson
22202*-- Author : Peter Richardson
22203C-----------------------------------------------------------------------
22204 SUBROUTINE HWHGBS(WEIGHT,GEN)
22205C-----------------------------------------------------------------------
22206C Multichannel phase space for gauge boson pair production
22207C ICH returns the channel used if OPTM=.FALSE.
22208C ICH specifies the channel to be used if OPTM=.TRUE.
22209C This is used in optimising the weights for the different channels
22210C-----------------------------------------------------------------------
c63d70bc 22211 INCLUDE 'herwig65.inc'
65767955 22212 INTEGER ICH,IDBOS,ISM(2,IMAXCH),I,J,IB(2),IDRES,IDP,IOPT,IPRC,ID1
22213 DOUBLE PRECISION XMASS,PLAB,PRW,PCM,RAND,HWRGEN,BMS2(2),TJAC,PLM,
22214 & MJAC(2),TWOPI2,SJAC,STOT,THAT,UHAT,TMIN,TMAX,UMIN,UMAX,PS(2),
22215 & ETOT,HWUPCM,PST,HWRUNI,TAU,XJAC,PHI,SINTH,SIG(2),CV,CA,BR(2),
22216 & G(IMAXCH),XF,DEM,TN,UN,SN,S1,S2,MB1,MB2,WEIGHT,BRFAC,BRZ(12)
22217 LOGICAL HWRLOG,GEN
22218 COMMON /HWBOSN/ XMASS(2),PLAB(5,10),PRW(5,2),PCM(5,10),IDBOS(2),
22219 & IDRES,IDP(10),IOPT
22220 EXTERNAL HWRGEN,HWRLOG,HWUPCM,HWRUNI
22221 SAVE ISM,IPRC
22222 PARAMETER(TWOPI2=39.4784176D0)
22223 DOUBLE PRECISION WI(IMAXCH)
22224 COMMON /HWPSOM/ WI
22225 SAVE SIG,BRZ
22226 DATA SIG/1.0D0,-1.0D0/
22227 DATA BRZ/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
22228 & 0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
22229 IF(IERROR.NE.0) RETURN
22230 WEIGHT = ZERO
22231 IF(OPTM) THEN
22232 DO I=1,IMAXCH
22233 WI(I) = ZERO
22234 ENDDO
22235 ENDIF
22236 GEN = .FALSE.
22237C--set the smoothing for the bosons in the various channels
22238 IF(FSTWGT) THEN
22239 IPRC = MOD(IPROC,100)
22240 DO I=1,2
22241 ISM(1,I) = 1
22242 DO J=1,2
22243 ISM(1,4*I-2+J ) = 1
22244 ISM(1,4*I+J ) = 2
22245 ISM(2,4*I+2*J-3) = 1
22246 ISM(2,4*I+2*J-2) = 2
22247 ENDDO
22248 ENDDO
22249 ISM(2,1) = 1
22250 ISM(2,2) = 2
22251 ENDIF
22252C--select the channel to be used
22253 RAND=HWRGEN(0)
22254 DO ICH=1,IMAXCH
22255 IF(CHON(ICH)) THEN
22256 IF(CHNPRB(ICH).GT.RAND) GOTO 10
22257 RAND = RAND-CHNPRB(ICH)
22258 ENDIF
22259 ENDDO
22260 10 CONTINUE
22261C--select the boson masses and compute that part of the denominator
22262C--decide which boson to do first
22263 IF(HWRLOG(HALF)) THEN
22264 IB(1) = 1
22265 IB(2) = 2
22266 ELSE
22267 IB(1) = 2
22268 IB(2) = 1
22269 ENDIF
22270C--find the boson masses
22271 CALL HWHGB1(ISM(IB(1),ICH),2,IDBOS(IB(1)),MJAC(IB(1)),BMS2(IB(1)),
22272 & (PHEP(5,3)-EMMIN)**2,EMMIN**2)
22273 XMASS(IB(1)) = SQRT(BMS2(IB(1)))
22274 CALL HWHGB1(ISM(IB(2),ICH),2,IDBOS(IB(2)),MJAC(IB(2)),BMS2(IB(2)),
22275 & (PHEP(5,3)-XMASS(IB(1)))**2,EMMIN**2)
22276 XMASS(IB(2)) = SQRT(BMS2(IB(2)))
22277 DO I=1,2
22278 MJAC(I) = HALF*MJAC(I)/TWOPI2
22279 ENDDO
22280C--now generate the values of s
22281C--according to a Breit-Wigner for the first two
22282 IF(ICH.LE.2) THEN
22283 CALL HWHGB1(1,2,IDRES,SJAC,STOT,PHEP(5,3)**2,
22284 & (SQRT(BMS2(1)+PTMIN**2)+SQRT(BMS2(2)+PTMIN**2))**2)
22285C--according to a power law for the rest
22286 ELSE
22287 CALL HWHGB1(2,2,IDRES,SJAC,STOT,PHEP(5,3)**2,
22288 & (SQRT(BMS2(1)+PTMIN**2)+SQRT(BMS2(2)+PTMIN**2))**2)
22289 ENDIF
22290 ETOT = SQRT(STOT)
22291C--find the centre of mass momenta
22292 PST = HWUPCM(ETOT,XMASS(1),XMASS(2))
22293 IF(PST.LT.PTMIN) RETURN
22294 PRW(4,1) = SQRT(BMS2(1)+PST**2)
22295 PRW(4,2) = SQRT(BMS2(2)+PST**2)
22296C--now generate the value of t and u
22297 PLM = SQRT(PST**2-PTMIN**2)
22298 TMIN = BMS2(1)-ETOT*(PRW(4,1)+PLM)
22299 TMAX = BMS2(1)-ETOT*(PRW(4,1)-PLM)
22300 UMIN = BMS2(2)-ETOT*(PRW(4,2)+PLM)
22301 UMAX = BMS2(2)-ETOT*(PRW(4,2)-PLM)
22302 SN = ONE/(TMAX-TMIN)
22303C--for the first two channels uniform in t
22304 IF(ICH.LE.2) THEN
22305 THAT = HWRUNI(1,TMIN,TMAX)
22306 UHAT = BMS2(1)+BMS2(2)-STOT-THAT
22307 TJAC = TMAX-TMIN
22308C--for the next four channels generate t according to 1/t
22309 ELSEIF(ICH.LE.6) THEN
22310 CALL HWHGB5(2,TJAC,THAT,TMAX,TMIN)
22311 UHAT = BMS2(1)+BMS2(2)-STOT-THAT
22312C--for the last four channels generate u according to 1/u
22313 ELSEIF(ICH.LE.10) THEN
22314 CALL HWHGB5(2,TJAC,UHAT,UMAX,UMIN)
22315 THAT = BMS2(1)+BMS2(2)-STOT-UHAT
22316 ELSE
22317 CALL HWWARN('HWHGBS',500)
22318 ENDIF
22319 CALL HWHGB5(1,TN,THAT,TMAX,TMIN)
22320 CALL HWHGB5(1,UN,UHAT,UMAX,UMIN)
22321C--generate the parton momentum fractions and find the pdf's
22322 TAU = STOT/PHEP(5,3)**2
22323 XX(1) = EXP(HWRUNI(3,LOG(TAU),ZERO))
22324 XX(2) = TAU/XX(1)
22325 XJAC = -LOG(TAU)*XX(1)
22326 XF = ONE/XJAC
22327 EMSCA=ETOT
22328 CALL HWSGEN(.FALSE.)
22329C--Centre of mass collison angle
22330 COSTH = (THAT-BMS2(1)+ETOT*PRW(4,1))/ETOT/PST
22331 PHI = HWRUNI(4,ZERO,TWO*PIFAC)
22332 SINTH = SQRT(ONE-COSTH**2)
22333C--incoming momenta in the centre of mass frame
22334 DO I=1,2
22335 PLAB(1,I) = ZERO
22336 PLAB(2,I) = ZERO
22337 PLAB(3,I) = HALF*ETOT
22338 PLAB(4,I) = HALF*ETOT
22339 PLAB(5,I) = ZERO
22340 ENDDO
22341 PLAB(3,2) = -PLAB(3,2)
22342C--outgoing boson momenta in the centre of mass frame
22343 DO I=1,2
22344 PRW(1,I) = SIG(I)*SINTH*COS(PHI)*PST
22345 PRW(2,I) = SIG(I)*SINTH*SIN(PHI)*PST
22346 PRW(3,I) = SIG(I)*COSTH*PST
22347 PRW(5,I) = XMASS(I)
22348 ENDDO
22349C--now find the boson decay products
22350C--find the momenta of the boson decay products
22351 IF(IPRC.EQ.20) IDBOS(1)=198
22352 DO 90 I=1,2
22353 CALL HWDBZ2(IDBOS(I),IDP(2*I+1),IDP(2*I+2),CV,CA,BR(I),IOPT,
22354 & XMASS(I))
22355 IF(BR(I).EQ.ZERO) RETURN
22356 PRW(5,I)=XMASS(I)
22357 PLAB(5,2*I+1) = ZERO
22358 PLAB(5,2*I+2) = ZERO
22359 PS(I) = HALF*XMASS(I)
22360 PLAB(5,2*I+1)=ZERO
22361 PLAB(5,2*I+2)=ZERO
22362 CALL HWDTWO(PRW(1,I),PLAB(1,2*I+1),PLAB(1,2*I+2),
22363 & PS(I),TWO,.TRUE.)
22364 90 CONTINUE
22365 BRFAC = BR(2)
22366 IF(IOPT.EQ.0) BRFAC = BRFAC*BR(1)
22367 DO I=1,2
22368 IF(IDBOS(I).EQ.200) THEN
22369 ID1 = IDP(1+2*I)
22370 IF(ID1.GE.121) ID1 = ID1-114
22371 BRFAC = BRFAC/BRZ(ID1)
22372 ENDIF
22373 ENDDO
22374 DO I=1,2
22375 MJAC(I) = MJAC(I)*PS(I)/XMASS(I)
22376 ENDDO
22377C--set up a vector with the centre of mass
22378 PLAB(1,7) = ZERO
22379 PLAB(2,7) = ZERO
22380 PLAB(3,7) = HALF*PHEP(5,3)*(XX(1)-XX(2))
22381 PLAB(4,7) = HALF*PHEP(5,3)*(XX(1)+XX(2))
22382 PLAB(5,7) = ETOT
22383C--now find the denominator
22384 CALL HWHGB1(1,1,IDRES,S1,STOT,PHEP(5,3)**2,
22385 & (XMASS(1)+XMASS(2))**2)
22386 CALL HWHGB1(2,1,IDRES,S2,STOT,PHEP(5,3)**2,
22387 & (XMASS(1)+XMASS(2))**2)
22388 DEM = ZERO
22389 DO I=1,IMAXCH
22390 IF(CHON(I)) THEN
22391C--factors due to the choice of s and t
22392 IF(I.LE.2) THEN
22393 G(I) = SN*S1
22394 ELSEIF(I.LE.6) THEN
22395 G(I) = TN*S2
22396 ELSE
22397 G(I) = UN*S2
22398 ENDIF
22399C--factors due to the boson masses
22400 CALL HWHGB1(ISM(IB(1),I),1,IDBOS(IB(1)),MB1,BMS2(IB(1)),
22401 & (PHEP(5,3)-EMMIN)**2,EMMIN**2)
22402 CALL HWHGB1(ISM(IB(2),I),1,IDBOS(IB(2)),MB2,BMS2(IB(2)),
22403 & (PHEP(5,3)-XMASS(IB(1)))**2,EMMIN**2)
22404 G(I) = G(I)*MB1*MB2*XF
22405 DEM = DEM+CHNPRB(I)*G(I)
22406 ENDIF
22407 ENDDO
22408C--now combine everything to get the weight
22409 WEIGHT = GEV2NB*TJAC*SJAC*G(ICH)/DEM/XX(1)*
22410 & MJAC(1)*MJAC(2)*XJAC/64.0D0/PIFAC/STOT**3*BRFAC
22411 GEN = .TRUE.
22412C--compute the weights for the different channels if optimizing
22413 IF(OPTM) THEN
22414 DO I=1,IMAXCH
22415 IF(CHON(I)) WI(I)=G(I)*WEIGHT**2/DEM
22416 ENDDO
22417 ENDIF
22418 END
22419CDECK ID>, HWHGB1.
22420*CMZ :- -02/04/01 12.11.55 by Peter Richardson
22421*-- Author : Peter Richardson
22422C-----------------------------------------------------------------------
22423 SUBROUTINE HWHGB1(ISM,IOPT,IDBOZ,FJAC,MBOS2,MMAX,MMIN)
22424C-----------------------------------------------------------------------
22425C Subroutine to select gauge boson mass for HWHGBP
22426C ISM=1 select according to Breit-Wigner for IDBOZ
22427C ISM=2 select according to power law for IDBOZ
22428C IOPT=1 return the function at MBOS2
22429C IOPT=2 calculate MBOS2
22430C-----------------------------------------------------------------------
c63d70bc 22431 INCLUDE 'herwig65.inc'
65767955 22432 INTEGER IDBOZ,ISM,IOPT
22433 DOUBLE PRECISION MBOZ,FJAC,GBOZ,GMBOZ,MPOW,MMIN,
22434 & MBOS2,A1,A2,A01,A02,RPOW,QPOW,HWRGEN,MMAX,EMSQ
22435 EXTERNAL HWRGEN
22436C--set the boson mass
22437 IF(IDBOZ.EQ.198.OR.IDBOZ.EQ.199) THEN
22438 MBOZ = RMASS(198)
22439 GBOZ = GAMW
22440 ELSEIF(IDBOZ.EQ.200) THEN
22441 MBOZ = RMASS(200)
22442 GBOZ = GAMZ
22443 ELSE
22444 CALL HWWARN('HWHGB1',500)
22445 ENDIF
22446 EMSQ=MBOZ**2
22447 GMBOZ=MBOZ*GBOZ
22448C--smooth a Breit-Wigner only
22449 IF(ISM.EQ.1) THEN
22450 A02 = ATAN((MMIN-EMSQ)/GMBOZ)
22451 A2 = ATAN((MMAX-EMSQ)/GMBOZ)-A02
22452 IF(IOPT.EQ.1) THEN
22453 FJAC = GMBOZ/((MBOS2-EMSQ)**2+GMBOZ**2)/A2
22454 ELSE
22455 MBOS2 = EMSQ+GMBOZ*TAN(A02+A2*HWRGEN(1))
22456 FJAC = A2*((MBOS2-EMSQ)**2+GMBOZ**2)/GMBOZ
22457 ENDIF
22458C--smooth a powerlaw only
22459 ELSEIF(ISM.EQ.2) THEN
22460 IF(EMPOW.EQ.TWO) THEN
22461 A01 = LOG(MMIN)
22462 A1 = LOG(MMAX)-A01
22463 IF(IOPT.EQ.1) THEN
22464 FJAC = ONE/MBOS2/A1
22465 ELSE
22466 MBOS2 = EXP(A01+A1*HWRGEN(2))
22467 FJAC = A1*MBOS2
22468 ENDIF
22469 ELSE
22470 MPOW = -EMPOW/TWO
22471 QPOW = ONE+MPOW
22472 RPOW = ONE/QPOW
22473 A01 = MMIN**QPOW
22474 A1 = (MMAX**QPOW-A01)
22475 IF(IOPT.EQ.1) THEN
22476 FJAC = QPOW*MBOS2**MPOW/A1
22477 ELSE
22478 MBOS2 = (A01+A1*HWRGEN(2))**RPOW
22479 FJAC = A1*RPOW/MBOS2**MPOW
22480 ENDIF
22481 ENDIF
22482 ELSE
22483 CALL HWWARN('HWHGB1',501)
22484 ENDIF
22485 END
22486CDECK ID>, HWHGB2.
22487*CMZ :- -02/04/01 12.11.55 by Peter Richardson
22488*-- Author : Peter Richardson
22489C-----------------------------------------------------------------------
22490 SUBROUTINE HWHGB2(HCS,IDP,PHOTON)
22491C-----------------------------------------------------------------------
22492C WW cross section in hadron hadron
22493C-----------------------------------------------------------------------
c63d70bc 22494 INCLUDE 'herwig65.inc'
65767955 22495 DOUBLE PRECISION HCS,RCS,HWRGEN,DIST(2),CFAC,WAMP(2),S34,S56,KWW2,
22496 & MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),
22497 & CSW,CFAC1
22498 DOUBLE COMPLEX ZH,ZCH,ZD,Z1,Z2,ZHF,P12,Z12,S134,S156,AWW,BWW,
22499 & CWW,DWW,AWWM(2),AWWP(2),HWHEW4
22500 INTEGER IDP(10),I,I1,I2,MAPZ(4,3),P1,P2,P3,P4
22501 PARAMETER(Z1=(0.0D0,1.0D0),Z2=(2.0D0,0.0D0),
22502 & ZHF=(0.5D0,0.0D0))
22503 LOGICAL PHOTON
22504 EXTERNAL HWRGEN,HWHEW4
22505 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
22506 COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
22507 SAVE WAMP,AWWM,AWWP
22508 SAVE MAPZ
22509 DATA MAPZ/1,2,121,122,3,4,123,125,5,6,124,126/
22510 IF(GENEV) THEN
22511 RCS = HCS*HWRGEN(1)
22512 ELSE
22513C--Now calculate the matrix element
22514 Z12 = ONE/(Z2*ZD(1,2)-MZ2+Z1*GMZ)
22515 P12 = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/ZD(1,2)
22516 S134 = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/(ZD(1,3)+ZD(1,4)+ZD(3,4))
22517 S156 = ZHF*(Z2*ZD(1,2)-MZ2)*Z12/(ZD(1,5)+ZD(1,6)+ZD(5,6))
22518 S34 = DBLE(Z2*ZD(3,4))
22519 S56 = DBLE(Z2*ZD(5,6))
22520 KWW2 = ONE/((S34-MW2)**2+GMW**2)/((S56-MW2)**2+GMW**2)
22521 & /SWEIN**4/16.0D0
22522 DO I=1,2
22523 DWW = LF(I)*Z12-RF(I)*P12
22524 CWW = RF(I)*(Z12-P12)
22525 AWW = DWW + ZHF*S134*(TAUI(I)+ONE)
22526 BWW = DWW + ZHF*S156*(TAUI(I)-ONE)
22527 AWWM(I) = AWW*HWHEW4(1,2,3,4,5,6)-BWW*HWHEW4(1,2,5,6,3,4)
22528 AWWP(I) = CWW*(HWHEW4(2,1,5,6,3,4)-HWHEW4(2,1,3,4,5,6))
22529 WAMP(I) = KWW2*DBLE( AWWM(I)*DCONJG(AWWM(I))
22530 & +AWWP(I)*DCONJG(AWWP(I)))
22531 ENDDO
22532 ENDIF
22533 HCS = ZERO
22534 CFAC = CFAC1*81.0D0
22535 DO I=1,2
22536 DO I1=1,3
22537 IDP(1) = MAPZ(I,I1)
22538 IDP(2) = IDP(1)+6
22539 DIST(1)=DISF(IDP(1),1)*DISF(IDP(2),2)
22540 DIST(2)=DISF(IDP(2),1)*DISF(IDP(1),2)
22541 DO I2=1,2
22542 HCS = HCS+DIST(I2)*CFAC*WAMP(I)
22543 IF(GENEV.AND.HCS.GT.RCS) THEN
22544C--new for spin correlations
22545 IF(SYSPIN) THEN
22546 NSPN = 1
22547 DO 10 P1=1,2
22548 DO 10 P2=1,2
22549 DO 10 P3=1,2
22550 DO 10 P4=1,2
22551 10 MESPN(P1,P2,P3,P4,1,1) = (0.0D0,0.0D0)
22552 MESPN(1,2,2,1,1,1) = AWWP(I)
22553 MESPN(2,2,2,1,1,1) = AWWM(I)
22554 NCFL(1) = 1
22555 SPNCFC(1,1,1) = ONE
22556 ENDIF
22557 GOTO 999
22558 ENDIF
22559 IDP(1) = IDP(1)+6
22560 IDP(2) = IDP(2)-6
22561 ENDDO
22562 ENDDO
22563 ENDDO
22564 999 RETURN
22565 END
22566CDECK ID>, HWHGB3.
22567*CMZ :- -02/04/01 12.11.55 by Peter Richardson
22568*-- Author : Peter Richardson
22569C-----------------------------------------------------------------------
22570 SUBROUTINE HWHGB3(HCS,IDP,PHOTON)
22571C-----------------------------------------------------------------------
22572C ZZ cross section in hadron hadron
22573C-----------------------------------------------------------------------
c63d70bc 22574 INCLUDE 'herwig65.inc'
65767955 22575 DOUBLE PRECISION AMP(2),RCS,HCS,HWRGEN,DIST(2),S34,S56,CFAC,
22576 & MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),TAUI(2),
22577 & CSW,CFAC1
22578 DOUBLE COMPLEX ZH,ZCH,ZD,P34,P56,Z34,Z56,Z1,ZAMP(8),S134,S156,
22579 & HWHEW4,TAMP,Z0,AMPT(2,2,2,2),CP
22580 INTEGER I,P1,P2,P3,IDP(10),I2,MAPZ(4,3),I1,ID(2),O(2)
22581 EXTERNAL HWHEW4,HWRGEN
22582 LOGICAL PHOTON
22583 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
22584 COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
22585 PARAMETER(Z0=(0.0D0,0.0D0),Z1=(0.0D0,1.0D0))
22586 SAVE AMP,ID,AMPT
22587 SAVE MAPZ,O
22588 DATA MAPZ/1,2,121,122,3,4,123,125,5,6,124,126/
22589 DATA O/2,1/
22590C--initialisation
22591 IF(GENEV) THEN
22592 RCS = HCS*HWRGEN(0)
22593 ELSE
22594C--Identitiys of the decay prodcucts (d=1,u=2,e=3,nu=4)
22595 DO I=1,2
22596 ID(I) = IDP(1+2*I)
22597 IF(ID(I).GE.121) ID(I) = ID(I)-114
22598 ID(I) = MOD(ID(I)+1,2)+2*INT((ID(I)-1)/6)+1
22599 ENDDO
22600C--the various propagators we need
22601 S34 = TWO*DBLE(ZD(3,4))
22602 S56 = TWO*DBLE(ZD(5,6))
22603 Z34 = ONE/(S34-MZ2+Z1*GMZ)
22604 Z56 = ONE/(S56-MZ2+Z1*GMZ)
22605 IF(PHOTON) THEN
22606 P34 = Z34*(S34-MZ2)/S34
22607 P56 = Z56*(S56-MZ2)/S56
22608 ELSE
22609 P34 = Z0
22610 P56 = Z0
22611 ENDIF
22612 S134 = HALF/(ZD(1,3)+ZD(1,4)+ZD(3,4))
22613 S156 = HALF/(ZD(1,5)+ZD(1,6)+ZD(5,6))
22614C--Now calculate the amplitudes
22615 ZAMP(1)=HWHEW4(1,2,3,4,5,6)*S134+HWHEW4(1,2,5,6,3,4)*S156
22616 ZAMP(2)=HWHEW4(1,2,4,3,5,6)*S134+HWHEW4(1,2,5,6,4,3)*S156
22617 ZAMP(3)=HWHEW4(1,2,3,4,6,5)*S134+HWHEW4(1,2,6,5,3,4)*S156
22618 ZAMP(4)=HWHEW4(1,2,4,3,6,5)*S134+HWHEW4(1,2,6,5,4,3)*S156
22619 ZAMP(5)=HWHEW4(2,1,3,4,5,6)*S156+HWHEW4(2,1,5,6,3,4)*S134
22620 ZAMP(6)=HWHEW4(2,1,4,3,5,6)*S156+HWHEW4(2,1,5,6,4,3)*S134
22621 ZAMP(7)=HWHEW4(2,1,3,4,6,5)*S156+HWHEW4(2,1,6,5,3,4)*S134
22622 ZAMP(8)=HWHEW4(2,1,4,3,6,5)*S156+HWHEW4(2,1,6,5,4,3)*S134
22623C--Now the amplitudes squared for the process
22624 DO I=1,2
22625 TAMP = Z0
22626 DO P1=1,2
22627 DO P2=1,2
22628 DO P3=1,2
22629 IF(PHOTON) THEN
22630 CP = G(I,P1)**2*G(ID(1),P2)*G(ID(2),P3)*Z34*Z56
22631 & +G(I,P1)*EE(I)*G(ID(1),P2)*EE(ID(2))*Z34*P56
22632 & +G(I,P1)*EE(I)*EE(ID(1))*G(ID(2),P3)*P34*Z56
22633 & +EE(I)**2*EE(ID(1))*EE(ID(2))*P34*P56
22634 ELSE
22635 CP = G(I,P1)**2*G(ID(1),P2)*G(ID(2),P3)*Z34*Z56
22636 ENDIF
22637 AMPT(I,P1,P2,P3) = ZAMP(4*P1+2*P3+P2-6)*CP
22638 TAMP = TAMP+AMPT(I,P1,P2,P3)*DCONJG(AMPT(I,P1,P2,P3))
22639 ENDDO
22640 ENDDO
22641 ENDDO
22642 AMP(I) = HALF*DBLE(TAMP)
22643 ENDDO
22644 ENDIF
22645C--Now calculate the cross section
22646 HCS = 0.0D0
22647 CFAC = CFAC1
22648 IF(ID(1).LE.2) CFAC = CFAC*THREE
22649 IF(ID(2).LE.2) CFAC = CFAC*THREE
22650 DO I=1,2
22651 DO I1=1,3
22652 IDP(1) = MAPZ(I,I1)
22653 IDP(2) = MAPZ(I,I1)+6
22654 DIST(1)=DISF(IDP(1),1)*DISF(IDP(2),2)
22655 DIST(2)=DISF(IDP(2),1)*DISF(IDP(1),2)
22656 DO I2=1,2
22657 HCS = HCS+CFAC*DIST(I2)*AMP(I)
22658 IF(GENEV.AND.HCS.GT.RCS) THEN
22659C--New for spin correlations
22660 IF(SYSPIN) THEN
22661 NSPN = 1
22662 DO 10 P1=1,2
22663 DO 10 P2=1,2
22664 DO 10 P3=1,2
22665 MESPN(P1,P2,P3,1,1,1) = AMPT(I,O(P1),O(P2),O(P3))
22666 10 MESPN(P1,P2,P3,2,1,1) = (0.0D0,0.0D0)
22667 NCFL(1) = 1
22668 SPNCFC(1,1,1) = ONE
22669 ENDIF
22670 GOTO 999
22671 ENDIF
22672 ENDDO
22673 IDP(1) = IDP(1)+6
22674 IDP(2) = IDP(2)-6
22675 ENDDO
22676 ENDDO
22677 999 RETURN
22678 END
22679CDECK ID>, HWHGB4.
22680*CMZ :- -02/04/01 12.11.55 by Peter Richardson
22681*-- Author : Peter Richardson
22682C-----------------------------------------------------------------------
22683 SUBROUTINE HWHGB4(HCS,IDP,PHOTON)
22684C-----------------------------------------------------------------------
22685C WZ cross section in hadron hadron
22686C-----------------------------------------------------------------------
c63d70bc 22687 INCLUDE 'herwig65.inc'
65767955 22688 DOUBLE PRECISION AMP(2),HCS,RCS,HWRGEN,W34,DIST(2),S34,S56,CFAC,
22689 & TCS,S12,MW2,MZ2,GMW,GMZ,G(4,2),EE(4),CKM2(12),RF(2),LF(2),
22690 & TAUI(2),CSW,CFAC1
22691 DOUBLE COMPLEX ZH,ZCH,ZD,P56,Z56,Z1,Z0,S134,S156,HWHEW4,
22692 & CP(4),W12,F(4),TAMP(2,2)
22693 INTEGER IDP(10),I,J,I1,I2,ID,P1,P2,P3,P4
22694 LOGICAL PHOTON
22695 EXTERNAL HWRGEN,HWHEW4
22696 COMMON/HWHEWQ/ZH(8,8),ZCH(8,8),ZD(8,8)
22697 COMMON /HWHGBC/ MW2,MZ2,GMW,GMZ,G,EE,CKM2,RF,LF,TAUI,CSW,CFAC1
22698 PARAMETER(Z0=(0.0D0,0.0D0),Z1=(0.0D0,1.0D0))
22699 SAVE AMP,ID,TAMP
22700 IF(GENEV) THEN
22701 RCS = HCS*HWRGEN(1)
22702 ELSE
22703C--identity of the Z decay product (d=1,u=2,e=3,nu=4)
22704 ID = IDP(5)
22705 IF(ID.GE.121) ID = ID-114
22706 ID = MOD(ID+1,2)+2*INT((ID-1)/6)+1
22707C--the various propagators we need
22708 S12 = TWO*DBLE(ZD(1,2))
22709 S34 = TWO*DBLE(ZD(3,4))
22710 S56 = TWO*DBLE(ZD(5,6))
22711 Z56 = ONE/(S56-MZ2+Z1*GMZ)
22712 IF(PHOTON) THEN
22713 P56 = Z56*(S56-MZ2)/S56
22714 ELSE
22715 P56 = Z0
22716 ENDIF
22717 W12 = ONE/(S12-MW2+Z1*GMW)
22718 S134 = HALF*W12*(S12-MW2)/(ZD(1,3)+ZD(1,4)+ZD(3,4))
22719 S156 = HALF*W12*(S12-MW2)/(ZD(1,5)+ZD(1,6)+ZD(5,6))
22720 W34 = ONE/((S34-MW2)**2+GMW**2)/SWEIN**2/FOUR
22721C--calculate the coefficents of the various amplitudes
22722 F(1) = HWHEW4(1,2,3,4,5,6)
22723 F(2) = HWHEW4(1,2,5,6,3,4)
22724 F(3) = HWHEW4(1,2,3,4,6,5)
22725 F(4) = HWHEW4(1,2,6,5,3,4)
22726 DO I=1,2
22727 IF(I.EQ.1) THEN
22728 J=2
22729 ELSE
22730 J=1
22731 ENDIF
22732 CP(1) = G(J,1)*S134-TAUI(I)*CSW*W12
22733 CP(2) = G(I,1)*S156+TAUI(I)*CSW*W12
22734 IF(PHOTON) THEN
22735 CP(3) = EE(J)*S134-TAUI(I)*W12
22736 CP(4) = EE(I)*S156+TAUI(I)*W12
22737 ELSE
22738 CP(3) = Z0
22739 CP(4) = Z0
22740 ENDIF
22741 TAMP(I,1) = F(1)*(G(ID,1)*Z56*CP(1)+EE(ID)*P56*CP(3))
22742 & +F(2)*(G(ID,1)*Z56*CP(2)+EE(ID)*P56*CP(4))
22743 TAMP(I,2) = F(3)*(G(ID,2)*Z56*CP(1)+EE(ID)*P56*CP(3))
22744 & +F(4)*(G(ID,2)*Z56*CP(2)+EE(ID)*P56*CP(4))
22745 AMP(I) = W34*DBLE( TAMP(I,1)*DCONJG(TAMP(I,1))
22746 & +TAMP(I,2)*DCONJG(TAMP(I,2)))
22747 ENDDO
22748 ENDIF
22749C--Now calculate the cross section
22750 HCS = ZERO
22751 CFAC = CFAC1*9.0D0
22752 IF(ID.LE.2) CFAC = CFAC*THREE
22753 DO I=1,2
22754 DO I1=1,3
22755 IF(I.EQ.1) THEN
22756 IDP(1) = 2*I1+5
22757 ELSE
22758 IDP(1) = 2*I1+6
22759 ENDIF
22760 DO J=1,3
22761 IF(I.EQ.1) THEN
22762 IDP(2) = 2*J
22763C**Bug fix 2/7/01 by BRW (unsquare)
22764 TCS = VCKM(J,I1)
22765 ELSE
22766 IDP(2) = 2*J-1
22767 TCS = VCKM(I1,J)
22768C**End bug fix
22769 ENDIF
22770 DIST(1) = TCS*DISF(IDP(1),1)*DISF(IDP(2),2)
22771 DIST(2) = TCS*DISF(IDP(2),1)*DISF(IDP(1),2)
22772 DO I2=1,2
22773 HCS = HCS+CFAC*DIST(I2)*AMP(I)
22774 IF(GENEV.AND.HCS.GT.RCS) GOTO 900
22775 ENDDO
22776 ENDDO
22777 ENDDO
22778 ENDDO
22779 900 IF(GENEV.AND.I2.EQ.2) THEN
22780 I1 = IDP(1)
22781 IDP(1) = IDP(2)
22782 IDP(2) = I1
22783 ENDIF
22784 IF(SYSPIN.AND.GENEV) THEN
22785 NSPN = 1
22786 DO 10 P1=1,2
22787 DO 10 P2=1,2
22788 DO 10 P3=1,2
22789 DO 10 P4=1,2
22790 10 MESPN(P1,P2,P3,P4,1,1) = (0.0D0,0.0D0)
22791 MESPN(2 ,2 ,1 ,1 ,1,1) = TAMP(I,2)
22792 MESPN(2 ,2 ,2 ,1 ,1,1) = TAMP(I,1)
22793 NCFL(1) = 1
22794 SPNCFC(1,1,1) = ONE
22795 ENDIF
22796 END
22797CDECK ID>, HWHGB5.
22798*CMZ :- -02/04/01 12.11.55 by Peter Richardson
22799*-- Author : Peter Richardson
22800C-----------------------------------------------------------------------
22801 SUBROUTINE HWHGB5(IOPT,FJAC,T,TMAX,TMIN)
22802C-----------------------------------------------------------------------
22803C Subroutine to select t or u for HWHGBP
22804C-----------------------------------------------------------------------
c63d70bc 22805 INCLUDE 'herwig65.inc'
65767955 22806 INTEGER IOPT
22807 DOUBLE PRECISION FJAC,TPOW,TMIN,T,A1,A01,RPOW,QPOW,HWRGEN,TMAX,TN,
22808 & TX,MT
22809 EXTERNAL HWRGEN
22810 TPOW = -1.0D0
22811 TX = -TMIN
22812 TN = -TMAX
22813 IF(TPOW.EQ.-ONE) THEN
22814 A1 = LOG(TX/TN)
22815 IF(IOPT.EQ.1) THEN
22816 FJAC =-ONE/T/A1
22817 ELSE
22818 T = -TN*EXP(A1*HWRGEN(2))
22819 FJAC =-A1*T
22820 ENDIF
22821 ELSE
22822 QPOW = ONE+TPOW
22823 RPOW = ONE/QPOW
22824 A01 = TN**QPOW
22825 A1 = (TX**QPOW-A01)
22826 IF(IOPT.EQ.1) THEN
22827 MT = -T
22828 FJAC =QPOW*MT**TPOW/A1
22829 ELSE
22830 MT = (A01+A1*HWRGEN(2))**RPOW
22831 T = -MT
22832 FJAC = A1*RPOW/MT**TPOW
22833 ENDIF
22834 ENDIF
22835 END
22836CDECK ID>, HWHGRV.
22837*CMZ :- -13/10/00 10:48:07 by Peter Richardson
22838*-- Author Kosuke Odagiri
22839C-----------------------------------------------------------------------
22840 SUBROUTINE HWHGRV
22841C-----------------------------------------------------------------------
22842C Massive spin-2 resonance (massive graviton)
22843C Universal tensor coupling to the energy-momentum tensor is assumed
22844C viz L = - G(mu,nu) T(mu,nu) / GRVLAM
22845C If GAMGRV is zero, it is revaluated during the first run
22846C MEAN EVWGT = SIGMA IN NB
22847C-----------------------------------------------------------------------
c63d70bc 22848 INCLUDE 'herwig65.inc'
65767955 22849 DOUBLE PRECISION HWRGEN,HWRUNI,EPS,EMSQG,
22850 & EMGMG,S,CC,SS,SS2,M1(16),M2(16),M3,M4,M5(3),M6(3),
22851 & RNGLU,FACT,HCS,FACTR,RCS,A2,A02,QPE,SQPE,RGRV
22852 INTEGER IMODE,JQMN,JQMX,JQ,JLMN,JLMX,JL,IQ,I,ID1,ID2,ID3,ID4,
22853 & IADD(2,2)
22854 LOGICAL JGLU,JPHO,JW,JZ,JH
22855 EXTERNAL HWRGEN,HWRUNI
22856 SAVE HCS,JQMN,JQMX,JLMN,JLMX,JGLU,JPHO,JW,JZ,JH,EMSQG,EMGMG,
22857 & A2,A02,FACT,RNGLU,M1,M2,M3,M4,M5,M6
22858 PARAMETER (EPS=1.D-9)
22859 SAVE IADD
22860 DATA IADD/0,6,6,0/
22861 IF (GENEV) THEN
22862 RCS=HCS*HWRGEN(0)
22863 ELSE
22864 IF (FSTWGT) THEN
22865C Set limits for which particles to include
22866 JLMN=1
22867 JLMX=0
22868 JQMN=1
22869 JQMX=0
22870 JGLU=.FALSE.
22871 JPHO=.FALSE.
22872 JW =.FALSE.
22873 JZ =.FALSE.
22874 JH =.FALSE.
22875 IMODE=MOD(IPROC,100)
22876 IF (IMODE.EQ.0) THEN
22877 JQMN=1
22878 JQMX=6
22879 JGLU=.TRUE.
22880 JLMN=11
22881 JLMX=16
22882 JPHO=.TRUE.
22883 JW =.TRUE.
22884 JZ =.TRUE.
22885 JH =.TRUE.
22886 ELSEIF (IMODE.EQ.10) THEN
22887 JQMN=1
22888 JQMX=6
22889 JGLU=.TRUE.
22890 ELSEIF (IMODE.GT.10.AND.IMODE.LE.16) THEN
22891 JQMN=IMODE-10
22892 JQMX=IMODE-10
22893 ELSEIF (IMODE.EQ.20) THEN
22894 JGLU=.TRUE.
22895 ELSEIF (IMODE.EQ.50) THEN
22896 JLMN=11
22897 JLMX=16
22898 JPHO=.TRUE.
22899 ELSEIF (IMODE.GT.50.AND.IMODE.LE.56) THEN
22900 JLMN=IMODE-40
22901 JLMX=IMODE-40
22902 ELSEIF (IMODE.EQ.60) THEN
22903 JPHO=.TRUE.
22904 ELSEIF (IMODE.EQ.70) THEN
22905 JW =.TRUE.
22906 JZ =.TRUE.
22907 JH =.TRUE.
22908 ELSEIF (IMODE.EQ.71) THEN
22909 JW =.TRUE.
22910 ELSEIF (IMODE.EQ.72) THEN
22911 JZ =.TRUE.
22912 ELSEIF (IMODE.EQ.73) THEN
22913 JH =.TRUE.
22914 ELSE
22915 CALL HWWARN('HWHGRV',500)
22916 ENDIF
22917 RNGLU=CAFAC**2-ONE
22918 IF (GAMGRV.EQ.ZERO) THEN
22919C Calculate the width if GAMGRV=ZERO.
22920C Quarks
22921 DO 10 JQ=1,6
22922 RGRV=(RMASS(JQ)/EMGRV)**2
22923 QPE=ONE-4.D0*RGRV
22924 IF (QPE.GT.ZERO) THEN
22925 SQPE=SQRT(QPE)
22926 GAMGRV=GAMGRV+CAFAC*SQPE**3*(ONE+8.D0/3.D0*RGRV)/4.D0
22927 END IF
22928 10 CONTINUE
22929C Leptons
22930 DO 20 JL=121,126
22931 RGRV=(RMASS(JL)/EMGRV)**2
22932 QPE=ONE-4.D0*RGRV
22933 IF (QPE.GT.ZERO) THEN
22934 SQPE=SQRT(QPE)
22935 GAMGRV=GAMGRV+SQPE**3*(ONE+8.D0/3.D0*RGRV)/4.D0
22936 END IF
22937 20 CONTINUE
22938C Photons
22939 GAMGRV=GAMGRV+HALF
22940C gg
22941 GAMGRV=GAMGRV+HALF*RNGLU
22942C ZZ
22943 RGRV=(RMASS(200)/EMGRV)**2
22944 QPE=ONE-4.D0*RGRV
22945 IF (QPE.GT.ZERO) THEN
22946 SQPE=SQRT(QPE)
22947 GAMGRV=GAMGRV+SQPE*
22948 & (13.D0/12.D0+14.D0/3.D0*RGRV+4.D0*RGRV**2)/TWO
22949 END IF
22950C WW
22951 RGRV=(RMASS(198)/EMGRV)**2
22952 QPE=ONE-4.D0*RGRV
22953 IF (QPE.GT.ZERO) THEN
22954 SQPE=SQRT(QPE)
22955 GAMGRV=GAMGRV+SQPE*
22956 & (13.D0/12.D0+14.D0/3.D0*RGRV+4.D0*RGRV**2)
22957 END IF
22958C HH
22959 RGRV=(RMASS(201)/EMGRV)**2
22960 QPE=ONE-4.D0*RGRV
22961 IF (QPE.GT.ZERO) THEN
22962 SQPE=SQRT(QPE)
22963 GAMGRV=GAMGRV+SQPE**5/12.D0/TWO
22964 END IF
22965 GAMGRV=GAMGRV*EMGRV**3/(GRVLAM**2*40.D0*PIFAC)
22966 END IF
22967 EMSQG=EMGRV**2
22968 EMGMG=EMGRV*GAMGRV
22969 A02=ATAN((EMMIN**2-EMSQG)/EMGMG)
22970 A2 =ATAN((EMMAX**2-EMSQG)/EMGMG)-A02
22971 ENDIF
22972 EVWGT=0.
22973C Select a mass for the produced pair
22974 S=EMSQG+EMGMG*TAN(A02+A2*HWRGEN(1))
22975 EMSCA=SQRT(S)
22976C Select initial momentum fractions
22977 XXMIN=S/PHEP(5,3)**2
22978 XLMIN=LOG(XXMIN)
22979 CALL HWSGEN(.TRUE.)
22980 COSTH=HWRUNI(0,-ONE,ONE)
22981C
22982 FACT=-GEV2NB*A2*XLMIN*S**2/(GRVLAM**4*EMGMG*16.D0*PIFAC)
22983 CC = COSTH**2
22984 SS = ONE-CC
22985 SS2= SS**2
22986C QQ,GG -> FF
22987 DO 110 I=1,6
22988 JQ=I
22989 JL=I+10
22990 QPE=ONE-4.D0*RMASS(JQ)**2/S
22991 IF (QPE.GT.ZERO) THEN
22992 SQPE=SQRT(QPE)
22993 M1(JQ)=SQPE*QPE*(ONE+CC-4.D0*QPE*SS*CC)/64.D0/CAFAC
22994 M2(JQ)=SQPE*QPE*SS*(TWO-QPE*SS)/16.D0/RNGLU
22995 ELSE
22996 M1(JQ)=ZERO
22997 M2(JQ)=ZERO
22998 END IF
22999 QPE=ONE-4.D0*RMASS(JL+110)**2/S
23000 IF (QPE.GT.ZERO) THEN
23001 SQPE=SQRT(QPE)
23002 M1(JL)=SQPE*QPE*(ONE+CC-4.D0*QPE*SS*CC)/64.D0/CAFAC
23003 M2(JL)=SQPE*QPE*SS*(TWO-QPE*SS)/16.D0/RNGLU
23004 ELSE
23005 M1(JL)=ZERO
23006 M2(JL)=ZERO
23007 END IF
23008 110 CONTINUE
23009C QQ,GG -> BB (massless)
23010 M3=SS*(ONE+CC)/32.D0/CAFAC
23011 M4=(CC+SS2/8.D0)/4.D0/RNGLU
23012C QQ,GG -> W,Z,H
23013 QPE=ONE-4.D0*RMASS(198)**2/S
23014 IF (QPE.GT.ZERO) THEN
23015 SQPE=SQRT(QPE)
23016 M5(1)=SQPE*(ONE-.5D0*QPE*(ONE+CC)+.75D0*QPE**2*CC*SS)/8.D0/CAFAC
23017 M6(1)=SQPE*(ONE-QPE*SS+3.D0*QPE**2*SS2/16.D0)/2.D0/RNGLU
23018 ELSE
23019 M5(1)=ZERO
23020 M6(1)=ZERO
23021 END IF
23022 QPE=ONE-4.D0*RMASS(200)**2/S
23023 IF (QPE.GT.ZERO) THEN
23024 SQPE=SQRT(QPE)
23025 M5(2)=SQPE*(ONE-.5D0*QPE*(ONE+CC)+.75D0*QPE**2*CC*SS)/16.D0/CAFAC
23026 M6(2)=SQPE*(ONE-QPE*SS+3.D0*QPE**2*SS2/16.D0)/4.D0/RNGLU
23027 ELSE
23028 M5(2)=ZERO
23029 M6(2)=ZERO
23030 END IF
23031 QPE=ONE-4.D0*RMASS(201)**2/S
23032 IF (QPE.GT.ZERO) THEN
23033 SQPE=SQRT(QPE)
23034 M5(3)=SQPE*(QPE**2*SS*CC)/64.D0/CAFAC
23035 M6(3)=SQPE*(QPE**2*SS2)/64.D0/RNGLU
23036 ELSE
23037 M5(3)=ZERO
23038 M6(3)=ZERO
23039 END IF
23040 END IF
23041 HCS=ZERO
23042 DO 90 I=1,2
23043C I=1 quark first, I=2 anti-quark first
23044 DO 80 IQ=1,6
23045 ID1=IQ+IADD(1,I)
23046 ID2=IQ+IADD(2,I)
23047 IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 80
23048 FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
23049C Quark final states
23050 DO 60 JQ=JQMN,JQMX
23051 ID3=JQ
23052 ID4=JQ+6
23053 HCS=HCS+FACTR*M1(JQ)*CAFAC
23054 IF (GENEV.AND.HCS.GT.RCS) THEN
23055 CALL HWHQCP(ID3,ID4,2143,50)
23056 GOTO 99
23057 ENDIF
23058 60 CONTINUE
23059C Lepton final states
23060 DO 70 JL=JLMN,JLMX
23061 ID3=110+JL
23062 ID4=ID3+6
23063 HCS=HCS+FACTR*M1(JL)
23064 IF (GENEV.AND.HCS.GT.RCS) THEN
23065 CALL HWHQCP(ID3,ID4,2134,50)
23066 GOTO 99
23067 ENDIF
23068 70 CONTINUE
23069C Bosonic final states
23070 IF (JPHO) THEN
23071 ID3=59
23072 ID4=59
23073 HCS=HCS+FACTR*M3
23074 IF (GENEV.AND.HCS.GT.RCS) THEN
23075 CALL HWHQCP(ID3,ID4,2134,50)
23076 GOTO 99
23077 ENDIF
23078 END IF
23079 IF (JW) THEN
23080 ID3=198
23081 ID4=199
23082 HCS=HCS+FACTR*M5(1)
23083 IF (GENEV.AND.HCS.GT.RCS) THEN
23084 CALL HWHQCP(ID3,ID4,2134,50)
23085 GOTO 99
23086 ENDIF
23087 END IF
23088 IF (JZ) THEN
23089 ID3=200
23090 ID4=200
23091 HCS=HCS+FACTR*M5(2)
23092 IF (GENEV.AND.HCS.GT.RCS) THEN
23093 CALL HWHQCP(ID3,ID4,2134,50)
23094 GOTO 99
23095 ENDIF
23096 END IF
23097 IF (JH) THEN
23098 ID3=201
23099 ID4=201
23100 HCS=HCS+FACTR*M5(3)
23101 IF (GENEV.AND.HCS.GT.RCS) THEN
23102 CALL HWHQCP(ID3,ID4,2134,50)
23103 GOTO 99
23104 ENDIF
23105 END IF
23106 IF (JGLU) THEN
23107 ID3=13
23108 ID4=13
23109 HCS=HCS+FACTR*M3*RNGLU
23110 IF (GENEV.AND.HCS.GT.RCS) THEN
23111 CALL HWHQCP(ID3,ID4,2143,50)
23112 GOTO 99
23113 ENDIF
23114 END IF
23115 80 CONTINUE
23116 90 CONTINUE
23117C Gluon initial states
23118 ID1=13
23119 ID2=13
23120 IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 30
23121 FACTR=FACT*DISF(ID1,1)*DISF(ID2,2)
23122C Quark final states
23123 DO 40 JQ=JQMN,JQMX
23124 ID3=JQ
23125 ID4=JQ+6
23126 HCS=HCS+FACTR*M2(JQ)*CAFAC
23127 IF (GENEV.AND.HCS.GT.RCS) THEN
23128 CALL HWHQCP(ID3,ID4,2143,51)
23129 GOTO 99
23130 ENDIF
23131 40 CONTINUE
23132C Lepton final states
23133 DO 50 JL=JLMN,JLMX
23134 ID3=110+JL
23135 ID4=ID3+6
23136 HCS=HCS+FACTR*M2(JL)
23137 IF (GENEV.AND.HCS.GT.RCS) THEN
23138 CALL HWHQCP(ID3,ID4,2134,51)
23139 GOTO 99
23140 ENDIF
23141 50 CONTINUE
23142C Vector boson final states
23143 IF (JPHO) THEN
23144 ID3=59
23145 ID4=59
23146 HCS=HCS+FACTR*M4
23147 IF (GENEV.AND.HCS.GT.RCS) THEN
23148 CALL HWHQCP(ID3,ID4,2134,51)
23149 GOTO 99
23150 ENDIF
23151 END IF
23152 IF (JW) THEN
23153 ID3=198
23154 ID4=199
23155 HCS=HCS+FACTR*M6(1)
23156 IF (GENEV.AND.HCS.GT.RCS) THEN
23157 CALL HWHQCP(ID3,ID4,2134,51)
23158 GOTO 99
23159 ENDIF
23160 END IF
23161 IF (JZ) THEN
23162 ID3=200
23163 ID4=200
23164 HCS=HCS+FACTR*M6(2)
23165 IF (GENEV.AND.HCS.GT.RCS) THEN
23166 CALL HWHQCP(ID3,ID4,2134,51)
23167 GOTO 99
23168 ENDIF
23169 END IF
23170 IF (JH) THEN
23171 ID3=201
23172 ID4=201
23173 HCS=HCS+FACTR*M6(3)
23174 IF (GENEV.AND.HCS.GT.RCS) THEN
23175 CALL HWHQCP(ID3,ID4,2134,51)
23176 GOTO 99
23177 ENDIF
23178 END IF
23179 IF (JGLU) THEN
23180 ID3=13
23181 ID4=13
23182 HCS=HCS+FACTR*M4*RNGLU
23183 IF (GENEV.AND.HCS.GT.RCS) THEN
23184 CALL HWHQCP(ID3,ID4,2143,51)
23185 GOTO 99
23186 ENDIF
23187 END IF
23188 30 CONTINUE
23189 EVWGT=HCS
23190 RETURN
23191C Generate event
23192 99 IDN(1)=ID1
23193 IDN(2)=ID2
23194 IDCMF=208
23195 CALL HWETWO(.TRUE.,.TRUE.)
23196 IF (AZSPIN) THEN
23197C Calculate coefficients for constructing spin density matrices
23198C Set to zero for now
23199 CALL HWVZRO(7,GCOEF)
23200 END IF
23201 END
23202CDECK ID>, HWHGUP.
23203*CMZ :- -16/07/02 09.40.25 by Peter Richardson
23204*-- Author : Peter Richardson
23205C----------------------------------------------------------------------
23206 SUBROUTINE HWHGUP
23207C----------------------------------------------------------------------
23208C Use the GUPI (Generic User Process Interface) event common block
23209C as the hard process for HERWIG
23210C----------------------------------------------------------------------
c63d70bc 23211 INCLUDE 'herwig65.inc'
65767955 23212C--Les Houches Common Block
23213 INTEGER MAXPUP
23214 PARAMETER(MAXPUP=100)
23215 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
23216 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
23217 COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
23218 & IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
23219 & XMAXUP(MAXPUP),LPRUP(MAXPUP)
23220 INTEGER MAXNUP
23221 PARAMETER (MAXNUP=500)
23222 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
23223 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
23224 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
23225 & IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
23226 & ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
23227 & SPINUP(MAXNUP)
23228C--Local variables
23229 COMMON /HWGUP/ILOC(NMXHEP),JLOC(MAXNUP)
23230 INTEGER ILOC,JLOC,JHEP,ID
23231 INTEGER IHEP,IDIN(2),I,IDRES(2,MAXPUP),IRES,ICMF,ISTART,JRES,J
23232 DOUBLE PRECISION PTEMP(5)
23233 CHARACTER *8 DUMMY
23234 LOGICAL HWRLOG
23235 EXTERNAL HWRLOG
23236 IRES = 0
23237C--zero the variables
23238 DO I=1,NUP
23239 JLOC(I) = 0
23240 ENDDO
23241 DO I=1,NMXHEP
23242 ILOC(I) = 0
23243 ENDDO
23244c---generate hard subprocess
23245C--now do the event selection bit
23246 IF(.NOT.GENEV) THEN
23247 IDPRUP = LPRUP(ITYPLH)
23248 CALL UPEVNT_GUP
23249 IF(ABS(IDWTUP).EQ.1.OR.ABS(IDWTUP).EQ.2.OR.
23250 & ABS(IDWTUP).EQ.4) THEN
23251 EVWGT = XWGTUP*1.0D-3
23252 ELSEIF(ABS(IDWTUP).EQ.3) THEN
23253 EVWGT = SIGN(ONE,XWGTUP)
23254 ELSE
23255 CALL HWWARN('HWHGUP',510)
23256 ENDIF
23257C--check the sign of the weight
23258 IF(IDWTUP.GT.ZERO.AND.EVWGT.LT.ZERO) CALL HWWARN('HWHGUP',520)
23259 RETURN
23260 ENDIF
23261C--update the number of events
23262 LHNEVT(ITYPLH) = LHNEVT(ITYPLH)+1
23263 ITYPLH = 0
23264C--first search to see if there are incoming beam particles in the record
23265 I = 0
23266 DO IHEP=1,NUP
23267 IF(ISTUP(IHEP).EQ.-9) THEN
23268 I=I+1
23269 IF(I.EQ.3) THEN
23270 CALL HWWARN('HWHGUP',102)
23271 GOTO 999
23272 ENDIF
23273 IDIN(I) = IHEP
23274 ENDIF
23275 ENDDO
23276C--put the beam particles in the record
23277C--require the soft event
23278 GENSOF = LHSOFT.AND.HWRLOG(PRSOF)
23279C--if given for event from event common block
23280 NHEP = 0
23281 IF(I.EQ.2) THEN
23282C--otherwise from the process common block
23283 ELSEIF(I.EQ.0) THEN
23284 DO I=1,2
23285 CALL HWUIDT(1,IDBMUP(I),IDHW(I),DUMMY)
23286 PHEP(1,I) = ZERO
23287 PHEP(2,I) = ZERO
23288 PHEP(4,I) = EBMUP(I)
23289 PHEP(5,I) = RMASS(IDHW(I))
23290 PHEP(3,I) = SQRT(EBMUP(I)**2-RMASS(IDHW(I))**2)
23291 ISTHEP(I) = 100+I
23292 ENDDO
23293 PHEP(3,2) = -PHEP(3,2)
23294 NHEP = NHEP+2
23295C--if not correct issue warning
23296 ELSE
23297 CALL HWWARN('HWHGUP',103)
23298 GOTO 999
23299 ENDIF
23300C--setup the centre-of-mass energy
23301 CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP),PHEP(1,NHEP+1))
23302 CALL HWUMAS(PHEP(1,NHEP+1))
23303 JMOHEP(1,NHEP+1) = NHEP-1
23304 JMOHEP(2,NHEP+1) = NHEP
23305 IDHW(3) = 14
23306 ISTHEP(3) = 103
23307 NHEP = NHEP+1
23308C--search for the incoming particles in collision
23309 I = 0
23310 DO IHEP=1,NUP
23311 IF(ISTUP(IHEP).EQ.-1) THEN
23312 I = I+1
23313 IF(I.EQ.3) THEN
23314 CALL HWWARN('HWHGUP',100)
23315 GOTO 999
23316 ENDIF
23317 IDIN(I) = IHEP
23318 ENDIF
23319 ENDDO
23320C--require two incoming particles
23321 IF(I.NE.2) THEN
23322 CALL HWWARN('HWHGUP',101)
23323 GOTO 999
23324 ENDIF
23325C--Now write these particles into the event record
23326 DO I=1,2
23327 IDHEP(NHEP+I) = IDUP(IDIN(I))
23328 ISTHEP(NHEP+I) = 110+I
23329 CALL HWUIDT(1,IDUP(IDIN(I)),IDHW(NHEP+I),DUMMY)
23330 CALL HWVEQU(5,PUP(1,IDIN(I)),PHEP(1,NHEP+I))
23331 JMOHEP(1,NHEP+I) = NHEP+3
23332 ILOC(NHEP+I) = IDIN(I)
23333 JLOC(I) = NHEP+I
23334C--special for pairtcles which are identical to the beam
23335 DO J=1,2
23336 IF(IDHEP(NHEP+I).EQ.IDHEP(J)) THEN
23337 JDAHEP(1,J) = NHEP+I
23338 JDAHEP(2,J) = NHEP+I
23339 ENDIF
23340 ENDDO
23341 ENDDO
23342 CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,NHEP+3))
23343 CALL HWUMAS(PHEP(1,NHEP+3))
23344C--add the hard entry
23345 IDHW(NHEP+3) = 15
23346 ISTHEP(NHEP+3) = 110
23347 JMOHEP(1,NHEP+3) = NHEP+1
23348 JMOHEP(2,NHEP+3) = NHEP+2
23349 JDAHEP(1,NHEP+3) = NHEP+4
23350 NHEP = NHEP+3
23351 ICMF = NHEP
23352C--now search for the outgoing particles and add them to the event record
23353 DO I=1,NUP
23354C--normal outgoing particles
23355 IF(ISTUP(I).EQ.1.AND.
23356 & (MOTHUP(1,I).EQ.IDIN(1).OR.MOTHUP(1,I).EQ.IDIN(2))) THEN
23357 NHEP = NHEP+1
23358 IDHEP(NHEP) = IDUP(I)
23359 CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
23360 CALL HWVEQU(5,PUP(1,I),PHEP(1,NHEP))
23361 JMOHEP(1,NHEP) = ICMF
23362 JMOHEP(2,NHEP) = 0
23363 JDAHEP(2,NHEP) = 0
23364 ILOC(NHEP) = I
23365 JLOC(I) = NHEP
23366C--resonances which must have mass preserved and resonances
23367C-- which don't have to have mass preserved
23368C--for the time being we won't disguish between these two options
23369 ELSEIF((ISTUP(I).EQ.2.OR.ISTUP(I).EQ.3).AND.
23370 & (MOTHUP(1,I).EQ.IDIN(1).OR.MOTHUP(1,I).EQ.IDIN(2))) THEN
23371 NHEP = NHEP+1
23372 IDHEP(NHEP) = IDUP(I)
23373 CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
23374 CALL HWVEQU(5,PUP(1,I),PHEP(1,NHEP))
23375 IRES = IRES+1
23376 IDRES(1,IRES) = NHEP
23377 IDRES(2,IRES) = I
23378 JMOHEP(1,NHEP) = ICMF
23379 JMOHEP(2,NHEP) = 0
23380 JDAHEP(2,NHEP) = 0
23381 ILOC(NHEP) = I
23382 JLOC(I) = NHEP
23383 ELSEIF(ISTUP(I).NE.-9.AND.ISTUP(I).NE.-1.AND.ISTUP(I).NE.1.AND.
23384 & ISTUP(I).NE.2.AND.ISTUP(I).NE.3) THEN
23385 CALL HWWARN('HWHGUP',500)
23386 ENDIF
23387 ENDDO
23388C--Modified 2/7/03 for 2->1 processes
23389 IF(ICMF+1.EQ.NHEP) THEN
23390 NHEP = NHEP-1
23391 IDHEP(NHEP) = IDHEP(NHEP+1)
23392 IDHEP(NHEP+1) = 0
23393 IDHW(NHEP) = IDHW(NHEP+1)
23394 IDHW(NHEP+1) = 0
23395 CALL HWVEQU(5,PHEP(1,NHEP+1),PHEP(1,NHEP))
23396 JMOHEP(1,NHEP+1) = 0
23397 JMOHEP(2,NHEP+1) = 0
23398 JDAHEP(1,NHEP+1) = 0
23399 JDAHEP(2,NHEP+1) = 0
23400 JDAHEP(1,NHEP ) = NHEP
23401 JDAHEP(2,NHEP ) = NHEP
23402 ILOC(NHEP) = ILOC(NHEP+1)
23403 ILOC(NHEP+1) = 0
23404 JLOC(ILOC(NHEP)) = NHEP
23405 JLOC(NHEP+1) = 0
23406 DO I=1,IRES
23407 IF(IDRES(1,IRES).EQ.NHEP+1) IDRES(1,IRES) = NHEP
23408 ENDDO
23409 ELSE
23410 JDAHEP(2,ICMF) = NHEP
23411C--setup the status codes
23412 ISTHEP(ICMF+1) = 113
23413 DO IHEP=ICMF+2,NHEP
23414 ISTHEP(IHEP) = 114
23415 ENDDO
23416 ENDIF
23417C--End mod
23418 ISTART = ICMF-3
23419 EMSCA = SCALUP
23420C--generate parton shower
23421 CALL HWBGUP(ISTART,ICMF)
23422C--now we need to sort out the resonances
23423 IF(IRES.EQ.0) RETURN
23424 JRES = 1
23425 35 ID = IDHEP(IDRES(1,JRES))
23426 36 IF(JDAHEP(1,IDRES(1,JRES)).NE.0.AND.
23427 & JDAHEP(1,IDRES(1,JRES)).NE.IDRES(1,JRES)) THEN
23428 IF(IDHEP(IDRES(1,JRES)).EQ.94) THEN
23429 DO IHEP=JDAHEP(1,IDRES(1,JRES)),JDAHEP(2,IDRES(1,JRES))
23430 IF(IDHEP(IHEP).EQ.ID) THEN
23431 IDRES(1,JRES) = IHEP
23432 GOTO 36
23433 ENDIF
23434 ENDDO
23435 ELSE
23436 IDRES(1,JRES) = JDAHEP(1,IDRES(1,JRES))
23437 ENDIF
23438 GOTO 36
23439 ENDIF
23440C--make a copy of this particle
23441 IHEP = IDRES(1,JRES)
23442 JMOHEP(1,NHEP+1) = JMOHEP(1,IDRES(1,JRES))
23443 JMOHEP(2,NHEP+1) = JMOHEP(2,IDRES(1,JRES))
23444 IDHEP(NHEP+1) = IDHEP(IDRES(1,JRES))
23445 IDHW(NHEP+1) = IDHW(IDRES(1,JRES))
23446 CALL HWVEQU(5,PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP+1))
23447 IDRES(1,JRES) = NHEP+1
23448 JLOC(IDRES(2,JRES)) = IDRES(1,JRES)
23449 ISTHEP(NHEP+1) = 155
23450 NHEP = NHEP+1
23451C Reset colour pointers (if set)
23452 JHEP=JMOHEP(2,IHEP)
23453 IF (JHEP.GT.0) THEN
23454 IF (JDAHEP(2,JHEP).EQ.IHEP) JDAHEP(2,JHEP)=NHEP
23455 IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
23456 & .AND.ABS(IDHEP(JHEP)).GT.1000000
23457 & .AND.JDAHEP(2,JHEP-1).EQ.IHEP) JDAHEP(2,JHEP-1) = NHEP
23458 ENDIF
23459 JHEP=JDAHEP(2,IHEP)
23460 IF (JHEP.GT.0) THEN
23461 IF (JMOHEP(2,JHEP).EQ.IHEP) JMOHEP(2,JHEP)=NHEP
23462 IF(.NOT.RPARTY.AND.ISTHEP(JHEP).EQ.155
23463 & .AND.ABS(IDHEP(JHEP)).GT.1000000
23464 & .AND.JMOHEP(2,JHEP-1).EQ.IHEP) JMOHEP(2,JHEP-1) = NHEP
23465 ENDIF
23466C Relabel original track
23467 IF (ISTHEP(IHEP).NE.120) ISTHEP(IHEP)=3
23468 JMOHEP(2,IHEP)=JMOHEP(1,IHEP)
23469 JDAHEP(1,IHEP)=NHEP
23470 JDAHEP(2,IHEP)=NHEP
23471C--look for all the particles which have this as a mother
23472C--now search for the outgoing particles and add them to the event record
23473 JDAHEP(1,NHEP) = NHEP+1
23474 ISTHEP(NHEP+1) = 113
23475 DO I=1,NUP
23476 IF(ISTUP(I).EQ.1.AND.MOTHUP(1,I).EQ.IDRES(2,JRES)) THEN
23477 NHEP = NHEP+1
23478 IDHEP(NHEP) = IDUP(I)
23479 CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
23480 CALL HWULOF(PUP(1,IDRES(2,JRES)),PUP(1,I),PHEP(1,NHEP))
23481 CALL HWULOB(PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP),PHEP(1,NHEP))
23482 JMOHEP(1,NHEP) = IDRES(1,JRES)
23483 JMOHEP(2,NHEP) = 0
23484 JDAHEP(2,NHEP) = 0
23485 ILOC(NHEP) = I
23486 JLOC(I) = NHEP
23487 ELSEIF((ISTUP(I).EQ.2.OR.ISTUP(I).EQ.3).AND.
23488 & MOTHUP(1,I).EQ.IDRES(2,JRES)) THEN
23489 NHEP = NHEP+1
23490 IDHEP(NHEP) = IDUP(I)
23491 CALL HWUIDT(1,IDUP(I),IDHW(NHEP),DUMMY)
23492 CALL HWULOF(PUP(1,IDRES(2,JRES)),PUP(1,I),PHEP(1,NHEP))
23493 CALL HWULOB(PHEP(1,IDRES(1,JRES)),PHEP(1,NHEP),PHEP(1,NHEP))
23494 IRES = IRES+1
23495 IDRES(1,IRES) = NHEP
23496 IDRES(2,IRES) = I
23497 JMOHEP(1,NHEP) = IDRES(1,JRES)
23498 JMOHEP(2,NHEP) = 0
23499 JDAHEP(2,NHEP) = 0
23500 ILOC(NHEP) = I
23501 JLOC(I) = NHEP
23502 ENDIF
23503 ENDDO
23504C--special for top decays to ensure b is second and W is first, this seems
23505C--to cause problems if the order is the other way around
23506 IF(ABS(IDHEP(IDRES(1,JRES))).EQ.6.AND.
23507 & NHEP-IDRES(1,JRES).EQ.2) THEN
23508 IF(ABS(IDHEP(NHEP-1)).EQ.5) THEN
23509C--swap momenta
23510 CALL HWVEQU(5,PHEP(1,NHEP),PTEMP)
23511 CALL HWVEQU(5,PHEP(1,NHEP-1),PHEP(1,NHEP))
23512 CALL HWVEQU(5,PTEMP,PHEP(1,NHEP-1))
23513C--swap id's
23514 J = IDHW(NHEP)
23515 IDHW(NHEP) = IDHW(NHEP-1)
23516 IDHW(NHEP-1) = J
23517 J = IDHEP(NHEP)
23518 IDHEP(NHEP) = IDHEP(NHEP-1)
23519 IDHEP(NHEP-1) = J
23520C--locations
23521 J = ILOC(NHEP)
23522 ILOC(NHEP) = ILOC(NHEP-1)
23523 ILOC(NHEP-1) = J
23524 JLOC(ILOC(NHEP-1)) = NHEP-1
23525 JLOC(ILOC(NHEP)) = NHEP
23526C--resonances
23527 DO I=1,IRES
23528 IF(IDRES(1,I).EQ.NHEP) IDRES(1,I) = NHEP-1
23529 ENDDO
23530 ENDIF
23531 ENDIF
23532 DO IHEP=IDRES(1,JRES)+2,NHEP
23533 ISTHEP(IHEP) = 114
23534 ENDDO
23535 JDAHEP(2,IDRES(1,JRES)) = NHEP
23536 ISTART = IDRES(1,JRES)
23537 EMSCA = PHEP(4,IDRES(1,JRES))
23538 CALL HWBGUP(ISTART,0)
23539 IF(JRES.NE.IRES) THEN
23540 JRES = JRES+1
23541 GOTO 35
23542 ENDIF
23543 999 RETURN
23544 END
23545CDECK ID>, HWHHVY.
23546*CMZ :- -18/05/99 14.55.44 by Kosuke Odagiri
23547*-- Author : Bryan Webber
23548C-----------------------------------------------------------------------
23549 SUBROUTINE HWHHVY
23550C-----------------------------------------------------------------------
23551C QCD HEAVY FLAVOUR PRODUCTION: MEAN EVWGT = SIGMA IN NB
23552C-----------------------------------------------------------------------
c63d70bc 23553 INCLUDE 'herwig65.inc'
65767955 23554 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,RCS,Z1,Z2,ET,EJ,
23555 & QM2,QPE,FACTR,S,T,U,ST,TU,US,TUS,UST,EN,RN,AF,ASTU,
23556 & AUST,CF,CN,CS,CSTU,CSUT,CTSU,CTUS,HCS,UT,SU,GT,DIST,KK,KK2,
23557 & YJ1INF,YJ1SUP,YJ2INF,YJ2SUP
23558 INTEGER IQ1,IQ2,ID1,ID2
23559 LOGICAL HQ1,HQ2
23560 EXTERNAL HWRGEN,HWRUNI,HWUALF
23561 SAVE HCS,ASTU,AUST,CSTU,CSUT,CTSU,CTUS,S,T,TU,U,US
23562 PARAMETER (EPS=1.D-9)
23563 IF (GENEV) THEN
23564 RCS=HCS*HWRGEN(0)
23565 ELSE
23566 EVWGT=0.
23567 CALL HWRPOW(ET,EJ)
23568 KK = ET/PHEP(5,3)
23569 KK2=KK**2
23570 IF (KK.GE.ONE) RETURN
23571 YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
23572 YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
23573 IF (YJ1INF.GE.YJ1SUP) RETURN
23574 Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
23575 YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
23576 YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
23577 IF (YJ2INF.GE.YJ2SUP) RETURN
23578 Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
23579 XX(1)=HALF*(Z1+Z2)*KK
23580 IF (XX(1).GE.ONE) RETURN
23581 XX(2)=XX(1)/(Z1*Z2)
23582 IF (XX(2).GE.ONE) RETURN
23583 S=XX(1)*XX(2)*PHEP(5,3)**2
23584 IQ1=MOD(IPROC,100)
23585 QM2=RMASS(IQ1)**2
23586 QPE=S-4.*QM2
23587 IF (QPE.LE.ZERO) RETURN
23588 COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE)
23589 IF (ABS(COSTH).GT.ONE) RETURN
23590C---REDEFINE S, T, U AS P1.P2, -P1.P3, -P1.P4
23591 S=HALF*S
23592 T=-HALF*(1.+Z2/Z1)*(HALF*ET)**2
23593 U=-S-T
23594C---SET EMSCA TO HEAVY HARD PROCESS SCALE
23595 EMSCA=SQRT(4.*S*T*U/(S*S+T*T+U*U))
23596 FACTR = GEV2NB*.125*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2
23597 & *(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
23598 CALL HWSGEN(.FALSE.)
23599C
23600 ST=S/T
23601 TU=T/U
23602 UT=U/T
23603 US=U/S
23604 SU=S/U
23605 TUS=US/ST
23606 UST=ST/TU
23607C
23608 EN=CAFAC
23609 RN=CFFAC/EN
23610 AF=FACTR*RN
23611 ASTU=AF*(1.-2.*UST+QM2/T)
23612 AUST=AF*(1.-2.*TUS+QM2/S)
23613 CF=FACTR/(2.*CFFAC)
23614 CN=1./(EN*EN)
23615C-----------------------------------------------------------------------
23616C---Heavy flavour colour decomposition modifications below (KO)
23617C-----------------------------------------------------------------------
23618 CS=(TU+UT-CN/TUS)*(HALF-TUS+QM2/S-QM2**2/U/T/TWO)
23619 CSTU=CF*CS/(ONE+TU**2)
23620 CSUT=CF*CS/(ONE+UT**2)
23621 CS=(SU+US-CN/UST)*(HALF-UST+QM2/T-QM2**2/U/S/TWO)
23622 CTSU=-FACTR*CS/(ONE+SU**2)
23623 CTUS=-FACTR*CS/(ONE+US**2)
23624C-----------------------------------------------------------------------
23625C CS=HALF/TU-QM2/T-HALF*(QM2/T)**2
23626C CSTU=CF*(CS- US**2-QM2/S - CN*(CS+QM2*QM2/(S*T)))
23627C CS=HALF*TU-QM2/U-HALF*(QM2/U)**2
23628C CSUT=CF*(CS-1./ST**2-QM2/S - CN*(CS+QM2*QM2/(S*U)))
23629C CS=HALF*US-QM2/S-HALF*(QM2/S)**2
23630C CTSU=-FACTR*(CS-1./TU**2-QM2/T - CN*(CS+QM2*QM2/(S*T)))
23631C CS=HALF/US-QM2/U-HALF*(QM2/U)**2
23632C CTUS=-FACTR*(CS- ST**2-QM2/T - CN*(CS+QM2*QM2/(T*U)))
23633C-----------------------------------------------------------------------
23634 ENDIF
23635C
23636 HCS=0.
23637 IQ2=IQ1+6
23638 DO 6 ID1=1,13
23639 IF (DISF(ID1,1).LT.EPS) GOTO 6
23640 HQ1=ID1.EQ.IQ1.OR.ID1.EQ.IQ2
23641 DO 5 ID2=1,13
23642 IF (DISF(ID2,2).LT.EPS) GOTO 5
23643 HQ2=ID2.EQ.IQ1.OR.ID2.EQ.IQ2
23644 DIST=DISF(ID1,1)*DISF(ID2,2)
23645 IF (HQ1.OR.HQ2) THEN
23646C---PROCESSES INVOLVING HEAVY CONSTITUENT
23647C N.B. NEGLECT CASE THAT BOTH ARE HEAVY
23648 IF (HQ1.AND.HQ2) GOTO 5
23649 IF (ID1.LT.7) THEN
23650C---QUARK FIRST
23651 IF (ID2.LT.7) THEN
23652 HCS=HCS+ASTU*DIST
23653 IF (GENEV.AND.HCS.GT.RCS) THEN
23654 CALL HWHQCP(ID1,ID2,3421, 3)
23655 GOTO 9
23656 ENDIF
23657 ELSEIF (ID2.NE.13) THEN
23658 HCS=HCS+ASTU*DIST
23659 IF (GENEV.AND.HCS.GT.RCS) THEN
23660 CALL HWHQCP(ID1,ID2,3142, 9)
23661 GOTO 9
23662 ENDIF
23663 ELSE
23664 HCS=HCS+CTSU*DIST
23665 IF (GENEV.AND.HCS.GT.RCS) THEN
23666 CALL HWHQCP(ID1,ID2,3142,10)
23667 GOTO 9
23668 ENDIF
23669 HCS=HCS+CTUS*DIST
23670 IF (GENEV.AND.HCS.GT.RCS) THEN
23671 CALL HWHQCP(ID1,ID2,3421,11)
23672 GOTO 9
23673 ENDIF
23674 ENDIF
23675 ELSEIF (ID1.NE.13) THEN
23676C---QBAR FIRST
23677 IF (ID2.LT.7) THEN
23678 HCS=HCS+ASTU*DIST
23679 IF (GENEV.AND.HCS.GT.RCS) THEN
23680 CALL HWHQCP(ID1,ID2,2413,17)
23681 GOTO 9
23682 ENDIF
23683 ELSEIF (ID2.NE.13) THEN
23684 HCS=HCS+ASTU*DIST
23685 IF (GENEV.AND.HCS.GT.RCS) THEN
23686 CALL HWHQCP(ID1,ID2,4312,20)
23687 GOTO 9
23688 ENDIF
23689 ELSE
23690 HCS=HCS+CTSU*DIST
23691 IF (GENEV.AND.HCS.GT.RCS) THEN
23692 CALL HWHQCP(ID1,ID2,2413,21)
23693 GOTO 9
23694 ENDIF
23695 HCS=HCS+CTUS*DIST
23696 IF (GENEV.AND.HCS.GT.RCS) THEN
23697 CALL HWHQCP(ID1,ID2,4312,22)
23698 GOTO 9
23699 ENDIF
23700 ENDIF
23701 ELSE
23702C---GLUON FIRST
23703 IF (ID2.LT.7) THEN
23704 HCS=HCS+CTSU*DIST
23705 IF (GENEV.AND.HCS.GT.RCS) THEN
23706 CALL HWHQCP(ID1,ID2,2413,23)
23707 GOTO 9
23708 ENDIF
23709 HCS=HCS+CTUS*DIST
23710 IF (GENEV.AND.HCS.GT.RCS) THEN
23711 CALL HWHQCP(ID1,ID2,3421,24)
23712 GOTO 9
23713 ENDIF
23714 ELSEIF (ID2.LT.13) THEN
23715 HCS=HCS+CTSU*DIST
23716 IF (GENEV.AND.HCS.GT.RCS) THEN
23717 CALL HWHQCP(ID1,ID2,3142,25)
23718 GOTO 9
23719 ENDIF
23720 HCS=HCS+CTUS*DIST
23721 IF (GENEV.AND.HCS.GT.RCS) THEN
23722 CALL HWHQCP(ID1,ID2,4312,26)
23723 GOTO 9
23724 ENDIF
23725 ENDIF
23726 ENDIF
23727 ELSEIF (ID2.NE.13.AND.ID2.EQ.ID1+6) THEN
23728C---LIGHT Q-QBAR ANNIHILATION
23729 HCS=HCS+AUST*DIST
23730 IF (GENEV.AND.HCS.GT.RCS) THEN
23731 CALL HWHQCP(IQ1,IQ2,2413, 4)
23732 GOTO 9
23733 ENDIF
23734 ELSEIF (ID1.NE.13.AND.ID1.EQ.ID2+6) THEN
23735C---LIGHT QBAR-Q ANNIHILATION
23736 HCS=HCS+AUST*DIST
23737 IF (GENEV.AND.HCS.GT.RCS) THEN
23738 CALL HWHQCP(IQ2,IQ1,3142,12)
23739 GOTO 9
23740 ENDIF
23741 ELSEIF (ID1.EQ.13.AND.ID2.EQ.13) THEN
23742C---GLUON FUSION
23743 HCS=HCS+CSTU*DIST
23744 IF (GENEV.AND.HCS.GT.RCS) THEN
23745 CALL HWHQCP(IQ1,IQ2,2413,27)
23746 GOTO 9
23747 ENDIF
23748 HCS=HCS+CSUT*DIST
23749 IF (GENEV.AND.HCS.GT.RCS) THEN
23750 CALL HWHQCP(IQ1,IQ2,4123,28)
23751 GOTO 9
23752 ENDIF
23753 ENDIF
23754 5 CONTINUE
23755 6 CONTINUE
23756 EVWGT=HCS
23757 RETURN
23758C---GENERATE EVENT
23759 9 IDN(1)=ID1
23760 IDN(2)=ID2
23761 IDCMF=15
23762 CALL HWETWO(.TRUE.,.TRUE.)
23763 IF (AZSPIN) THEN
23764C Calculate coefficients for constructing spin density matrices
23765 IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR.
23766 & IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN
23767C qqbar-->gg or qbarq-->gg
23768 UT=1./TU
23769 GCOEF(1)=UT+TU
23770 GCOEF(2)=-2.
23771 GCOEF(3)=0.
23772 GCOEF(4)=0.
23773 GCOEF(5)=GCOEF(1)
23774 GCOEF(6)=UT-TU
23775 GCOEF(7)=-GCOEF(6)
23776 ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
23777 & IHPRO.EQ.21.OR.IHPRO.EQ.22.OR.
23778 & IHPRO.EQ.23.OR.IHPRO.EQ.24.OR.
23779 & IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN
23780C qg-->qg or qbarg-->qbarg or gq-->gq or gqbar-->gqbar
23781 SU=1./US
23782 GCOEF(1)=-(SU+US)
23783 GCOEF(2)=0.
23784 GCOEF(3)=2.
23785 GCOEF(4)=0.
23786 GCOEF(5)=SU-US
23787 GCOEF(6)=GCOEF(1)
23788 GCOEF(7)=-GCOEF(5)
23789 ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN
23790C gg-->qqbar
23791 UT=1./TU
23792 GCOEF(1)=TU+UT
23793 GCOEF(2)=-2.
23794 GCOEF(3)=0.
23795 GCOEF(4)=0.
23796 GCOEF(5)=GCOEF(1)
23797 GCOEF(6)=TU-UT
23798 GCOEF(7)=-GCOEF(6)
23799 ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR.
23800 & IHPRO.EQ.31) THEN
23801C gg-->gg
23802 GT=S*S+T*T+U*U
23803 GCOEF(2)=2.*U*U*T*T
23804 GCOEF(3)=2.*S*S*U*U
23805 GCOEF(4)=2.*S*S*T*T
23806 GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4)
23807 GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2)
23808 GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3)
23809 GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4)
23810 ELSE
23811 CALL HWVZRO(7,GCOEF)
23812 ENDIF
23813 ENDIF
23814 END
23815CDECK ID>, HWHIBG.
23816*CMZ :- -26/11/00 17.21.55 by Bryan Webber
23817*-- Author : Kosuke Odagiri & Stefano Moretti
23818C-----------------------------------------------------------------------
23819C...Generate completely differential cross section (EVWGT) in the variables
23820C...X(I) with I=1,3 (see below) for the processes IPROC=3410,3420,3430,3450
23821C...as described in the HERWIG 6 documentation file.
23822C...It includes interface to PDFs and takes into account color connections
23823C...among partons.
23824C
23825C...First release: 6-AUG-1999 by Kosuke Odagiri
23826C...Last modified: 6-SEP-1999 by Stefano Moretti
23827C
23828C-----------------------------------------------------------------------
23829 SUBROUTINE HWHIBG
23830C-----------------------------------------------------------------------
23831C HIGGS + HEAVY QUARK (BOTTOM & TOP) PRODUCTION (2HDM)
23832C-----------------------------------------------------------------------
c63d70bc 23833 INCLUDE 'herwig65.inc'
65767955 23834 DOUBLE PRECISION HWRGEN, HWUALF, HWUAEM, EPS, HCS, RCS,
23835 & DIST, SM, DM, QPE, PF, SQPE, EMSC2, FACTR, S, T3, U4,
23836 & SN2TH, ME2(0:4), MW, XWEIN, PT2MIN, PT2, GQH(0:4), G1, RMMIN,
23837 & EMG, EMQ, EMH, EMG2, EMQ2, EMH2, EMHWT, ECM_MAX, X(3), XL(3),
23838 & XU(3), WEIGHT, ECM, SHAT, TAU, T, TL, TLMIN, TLMAX, TTMIN, TTMAX,
23839 & CTMP, PCM, PCM2, RCM, RCM2, FKLN
23840 INTEGER ID1, ID2, IH, IQ, I
23841 EXTERNAL HWRGEN, HWUALF, HWUAEM
23842 SAVE HCS,ME2,S,SHAT
23843 PARAMETER (EPS = 1.D-9)
23844 EQUIVALENCE (MW, RMASS(198))
23845 PARAMETER (EMG=0.,EMG2=0.)
23846C...generate event.
23847 IF (GENEV) THEN
23848 RCS = HCS*HWRGEN(0)
23849 ELSE
23850 HCS = ZERO
23851 EVWGT = ZERO
23852C...minimum transverse momentum.
23853 PTMIN = ZERO
23854 PT2MIN = PTMIN**2
23855C...accompanying quark.
23856 IQ=5
23857 IF(IHIGGS.GE.5)IQ=6
23858 EMQ=RMASS(IQ)
23859 EMQ2=EMQ*EMQ
23860C...on-shell Higgs.
23861 EMH=RMASS(201+IHIGGS)
23862 EMHWT=1.D0
23863 EMH2=EMH*EMH
23864 RMMIN=(EMQ+EMH)/2.
23865C...energy at hadron level.
23866 ECM_MAX=PBEAM1+PBEAM2
23867 S=ECM_MAX*ECM_MAX
23868C...phase space variables.
23869C...IF IQ=5 -> X(1)=(LOG(|T|)-LOG(|TMIN|))/(LOG(|TMAX|)-LOG(|TMIN|),
23870C...IF IQ=6 -> X(1)=COS(THETA_CM);
23871C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+EMH)**2-1./ECM_MAX**2),
23872C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
23873C...phase space borders.
23874 IF(IQ.EQ.5)XL(1)=0.
23875 IF(IQ.EQ.6)XL(1)=-1.
23876 XU(1)=1.
23877 XL(2)=0.
23878 XU(2)=1.
23879 XL(3)=0.
23880 XU(3)=1.
23881C...single phase space point.
23882 WEIGHT=1.
23883 DO I=1,3
23884 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
23885 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
23886 END DO
23887C...energy at parton level.
23888 ECM=SQRT(1./(X(2)*(1./(EMQ+EMH)**2-1./ECM_MAX**2)
23889 & +1./ECM_MAX**2))
23890 IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
23891 SHAT=ECM*ECM
23892 TAU=SHAT/S
23893C...momentum fractions X1 and X2.
23894 XX(1)=EXP(LOG(TAU)*(1.-X(3)))
23895 XX(2)=TAU/XX(1)
23896C...reconstruct polar angle.
23897 IF(IQ.EQ.5)THEN
23898 PCM2=((SHAT-EMQ2-EMG2)**2
23899 & -(2.*EMQ*EMG)**2)/(4.*SHAT)
23900 PCM=SQRT(PCM2)
23901 RCM2=((SHAT-EMQ2-EMH2)**2
23902 & -(2.*EMQ*EMH)**2)/(4.*SHAT)
23903 RCM=SQRT(RCM2)
23904 FKLN=SQRT((SHAT-(EMQ+EMG)**2)*(SHAT-(EMQ-EMG)**2))
23905 & *SQRT((SHAT-(EMQ+EMH)**2)*(SHAT-(EMQ-EMH)**2))
23906 TTMAX=EMG2+EMQ2-0.5D0/ECM/ECM
23907 & *((SHAT+EMG2-EMQ2)*(SHAT+EMQ2-EMH2)
23908 & -FKLN)
23909 TTMIN=EMG2+EMQ2-0.5D0/ECM/ECM
23910 & *((SHAT+EMG2-EMQ2)*(SHAT+EMQ2-EMH2)
23911 & +FKLN)
23912 TLMAX=LOG(ABS(TTMIN))
23913 TLMIN=LOG(ABS(TTMAX))
23914 TL=X(1)*(TLMAX-TLMIN)+TLMIN
23915 T=EXP(TL)
23916 CTMP=-T-EMG2-EMQ2
23917 & +2.*SQRT(PCM2+EMG2)*SQRT(RCM2+EMQ2)
23918 COSTH = CTMP/2./PCM/RCM
23919 ELSE IF(IQ.EQ.6)THEN
23920 COSTH = X(1)
23921 END IF
23922 SN2TH = 0.25D0 - 0.25D0*COSTH**2
23923 IF((0.25D0-RMMIN**2/SHAT).LT.0.)THEN
23924 EVWGT=0.
23925 RETURN
23926 END IF
23927 T3 = ( SQRT(0.25D0-RMMIN**2/SHAT) * COSTH - HALF ) * SHAT
23928 U4 = - T3 - SHAT
23929 EMSC2 = TWO*SHAT*T3*U4/(SHAT**2+T3**2+U4**2)
23930 EMSCA = SQRT( EMSC2 )
23931 CALL HWSGEN(.FALSE.)
23932 EVWGT = ZERO
23933 XWEIN = TWO * SWEIN
23934 FACTR = GEV2NB*PIFAC*HWUAEM(EMSC2)/XWEIN/SHAT
23935 & *HWUALF(1,EMSCA)/TWO/CAFAC/2.
23936C...Jacobians from COSTH to X(1).
23937 IF(IQ.EQ.5)THEN
23938 FACTR=FACTR*(TLMAX-TLMIN)/2./PCM/RCM*T
23939 ELSE
23940 CONTINUE
23941 END IF
23942C...Jacobians from X1,X2 to X(2),X(3).
23943 FACTR=FACTR/S*(-LOG(TAU))*(1./(EMQ+EMH)**2-1./ECM_MAX**2)
23944C...CKM mixing top/bottom quark.
23945c bug fix 20/05/01 SM.
23946 IF(IQ.EQ.6)FACTR=FACTR*VCKM(3,3)
23947c end of bug fix.
23948C...Higgs resonance.
23949 FACTR=FACTR*EMHWT
23950C...constant weight.
23951 FACTR=FACTR*WEIGHT
23952C...SM/MSSM couplings.
23953 IF (IHIGGS.EQ.0) THEN
23954 GQH(0)=(RMASS(5)/MW)**2/TWO
23955 ELSE
23956 G1 = (RMASS(5)/MW/COSB)**2/TWO
23957 GQH(1) = G1*SINA**2
23958 GQH(2) = G1*COSA**2
23959 GQH(3) = G1*SINB**2
23960 GQH(4) = GQH(3)+(RMASS(6)/MW/TANB)**2/TWO
23961 END IF
23962C...Matrix elements.
23963 DO IH = 0,4
23964 ME2(IH) = ZERO
23965 END DO
23966c
23967c g b -> Q H
23968c
23969 ID1 = 5
23970 IH=IHIGGS
23971 IF(IHIGGS.NE.0)IH=IHIGGS-1
23972 IF (IH.EQ.4) ID1 = 6
23973 ID2 = 201+IHIGGS
23974 SM = RMASS(ID1)+RMASS(ID2)
23975 QPE = SHAT-SM**2
23976 IF (QPE.GT.ZERO) THEN
23977 DM = RMASS(ID1)-RMASS(ID2)
23978 QPE = QPE*(SHAT-DM**2)/SHAT
23979 END IF
23980 PT2 = QPE*SN2TH
23981 IF (PT2.GT.PT2MIN) THEN
23982 SQPE = SQRT(QPE*SHAT)
23983 PF = SQPE/SHAT
23984 T3 = (SQPE*COSTH - SHAT - SM*DM) / TWO
23985 U4 = - T3 - SHAT
23986 ME2(IH) = FACTR*PF * GQH(IH) *
23987 & U4/SHAT/T3*(-U4+TWO*SM*DM/T3/U4*SHAT*PT2)
23988 ELSE
23989 ME2(IH) = ZERO
23990 END IF
23991 END IF
23992 HCS = ZERO
23993c
23994c g b
23995 ID1 = 13
23996 ID2 = 5
23997 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
23998 DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
23999 DO IH = 0,3
24000 HCS = HCS + DIST*ME2(IH)
24001 IF (GENEV.AND.HCS.GT.RCS) THEN
24002 CALL HWHQCP(5,IHIGGS+201,2314,1)
24003 GOTO 9
24004 ENDIF
24005 END DO
24006 HCS = HCS + DIST*ME2(4)
24007 IF (GENEV.AND.HCS.GT.RCS) THEN
24008 CALL HWHQCP(6,207,2314,1)
24009 GOTO 9
24010 ENDIF
24011 END IF
24012c _
24013c g b
24014 ID1 = 13
24015 ID2 = 11
24016 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
24017 DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
24018 DO IH = 0,3
24019 HCS = HCS + DIST*ME2(IH)
24020 IF (GENEV.AND.HCS.GT.RCS) THEN
24021 CALL HWHQCP(11,IHIGGS+201,3124,1)
24022 GOTO 9
24023 ENDIF
24024 END DO
24025 HCS = HCS + DIST*ME2(4)
24026 IF (GENEV.AND.HCS.GT.RCS) THEN
24027 CALL HWHQCP(12,206,3124,1)
24028 GOTO 9
24029 ENDIF
24030 END IF
24031c
24032c b g
24033 ID1 = 5
24034 ID2 = 13
24035 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
24036 DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
24037 DO IH = 0,3
24038 HCS = HCS + DIST*ME2(IH)
24039 IF (GENEV.AND.HCS.GT.RCS) THEN
24040 CALL HWHQCP(IHIGGS+201,5,4132,1)
24041 GOTO 9
24042 ENDIF
24043 END DO
24044 HCS = HCS + DIST*ME2(4)
24045 IF (GENEV.AND.HCS.GT.RCS) THEN
24046 CALL HWHQCP(207,6,4132,1)
24047 GOTO 9
24048 ENDIF
24049 END IF
24050c _
24051c b g
24052 ID1 = 11
24053 ID2 = 13
24054 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
24055 DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
24056 DO IH = 0,3
24057 HCS = HCS + DIST*ME2(IH)
24058 IF (GENEV.AND.HCS.GT.RCS) THEN
24059 CALL HWHQCP(IHIGGS+201,11,2431,1)
24060 GOTO 9
24061 ENDIF
24062 END DO
24063 HCS = HCS + DIST*ME2(4)
24064 IF (GENEV.AND.HCS.GT.RCS) THEN
24065 CALL HWHQCP(206,12,2431,1)
24066 GOTO 9
24067 ENDIF
24068 END IF
24069 EVWGT = HCS
24070 RETURN
24071C---GENERATE EVENT
24072 9 IDN(1)=ID1
24073 IDN(2)=ID2
24074 IDCMF=15
24075 CALL HWETWO(.TRUE.,.TRUE.)
24076 IF (AZSPIN) THEN
24077C Calculate coefficients for constructing spin density matrices
24078C Set to zero for now
24079 CALL HWVZRO(7,GCOEF)
24080 END IF
24081 END
24082CDECK ID>, HWHIBK.
24083*CMZ :- -26/11/00 17.21.55 by Bryan Webber
24084*-- Author : Stefano Moretti
24085C-----------------------------------------------------------------------
24086C...Generate completely differential cross section (EVWGT) in the variables
24087C...X(I) with I=1,4 (see below) for the process IPROC=3350, as described
24088C...in the HERWIG 6 documentation file.
24089C...It includes interface to PDFs and takes into account color connections
24090C...among partons.
24091C
24092C...First release: 8-APR-1999 by Stefano Moretti
24093C
24094 SUBROUTINE HWHIBK
24095C-----------------------------------------------------------------------
24096C ASSOCIATE PRODUCTION W+H- FROM QUARK FUSION (2HDM)
24097C-----------------------------------------------------------------------
c63d70bc 24098 INCLUDE 'herwig65.inc'
65767955 24099 INTEGER I,J,IHEL
24100 DOUBLE PRECISION EMH,EMHWT,RMW,EMW
24101 DOUBLE PRECISION RMH
24102 DOUBLE PRECISION X(4),XL(4),XU(4)
24103 DOUBLE PRECISION CT,ST
24104 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
24105 DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
24106 DOUBLE PRECISION EMIN,PCM2,PCM,RCM2,RCM
24107 DOUBLE PRECISION M2,M2L,M2T
24108 DOUBLE PRECISION ALPHA,EMSC2
24109 DOUBLE PRECISION HWRGEN,HWUAEM
24110 DOUBLE PRECISION RNMIN,RNMAX,THETA_MIN,THETA_MAX
24111 DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
24112 DOUBLE PRECISION WEIGHT
24113 DOUBLE PRECISION VSAVE
24114 SAVE EMH,EMW,HCS,M2,M2L,M2T,FACT,S,CT
24115 LOGICAL HWRLOG
24116 EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2BK,HWETWO,HWRLOG
24117 PARAMETER (EPS=1.D-9)
24118 EQUIVALENCE (RMW ,RMASS(198))
24119 EQUIVALENCE (RMH ,RMASS(206))
24120 IF(GENEV)THEN
24121 RCS=HCS*HWRGEN(0)
24122 ELSE
24123 HCS=0.
24124 EVWGT=0.
24125C...assign final state masses.
24126 EMH=RMH
24127 EMHWT=1.D0
24128C...energy at hadron level.
24129 ECM_MAX=PBEAM1+PBEAM2
24130 S=ECM_MAX*ECM_MAX
24131C...phase space variables.
24132C...X(1)=COS(THETA_CM),
24133C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMW+EMH)**2-1./ECM_MAX**2),
24134C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
24135C...X(4)=(THETA-THETA_MIN)/(THETA_MAX-THETA_MIN),
24136C...where THETA=ATAN((EMW*EMW-RMW*RMW)/RMW/GAMW);
24137C...phase space borders.
24138 XL(1)=-1.
24139 XU(1)=1.
24140 XL(2)=0.
24141 XU(2)=1.
24142 XL(3)=0.
24143 XU(3)=1.
24144 XL(4)=0.
24145 XU(4)=1.
24146C...single phase space point.
24147 WEIGHT=1.
24148 DO I=1,4
24149 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
24150 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
24151 END DO
24152C...resonant boson mass (limits to -10*W-widths to improve efficiency).
24153 RNMIN=RMW-GAMMAX*GAMW
24154 THETA_MIN=ATAN((RNMIN*RNMIN-RMW*RMW)/RMW/GAMW)
24155 RNMAX=ECM_MAX-EMH
24156 THETA_MAX=ATAN((RNMAX*RNMAX-RMW*RMW)/RMW/GAMW)
24157 EMW=SQRT((TAN(X(4)*(THETA_MAX-THETA_MIN)+THETA_MIN))
24158 & *RMW*GAMW+RMW*RMW)
24159C...energy at parton level.
24160 ECM=SQRT(1./(X(2)*(1./(EMW+EMH)**2-1./ECM_MAX**2)
24161 & +1./ECM_MAX**2))
24162 IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
24163 SHAT=ECM*ECM
24164 TAU=SHAT/S
24165C...momentum fractions X1 and X2.
24166 XX(1)=EXP(LOG(TAU)*(1.-X(3)))
24167 XX(2)=TAU/XX(1)
24168C...two particle kinematics.
24169 CT=X(1)
24170 IF(HWRLOG(HALF))THEN
24171 ST=+SQRT(1.-CT*CT)
24172 ELSE
24173 ST=-SQRT(1.-CT*CT)
24174 END IF
24175 RCM2=((SHAT-EMW*EMW-EMH*EMH)**2
24176 & -(2.*EMW*EMH)**2)/(4.*SHAT)
24177 RCM=SQRT(RCM2)
24178 P3(0)=SQRT(RCM2+EMW*EMW)
24179 P3(1)=0.
24180 P3(2)=RCM*ST
24181 P3(3)=RCM*CT
24182 P4(0)=SQRT(RCM2+EMH*EMH)
24183 P4(1)=0.
24184 P4(2)=-RCM*ST
24185 P4(3)=-RCM*CT
24186C...incoming parton: massless.
24187 EMIN=0.
24188C...initial state momenta in the partonic CM.
24189 PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
24190 & -(2.*EMIN*EMIN)**2)/(4.*SHAT)
24191 PCM=SQRT(PCM2)
24192 P1(0)=SQRT(PCM2+EMIN*EMIN)
24193 P1(1)=0.
24194 P1(2)=0.
24195 P1(3)=PCM
24196 P2(0)=SQRT(PCM2+EMIN*EMIN)
24197 P2(1)=0.
24198 P2(2)=0.
24199 P2(3)=-PCM
24200C...color structured ME summed/averaged over final/initial spins and colors.
24201 CALL HWH2BK(P1,P2,P3,P4,EMW,EMH,M2,M2L,M2T)
24202 IF(M2.LE.0.)RETURN
24203C...charge conjugation.
24204 M2=M2*2.
24205 M2L=M2L*2.
24206 M2T=M2T*2.
24207C...constant factors: phi along beam and conversion GeV^2->nb.
24208 FACT=2.*PIFAC*GEV2NB
24209C...Jacobians from X1,X2 to X(2),X(3)
24210 FACT=FACT/S*(-LOG(TAU))*(1./(EMW+EMH)**2-1./ECM_MAX**2)
24211C...phase space Jacobians, pi's and flux.
24212 FACT=FACT/64./PIFAC/PIFAC*RCM/PCM
24213C...hard scale.
24214 EMSCA=RMW+RMH
24215C...EW couplings.
24216 EMSC2=EMSCA*EMSCA
24217 ALPHA=HWUAEM(EMSC2)
24218 FACT=FACT*(PIFAC*ALPHA/SWEIN/RMW/RMW/SQRT(2.))**2
24219C...Higgs resonance.
24220 FACT=FACT*EMHWT
24221C...vector boson resonance.
24222 FACT=FACT*(THETA_MAX-THETA_MIN)/PIFAC
24223C...constant weight.
24224 FACT=FACT*WEIGHT
24225 END IF
24226C...set up PDFs.
24227 HCS=0.
24228 CALL HWSGEN(.FALSE.)
24229 DO I=5,11,6
24230 IF(DISF(I,1).LT.EPS)THEN
24231 GOTO 200
24232 END IF
24233 IF(I.LE.6)J=I+6
24234 IF(I.GE.7)J=I-6
24235 IF(DISF(J,2).LT.EPS)THEN
24236 GOTO 200
24237 END IF
24238 DIST=DISF(I,1)*DISF(J,2)*S
24239C...no need to set up color connections.
24240 HCS=HCS+M2*DIST*FACT
24241 IF(GENEV.AND.HCS.GT.RCS)THEN
24242C...generate event.
24243 IDN(1)=I
24244 IDN(2)=J
24245 IDN(3)=NINT(198.+HWRGEN(0))
24246 IF(IDN(3).EQ.198)IDN(4)=207
24247 IF(IDN(3).EQ.199)IDN(4)=206
24248C...set up status and IDs: use HWETWO.
24249 COSTH=CT
24250 IDCMF=15
24251 ICO(1)=2
24252 ICO(2)=1
24253 ICO(3)=3
24254 ICO(4)=4
24255C...trick HWETWO in using off-shell V mass
24256 VSAVE=RMASS(IDN(3))
24257 RMASS(IDN(3))=EMW
24258C-- BRW fix 27/8/04: avoid double smearing of V mass
24259 CALL HWETWO(.FALSE.,.TRUE.)
24260 RMASS(IDN(3))=VSAVE
24261 IF(AZSPIN)THEN
24262C...set to zero the coefficients of the spin density matrices.
24263 CALL HWVZRO(7,GCOEF)
24264 END IF
24265C...calculates approximately polarized decay matrix of gauge boson.
24266 IF(IERROR.NE.0)RETURN
24267 IHEL=0
24268 IF(ICHRG(I)*ICHRG(IDN(3)).LT.0.D0)IHEL=1
24269 IF(M2L.LT.0.)M2L=0.
24270 IF(M2T.LT.0.)M2T=0.
24271 RHOHEP(2,NHEP-1)=M2L/M2
24272 RHOHEP(1,NHEP-1)=M2T/M2*(1-IHEL)
24273 RHOHEP(3,NHEP-1)=M2T/M2*( IHEL)
24274 RETURN
24275 END IF
24276 200 CONTINUE
24277 END DO
24278 EVWGT=HCS
24279 END
24280CDECK ID>, HWHIG1.
24281*CMZ :- -23/08/94 13.22.29 by Mike Seymour
24282*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24283*- Split in 3 files by M. Kirsanov
24284C-----------------------------------------------------------------------
24285 FUNCTION HWHIG1(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
24286C-----------------------------------------------------------------------
24287C Basic matrix elements for Higgs + jet production; used in HWHIGA
24288C-----------------------------------------------------------------------
24289 IMPLICIT NONE
24290 DOUBLE COMPLEX HWHIG1,BI(4),CI(7),DI(3)
24291 DOUBLE PRECISION S,T,U,EH2,EQ2,S1,T1,U1,ONE,TWO,FOUR,HALF
24292 INTEGER I,J,K,I1,J1,K1
24293 COMMON/CINTS/BI,CI,DI
24294 PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0)
24295C-----------------------------------------------------------------------
24296C +++ helicity amplitude for: g+g --> g+H
24297C-----------------------------------------------------------------------
24298 S1=S-EH2
24299 T1=T-EH2
24300 U1=U-EH2
24301 HWHIG1=EQ2*FOUR*DSQRT(TWO*S*T*U)*(
24302 & -FOUR*(ONE/(U*T)+ONE/(U*U1)+ONE/(T*T1))
24303 & -FOUR*((TWO*S+T)*BI(K)/U1**2+(TWO*S+U)*BI(J)/T1**2)/S
24304 & -(S-FOUR*EQ2)*(S1*CI(I1)+(U-S)*CI(J1)+(T-S)*CI(K1))/(S*T*U)
24305 & -8.D0*EQ2*(CI(J1)/(T*T1)+CI(K1)/(U*U1))
24306 & +HALF*(S-FOUR*EQ2)*(S*T*DI(K)+U*S*DI(J)-U*T*DI(I))/(S*T*U)
24307 & +FOUR*EQ2*DI(I)/S
24308 & -TWO*(U*CI(K)+T*CI(J)+U1*CI(K1)+T1*CI(J1)-U*T*DI(I))/S**2 )
24309 END
24310CDECK ID>, HWHIG2.
24311*CMZ :- -23/08/94 13.22.29 by Mike Seymour
24312*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24313C-----------------------------------------------------------------------
24314 FUNCTION HWHIG2(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
24315C-----------------------------------------------------------------------
24316C Basic matrix elements for Higgs + jet production; used in HWHIGA
24317C-----------------------------------------------------------------------
24318 IMPLICIT NONE
24319 DOUBLE COMPLEX HWHIG2,BI(4),CI(7),DI(3)
24320 DOUBLE PRECISION S,T,U,EH2,EQ2,S1,T1,U1,ONE,TWO,FOUR,HALF
24321 INTEGER I,J,K,I1,J1,K1
24322 COMMON/CINTS/BI,CI,DI
24323 PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0)
24324C-----------------------------------------------------------------------
24325C ++- helicity amplitude for: g+g --> g+H
24326C-----------------------------------------------------------------------
24327 S1=S-EH2
24328 T1=T-EH2
24329 U1=U-EH2
24330 HWHIG2=EQ2*FOUR*DSQRT(TWO*S*T*U)*(FOUR*EH2
24331 & +(EH2-FOUR*EQ2)*(S1*CI(4)+T1*CI(5)+U1*CI(6))
24332 & -HALF*(EH2-FOUR*EQ2)*(S*T*DI(3)+U*S*DI(2)+U*T*DI(1)) )/(S*T*U)
24333 END
24334CDECK ID>, HWHIG5.
24335*CMZ :- -23/08/94 13.22.29 by Mike Seymour
24336*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24337C-----------------------------------------------------------------------
24338 FUNCTION HWHIG5(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1)
24339C-----------------------------------------------------------------------
24340C Basic matrix elements for Higgs + jet production; used in HWHIGA
24341C-----------------------------------------------------------------------
24342 IMPLICIT NONE
24343 DOUBLE COMPLEX HWHIG5,BI(4),CI(7),DI(3)
24344 DOUBLE PRECISION S,T,U,EH2,EQ2,ONE,TWO,FOUR,HALF
24345 INTEGER I,J,K,I1,J1,K1
24346 COMMON/CINTS/BI,CI,DI
24347 PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0)
24348C-----------------------------------------------------------------------
24349C Amplitude for: q+qbar --> g+H
24350C-----------------------------------------------------------------------
24351 HWHIG5=DCMPLX(TWO)+DCMPLX(TWO*S/(S-EH2))*BI(I)
24352 & +DCMPLX(FOUR*EQ2-U-T)*CI(K)
24353 END
24354CDECK ID>, HWHIBQ.
24355*CMZ :- -30/06/01 18.40.33 by Stefano Moretti
24356*-- Author : Stefano Moretti
24357C-----------------------------------------------------------------------
24358C...Generate completely differential cross section (EVWGT) in the variables
24359C...X(I) with I=1,6 (see below) for the process IPROC=3500, as described
24360C...in the HERWIG 6 documentation file.
24361C...It includes interface to PDFs and takes into account color connections
24362C...among partons.
24363C
24364C...First release: 12-APR-2000 by Stefano Moretti
24365C
24366C-----------------------------------------------------------------------
24367 SUBROUTINE HWHIBQ
24368C-----------------------------------------------------------------------
24369C PRODUCTION OF MSSM CHARGED HIGGSES FROM B-QUARK+LIGHT-QUARK FUSION
24370C-----------------------------------------------------------------------
c63d70bc 24371 INCLUDE 'herwig65.inc'
65767955 24372 INTEGER I,J,K,L,M,N
24373 INTEGER II,JJ,ITMP
24374 INTEGER IFL,IRES
24375 DOUBLE PRECISION EMQ,ENQ,EMQH,EMB,EMH,EMHWT,EMT,EMW
24376 DOUBLE PRECISION EMH01,EMH02,EMH03
24377 DOUBLE PRECISION WCKM,CKM,GAMT
24378 DOUBLE PRECISION X(6),XL(6),XU(6)
24379 DOUBLE PRECISION Q3(0:3),Q35(0:3)
24380 DOUBLE PRECISION Q1(5),Q2(5),H(5)
24381 DOUBLE PRECISION CT4,ST4,CT3,ST3,CF3,SF3,RQ42,RQ4,RQ32,RQ3,PQ3
24382 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
24383 DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
24384 DOUBLE PRECISION XTMP
24385 DOUBLE PRECISION EMIN1,EMIN2,PCM2,PCM
24386 DOUBLE PRECISION M2B,M2BBAR
24387 DOUBLE PRECISION ALPHA,EMSC2
24388 DOUBLE PRECISION HWRGEN,HWUAEM
24389 DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
24390 DOUBLE PRECISION QAUX(0:3)
24391 DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
24392 DOUBLE PRECISION WEIGHT
24393 SAVE HCS,M2B,M2BBAR,FACT,S,WCKM,P3,P4,P5
24394 LOGICAL HWRLOG
24395 EXTERNAL HWRGEN,HWUAEM,HWH2BH,HWEONE,HWRLOG,
24396 & HWUMAS,HWULOB
24397 EQUIVALENCE (EMB,RMASS(5)),(EMT,RMASS(6))
24398 EQUIVALENCE (EMW,RMASS(198))
24399 EQUIVALENCE (EMH01,RMASS(204)),
24400 & (EMH02,RMASS(203)),
24401 & (EMH03,RMASS(205))
24402 EQUIVALENCE (CKM,VCKM(3,3))
24403 PARAMETER (EPS=1.D-9)
24404 IF(GENEV)THEN
24405 RCS=HCS*HWRGEN(0)
24406 ELSE
24407 HCS=0.
24408 EVWGT=0.
24409C...assign final state masses.
24410 EMQ=0.
24411 ENQ=0
24412 EMH=RMASS(206)
24413 EMHWT=1.
24414C...assign top width.
24415 GAMT=HBAR/RLTIM(6)
24416C...energy at hadron level.
24417 ECM_MAX=PBEAM1+PBEAM2
24418 S=ECM_MAX*ECM_MAX
24419C...phase space variables.
24420C...X(1)=(EMQH-EMQ-EMH)/(ECM-EMQ-ENQ-EMH),
24421C...X(2)=1/[-(P2-P3)^2+MW^2],X(3)=COS(THETA4_CM_35),X(4)=FI4_CM_35,
24422C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2),
24423C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU);
24424C...phase space borders.
24425 XL(1)=0.
24426 XU(1)=1.
24427c...for XL(2),XU(2) see below (non constant).
24428 XL(3)=-1.
24429 XU(3)=1.
24430 XL(4)=0.
24431 XU(4)=2.*PIFAC
24432 XL(5)=0.
24433 XU(5)=1.
24434 XL(6)=0.
24435 XU(6)=1.
24436C...single phase space point.
24437 100 CONTINUE
24438 WEIGHT=1.
24439 DO I=1,6
24440 IF(I.EQ.2)GOTO 125
24441 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
24442 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
24443 125 CONTINUE
24444 END DO
24445C...energy at parton level.
24446 ECM=SQRT(1./(X(5)*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2)
24447 & +1./ECM_MAX**2))
24448 IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
24449 SHAT=ECM*ECM
24450 TAU=SHAT/S
24451C...momentum fractions X1 and X2.
24452 XX(1)=EXP(LOG(TAU)*(1.-X(6)))
24453 XX(2)=TAU/XX(1)
24454C...incoming partons massless.
24455 EMIN1=0.
24456 EMIN2=0.
24457C...initial state momenta in the partonic CM.
24458 PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
24459 & -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
24460 PCM=SQRT(PCM2)
24461C...three particle kinematics.
24462 EMQH=X(1)*(ECM-EMQ-ENQ-EMH)+EMQ+EMH
24463 RQ42=((ECM*ECM-ENQ*ENQ-EMQH*EMQH)**2-(2.*ENQ*EMQH)**2)/
24464 & (4.*ECM*ECM)
24465 IF(RQ42.LT.0.)THEN
24466 GOTO 100
24467 ELSE
24468 RQ4=SQRT(RQ42)
24469 ENDIF
24470C...X(2): integrate over W propagator.
24471 XL(2)=1./(4.*SQRT(PCM2+EMIN2*EMIN2)*RQ4+EMW*EMW)
24472 XU(2)=1./(EMW*EMW)
24473 X(2)=XL(2)+(XU(2)-XL(2))*HWRGEN(0)
24474 WEIGHT=WEIGHT*ABS(XU(2)-XL(2))
24475 XTMP=1./X(2)
24476 XTMP=(XTMP-EMW*EMW)/2./SQRT(PCM2+EMIN2*EMIN2)
24477 CT4=1.-XTMP/((SHAT-EMQH*EMQH+2.*ENQ*ENQ)/(2.*ECM))
24478 IF(CT4.GT.+1.)CT4=+1.
24479 IF(CT4.LT.-1.)CT4=-1.
24480 IF(HWRLOG(HALF))THEN
24481 ST4=+SQRT(1.-CT4*CT4)
24482 ELSE
24483 ST4=-SQRT(1.-CT4*CT4)
24484 END IF
24485 CT3=X(3)
24486 ST3=SQRT(1.-CT3*CT3)
24487 CF3=COS(X(4))
24488 SF3=SIN(X(4))
24489 P4(1)=0.
24490 P4(2)=-RQ4*ST4
24491 P4(3)=-RQ4*CT4
24492 P4(0)=SQRT(RQ42+ENQ*ENQ)
24493 DO I=1,3
24494 Q35(I)=-P4(I)
24495 END DO
24496 Q35(0)=SQRT(RQ42+EMQH*EMQH)
24497 RQ32=((EMQH*EMQH-EMH*EMH-EMQ*EMQ)**2-(2.*EMH*EMQ)**2)/
24498 & (4.*EMQH*EMQH)
24499 IF(RQ32.LT.0.)THEN
24500 GOTO 100
24501 ELSE
24502 RQ3=SQRT(RQ32)
24503 ENDIF
24504 Q3(1)=RQ3*ST3*CF3
24505 Q3(2)=RQ3*ST3*SF3
24506 Q3(3)=RQ3*CT3
24507 Q3(0)=SQRT(RQ32+EMQ*EMQ)
24508 PQ3=0.
24509 DO I=1,3
24510 PQ3=PQ3+Q35(I)*Q3(I)
24511 END DO
24512 P3(0)=(Q35(0)*Q3(0)+PQ3)/EMQH
24513 P5(0)=Q35(0)-P3(0)
24514 DO I=1,3
24515 P3(I)=Q3(I)+Q35(I)*(P3(0)+Q3(0))/(Q35(0)+EMQH)
24516 P5(I)=Q35(I)-P3(I)
24517 END DO
24518C...initial state.
24519 P1(0)=SQRT(PCM2+EMIN1*EMIN1)
24520 P1(1)=0.
24521 P1(2)=0.
24522 P1(3)=PCM
24523 P2(0)=SQRT(PCM2+EMIN2*EMIN2)
24524 P2(1)=0.
24525 P2(2)=0.
24526 P2(3)=-PCM
24527C...option: top diagram removed if can be resonant to avoid double counting.
24528 IRES=1
24529C IF((EMT-EMB-EMH).GE.0.)IRES=0
24530C...color structured ME summed/averaged over final/initial spins and colors.
24531C...IFL=+1 selects b.
24532 IFL=+1
24533 CALL HWH2BH(P1,P2,P3,P4,P5,EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,
24534 & IFL,IRES,CKM,GAMT,M2B)
24535C...IFL=-1 selects b-bar.
24536 IFL=-1
24537 CALL HWH2BH(P1,P2,P3,P4,P5,EMW,EMH,EMH01,EMH02,EMH03,EMB,EMT,
24538 & IFL,IRES,CKM,GAMT,M2BBAR)
24539C...constant factors: phi along beam and conversion GeV^2->nb.
24540 FACT=2.*PIFAC*GEV2NB
24541C...Jacobians from X1,X2 to X(5),X(6)
24542 FACT=FACT/S*(-LOG(TAU))*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2)
24543C...phase space Jacobians, pi's and flux.
24544 FACT=FACT*RQ3*RQ4/PCM/32./(2.*PIFAC)**5
24545 & *(ECM-EMQ-ENQ-EMH)
24546 FACT=FACT/2./P2(0)/P4(0)
24547 FACT=FACT*(2.*P2(0)*P4(0)*(1.-CT4)+EMW*EMW)**2
24548C...EW couplings.
24549 EMSCA=EMQ+ENQ+EMH
24550 EMSC2=EMSCA*EMSCA
24551 ALPHA=HWUAEM(EMSC2)
24552 FACT=FACT*64.*PIFAC**3*ALPHA**3/4./SWEIN/SWEIN/SWEIN/EMW/EMW
24553C...Higgs resonance.
24554 FACT=FACT*EMHWT
24555C...constant weight.
24556 FACT=FACT*WEIGHT
24557 END IF
24558C...set up PDFs.
24559 HCS=0.
24560 CALL HWSGEN(.FALSE.)
24561 DO I=1,12
24562 IF(DISF(I,1).LT.EPS)THEN
24563 GOTO 200
24564 END IF
24565 DO J=1,12
24566 IF(DISF(J,2).LT.EPS)THEN
24567 GOTO 175
24568 END IF
24569 IF((I.NE.5).AND.(I.NE.11).AND.
24570 & (J.NE.5).AND.(J.NE.11))THEN
24571 GOTO 150
24572 END IF
24573 II=J
24574 IF((I.NE.5).AND.(I.NE.11))II=I
24575 IF(II.GT.6)II=II-6
24576 ITMP=II
24577 II=(II+1)/2
24578 DIST=0.
24579 DO JJ=1,3
24580 WCKM=VCKM(II,JJ)
24581 IF((ITMP.EQ.5).AND.(II.EQ.3).AND.(JJ.EQ.3))WCKM=0.
24582 DIST=DIST+DISF(I,1)*DISF(J,2)*WCKM*S
24583 END DO
24584 IF((I.LE.6).AND.(J.LE.6))THEN
24585 HCS=HCS+M2B*DIST*FACT
24586 ELSE IF((I.LE.6).AND.(J.GE.7))THEN
24587 IF(J.NE.11)HCS=HCS+M2B*DIST*FACT
24588 IF(J.EQ.11)HCS=HCS+M2BBAR*DIST*FACT
24589 ELSE IF((I.GE.7).AND.(J.LE.6))THEN
24590 IF(I.NE.11)HCS=HCS+M2B*DIST*FACT
24591 IF(I.EQ.11)HCS=HCS+M2BBAR*DIST*FACT
24592 ELSE IF((I.GE.7).AND.(J.GE.7))THEN
24593 HCS=HCS+M2BBAR*DIST*FACT
24594 END IF
24595 IF(GENEV.AND.HCS.GT.RCS)THEN
24596C...generate event.
24597 IDN(1)=I
24598 IDN(2)=J
24599 IF((I.EQ.5).OR.(I.EQ.11))THEN
24600 K=I
24601 L=J+(-1)**(J+1)
24602 IDN(3)=K
24603 IDN(4)=L
24604 ELSE
24605 L=I+(-1)**(J+1)
24606 K=J
24607 IDN(3)=L
24608 IDN(4)=K
24609 END IF
24610 IF(IDN(2).EQ.IDN(4))THEN
24611 IDN(5)=
24612 & NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))-ICHRG(IDN(3))))
24613 ELSE
24614 IDN(5)=
24615 & NINT(198.5-.1667*FLOAT(ICHRG(IDN(2))-ICHRG(IDN(4))))
24616 END IF
24617 IDN(5)=IDN(5)+8
24618C...sets up incoming status and IDs only for 2->1: use HWEONE.
24619 IDCMF=15
24620 CALL HWEONE
24621 JDAHEP(1,NHEP)=NHEP+1
24622 JDAHEP(2,NHEP)=NHEP+3
24623 JMOHEP(1,NHEP+1)=NHEP
24624 JMOHEP(1,NHEP+2)=NHEP
24625 JMOHEP(1,NHEP+3)=NHEP
24626C...randomly rotate final state momenta around beam axis.
24627 PHI=2.*PIFAC*HWRGEN(0)
24628 CPHI=COS(PHI)
24629 SPHI=SIN(PHI)
24630 ROT(1,1)=+CPHI
24631 ROT(1,2)=+SPHI
24632 ROT(1,3)=0.
24633 ROT(2,1)=-SPHI
24634 ROT(2,2)=+CPHI
24635 ROT(2,3)=0.
24636 ROT(3,1)=0.
24637 ROT(3,2)=0.
24638 ROT(3,3)=1.
24639 DO L=1,3
24640 DO M=1,3
24641 QAUX(M)=0.
24642 DO N=1,3
24643 IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
24644 IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
24645 IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
24646 END DO
24647 END DO
24648 DO M=1,3
24649 IF(L.EQ.1)P3(M)=QAUX(M)
24650 IF(L.EQ.2)P4(M)=QAUX(M)
24651 IF(L.EQ.3)P5(M)=QAUX(M)
24652 END DO
24653 END DO
24654C...outgoing momenta (give quark masses non covariantly!)
24655 DO M=1,3
24656 Q1(M)=P3(M)
24657 Q2(M)=P4(M)
24658 H( M)=P5(M)
24659 END DO
24660 Q1(4)=P3(0)
24661 Q2(4)=P4(0)
24662 H( 4)=P5(0)
24663 Q1(5)=RMASS(IDN(3))
24664 Q1(4)=SQRT(Q1(4)**2+Q1(5)**2)
24665 Q2(5)=RMASS(IDN(4))
24666 Q2(4)=SQRT(Q2(4)**2+Q2(5)**2)
24667 H(4)=-Q1(4)-Q2(4)+PHEP(5,NHEP)
24668 CALL HWUMAS(H)
24669 CALL HWULOB(PHEP(1,NHEP),Q1,PHEP(1,NHEP+1))
24670 CALL HWULOB(PHEP(1,NHEP),Q2,PHEP(1,NHEP+2))
24671 CALL HWULOB(PHEP(1,NHEP),H ,PHEP(1,NHEP+3))
24672C...sets up outgoing status and IDs.
24673 ISTHEP(NHEP+1)=113
24674 ISTHEP(NHEP+2)=114
24675 ISTHEP(NHEP+3)=114
24676 IDHW(NHEP+1)=IDN(3)
24677 IDHEP(NHEP+1)=IDPDG(IDN(3))
24678 IDHW(NHEP+2)=IDN(4)
24679 IDHEP(NHEP+2)=IDPDG(IDN(4))
24680 IDHW(NHEP+3)=IDN(5)
24681 IDHEP(NHEP+3)=IDPDG(IDN(5))
24682C...sets up colour connections.
24683 JMOHEP(2,NHEP+1)=NHEP-2
24684 JMOHEP(2,NHEP+2)=NHEP-1
24685 JMOHEP(2,NHEP-1)=NHEP+2
24686 JMOHEP(2,NHEP-2)=NHEP+1
24687 JMOHEP(2,NHEP+3)=NHEP+3
24688 JDAHEP(2,NHEP+1)=NHEP-2
24689 JDAHEP(2,NHEP+2)=NHEP-1
24690 JDAHEP(2,NHEP-1)=NHEP+2
24691 JDAHEP(2,NHEP-2)=NHEP+1
24692 JDAHEP(2,NHEP+3)=NHEP+3
24693 NHEP=NHEP+3
24694 IF(AZSPIN)THEN
24695C...set to zero the coefficients of the spin density matrices.
24696 CALL HWVZRO(7,GCOEF)
24697 END IF
24698 RETURN
24699 END IF
24700 150 CONTINUE
24701 175 CONTINUE
24702 END DO
24703 200 CONTINUE
24704 END DO
24705 EVWGT=HCS
24706 END
24707CDECK ID>, HWHIGA.
24708*CMZ :- -23/08/94 13.22.29 by Mike Seymour
24709*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24710C-----------------------------------------------------------------------
24711 SUBROUTINE HWHIGA(S,T,U,EMH2,WTQQ,WTQG,WTGQ,WTGG)
24712C-----------------------------------------------------------------------
24713C Gives amplitudes squared for q-qbar, q(bar)-g and gg -> Higgs +jet
24714C IAPHIG (set in HWIGIN)=0: zero mass approximation =1: exact result
24715C =2: infinite mass limit.
24716C Only top loop included. A factor (alpha_s**3*alpha_W) is extracted
24717C-----------------------------------------------------------------------
c63d70bc 24718 INCLUDE 'herwig65.inc'
65767955 24719 DOUBLE COMPLEX HWHIGB,HWHIGC,HWHIGD,HWHIG5,HWHIG1,HWHIG2,BI(4),
24720 & CI(7),DI(3),EPSI,TAMP(7)
24721 DOUBLE PRECISION S,T,U,EMH2,WTQQ,WTQG,WTGQ,WTGG,EMW2,RNGLU,RNQRK,
24722 & FLUXGG,FLUXGQ,FLUXQQ,EMQ2,TAMPI(7),TAMPR(7)
24723 INTEGER I
24724 LOGICAL NOMASS
24725 EXTERNAL HWHIGB,HWHIGC,HWHIGD,HWHIG5,HWHIG1,HWHIG2
24726 COMMON/SMALL/EPSI
24727 COMMON/CINTS/BI,CI,DI
24728 EPSI=DCMPLX(ZERO,-1.D-10)
24729 EMW2=RMASS(198)**2
24730C Spin and colour flux factors plus enhancement factor
24731 RNGLU=1./FLOAT(NCOLO**2-1)
24732 RNQRK=1./FLOAT(NCOLO)
24733 FLUXGG=.25*RNGLU**2*ENHANC(6)**2
24734 FLUXGQ=.25*RNGLU*RNQRK*ENHANC(6)**2
24735 FLUXQQ=.25*RNQRK**2*ENHANC(6)**2
24736 IF (IAPHIG.EQ.2) THEN
24737C Infinite mass limit in loops
24738 WTGG=(2./3.)**2*FLOAT(NCOLO*(NCOLO**2-1))
24739 & *(EMH2**4+S**4+T**4+U**4)/(S*T*U*EMW2)*FLUXGG
24740 WTQQ= 16./9.*(U**2+T**2)/(S*EMW2)*FLUXQQ
24741 WTQG=-16./9.*(U**2+S**2)/(T*EMW2)*FLUXGQ
24742 WTGQ=-16./9.*(S**2+T**2)/(U*EMW2)*FLUXGQ
24743 RETURN
24744 ELSEIF (IAPHIG.EQ.1) THEN
24745C Exact result for loops
24746 NOMASS=.FALSE.
24747 ELSEIF (IAPHIG.EQ.0) THEN
24748C Small mass approximation in loops
24749 NOMASS=.TRUE.
24750 ELSE
24751 CALL HWWARN('HWHIGA',500)
24752 ENDIF
24753C Include only top quark contribution
24754 EMQ2=RMASS(6)**2
24755 BI(1)=HWHIGB(NOMASS,S,ZERO,ZERO,EMQ2)
24756 BI(2)=HWHIGB(NOMASS,T,ZERO,ZERO,EMQ2)
24757 BI(3)=HWHIGB(NOMASS,U,ZERO,ZERO,EMQ2)
24758 BI(4)=HWHIGB(NOMASS,EMH2,ZERO,ZERO,EMQ2)
24759 BI(1)=BI(1)-BI(4)
24760 BI(2)=BI(2)-BI(4)
24761 BI(3)=BI(3)-BI(4)
24762 CI(1)=HWHIGC(NOMASS,S,ZERO,ZERO,EMQ2)
24763 CI(2)=HWHIGC(NOMASS,T,ZERO,ZERO,EMQ2)
24764 CI(3)=HWHIGC(NOMASS,U,ZERO,ZERO,EMQ2)
24765 CI(7)=HWHIGC(NOMASS,EMH2,ZERO,ZERO,EMQ2)
24766 CI(4)=(S*CI(1)-EMH2*CI(7))/(S-EMH2)
24767 CI(5)=(T*CI(2)-EMH2*CI(7))/(T-EMH2)
24768 CI(6)=(U*CI(3)-EMH2*CI(7))/(U-EMH2)
24769 DI(1)=HWHIGD(NOMASS,U,T,EMH2,EMQ2)
24770 DI(2)=HWHIGD(NOMASS,S,U,EMH2,EMQ2)
24771 DI(3)=HWHIGD(NOMASS,S,T,EMH2,EMQ2)
24772C Compute complex amplitudes
24773 TAMP(1)=HWHIG1(S,T,U,EMH2,EMQ2,1,2,3,4,5,6)
24774 TAMP(2)=HWHIG2(S,T,U,EMH2,EMQ2,1,2,3,0,0,0)
24775 TAMP(3)=HWHIG1(T,S,U,EMH2,EMQ2,2,1,3,5,4,6)
24776 TAMP(4)=HWHIG1(U,T,S,EMH2,EMQ2,3,2,1,6,5,4)
24777 TAMP(5)=HWHIG5(S,T,U,EMH2,EMQ2,1,0,4,0,0,0)
24778 TAMP(6)=HWHIG5(T,S,U,EMH2,EMQ2,2,0,5,0,0,0)
24779 TAMP(7)=HWHIG5(U,T,S,EMH2,EMQ2,3,0,6,0,0,0)
24780 DO 20 I=1,7
24781 TAMPI(I)= DREAL(TAMP(I))
24782 20 TAMPR(I)=-DIMAG(TAMP(I))
24783C Square and add prefactors
24784 WTGG=0.03125*FLOAT(NCOLO*(NCOLO**2-1))/EMW2
24785 & *(TAMPR(1)**2+TAMPI(1)**2+TAMPR(2)**2+TAMPI(2)**2
24786 & +TAMPR(3)**2+TAMPI(3)**2+TAMPR(4)**2+TAMPI(4)**2)*FLUXGG
24787 WTQQ= 16.*(U**2+T**2)/(U+T)**2*EMQ2**2/(S*EMW2)
24788 & *(TAMPR(5)**2+TAMPI(5)**2)*FLUXQQ
24789 WTQG=-16.*(U**2+S**2)/(U+S)**2*EMQ2**2/(T*EMW2)
24790 & *(TAMPR(6)**2+TAMPI(6)**2)*FLUXGQ
24791 WTGQ=-16.*(S**2+T**2)/(S+T)**2*EMQ2**2/(U*EMW2)
24792 & *(TAMPR(7)**2+TAMPI(7)**2)*FLUXGQ
24793 END
24794CDECK ID>, HWHIGB.
24795*CMZ :- -23/08/94 13.22.29 by Mike Seymour
24796*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24797*- split in 3 files by M. Kirsanov
24798C-----------------------------------------------------------------------
24799 FUNCTION HWHIGB(NOMASS,S,T,EH2,EQ2)
24800C-----------------------------------------------------------------------
24801C One loop scalar integrals, used in HWHIGJ.
24802C If NOMASS=.TRUE. use a small mass approx. for particle in loop.
24803C-----------------------------------------------------------------------
c63d70bc 24804 INCLUDE 'herwig65.inc'
65767955 24805 DOUBLE COMPLEX HWHIGB,HWUCI2,HWULI2,EPSI,PII
24806 DOUBLE PRECISION S,T,EQ2,EH2,RAT
24807 LOGICAL NOMASS
24808 EXTERNAL HWULI2,HWUCI2
24809 COMMON/SMALL/EPSI
24810C-----------------------------------------------------------------------
24811C B_0(2p1.p2=S;mq,mq)
24812C-----------------------------------------------------------------------
24813 PII=DCMPLX(ZERO,PIFAC)
24814 IF (NOMASS) THEN
24815 RAT=DABS(S/EQ2)
24816 HWHIGB=-DLOG(RAT)+TWO
24817 IF (S.GT.ZERO) HWHIGB=HWHIGB+PII
24818 ELSE
24819 RAT=S/(FOUR*EQ2)
24820 IF (S.LT.ZERO) THEN
24821 HWHIGB=TWO-TWO*DSQRT(ONE-ONE/RAT)
24822 & *DLOG(DSQRT(-RAT)+DSQRT(ONE-RAT))
24823 ELSEIF (S.GT.ZERO.AND.RAT.LT.ONE) THEN
24824 HWHIGB=TWO-TWO*DSQRT(ONE/RAT-ONE)*DASIN(DSQRT(RAT))
24825 ELSEIF (RAT.GT.ONE) THEN
24826 HWHIGB=TWO-DSQRT(ONE-ONE/RAT)
24827 & *(TWO*DLOG(DSQRT(RAT)+DSQRT(RAT-ONE))-PII)
24828 ENDIF
24829 ENDIF
24830 END
24831CDECK ID>, HWHIGC.
24832*CMZ :- -23/08/94 13.22.29 by Mike Seymour
24833*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24834C-----------------------------------------------------------------------
24835 FUNCTION HWHIGC(NOMASS,S,T,EH2,EQ2)
24836C-----------------------------------------------------------------------
24837C One loop scalar integrals, used in HWHIGJ.
24838C If NOMASS=.TRUE. use a small mass approx. for particle in loop.
24839C-----------------------------------------------------------------------
c63d70bc 24840 INCLUDE 'herwig65.inc'
65767955 24841 DOUBLE COMPLEX HWHIGC,HWUCI2,HWULI2,EPSI,PII
24842 DOUBLE PRECISION S,T,EQ2,EH2,RAT,COSH
24843 LOGICAL NOMASS
24844 EXTERNAL HWULI2,HWUCI2
24845 COMMON/SMALL/EPSI
24846C-----------------------------------------------------------------------
24847C C_0(p{1,2}^2=0,2p1.p2=S;mq,mq,mq)
24848C-----------------------------------------------------------------------
24849 PII=DCMPLX(ZERO,PIFAC)
24850 IF (NOMASS) THEN
24851 RAT=DABS(S/EQ2)
24852 HWHIGC=HALF*DLOG(RAT)**2
24853 IF (S.GT.ZERO) HWHIGC=HWHIGC-HALF*PIFAC**2-PII*DLOG(RAT)
24854 HWHIGC=HWHIGC/S
24855 ELSE
24856 RAT=S/(FOUR*EQ2)
24857 IF (S.LT.ZERO) THEN
24858 HWHIGC=TWO*DLOG(DSQRT(-RAT)+DSQRT(ONE-RAT))**2/S
24859 ELSEIF (S.GT.ZERO.AND.RAT.LT.ONE) THEN
24860 HWHIGC=-TWO*(DASIN(DSQRT(RAT)))**2/S
24861 ELSEIF (RAT.GT.ONE) THEN
24862 COSH=DLOG(DSQRT(RAT)+DSQRT(RAT-ONE))
24863 HWHIGC=TWO*(COSH**2-PIFAC**2/FOUR-PII*COSH)/S
24864 ENDIF
24865 ENDIF
24866 END
24867CDECK ID>, HWHIGD.
24868*CMZ :- -23/08/94 13.22.29 by Mike Seymour
24869*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
24870C-----------------------------------------------------------------------
24871 FUNCTION HWHIGD(NOMASS,S,T,EH2,EQ2)
24872C-----------------------------------------------------------------------
24873C One loop scalar integrals, used in HWHIGJ.
24874C If NOMASS=.TRUE. use a small mass approx. for particle in loop.
24875C-----------------------------------------------------------------------
c63d70bc 24876 INCLUDE 'herwig65.inc'
65767955 24877 DOUBLE COMPLEX HWHIGD,HWUCI2,HWULI2,EPSI,PII,Z1,Z2
24878 DOUBLE PRECISION S,T,EQ2,EH2,DLS,DLT,DLM,RZ12,DL1,DL2,
24879 & ST,ROOT,XP,XM
24880 LOGICAL NOMASS
24881 EXTERNAL HWULI2,HWUCI2
24882 COMMON/SMALL/EPSI
24883C-----------------------------------------------------------------------
24884C D_0(p{1,2,3}^2=0,p4^2=EH2,2p1.p2=S,2p2.p3=T;mq,mq,mq,mq)
24885C-----------------------------------------------------------------------
24886 PII=DCMPLX(ZERO,PIFAC)
24887 IF (NOMASS) THEN
24888 DLS=DLOG(DABS(S/EQ2))
24889 DLT=DLOG(DABS(T/EQ2))
24890 DLM=DLOG(DABS(EH2/EQ2))
24891 IF (S.GE.ZERO.AND.T.LE.ZERO) THEN
24892 DL1=DLOG((EH2-T)/S)
24893 Z1=T/(T-EH2)
24894 Z2=(S-EH2)/S
24895 HWHIGD=DLS**2+DLT**2-DLM**2+DL1**2
24896 & +TWO*(DLOG(S/(EH2-T))*DLOG(-T/S)+HWULI2(Z1)-HWULI2(Z2)
24897 & +PII*DLOG(EH2/(EH2-T)))
24898 ELSEIF (S.LT.ZERO.AND.T.LT.ZERO) THEN
24899 Z1=(S-EH2)/S
24900 Z2=(T-EH2)/T
24901 RZ12=ONE/DREAL(Z1*Z2)
24902 DL1=DLOG((T-EH2)/(S-EH2))
24903 DL2=DLOG(RZ12)
24904 HWHIGD=DLS**2+DLT**2-DLM**2+TWO*PIFAC**2/THREE
24905 & +TWO*DLOG(S/(T-EH2))*DLOG(ONE/DREAL(Z2))
24906 & +TWO*DLOG(T/(S-EH2))*DLOG(ONE/DREAL(Z1))
24907 & -DL1**2-DL2**2-TWO*(HWULI2(Z1)+HWULI2(Z2))
24908 & +TWO*PII*DLOG(RZ12**2*EH2/EQ2)
24909 ENDIF
24910 HWHIGD=HWHIGD/(S*T)
24911 ELSE
24912 ST=S*T
24913 ROOT=DSQRT(ST**2-FOUR*ST*EQ2*(S+T-EH2))
24914 XP=HALF*(ST+ROOT)/ST
24915 XM=1-XP
24916 HWHIGD=TWO/ROOT*(-HWUCI2(EQ2,S,XP)-HWUCI2(EQ2,T,XP)
24917 & +HWUCI2(EQ2,EH2,XP)+DLOG(-XM/XP)
24918 & *(LOG(EQ2+EPSI)-LOG(EQ2+EPSI-S*XP*XM)
24919 & +LOG(EQ2+EPSI-EH2*XP*XM)-LOG(EQ2+EPSI-T*XP*XM)))
24920 ENDIF
24921 END
24922CDECK ID>, HWHIGE.
24923*CMZ :- -13/10/02 09.43.05 by Peter Richardson
24924*-- Author : Kosuke Odagiri and Stefano Moretti
24925C-----------------------------------------------------------------------
24926C...Generate completely differential cross section (EVWGT) in the variables
24927C...X(I) with I=1,4 (see below) for the processes from IPROC=1000-1099 (SM),
24928C...IPROC=1111-1139 (MSSM), as described in the HERWIG 6 documentation file.
24929C...(For IPROC=1140-1145 it describes MSSM charged Higgs production.)
24930C
24931C...First release: 18-SEP-2002 by Stefano Moretti
24932C
24933 SUBROUTINE HWHIGE
24934C--------------------------------------------------------------------------
24935C LEPTOPRODUCTION OF MS(SM) HIGGSES IN ASSOCIATION WITH HEAVY QUARK PAIRS
24936C--------------------------------------------------------------------------
c63d70bc 24937 INCLUDE 'herwig65.inc'
65767955 24938 INTEGER JHIGGS
24939 INTEGER I,L,M,N,NN
24940 INTEGER IH,IQ,JQ,IIQ,JJQ
24941 INTEGER IAD
24942 INTEGER IDEC,FLIP
24943 INTEGER ID1,ID2
24944 DOUBLE PRECISION CV,CA,BR
24945 DOUBLE PRECISION BRHIGQ,EMQ,ENQ,GMQ,EMQQ,EMH,GMH,EMHWT
24946 DOUBLE PRECISION T,TL,TLMIN,TLMAX,TTMIN,TTMAX,CTMP,RCM,RCM2
24947 DOUBLE PRECISION X(4),XL(4),XU(4)
24948 DOUBLE PRECISION Q4(0:3),Q34(0:3)
24949 DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4
24950 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
24951 DOUBLE PRECISION F(0:3),G(0:3)
24952 DOUBLE PRECISION ECM,SHAT,S
24953 DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM
24954 DOUBLE PRECISION HFC,HBC
24955 DOUBLE PRECISION M2EE
24956 DOUBLE PRECISION ALPHA,EMSC2
24957 DOUBLE PRECISION HWRGEN,HWUAEM
24958 DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
24959 DOUBLE PRECISION QAUX(0:3)
24960 DOUBLE PRECISION EPS,HCS,RCS,FACT
24961 DOUBLE PRECISION WEIGHT
24962 INTEGER IFL,KHIGGS,JH,JFL
24963 LOGICAL FIRST,GAUGE
24964 DOUBLE PRECISION E,Q3,YM3,GAM3,YM4,GAM4,GAM5,COLOUR
24965 DOUBLE PRECISION RM3,RM4,RM5
24966 DOUBLE PRECISION S2W,RMW,RMZ
24967 DOUBLE PRECISION RMHL,GAMHL
24968 DOUBLE PRECISION RMHH,GAMHH
24969 DOUBLE PRECISION RMHA,GAMHA
24970 EQUIVALENCE (RMHL,RMASS(203)),(RMHH,RMASS(204)),(RMHA,RMASS(205))
24971 LOGICAL HWRLOG
24972 EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2HE,HWEONE,HWRLOG
24973 PARAMETER (EPS=1.D-9)
24974 SAVE HCS,M2EE,FACT,S,SHAT,P3,P4,P5
24975 SAVE IIQ,JJQ,JHIGGS
24976C...ASSIGN Q/Q'-FLAVOUR.
24977 IF(IPROC.GE.1140)THEN
24978 IH=4
24979 IF(IPROC.EQ.1140)IQ=2
24980 IF(IPROC.EQ.1141)IQ=4
24981 IF(IPROC.EQ.1142)IQ=6
24982 IF(IPROC.EQ.1143)IQ=7
24983 IF(IPROC.EQ.1144)IQ=8
24984 IF(IPROC.EQ.1145)IQ=9
24985 IAD=7
24986 JQ=IQ+5
24987 GMQ=ZERO
24988 IF(JQ.EQ.11)GMQ=HBAR/RLTIM(6)
24989 ELSE
24990 IF(IMSSM.EQ.0)THEN
24991 IH=0
24992 IQ=6
24993 ELSE
24994 IF(IPROC.LT.1140)IH=3
24995 IF(IPROC.LT.1130)IH=2
24996 IF(IPROC.LT.1120)IH=1
24997 IQ=IPROC-1100-10*IH
24998 END IF
24999 IAD=6
25000 JQ=IQ+6
25001 GMQ=ZERO
25002 END IF
25003C...PROCESS EVENT.
25004 IF(GENEV)THEN
25005 RCS=HCS*HWRGEN(0)
25006 ELSE
25007 EVWGT=0.
25008 HCS=0.
25009C...ASSIGN FINAL STATE MASSES.
25010 IF(IQ.LE.6)THEN
25011 EMQ=RMASS(IQ)
25012 ENQ=RMASS(JQ)
25013 ELSE
25014 EMQ=RMASS(2*IQ-7+114+IAD)
25015 ENQ=RMASS(2*IQ-7+114 )
25016 END IF
25017 EMH=RMASS(201+IHIGGS)
25018 GMH=HBAR/RLTIM(201+IHIGGS)
25019 EMHWT=1.
25020C...ENERGY AT PARTON LEVEL.
25021 ECM=PBEAM1+PBEAM2
25022 S=ECM*ECM
25023 SHAT=S
25024 IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
25025C...PHASE SPACE VARIABLES.
25026C...X(1)=(EMQQ**2-(EMQ+ENQ)**2)/((ECM-EMH)**2-(EMQ+ENQ)**2),
25027C...LIGHT QUARKS -> X(2)=(LOG|T|-LOG|TMIN|)/(LOG|TMAX|-LOG|TMIN|),
25028C... X(3)=SIN(THETA4_CM_34),X(4)=COS(FI4_CM_34),
25029C...HEAVY QUARKS -> X(2)=COS(THETA5_CM),
25030C... X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34,
25031C...PHASE SPACE BORDERS.
25032 XL(1)=0.
25033 XU(1)=1.
25034 IF((IQ+JQ).EQ.18)THEN
25035 XL(2)=-1.
25036 XL(4)=0.
25037 XU(4)=2.*PIFAC
25038 ELSE
25039 XL(2)=0.
25040 XL(4)=-1.
25041 XU(4)=1.
25042 END IF
25043 XU(2)=1.
25044 XL(3)=-1.
25045 XU(3)=1.
25046C...SINGLE PHASE SPACE POINT.
25047 100 CONTINUE
25048 WEIGHT=1.
25049 DO I=1,4
25050 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
25051 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
25052 END DO
25053C...THREE PARTICLE KINEMATICS.
25054 EMQQ=SQRT(X(1)*((ECM-EMH)**2-(EMQ+ENQ)**2)+(EMQ+ENQ)**2)
25055C...INCOMING PARTONS: ALL MASSLESS.
25056 EMIN=0.
25057 IF((IQ+JQ).EQ.18)THEN
25058 CT5=X(2)
25059 CT4=X(3)
25060 ST4=SQRT(1.-CT4*CT4)
25061 CF4=COS(X(4))
25062 SF4=SIN(X(4))
25063 ELSE
25064 PCM2=((ECM*ECM-EMIN*EMIN-EMIN*EMIN)**2
25065 & -(2.*EMIN*EMIN)**2)/(4.*ECM*ECM)
25066 PCM=SQRT(PCM2)
25067 RCM2=((ECM*ECM-EMQQ*EMQQ-EMH*EMH)**2
25068 & -(2.*EMQQ*EMH)**2)/(4.*ECM*ECM)
25069 RCM=SQRT(RCM2)
25070 TTMAX=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
25071 & *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
25072 & -SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
25073 & *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
25074 TTMIN=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
25075 & *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
25076 & +SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
25077 & *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
25078 TLMIN=LOG(ABS(TTMAX))
25079 TLMAX=LOG(ABS(TTMIN))
25080 TL=X(2)*(TLMAX-TLMIN)+TLMIN
25081 T=EXP(ABS(TL))
25082 CTMP=-T-EMIN**2-EMQQ**2
25083 & +2.*SQRT(PCM**2+EMIN**2)*SQRT(RCM**2+EMQQ**2)
25084 CT5=CTMP/2./PCM/RCM
25085 ST4=X(3)
25086 CT4=SQRT(1.-ST4*ST4)
25087 CF4=X(4)
25088 SF4=SQRT(1.-CF4*CF4)
25089 END IF
25090 IF(HWRLOG(HALF))THEN
25091 ST5=+SQRT(1.-CT5*CT5)
25092 ELSE
25093 ST5=-SQRT(1.-CT5*CT5)
25094 END IF
25095 RQ52=((ECM*ECM-EMH*EMH-EMQQ*EMQQ)**2-(2.*EMH*EMQQ)**2)/
25096 & (4.*ECM*ECM)
25097 IF(RQ52.LT.0.)THEN
25098 GOTO 100
25099 ELSE
25100 RQ5=SQRT(RQ52)
25101 ENDIF
25102 P5(1)=0.
25103 P5(2)=RQ5*ST5
25104 P5(3)=RQ5*CT5
25105 P5(0)=SQRT(RQ52+EMH*EMH)
25106 DO I=1,3
25107 Q34(I)=-P5(I)
25108 END DO
25109 Q34(0)=SQRT(RQ52+EMQQ*EMQQ)
25110 RQ42=((EMQQ*EMQQ-EMQ*EMQ-ENQ*ENQ)**2-(2.*EMQ*ENQ)**2)/
25111 & (4.*EMQQ*EMQQ)
25112 IF(RQ42.LT.0.)THEN
25113 GOTO 100
25114 ELSE
25115 RQ4=SQRT(RQ42)
25116 ENDIF
25117 Q4(1)=RQ4*ST4*CF4
25118 Q4(2)=RQ4*ST4*SF4
25119 Q4(3)=RQ4*CT4
25120 Q4(0)=SQRT(RQ42+ENQ*ENQ)
25121 PQ4=0.
25122 DO I=1,3
25123 PQ4=PQ4+Q34(I)*Q4(I)
25124 END DO
25125 P4(0)=(Q34(0)*Q4(0)+PQ4)/EMQQ
25126 P3(0)=Q34(0)-P4(0)
25127 DO I=1,3
25128 P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMQQ)
25129 P3(I)=Q34(I)-P4(I)
25130 END DO
25131 IF(IMSSM.NE.0)THEN
25132 IF(IPROC.GE.1140)THEN
25133 IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
25134 ELSE
25135 IF((IQ.NE.6).AND.(IQ.NE.12).AND.
25136 & (JQ.NE.6).AND.(JQ.NE.12))THEN
25137 IF(SQRT(P3(1)**2+P3(2)**2).LT.PTMIN)RETURN
25138 IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
25139 ELSE
25140 CONTINUE
25141 END IF
25142 END IF
25143 END IF
25144C...INITIAL STATE MOMENTA IN THE PARTONIC CM.
25145 PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
25146 & -(2.*EMIN*EMIN)**2)/(4.*SHAT)
25147 PCM=SQRT(PCM2)
25148 P1(0)=SQRT(PCM2+EMIN*EMIN)
25149 P1(1)=0.
25150 P1(2)=0.
25151 P1(3)=PCM
25152 P2(0)=SQRT(PCM2+EMIN*EMIN)
25153 P2(1)=0.
25154 P2(2)=0.
25155 P2(3)=-PCM
25156C...COLOR STRUCTURED ME SUMMED/AVERAGED OVER FINAL/INITIAL SPINS AND COLORS.
25157C...EW AND QCD COUPLINGS.
25158 EMSCA=EMQ+ENQ+EMH
25159 EMSC2=EMSCA*EMSCA
25160 ALPHA=HWUAEM(EMSC2)
25161 FIRST=.TRUE.
25162 GAUGE=.FALSE.
25163 E=SQRT(4.D0*PIFAC*ALPHA)
25164 IF(IPROC.GE.1140)THEN
25165 IFL=IQ-1
25166 IF(IQ.EQ.7)IFL=IQ
25167 IF(IQ.EQ.8)IFL=IQ+1
25168 IF(IQ.EQ.9)IFL=IQ+2
25169 RM3=ENQ
25170 YM3=ENQ
25171 GAM3=0.D0
25172 RM4=EMQ
25173 YM4=EMQ
25174 GAM4=GMQ
25175C...CHARGED HIGGSES
25176 Q3=-1.D0
25177 IF(IFL.LE.6)Q3=-1.D0/3.D0
25178 JFL=0
25179 JH=IH
25180C...ASSIGN FERMION MOMENTA
25181 DO I=0,3
25182 F(I)=P4(I)
25183 G(I)=P3(I)
25184 END DO
25185 ELSE
25186 IFL=IQ
25187 IF(IQ.EQ.7)IFL=IQ
25188 IF(IQ.EQ.8)IFL=IQ+1
25189 IF(IQ.EQ.9)IFL=IQ+2
25190 RM3=EMQ
25191 YM3=EMQ
25192 GAM3=0.D0
25193 RM4=ENQ
25194 YM4=ENQ
25195 GAM4=0.D0
25196C...NEUTRAL HIGGSES
25197 IF((IFL.EQ.1).OR.(IFL.EQ.3).OR.(IFL.EQ.5 ))THEN
25198 Q3=-1.D0/3.D0
25199 ELSEIF((IFL.EQ.2).OR.(IFL.EQ.4).OR.(IFL.EQ.6 ))THEN
25200 Q3=+2.D0/3.D0
25201 ELSEIF((IFL.EQ.7).OR.(IFL.EQ.9).OR.(IFL.EQ.11))THEN
25202 Q3=-1.D0
25203 END IF
25204 IF((IFL.EQ.1).OR.(IFL.EQ.3).OR.(IFL.EQ. 5).OR.
25205 & (IFL.EQ.7).OR.(IFL.EQ.9).OR.(IFL.EQ.11))THEN
25206 JFL=1
25207 ELSEIF((IFL.EQ.2).OR.(IFL.EQ.4).OR.(IFL.EQ.6))THEN
25208 JFL=2
25209 END IF
25210 KHIGGS=IHIGGS
25211 IF(IHIGGS.NE.0)KHIGGS=IHIGGS-1
25212 JH=KHIGGS
25213C...ASSIGN FERMION MOMENTA
25214 DO I=0,3
25215 F(I)=P3(I)
25216 G(I)=P4(I)
25217 END DO
25218 END IF
25219 RM5=EMH
25220 GAM5=GMH
25221 S2W=SWEIN
25222 RMW=RMASS(198)
25223 RMZ=RMASS(200)
25224 GAMHL=HBAR/RLTIM(203)
25225 GAMHH=HBAR/RLTIM(204)
25226 GAMHA=HBAR/RLTIM(205)
25227 COLOUR=1.D0
25228 IF(IFL.LE.6)COLOUR=3.D0
25229C...MSSM COUPLINGS.
25230 IF(JH.LE.3)THEN
25231 HFC=ENHANC(IQ)
25232 HBC=ENHANC(10)
25233 ELSE
25234 HFC=ONE
25235 HBC=ONE
25236 END IF
25237C...ME.
25238 CALL HWH2HE(FIRST,GAUGE,JFL,JH,HFC,HBC,
25239 & E,S2W,TANB,ALPHAH,RMW,S,Q3,F,G,P5,
25240 & RM3,YM3,GAM3,RM4,YM4,GAM4,RM5,GAM5,
25241 & RMHL,GAMHL,RMHH,GAMHH,RMHA,GAMHA,
25242 & RMZ,GAMZ,COLOUR,M2EE)
25243C...CONSTANT FACTORS: PHI ALONG BEAM AND CONVERSION GEV^2->NB.
25244 FACT=2.*PIFAC*GEV2NB
25245C...PHASE SPACE JACOBIANS, PI'S AND FLUX.
25246 FACT=FACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5
25247 & *((ECM-EMH)**2-(EMQ+ENQ)**2)
25248 & /2./EMQQ/S
25249C...JACOBIANS FROM CT5 TO X(2).
25250 IF((IQ+JQ).EQ.18)THEN
25251 CONTINUE
25252 ELSE
25253 FACT=FACT*(TLMAX-TLMIN)/2./PCM/RCM*ABS(T)
25254 FACT=FACT*2.*ABS(ST4/CT4/SF4)
25255 END IF
25256C...CHARGE CONJUGATION.
25257 IF(IPROC.GE.1140)THEN
25258C...YES FOR CHARGED HIGGS.
25259 FACT=FACT*2.
25260 ELSE
25261C...NO FOR NEUTRAL HIGGSES.
25262 CONTINUE
25263 END IF
25264C...HIGGS RESONANCE.
25265 FACT=FACT*EMHWT
25266C...CONSTANT WEIGHT.
25267 FACT=FACT*WEIGHT
25268C...INCLUDE BR OF HIGGS.
25269 IF(IMSSM.EQ.0)THEN
25270 IDEC=MOD(IPROC,100)
25271 IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC)
25272 IF (IDEC.EQ.0) THEN
25273 BRHIGQ=0.D0
25274 DO I=1,6
25275 BRHIGQ=BRHIGQ+BRHIG(I)
25276 END DO
25277 FACT=FACT*BRHIGQ
25278 ENDIF
25279 IF (IDEC.EQ.10) THEN
25280 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
25281 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
25282 FACT=FACT*BR
25283 ELSEIF (IDEC.EQ.11) THEN
25284 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25285 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25286 FACT=FACT*BR
25287 ENDIF
25288 END IF
25289 END IF
25290C...SET UP FLAVOURS IN FINAL STATE.
25291 IF(IPROC.GE.1140)THEN
25292 IF(HWRGEN(0).LT.0.5)THEN
25293 JHIGGS=207-201
25294 IIQ=IQ
25295 JJQ=JQ
25296 FLIP=0
25297 ELSE
25298 JHIGGS=206-201
25299 IIQ=IQ-1
25300 JJQ=JQ+1
25301 FLIP=1
25302 END IF
25303 ELSE
25304 JHIGGS=IHIGGS
25305 IIQ=IQ
25306 JJQ=JQ
25307 FLIP=0
25308 END IF
25309 HCS=FACT*M2EE
25310 IF (GENEV.AND.HCS.GT.RCS) THEN
25311C...GENERATE EVENT.
25312 IDN(1)=IDHW(1)
25313 IDN(2)=IDHW(2)
25314 IF(IIQ.LE.12.AND.JJQ.LE.12)THEN
25315 IDN(3)=IIQ
25316 IDN(4)=JJQ
25317 ELSE
25318 IDN(3)=2*IIQ-7+114
25319 IDN(4)=2*IIQ-7+114+IAD
25320 END IF
25321 IDN(5)=201+JHIGGS
25322C...INCOMING PARTONS: NOW MASSIVE.
25323 EMIN1=RMASS(IDN(1))
25324 EMIN2=RMASS(IDN(2))
25325C...REDO INITIAL STATE MOMENTA IN THE PARTONIC CM.
25326 PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
25327 & -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
25328 PCM=SQRT(PCM2)
25329 P1(0)=SQRT(PCM2+EMIN1*EMIN1)
25330 P1(1)=0.
25331 P1(2)=0.
25332 P1(3)=PCM
25333 P2(0)=SQRT(PCM2+EMIN2*EMIN2)
25334 P2(1)=0.
25335 P2(2)=0.
25336 P2(3)=-PCM
25337C...SETS UP INCOMING STATUS AND IDS ONLY FOR 2->1: USE HWEONE.
25338 IDCMF=15
25339 XX(1)=ONE
25340 XX(2)=ONE
25341 CALL HWEONE
25342 JDAHEP(1,NHEP )=NHEP+1
25343 JDAHEP(2,NHEP )=NHEP+3
25344 JMOHEP(1,NHEP+1)=NHEP
25345 JMOHEP(1,NHEP+2)=NHEP
25346 JMOHEP(1,NHEP+3)=NHEP
25347C...RANDOMLY ROTATE FINAL STATE MOMENTA AROUND BEAM AXIS.
25348 PHI=2.*PIFAC*HWRGEN(0)
25349 CPHI=COS(PHI)
25350 SPHI=SIN(PHI)
25351 ROT(1,1)=+CPHI
25352 ROT(1,2)=+SPHI
25353 ROT(1,3)=0.
25354 ROT(2,1)=-SPHI
25355 ROT(2,2)=+CPHI
25356 ROT(2,3)=0.
25357 ROT(3,1)=0.
25358 ROT(3,2)=0.
25359 ROT(3,3)=1.
25360 DO L=1,3
25361 DO M=1,3
25362 QAUX(M)=0.
25363 DO N=1,3
25364 IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
25365 IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
25366 IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
25367 END DO
25368 END DO
25369 DO M=1,3
25370 IF(L.EQ.1)P3(M)=QAUX(M)
25371 IF(L.EQ.2)P4(M)=QAUX(M)
25372 IF(L.EQ.3)P5(M)=QAUX(M)
25373 END DO
25374 END DO
25375C...DO REAL INCOMING, OUTGOING MOMENTA IN THE LAB FRAME.
25376 DO M=NHEP-2,NHEP+3
25377 IF(M.EQ.NHEP )GO TO 888
25378 DO N=0,3
25379 NN=N
25380 IF(N.EQ.0)NN=4
25381 IF(M.EQ.NHEP-2)PHEP(NN,M)=P1(N)
25382 IF(M.EQ.NHEP-1)PHEP(NN,M)=P2(N)
25383 IF(M.EQ.NHEP+1)PHEP(NN,M)=P3(N)*(1-FLIP)+P4(N)*FLIP
25384 IF(M.EQ.NHEP+2)PHEP(NN,M)=P4(N)*(1-FLIP)+P3(N)*FLIP
25385 IF(M.EQ.NHEP+3)PHEP(NN,M)=P5(N)
25386 END DO
25387 888 CONTINUE
25388 END DO
25389C...NEEDS TO SET ALL FINAL STATE MASSES.
25390 PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2
25391 & -PHEP(3,NHEP+1)**2
25392 & -PHEP(2,NHEP+1)**2
25393 & -PHEP(1,NHEP+1)**2))
25394 PHEP(5,NHEP+2)=SQRT(ABS(PHEP(4,NHEP+2)**2
25395 & -PHEP(3,NHEP+2)**2
25396 & -PHEP(2,NHEP+2)**2
25397 & -PHEP(1,NHEP+2)**2))
25398 PHEP(5,NHEP+3)=SQRT(ABS(PHEP(4,NHEP+3)**2
25399 & -PHEP(3,NHEP+3)**2
25400 & -PHEP(2,NHEP+3)**2
25401 & -PHEP(1,NHEP+3)**2))
25402C...SETS CMF.
25403 DO I=1,4
25404 PHEP(I,NHEP )=PHEP(I,NHEP-2)+PHEP(I,NHEP-1)
25405 END DO
25406 PHEP(5,NHEP )=SQRT(ABS(PHEP(4,NHEP )**2
25407 & -PHEP(3,NHEP )**2
25408 & -PHEP(2,NHEP )**2
25409 & -PHEP(1,NHEP )**2))
25410C...SETS UP OUTGOING STATUS AND IDS.
25411 ISTHEP(NHEP+1)=113
25412 ISTHEP(NHEP+2)=114
25413 ISTHEP(NHEP+3)=114
25414 IDHW(NHEP+1)=IDN(3)
25415 IDHEP(NHEP+1)=IDPDG(IDN(3))
25416 IDHW(NHEP+2)=IDN(4)
25417 IDHEP(NHEP+2)=IDPDG(IDN(4))
25418 IDHW(NHEP+3)=IDN(5)
25419 IDHEP(NHEP+3)=IDPDG(IDN(5))
25420C...SETS UP COLOUR CONNECTIONS.
25421 JMOHEP(2,NHEP+1)=NHEP+2
25422 JMOHEP(2,NHEP+2)=NHEP+1
25423 JMOHEP(2,NHEP-1)=NHEP-2
25424 JMOHEP(2,NHEP-2)=NHEP-1
25425 JMOHEP(2,NHEP+3)=NHEP+3
25426 JDAHEP(2,NHEP+1)=NHEP+2
25427 JDAHEP(2,NHEP+2)=NHEP+1
25428 JDAHEP(2,NHEP-1)=NHEP-1
25429 JDAHEP(2,NHEP-2)=NHEP-2
25430 JDAHEP(2,NHEP+3)=NHEP+3
25431 NHEP=NHEP+3
25432 IF(AZSPIN)THEN
25433C...SET TO ZERO THE COEFFICIENTS OF THE SPIN DENSITY MATRICES.
25434 CALL HWVZRO(7,GCOEF)
25435 END IF
25436 END IF
25437C...COLLECT WEIGHT.
25438 EVWGT=HCS
25439 END
25440CDECK ID>, HWHIGH.
25441*CMZ :- -26/11/00 17.21.55 by Bryan Webber
25442*-- Author : Kosuke Odagiri & Stefano Moretti
25443C-----------------------------------------------------------------------
25444C...Generate completely differential cross section (EVWGT) in the variables
25445C...X(I) with I=1,3 (see below) for the processes IPROC=3315,3325,3335,3355,
25446C...3365,3375 as described in the HERWIG 6 documentation file.
25447C...It includes interface to PDFs and takes into account color connections
25448C...among partons.
25449C
25450C...First release: 16-AUG-1999 by Kosuke Odagiri
25451C...Last modified: 26-SEP-1999 by Stefano Moretti
25452C-----------------------------------------------------------------------
25453 SUBROUTINE HWHIGH
25454C-----------------------------------------------------------------------
25455C DRELL-YAN 2 PARTON -> 2 HIGGS PAIR (2HDM)
25456C-----------------------------------------------------------------------
c63d70bc 25457 INCLUDE 'herwig65.inc'
65767955 25458 DOUBLE PRECISION HWRGEN, HWUAEM, EPS, HCS, RCS, DIST, S, PF, QPE,
25459 & FACTR, SN2TH, MZ, MW, MNN(2,2), MCC(2), MCN(3), EMSC2, GW2, GZ2,
25460 & GHH(4), XWEIN, S2W, ECM_MAX, X(3), XL(3),
25461 & XU(3), WEIGHT, ECM, SHAT, TAU, RMH1, RMH2, EMH1, EMH2,
25462 & EMHWT1, EMHWT2, EMHHWT
25463 INTEGER I, J, IQ, IQ1, IQ2, ID1, ID2, IH, JH, IH1, IH2
25464 EXTERNAL HWRGEN, HWUAEM
25465 SAVE HCS,MNN,MCC,MCN,EMHHWT,S,SHAT
25466 PARAMETER (EPS = 1.D-9)
25467 DOUBLE COMPLEX Z, GZ, A, D, E
25468 PARAMETER (Z = (0.D0,1.D0))
25469 EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
25470C...process event.
25471 IF (GENEV) THEN
25472 RCS = HCS*HWRGEN(0)
25473 ELSE
25474 HCS = ZERO
25475 EVWGT = ZERO
25476C...minimum transverse momentum.
25477 PTMIN = ZERO
25478C...energy at hadron level.
25479 ECM_MAX=PBEAM1+PBEAM2
25480 S=ECM_MAX*ECM_MAX
25481C...phase space variables.
25482C...X(1)=COS(THETA_CM),
25483C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMH1+EMH2)**2-1./ECM_MAX**2),
25484C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
25485C...phase space borders.
25486 XL(1)=-1.
25487 XU(1)=1.
25488 XL(2)=0.
25489 XU(2)=1.
25490 XL(3)=0.
25491 XU(3)=1.
25492C...single phase space point.
25493 WEIGHT=1.
25494 DO I=1,3
25495 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
25496 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
25497 END DO
25498C...final state masses.
25499 IF((MOD(IPROC,10000).EQ.3365).OR.
25500 & (MOD(IPROC,10000).EQ.3375))THEN
25501 JH = IHIGGS-1
25502 ID1 = 205
25503 ID2 = 202 + JH
25504 ELSE IF(MOD(IPROC,10000).EQ.3355)THEN
25505 JH = 4
25506 ID1 = 206
25507 ID2 = 207
25508 ELSE IF((MOD(IPROC,10000).EQ.3315).OR.
25509 & (MOD(IPROC,10000).EQ.3325).OR.
25510 & (MOD(IPROC,10000).EQ.3335))THEN
25511 JH = IHIGGS-1
25512 ID1 = 206
25513 ID2 = 202 + JH
25514 END IF
25515 RMH1=RMASS(ID1)
25516 RMH2=RMASS(ID2)
25517 EMH1=RMH1
25518 EMH2=RMH2
25519 EMHWT1=1.
25520 EMHWT2=1.
25521 EMHHWT=EMHWT1*EMHWT2
25522C...energy at parton level.
25523 ECM=SQRT(1./(X(2)*(1./(EMH1+EMH2)**2-1./ECM_MAX**2)
25524 & +1./ECM_MAX**2))
25525 IF((EMH1.LE.0.).OR.(EMH1.GE.ECM))RETURN
25526 IF((EMH2.LE.0.).OR.(EMH2.GE.ECM))RETURN
25527 SHAT=ECM*ECM
25528 TAU=SHAT/S
25529C...momentum fractions X1 and X2.
25530 XX(1) = EXP(LOG(TAU)*(1.-X(3)))
25531 XX(2) = TAU/XX(1)
25532 COSTH = X(1)
25533 SN2TH = 0.25D0 - 0.25D0*COSTH**2
25534 EMSCA = EMH1+EMH2
25535 EMSC2 = EMSCA*EMSCA
25536 CALL HWSGEN(.FALSE.)
25537 EVWGT = ZERO
25538 FACTR = GEV2NB*PIFAC*(HWUAEM(EMSC2))**2/SHAT/CAFAC*SN2TH/2.
25539C...Jacobians from X1,X2 to X(2),X(3).
25540 FACTR = FACTR/S*(-LOG(TAU))*(1./(EMH1+EMH2)**2-1./ECM_MAX**2)
25541C...constant weight.
25542 FACTR = FACTR*WEIGHT
25543C...couplings and propagators.
25544 XWEIN = TWO*SWEIN
25545 S2W = DSQRT(XWEIN*(TWO-XWEIN))
25546 GZ = S2W*(SHAT-MZ**2+Z*SHAT*GAMZ/MZ)/SHAT
25547 GZ2 = DREAL(DCONJG(GZ)*GZ)
25548 GW2 = ((ONE-MW**2/SHAT)**2+(GAMW/MW)**2)*XWEIN**2
25549C...labels: 1 = h0, 2 = H0, 3 = A0, 4 = H+, 5 = H-.
25550 GHH(1)= COSBMA
25551 GHH(2)= SINBMA
25552 GHH(3)= ONE
25553 GHH(4)= ONE-XWEIN
25554C...set to zero all MEs.
25555 DO I=1,2
25556 MCC(I)=ZERO
25557 MCN(I)=ZERO
25558 DO J=1,2
25559 MNN(I,J)=ZERO
25560 END DO
25561 END DO
25562 MCN(3)=ZERO
25563C...start subprocesses.
25564 IF((MOD(IPROC,10000).EQ.3365).OR.
25565 & (MOD(IPROC,10000).EQ.3375))THEN
25566c
25567c _ o o o
25568c q q -> A h / H
25569c
25570 DO IH = JH,JH
25571 QPE = SHAT-(EMH1+EMH2)**2
25572 IF (QPE.GT.ZERO) THEN
25573 PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
25574 DO IQ = 1,2
25575 MNN(IH,IQ) =
25576 & FACTR*PF**3*GHH(IH)**2*(LFCH(IQ)**2+RFCH(IQ)**2)/GZ2
25577 END DO
25578 ELSE
25579 CONTINUE
25580 END IF
25581 END DO
25582 ELSE IF(MOD(IPROC,10000).EQ.3355)THEN
25583c
25584c _ + -
25585c q q -> H H
25586c
25587 IH = JH
25588 QPE = SHAT-(EMH1+EMH2)**2
25589 IF (QPE.GT.ZERO) THEN
25590 PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
25591 DO IQ = 1,2
25592 A = GHH(IH)/GZ
25593 D = QFCH(IQ)+A*LFCH(IQ)
25594 E = QFCH(IQ)+A*RFCH(IQ)
25595 MCC(IQ)=FACTR*PF**3*DREAL(DCONJG(D)*D+DCONJG(E)*E)
25596 END DO
25597 ELSE
25598 CONTINUE
25599 END IF
25600 ELSE IF((MOD(IPROC,10000).EQ.3315).OR.
25601 & (MOD(IPROC,10000).EQ.3325).OR.
25602 & (MOD(IPROC,10000).EQ.3335))THEN
25603c
25604c _ +- o o o
25605c q q' -> H h / H / A
25606c
25607 DO IH = JH,JH
25608 QPE = SHAT-(EMH1+EMH2)**2
25609 IF (QPE.GT.ZERO) THEN
25610 PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
25611 MCN(IH)=FACTR*PF**3/GW2*HALF*GHH(IH)**2
25612 ELSE
25613 CONTINUE
25614 END IF
25615 END DO
25616 END IF
25617 END IF
25618 HCS = 0.D0
25619C...start PDFs.
25620 DO 1 ID1 = 1, 12
25621 IF (DISF(ID1,1).LT.EPS) GOTO 1
25622 IF (ID1.GT.6) THEN
25623 ID2 = ID1 - 6
25624 ELSE
25625 ID2 = ID1 + 6
25626 END IF
25627 IQ = ID1 - ((ID1-1)/2)*2
25628 IF (DISF(ID2,2).LT.EPS) GOTO 1
25629 DIST = DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25630 IH1 = 205
25631 IH2 = 203
25632 HCS = HCS + DIST*EMHHWT*MNN(1,IQ)
25633 IF (GENEV.AND.HCS.GT.RCS) THEN
25634 CALL HWHQCP(IH1,IH2,2134,1)
25635 GOTO 9
25636 ENDIF
25637 IH2 = 204
25638 HCS = HCS + DIST*EMHHWT*MNN(2,IQ)
25639 IF (GENEV.AND.HCS.GT.RCS) THEN
25640 CALL HWHQCP(IH1,IH2,2134,2)
25641 GOTO 9
25642 ENDIF
25643 IH1 = 206
25644 IH2 = 207
25645 HCS = HCS + DIST*EMHHWT*MCC(IQ)
25646 IF (GENEV.AND.HCS.GT.RCS) THEN
25647 CALL HWHQCP(IH1,IH2,2134,3)
25648 GOTO 9
25649 ENDIF
25650 1 CONTINUE
25651c _ _ _ _
25652c ud(+), ud(-), du(-), du(+)
25653c
25654 DO 2 IQ1 = 1, 3
25655 DO IQ2 = 1, 3
25656 IF(VCKM(IQ1,IQ2).GT.EPS) THEN
25657c _
25658c ud (+)
25659c
25660 ID1 = IQ1 * 2
25661 ID2 = IQ2 * 2 + 5
25662 IH1 = 206
25663 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25664 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25665 DO IH = 1,3
25666 IH2 = 202+IH
25667 HCS = HCS + DIST*EMHHWT*MCN(IH)
25668 IF (GENEV.AND.HCS.GT.RCS) THEN
25669 CALL HWHQCP(IH1,IH2,2134,3+IH)
25670 GOTO 9
25671 ENDIF
25672 END DO
25673 END IF
25674c _
25675c du (+)
25676c
25677 ID1 = IQ2 * 2 + 5
25678 ID2 = IQ1 * 2
25679 IH1 = 206
25680 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25681 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25682 DO IH = 1,3
25683 IH2 = 202+IH
25684 HCS = HCS + DIST*EMHHWT*MCN(IH)
25685 IF (GENEV.AND.HCS.GT.RCS) THEN
25686 CALL HWHQCP(IH1,IH2,2134,3+IH)
25687 GOTO 9
25688 ENDIF
25689 END DO
25690 END IF
25691c _
25692c du (-)
25693c
25694 ID1 = IQ2 * 2 - 1
25695 ID2 = IQ1 * 2 + 6
25696 IH1 = 207
25697 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25698 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25699 DO IH = 1,3
25700 IH2 = 202+IH
25701 HCS = HCS + DIST*EMHHWT*MCN(IH)
25702 IF (GENEV.AND.HCS.GT.RCS) THEN
25703 CALL HWHQCP(IH1,IH2,2134,3+IH)
25704 GOTO 9
25705 ENDIF
25706 END DO
25707 END IF
25708c _
25709c ud (-)
25710c
25711 ID1 = IQ1 * 2 + 6
25712 ID2 = IQ2 * 2 - 1
25713 IH1 = 207
25714 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
25715 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)*S*SHAT
25716 DO IH = 1,3
25717 IH2 = 202+IH
25718 HCS = HCS + DIST*EMHHWT*MCN(IH)
25719 IF (GENEV.AND.HCS.GT.RCS) THEN
25720 CALL HWHQCP(IH1,IH2,2134,3+IH)
25721 GOTO 9
25722 ENDIF
25723 END DO
25724 END IF
25725 END IF
25726 END DO
25727 2 CONTINUE
25728 EVWGT = HCS
25729 RETURN
25730C...generate event.
25731 9 IDN(1)=ID1
25732 IDN(2)=ID2
25733 IDCMF=15
25734 CALL HWETWO(.TRUE.,.TRUE.)
25735 IF (AZSPIN) THEN
25736 CALL HWVZRO(7,GCOEF)
25737 END IF
25738 END
25739CDECK ID>, HWHIGJ.
25740*CMZ :- -23/08/94 13.22.29 by Mike Seymour
25741*-- Author : Ian Knowles
25742C-----------------------------------------------------------------------
25743 SUBROUTINE HWHIGJ
25744C-----------------------------------------------------------------------
25745C QCD Higgs plus jet production; mean EVWGT = Sigma in nb*Higgs B.R.
25746C Adapted from the program of U. Baur and E.W.N. Glover
25747C See: Nucl. Phys. B339 (1990) 38
25748C-----------------------------------------------------------------------
c63d70bc 25749 INCLUDE 'herwig65.inc'
65767955 25750 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWUAEM,EPS,RCS,EMH,EMHWT,
25751 & EMHTMP,BR,CV,CA,EMH2,ET,EJ,PT,EMT,EMAX,YMAX,YHINF,YHSUP,EXYH,
25752 & YMIN,YJINF,YJSUP,EXYJ,S,T,U,FACT,AMPQQ,AMPQG,AMPGQ,AMPGG,HCS,
25753 & FACTR
25754 INTEGER I,IDEC,ID1,ID2
25755 EXTERNAL HWRGEN,HWRUNI,HWUALF,HWUAEM
25756 SAVE HCS,AMPGG,AMPGQ,AMPQG,AMPQQ,EMH,FACT
25757 PARAMETER (EPS=1.D-9)
25758 IF (GENEV) THEN
25759 RCS=HCS*HWRGEN(0)
25760 ELSE
25761 EVWGT=0.
25762C Select a Higgs mass
25763 CALL HWHIGM(EMH,EMHWT)
25764 IF (EMH.LE.ZERO .OR. EMH.GE.PHEP(5,3)) RETURN
25765C Store branching ratio for specified Higgs deacy channel
25766 IDEC=MOD(IPROC,100)
25767 BR=1.
25768 IF (IDEC.EQ.0) THEN
25769 BR=0.
25770 DO 10 I=1,6
25771 10 BR=BR+BRHIG(I)
25772 ELSEIF (IDEC.EQ.10) THEN
25773 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
25774 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
25775 BR=BR*BRHIG(IDEC)
25776 ELSEIF (IDEC.EQ.11) THEN
25777 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25778 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
25779 BR=BR*BRHIG(IDEC)
25780 ELSEIF (IDEC.LE.12) THEN
25781 BR=BRHIG(IDEC)
25782 ENDIF
25783C Select subprocess kinematics
25784 EMH2=EMH**2
25785 CALL HWRPOW(ET,EJ)
25786 PT=.5*ET
25787 EMT=SQRT(PT**2+EMH2)
25788 EMAX=0.5*(PHEP(5,3)+EMH2/PHEP(5,3))
25789 IF (EMAX.LE.EMT) RETURN
25790 YMAX=LOG((EMAX+SQRT(EMAX**2-EMT**2))/EMT)
25791 YHINF=MAX(YJMIN,-YMAX)
25792 YHSUP=MIN(YJMAX, YMAX)
25793 IF (YHSUP.LE.YHINF) RETURN
25794 EXYH=EXP(HWRUNI(1,YHINF,YHSUP))
25795 YMIN=LOG(PT/(PHEP(5,3)-EMT/EXYH))
25796 YMAX=LOG((PHEP(5,3)-EMT*EXYH)/PT)
25797 YJINF=MAX(YJMIN,YMIN)
25798 YJSUP=MIN(YJMAX,YMAX)
25799 IF (YJSUP.LE.YJINF) RETURN
25800 EXYJ=EXP(HWRUNI(2,YJINF,YJSUP))
25801 XX(1)=(EMT*EXYH+PT*EXYJ)/PHEP(5,3)
25802 XX(2)=(EMT/EXYH+PT/EXYJ)/PHEP(5,3)
25803 S=XX(1)*XX(2)*PHEP(5,3)**2
25804 T=EMH2-XX(1)*EMT*PHEP(5,3)/EXYH
25805 U=EMH2-S-T
25806 COSTH=(S+2.*T-EMH2)/(S-EMH2)
25807C Set subprocess scale
25808 EMSCA=EMT
25809 CALL HWSGEN(.FALSE.)
25810 FACT=GEV2NB*PT*EJ*(YHSUP-YHINF)*(YJSUP-YJINF)*BR*EMHWT
25811 & *HWUALF(1,EMSCA)**3*HWUAEM(EMH2)/(SWEIN*16*PIFAC*S**2)
25812 CALL HWHIGA(S,T,U,EMH2,AMPQQ,AMPQG,AMPGQ,AMPGG)
25813 ENDIF
25814 HCS=0.
25815 DO 30 ID1=1,13
25816 IF (DISF(ID1,1).LT.EPS) GOTO 30
25817 FACTR=FACT*DISF(ID1,1)
25818 IF (ID1.LT.7) THEN
25819C Quark first:
25820 ID2=ID1+6
25821 HCS=HCS+FACTR*DISF(ID2,2)*AMPQQ
25822 IF (GENEV.AND.HCS.GT.RCS) THEN
25823 CALL HWHQCP(13 ,201,2314,81)
25824 GOTO 99
25825 ENDIF
25826 ID2=13
25827 HCS=HCS+FACTR*DISF(ID2,2)*AMPQG
25828 IF (GENEV.AND.HCS.GT.RCS) THEN
25829 CALL HWHQCP(ID1,201,3124,82)
25830 GOTO 99
25831 ENDIF
25832 ELSEIF (ID1.LT.13) THEN
25833C Antiquark first:
25834 ID2=ID1-6
25835 HCS=HCS+FACTR*DISF(ID2,2)*AMPQQ
25836 IF (GENEV.AND.HCS.GT.RCS) THEN
25837 CALL HWHQCP(13 ,201,3124,83)
25838 GOTO 99
25839 ENDIF
25840 ID2=13
25841 HCS=HCS+FACTR*DISF(ID2,2)*AMPQG
25842 IF (GENEV.AND.HCS.GT.RCS) THEN
25843 CALL HWHQCP(ID1,201,2314,84)
25844 GOTO 99
25845 ENDIF
25846 ELSE
25847C Gluon first:
25848 DO 20 ID2=1,12
25849 IF (DISF(ID2,2).LT.EPS) GOTO 20
25850 IF (ID2.LT.7) THEN
25851 HCS=HCS+FACTR*DISF(ID2,2)*AMPGQ
25852 IF (GENEV.AND.HCS.GT.RCS) THEN
25853 CALL HWHQCP(ID2,201,2314,85)
25854 GOTO 99
25855 ENDIF
25856 ELSE
25857 HCS=HCS+FACTR*DISF(ID2,2)*AMPGQ
25858 IF (GENEV.AND.HCS.GT.RCS) THEN
25859 CALL HWHQCP(ID2,201,3124,86)
25860 GOTO 99
25861 ENDIF
25862 ENDIF
25863 20 CONTINUE
25864 HCS=HCS+FACTR*DISF(13,2)*AMPGG
25865 IF (GENEV.AND.HCS.GT.RCS) THEN
25866 CALL HWHQCP(13 ,201,2314,87)
25867 GOTO 99
25868 ENDIF
25869 ENDIF
25870 30 CONTINUE
25871 EVWGT=HCS
25872 RETURN
25873C Generate event
25874 99 IDN(1)=ID1
25875 IDN(2)=ID2
25876 IDCMF=15
25877C Trick HWETWO into using off-shell Higgs mass
25878 EMHTMP=RMASS(IDN(4))
25879 RMASS(IDN(4))=EMH
25880C-- BRW fix 27/8/04: avoid double smearing of H mass
25881 CALL HWETWO(.TRUE.,.FALSE.)
25882 RMASS(IDN(4))=EMHTMP
25883 END
25884CDECK ID>, HWHIGM.
25885*CMZ :- -02/05/91 11.17.14 by Federico Carminati
25886*-- Author : Mike Seymour
25887C-----------------------------------------------------------------------
25888 SUBROUTINE HWHIGM(EM,WEIGHT)
25889C-----------------------------------------------------------------------
25890C CHOOSE HIGGS MASS:
25891C IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.2) THEN
25892C CHOOSE HIGGS MASS ACCORDING TO
25893C EM**4 / (EM**2-EMH**2)**2 + (GAMH*EMH)**2
25894C ELSE
25895C CHOOSE HIGGS MASS ACCORDING TO
25896C EMH * GAMH / (EM**2-EMH**2)**2 + (GAMH*EMH)**2
25897C ENDIF
25898C IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.1) THEN
25899C SUPPLY WEIGHT FACTOR TO YIELD
25900C EM * GAM(EM)/ (EM**2-EMH**2)**2 + (GAM(EM)*EM)**2
25901C ELSE
25902C SUPPLY WEIGHT FACTOR TO YIELD
25903C EM*(EMH/EM)**4 * GAM(EM)
25904C / (EM**2-EMH**2)**2 + (GAM(EM)*EMH**2/EM)**2
25905C AS SUGGESTED IN M.H.SEYMOUR, PHYS.LETT.B354(1995)409.
25906C ENDIF
25907C-----------------------------------------------------------------------
c63d70bc 25908 INCLUDE 'herwig65.inc'
65767955 25909 DOUBLE PRECISION HWRUNI,EM,WEIGHT,EMH,DIF,FUN,THETA,T,EMHLST,W0,
25910 & W1,EMM,GAMEM,T0,TMIN,TMAX,THEMIN,THEMAX,ZMIN,ZMAX,Z,F,GAMOFS
25911 INTEGER I
25912 EXTERNAL HWRUNI
25913 SAVE EMHLST,GAMEM,T0,TMIN,TMAX,THEMIN,THEMAX,ZMIN,ZMAX,W0,W1
25914 EQUIVALENCE (EMH,RMASS(201))
25915 DATA EMHLST/0D0/
25916C---SET UP INTEGRAND AND INDEFINITE INTEGRAL OF DISTRIBUTION
25917C THETA=ATAN((EM**2-EMH**2)/(GAMH*EMH)); T=TAN(THETA); T0=EMH/GAMH
25918 DIF(T,T0)=(T+T0)**2
25919 FUN(THETA,T,T0)=T + (T0*T0-1)*THETA + T0*LOG(1+T*T)
25920C---SET UP CONSTANTS
25921 IF (EMH.NE.EMHLST .OR. FSTWGT) THEN
25922 EMHLST=EMH
25923 GAMEM=GAMH*EMH
25924 T0=EMH/GAMH
25925 TMIN=(MAX(ONE*1E-10,EMH-GAMMAX*GAMH))**2/GAMEM-T0
25926 TMAX=( EMH+GAMMAX*GAMH )**2/GAMEM-T0
25927 THEMIN=ATAN(TMIN)
25928 THEMAX=ATAN(TMAX)
25929 ZMIN=FUN(THEMIN,TMIN,T0)
25930 ZMAX=FUN(THEMAX,TMAX,T0)
25931 W0=(ZMAX-ZMIN) / PIFAC * GAMEM
25932 W1=(THEMAX-THEMIN) / PIFAC
25933 ENDIF
25934C---CHOOSE HIGGS MASS
25935 IF (IOPHIG.EQ.0.OR.IOPHIG.EQ.2) THEN
25936 EM=0
25937 WEIGHT=0
25938 Z=HWRUNI(1,ZMIN,ZMAX)
25939C---SOLVE FUN(THETA,TAN(THETA))=Z BY NEWTON'S METHOD
25940 THETA=MAX(THEMIN, MIN(THEMAX, Z/T0**2 ))
25941 I=1
25942 F=0
25943 10 IF (I.LE.20 .AND. ABS(1-F/Z).GT.1E-4) THEN
25944 I=I+1
25945 IF (2*ABS(THETA).GT.PIFAC) THEN
25946 CALL HWWARN('HWHIGM',51)
25947 GOTO 999
25948 ENDIF
25949 T=TAN(THETA)
25950 F=FUN(THETA,T,T0)
25951 THETA=THETA-(F-Z)/DIF(T,T0)
25952 GOTO 10
25953 ENDIF
25954 IF (I.GT.20) CALL HWWARN('HWHIGM',1)
25955 ELSE
25956 THETA=HWRUNI(0,THEMIN,THEMAX)
25957 ENDIF
25958 EM=SQRT(GAMEM*(T0+TAN(THETA)))
25959C---NOW CALCULATE WEIGHT FACTOR FOR NON-CONSTANT HIGGS WIDTH
25960 GAMOFS=EM
25961 CALL HWDHIG(GAMOFS)
25962 IF (IOPHIG.EQ.0) THEN
25963 WEIGHT=W0*GAMOFS*EM /EM**4 *((EM**2-EMH**2)**2 + GAMEM**2)
25964 & /((EM**2-EMH**2)**2 +(GAMOFS*EM)**2)
25965 ELSEIF (IOPHIG.EQ.1) THEN
25966 WEIGHT=W1*GAMOFS*EM /GAMEM *((EM**2-EMH**2)**2 + GAMEM**2)
25967 & /((EM**2-EMH**2)**2 +(GAMOFS*EM)**2)
25968 ELSEIF (IOPHIG.EQ.2) THEN
25969 EMM=EM*(EMH/EM)**4
25970 WEIGHT=W0*GAMOFS*EMM/EM**4 *((EM**2-EMH**2)**2 + GAMEM**2)
25971 & /((EM**2-EMH**2)**2 +(GAMOFS*EMM)**2)
25972 ELSEIF (IOPHIG.EQ.3) THEN
25973 EMM=EM*(EMH/EM)**4
25974 WEIGHT=W1*GAMOFS*EMM/GAMEM *((EM**2-EMH**2)**2 + GAMEM**2)
25975 & /((EM**2-EMH**2)**2 +(GAMOFS*EMM)**2)
25976 ELSE
25977 CALL HWWARN('HWHIGM',500)
25978 ENDIF
25979 999 RETURN
25980 END
25981CDECK ID>, HWHIGQ.
25982*CMZ :- -26/11/00 17.21.55 by Bryan Webber
25983*-- Author : Stefano Moretti
25984C-----------------------------------------------------------------------
25985C...Generate completely differential cross section (EVWGT) in the variables
25986C...X(I) with I=1,6 (see below) for the processes from IPROC=2500-2599 (SM),
25987C...IPROC=3811-3899, as described in the HERWIG 6 documentation file.
25988C...(For IPROC=3839,3869,3899 it describes MSSM charged Higgs production.)
25989C...It includes interface to PDFs and takes into account color connections
25990C...among partons.
25991C
25992C...First release: 08-APR-1999 by Stefano Moretti
25993C...Last modified: 28-JUN-2001 by Stefano Moretti
25994C
25995 SUBROUTINE HWHIGQ
25996C-----------------------------------------------------------------------
25997C PRODUCTION OF MSSM HIGGSES IN ASSOCIATION WITH HEAVY QUARK PAIRS
25998C-----------------------------------------------------------------------
c63d70bc 25999 INCLUDE 'herwig65.inc'
65767955 26000 INTEGER JHIGGS
26001 INTEGER I,J,K,L,M,N
26002 INTEGER IS,IH,IQ,JQ,IIQ,JJQ,IQMIN,IQMAX,IGG,IQQ
26003 INTEGER IDEC,NC,FLIP
26004 INTEGER ID1,ID2
26005 DOUBLE PRECISION CV,CA,BR
26006 DOUBLE PRECISION BRHIGQ,EMQ,ENQ,EMQQ,EMH,EMHWT,EMW
26007 DOUBLE PRECISION PTMMIN,PTNMIN
26008 DOUBLE PRECISION T,TL,TLMIN,TLMAX,TTMIN,TTMAX,CTMP,RCM,RCM2
26009 DOUBLE PRECISION X(6),XL(6),XU(6)
26010 DOUBLE PRECISION Q4(0:3),Q34(0:3)
26011 DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4
26012 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
26013 DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
26014 DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM
26015 DOUBLE PRECISION M2GG,M2GGPL,M2GGMN,M2QQ
26016 DOUBLE PRECISION GM,GRND,FACGPM(2)
26017 DOUBLE PRECISION GGQQHT,GGQQHU,GGQQHNP,QQQQH
26018 DOUBLE PRECISION ALPHA,ALPHAS,EMSC2
26019 DOUBLE PRECISION HWRGEN,HWUAEM,HWUALF
26020 DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
26021 DOUBLE PRECISION VCOL,GCOL,QAUX(0:3)
26022 DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
26023 DOUBLE PRECISION WEIGHT
26024 SAVE HCS,M2QQ,M2GG,M2GGPL,M2GGMN,FACT,S,SHAT,P3,P4,P5
26025 SAVE IIQ,JJQ,JHIGGS
26026 LOGICAL HWRLOG
26027 EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWUALF,HWHQCP,HWH2QH,HWETWO,HWRLOG
26028 PARAMETER (EPS=1.D-9)
26029 EQUIVALENCE (EMW,RMASS(198)),(NC,NCOLO)
26030C...assign Q/Q'-flavour.
26031 IF((MOD(IPROC,10000).EQ.3839).OR.
26032 & (MOD(IPROC,10000).EQ.3869).OR.
26033 & (MOD(IPROC,10000).EQ.3899))THEN
26034 IQ=6
26035 JQ=11
26036 GM=HBAR/RLTIM(6)*RMASS(6)
26037 ELSE
26038 IF(IMSSM.EQ.0)THEN
26039 IS=0
26040 IH=0
26041 IQ=6
26042 ELSE
26043 IF(MOD(IPROC,10000).LT.4000)IS=6
26044 IF(MOD(IPROC,10000).LT.3870)IS=3
26045 IF(MOD(IPROC,10000).LT.3840)IS=0
26046 IH=MOD(IPROC,10000)/10-380-IS
26047 IQ=MOD(IPROC,10000)-3800-10*(IH+IS)
26048 END IF
26049 JQ=IQ+6
26050 GM=ZERO
26051 END IF
26052C...process event.
26053 IF(GENEV)THEN
26054 RCS=HCS*HWRGEN(0)
26055 ELSE
26056 EVWGT=0.
26057 HCS=0.
26058C...assign final state masses.
26059 EMQ=RMASS(IQ)
26060 ENQ=RMASS(JQ)
26061 EMH=RMASS(201+IHIGGS)
26062 EMHWT=1.
26063 IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMHWT)
26064C...energy at hadron level.
26065 ECM_MAX=PBEAM1+PBEAM2
26066 S=ECM_MAX*ECM_MAX
26067C...phase space variables.
26068C...X(1)=(EMQQ**2-(EMQ+ENQ)**2)/((ECM-EMH)**2-(EMQ+ENQ)**2),
26069C...LIGHT QUARKS -> X(2)=(LOG|T|-LOG|TMIN|)/(LOG|TMAX|-LOG|TMIN|),
26070C... X(3)=SIN(THETA4_CM_34),X(4)=COS(FI4_CM_34),
26071C...HEAVY QUARKS -> X(2)=COS(THETA5_CM),
26072C... X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34,
26073C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2),
26074C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU);
26075C...phase space borders.
26076 XL(1)=0.
26077 XU(1)=1.
26078 IF((IQ+JQ).EQ.18)THEN
26079 XL(2)=-1.
26080 XL(4)=0.
26081 XU(4)=2.*PIFAC
26082 ELSE
26083 XL(2)=0.
26084 XL(4)=-1.
26085 XU(4)=1.
26086 END IF
26087 XU(2)=1.
26088 XL(3)=-1.
26089 XU(3)=1.
26090 XL(5)=0.
26091 XU(5)=1.
26092 XL(6)=0.
26093 XU(6)=1.
26094C...single phase space point.
26095 100 CONTINUE
26096 WEIGHT=1.
26097 DO I=1,6
26098 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
26099 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
26100 END DO
26101C...energy at parton level.
26102 PTMMIN=0.
26103 PTNMIN=0.
26104 IF(IMSSM.NE.0)THEN
26105 IF((MOD(IPROC,10000).EQ.3839).OR.
26106 & (MOD(IPROC,10000).EQ.3869).OR.
26107 & (MOD(IPROC,10000).EQ.3899))THEN
26108 PTNMIN=PTMIN
26109 ELSE
26110 IF((IQ.NE.6).AND.(IQ.NE.12).AND.
26111 & (JQ.NE.6).AND.(JQ.NE.12))THEN
26112 PTMMIN=PTMIN
26113 PTNMIN=PTMIN
26114 ELSE
26115 CONTINUE
26116 END IF
26117 END IF
26118 END IF
26119 ECM=SQRT(1./(X(5)*(1./(SQRT(PTMMIN**2+EMQ**2)
26120 & +SQRT(PTNMIN**2+ENQ**2)+EMH)**2
26121 & -1./ECM_MAX**2)
26122 & +1./ECM_MAX**2))
26123 IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
26124 SHAT=ECM*ECM
26125 TAU=SHAT/S
26126C...momentum fractions X1 and X2.
26127 XX(1)=EXP(LOG(TAU)*(1.-X(6)))
26128 XX(2)=TAU/XX(1)
26129C...three particle kinematics.
26130 EMQQ=SQRT(X(1)*((ECM-EMH)**2-(EMQ+ENQ)**2)+(EMQ+ENQ)**2)
26131C...incoming partons: all massless.
26132 EMIN=0.
26133 IF((IQ+JQ).EQ.18)THEN
26134 CT5=X(2)
26135 CT4=X(3)
26136 ST4=SQRT(1.-CT4*CT4)
26137 CF4=COS(X(4))
26138 SF4=SIN(X(4))
26139 ELSE
26140 PCM2=((ECM*ECM-EMIN*EMIN-EMIN*EMIN)**2
26141 & -(2.*EMIN*EMIN)**2)/(4.*ECM*ECM)
26142 PCM=SQRT(PCM2)
26143 RCM2=((ECM*ECM-EMQQ*EMQQ-EMH*EMH)**2
26144 & -(2.*EMQQ*EMH)**2)/(4.*ECM*ECM)
26145 RCM=SQRT(RCM2)
26146 TTMAX=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
26147 & *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
26148 & -SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
26149 & *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
26150 TTMIN=EMIN**2+EMQQ**2-0.5D0/ECM/ECM
26151 & *((ECM*ECM+EMIN**2-EMIN**2)*(ECM*ECM+EMQQ**2-EMH**2)
26152 & +SQRT((ECM*ECM-(EMIN+EMIN)**2)*(ECM*ECM-(EMIN-EMIN)**2))
26153 & *SQRT((ECM*ECM-(EMQQ+EMH)**2)*(ECM*ECM-(EMQQ-EMH)**2)))
26154 TLMIN=LOG(ABS(TTMAX))
26155 TLMAX=LOG(ABS(TTMIN))
26156 TL=X(2)*(TLMAX-TLMIN)+TLMIN
26157 T=EXP(ABS(TL))
26158 CTMP=-T-EMIN**2-EMQQ**2
26159 & +2.*SQRT(PCM**2+EMIN**2)*SQRT(RCM**2+EMQQ**2)
26160 CT5=CTMP/2./PCM/RCM
26161 ST4=X(3)
26162 CT4=SQRT(1.-ST4*ST4)
26163 IF (HWRLOG(HALF)) CT4=-CT4
26164 CF4=X(4)
26165 SF4=SQRT(1.-CF4*CF4)
26166 IF (HWRLOG(HALF)) SF4=-SF4
26167 END IF
26168 ST5=SQRT(1.-CT5*CT5)
26169 IF (HWRLOG(HALF)) ST5=-ST5
26170 RQ52=((ECM*ECM-EMH*EMH-EMQQ*EMQQ)**2-(2.*EMH*EMQQ)**2)/
26171 & (4.*ECM*ECM)
26172 IF(RQ52.LT.0.)THEN
26173 GOTO 100
26174 ELSE
26175 RQ5=SQRT(RQ52)
26176 ENDIF
26177 P5(1)=0.
26178 P5(2)=RQ5*ST5
26179 P5(3)=RQ5*CT5
26180 P5(0)=SQRT(RQ52+EMH*EMH)
26181 DO I=1,3
26182 Q34(I)=-P5(I)
26183 END DO
26184 Q34(0)=SQRT(RQ52+EMQQ*EMQQ)
26185 RQ42=((EMQQ*EMQQ-EMQ*EMQ-ENQ*ENQ)**2-(2.*EMQ*ENQ)**2)/
26186 & (4.*EMQQ*EMQQ)
26187 IF(RQ42.LT.0.)THEN
26188 GOTO 100
26189 ELSE
26190 RQ4=SQRT(RQ42)
26191 ENDIF
26192 Q4(1)=RQ4*ST4*CF4
26193 Q4(2)=RQ4*ST4*SF4
26194 Q4(3)=RQ4*CT4
26195 Q4(0)=SQRT(RQ42+ENQ*ENQ)
26196 PQ4=0.
26197 DO I=1,3
26198 PQ4=PQ4+Q34(I)*Q4(I)
26199 END DO
26200 P4(0)=(Q34(0)*Q4(0)+PQ4)/EMQQ
26201 P3(0)=Q34(0)-P4(0)
26202 DO I=1,3
26203 P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMQQ)
26204 P3(I)=Q34(I)-P4(I)
26205 END DO
26206 IF(IMSSM.NE.0)THEN
26207 IF((MOD(IPROC,10000).EQ.3839).OR.
26208 & (MOD(IPROC,10000).EQ.3869).OR.
26209 & (MOD(IPROC,10000).EQ.3899))THEN
26210 IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
26211 ELSE
26212 IF((IQ.NE.6).AND.(IQ.NE.12).AND.
26213 & (JQ.NE.6).AND.(JQ.NE.12))THEN
26214 IF(SQRT(P3(1)**2+P3(2)**2).LT.PTMIN)RETURN
26215 IF(SQRT(P4(1)**2+P4(2)**2).LT.PTMIN)RETURN
26216 ELSE
26217 CONTINUE
26218 END IF
26219 END IF
26220 END IF
26221C...initial state momenta in the partonic CM.
26222 PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
26223 & -(2.*EMIN*EMIN)**2)/(4.*SHAT)
26224 PCM=SQRT(PCM2)
26225 P1(0)=SQRT(PCM2+EMIN*EMIN)
26226 P1(1)=0.
26227 P1(2)=0.
26228 P1(3)=PCM
26229 P2(0)=SQRT(PCM2+EMIN*EMIN)
26230 P2(1)=0.
26231 P2(2)=0.
26232 P2(3)=-PCM
26233C...color structured ME summed/averaged over final/initial spins and colors.
26234 IGG=1
26235 IQQ=1
26236 IF((MOD(IPROC,10000).EQ.3839).OR.
26237 & (MOD(IPROC,10000).EQ.3869).OR.
26238 & (MOD(IPROC,10000).EQ.3899))THEN
26239 IF(MOD(IPROC,10000).EQ.3869)IQQ=0
26240 IF(MOD(IPROC,10000).EQ.3899)IGG=0
26241 GRND=TANB
26242 ELSE
26243 IF(IMSSM.NE.0)THEN
26244 IF((MOD(IPROC,10000)/10-380).EQ.4)IQQ=0
26245 IF((MOD(IPROC,10000)/10-380).EQ.7)IGG=0
26246 END IF
26247 GRND=ONE
26248 END IF
26249 FACGPM(1) = ENQ *GRND
26250 FACGPM(2) = EMQ*PARITY/GRND
26251 CALL HWH2QH(ECM,P1,P2,P3,P4,P5,EMQ,ENQ,EMH,FACGPM,GM,IGG,IQQ,
26252 & GGQQHT,GGQQHU,GGQQHNP,QQQQH)
26253 M2GG=GGQQHNP/(8.*CFFAC)
26254 M2GGPL=GGQQHT/(8.*CFFAC)
26255 M2GGMN=GGQQHU/(8.*CFFAC)
26256 M2QQ=QQQQH*(1.-1./CAFAC**2)/4.
26257C...constant factors: phi along beam and conversion GeV^2->nb.
26258 FACT=2.*PIFAC*GEV2NB
26259C...Jacobians from X1,X2 to X(5),X(6)
26260 FACT=FACT/S*(-LOG(TAU))*(1./(EMQ+ENQ+EMH)**2-1./ECM_MAX**2)
26261C...phase space Jacobians, pi's and flux.
26262 FACT=FACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5
26263 & *((ECM-EMH)**2-(EMQ+ENQ)**2)
26264 & /2./EMQQ
26265C...Jacobians from CT5 to X(2).
26266 IF((IQ+JQ).EQ.18)THEN
26267 CONTINUE
26268 ELSE
26269 FACT=FACT*(TLMAX-TLMIN)/2./PCM/RCM*ABS(T)
26270 FACT=FACT*2.*ABS(ST4/CT4/SF4)
26271 END IF
26272C...EW and QCD couplings.
26273 EMSCA=EMQ+ENQ+EMH
26274 EMSC2=EMSCA*EMSCA
26275 ALPHA=HWUAEM(EMSC2)
26276 ALPHAS=HWUALF(1,EMSCA)
26277 FACT=FACT*4.*PIFAC*ALPHA/4./SWEIN/EMW/EMW
26278 FACT=FACT*16.*PIFAC**2*ALPHAS**2
26279 IF((MOD(IPROC,10000).EQ.3839).OR.
26280 & (MOD(IPROC,10000).EQ.3869).OR.
26281 & (MOD(IPROC,10000).EQ.3899))THEN
26282C...enhancement factor for coupling+c.c.
26283 FACT=FACT*4.*VCKM(3,3)
26284 ELSE
26285C...enhancement factor for MSSM.
26286 FACT=FACT*ENHANC(IQ)*ENHANC(IQ)
26287 END IF
26288C...Higgs resonance.
26289 FACT=FACT*EMHWT
26290C...constant weight.
26291 FACT=FACT*WEIGHT
26292C...include BR of Higgs.
26293 IF(IMSSM.EQ.0)THEN
26294 IDEC=MOD(IPROC,100)
26295 IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC)
26296 IF (IDEC.EQ.0) THEN
26297 BRHIGQ=0.D0
26298 DO I=1,6
26299 BRHIGQ=BRHIGQ+BRHIG(I)
26300 END DO
26301 FACT=FACT*BRHIGQ
26302 ENDIF
26303c bug fix 11/10/02 SM.
26304 IF (IDEC.EQ.10) THEN
26305 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
26306 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
26307 FACT=FACT*BR
26308 ELSEIF (IDEC.EQ.11) THEN
26309 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26310 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26311 FACT=FACT*BR
26312 ENDIF
26313c end of bug fix.
26314 END IF
26315 END IF
26316C...set up flavours in final state.
26317 IF((MOD(IPROC,10000).EQ.3839).OR.
26318 & (MOD(IPROC,10000).EQ.3869).OR.
26319 & (MOD(IPROC,10000).EQ.3899))THEN
26320 IF(HWRGEN(0).LT.0.5)THEN
26321 JHIGGS=207-201
26322 IIQ=6
26323 JJQ=11
26324 FLIP=0
26325 ELSE
26326 JHIGGS=206-201
26327 IIQ=5
26328 JJQ=12
26329 FLIP=1
26330 END IF
26331 ELSE
26332 JHIGGS=IHIGGS
26333 IIQ=IQ
26334 JJQ=JQ
26335 FLIP=0
26336 END IF
26337C...set up PDFs.
26338 HCS=0.
26339 CALL HWSGEN(.FALSE.)
26340 IQMAX=13
26341 IQMIN=1
26342 IF((MOD(IPROC,10000).EQ.3839).OR.
26343 & (MOD(IPROC,10000).EQ.3869).OR.
26344 & (MOD(IPROC,10000).EQ.3899))THEN
26345 IF(MOD(IPROC,10000).EQ.3869)IQMIN=13
26346 IF(MOD(IPROC,10000).EQ.3899)IQMAX=12
26347 ELSE
26348 IF(IMSSM.NE.0)THEN
26349C...Some compilers don't like this statement.
26350C Since it does nothing, just comment it out.
26351C IF((MOD(IPROC,10000).GE.3811).AND.
26352C & (MOD(IPROC,10000).LE.3836))CONTINUE
26353 IF((MOD(IPROC,10000).GE.3841).AND.
26354 & (MOD(IPROC,10000).LE.3866))IQMIN=13
26355 IF((MOD(IPROC,10000).GE.3871).AND.
26356 & (MOD(IPROC,10000).LE.3896))IQMAX=12
26357 END IF
26358 END IF
26359 DO I=IQMIN,IQMAX
26360 IF(DISF(I,1).LT.EPS)THEN
26361 GOTO 200
26362 END IF
26363 K=I/7
26364 L=+1-2*K
26365 IF(I.EQ.13)L=0
26366 J=I+L*6
26367 IF(DISF(J,2).LT.EPS)THEN
26368 GOTO 200
26369 END IF
26370 DIST=DISF(I,1)*DISF(J,2)*S
26371 IF(I.LT.13)THEN
26372C...set up color connections: qq-scattering.
26373 IF(J.EQ.I+6)THEN
26374 HCS=HCS+M2QQ*DIST*FACT
26375 IF(GENEV.AND.HCS.GT.RCS)THEN
26376 CONTINUE
26377 CALL HWHQCP(IIQ,JJQ,2413, 4)
26378 GOTO 9
26379 END IF
26380 ELSE IF(I.EQ.J+6)THEN
26381 HCS=HCS+M2QQ*DIST*FACT
26382 IF(GENEV.AND.HCS.GT.RCS)THEN
26383 FLIP=(2-2*FLIP)/2
26384 CALL HWHQCP(JJQ,IIQ,3142,12)
26385 GOTO 9
26386 END IF
26387 END IF
26388 ELSE
26389C...set up color connections: gg-scattering.
26390 HCS=HCS
26391 & +(M2GGPL-M2GG*M2GGPL/(M2GGPL+M2GGMN)/FLOAT(NC)**2)*DIST*FACT
26392 IF(GENEV.AND.HCS.GT.RCS) THEN
26393 CALL HWHQCP(IIQ,JJQ,2413,27)
26394 GOTO 9
26395 ENDIF
26396 HCS=HCS
26397 & +(M2GGMN-M2GG*M2GGMN/(M2GGPL+M2GGMN)/FLOAT(NC)**2)*DIST*FACT
26398 IF(GENEV.AND.HCS.GT.RCS) THEN
26399 CALL HWHQCP(IIQ,JJQ,4123,28)
26400 GOTO 9
26401 ENDIF
26402 END IF
26403 200 CONTINUE
26404 END DO
26405 EVWGT=HCS
26406 RETURN
26407C...generate event.
26408 9 IDN(1)=I
26409 IDN(2)=J
26410 IDN(5)=201+JHIGGS
26411C...incoming partons: now massive.
26412 EMIN1=RMASS(IDN(1))
26413 EMIN2=RMASS(IDN(2))
26414C...redo initial state momenta in the partonic CM.
26415 PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
26416 & -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
26417 PCM=SQRT(PCM2)
26418 P1(0)=SQRT(PCM2+EMIN1*EMIN1)
26419 P1(1)=0.
26420 P1(2)=0.
26421 P1(3)=PCM
26422 P2(0)=SQRT(PCM2+EMIN2*EMIN2)
26423 P2(1)=0.
26424 P2(2)=0.
26425 P2(3)=-PCM
26426C...randomly rotate final state momenta around beam axis.
26427 PHI=2.*PIFAC*HWRGEN(0)
26428 CPHI=COS(PHI)
26429 SPHI=SIN(PHI)
26430 ROT(1,1)=+CPHI
26431 ROT(1,2)=+SPHI
26432 ROT(1,3)=0.
26433 ROT(2,1)=-SPHI
26434 ROT(2,2)=+CPHI
26435 ROT(2,3)=0.
26436 ROT(3,1)=0.
26437 ROT(3,2)=0.
26438 ROT(3,3)=1.
26439 DO L=1,3
26440 DO M=1,3
26441 QAUX(M)=0.
26442 DO N=1,3
26443 IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
26444 IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
26445 IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
26446 END DO
26447 END DO
26448 DO M=1,3
26449 IF(L.EQ.1)P3(M)=QAUX(M)
26450 IF(L.EQ.2)P4(M)=QAUX(M)
26451 IF(L.EQ.3)P5(M)=QAUX(M)
26452 END DO
26453 END DO
26454C...use HWETWO only to set up status and IDs of quarks.
26455 COSTH=0.
26456 IDCMF=15
26457 CALL HWETWO(.TRUE.,.TRUE.)
26458C...do real incoming, outgoing momenta in the lab frame.
26459 VCOL=(XX(1)-XX(2))/(XX(1)+XX(2))
26460 GCOL=(XX(1)+XX(2))/2./SQRT(XX(1)*XX(2))
26461 DO M=NHEP-4,NHEP+1
26462 IF(M.EQ.NHEP-2)GO TO 888
26463 DO N=0,3
26464 IF(M.EQ.NHEP-4)QAUX(N)=P1(N)
26465 IF(M.EQ.NHEP-3)QAUX(N)=P2(N)
26466 IF(M.EQ.NHEP-1)QAUX(N)=P3(N)*(1-FLIP)+P4(N)*FLIP
26467 IF(M.EQ.NHEP )QAUX(N)=P4(N)*(1-FLIP)+P3(N)*FLIP
26468 IF(M.EQ.NHEP+1)QAUX(N)=P5(N)
26469 END DO
26470C...perform boost.
26471 PHEP(4,M)=GCOL*(QAUX(0)+VCOL*QAUX(3))
26472 PHEP(3,M)=GCOL*(QAUX(3)+VCOL*QAUX(0))
26473 PHEP(2,M)=QAUX(2)
26474 PHEP(1,M)=QAUX(1)
26475 888 CONTINUE
26476 END DO
26477C...needs to set all final state masses.
26478 PHEP(5,NHEP-1)=SQRT(ABS(PHEP(4,NHEP-1)**2
26479 & -PHEP(3,NHEP-1)**2
26480 & -PHEP(2,NHEP-1)**2
26481 & -PHEP(1,NHEP-1)**2))
26482 PHEP(5,NHEP )=SQRT(ABS(PHEP(4,NHEP )**2
26483 & -PHEP(3,NHEP )**2
26484 & -PHEP(2,NHEP )**2
26485 & -PHEP(1,NHEP )**2))
26486 PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2
26487 & -PHEP(3,NHEP+1)**2
26488 & -PHEP(2,NHEP+1)**2
26489 & -PHEP(1,NHEP+1)**2))
26490C...sets CMF.
26491 DO I=1,4
26492 PHEP(I,NHEP-2)=PHEP(I,NHEP-4)+PHEP(I,NHEP-3)
26493 END DO
26494 PHEP(5,NHEP-2)=SQRT(ABS(PHEP(4,NHEP-2)**2
26495 & -PHEP(3,NHEP-2)**2
26496 & -PHEP(2,NHEP-2)**2
26497 & -PHEP(1,NHEP-2)**2))
26498C...status and IDs for Higgs.
26499 ISTHEP(NHEP+1)=114
26500 IDHW(NHEP+1)=IDN(5)
26501 IDHEP(NHEP+1)=IDPDG(IDN(5))
26502C...Higgs colour (self-)connections.
26503 JMOHEP(1,NHEP+1)=NHEP-2
26504 JMOHEP(2,NHEP+1)=NHEP+1
26505 JDAHEP(2,NHEP+1)=NHEP+1
26506 JDAHEP(2,NHEP-2)=NHEP+1
26507 NHEP=NHEP+1
26508 IF(AZSPIN)THEN
26509C...set to zero the coefficients of the spin density matrices.
26510 CALL HWVZRO(7,GCOEF)
26511 END IF
26512 END
26513C-----------------------------------------------------------------------
26514CDECK ID>, HWHIGS.
26515*CMZ :- -02/04/98 14.52.22 by Mike Seymour
26516*-- Author : Mike Seymour
26517*-- Modified: Stefano Moretti 04/05/98
26518C-----------------------------------------------------------------------
26519 SUBROUTINE HWHIGS
26520C-----------------------------------------------------------------------
26521C HIGGS PRODUCTION VIA GLUON OR QUARK FUSION
26522C MEAN EVWGT = HIGGS PRODN C-S * BRANCHING FRACTION IN NB
26523C-----------------------------------------------------------------------
c63d70bc 26524 INCLUDE 'herwig65.inc'
65767955 26525 DOUBLE PRECISION HWUALF,HWHIGT,HWRGEN,HWUSQR,HWUAEM,BRHIGQ,EMH,
26526 & CSFAC(13),EVSUM(13),EMFAC,CV,CA,BR,RWGT,E1,E2,EMQ,GFACTR,RQM(6)
26527 INTEGER IDEC,I,J,ID1,ID2
26528 EXTERNAL HWUALF,HWHIGT,HWRGEN,HWUSQR,HWUAEM
26529 SAVE CSFAC,BR,EVSUM
26530 IF (GENEV) THEN
26531 RWGT=HWRGEN(0)*EVSUM(13)
26532 IDN(1)=1
26533 DO 10 I=1,12
26534 10 IF (RWGT.GT.EVSUM(I)) IDN(1)=I+1
26535 IDN(2)=13
26536 IF (IDN(1).LE.12) IDN(2)=IDN(1)-6
26537 IF (IDN(1).LE. 6) IDN(2)=IDN(1)+6
26538 IDCMF=201+IHIGGS
26539 CALL HWEONE
26540 ELSE
26541 EVWGT=0.
26542 EMH=RMASS(201+IHIGGS)
26543 EMFAC=1.D0
26544 IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC)
26545 IF (EMH.LE.0 .OR. EMH.GE.PHEP(5,3)) RETURN
26546 EMSCA=EMH
26547 IF (EMSCA.NE.EMLST) THEN
26548 EMLST=EMH
26549 XXMIN=(EMH/PHEP(5,3))**2
26550 XLMIN=LOG(XXMIN)
26551 GFACTR=GEV2NB*HWUAEM(EMH**2)/(576.*SWEIN*RMASS(198)**2)
26552C--MOD BY BRW 16/07/03 TO USE RUNNING MASSES
26553 CALL HWURQM(EMH,RQM)
26554 DO 20 I=1,13
26555 IF (I.EQ.13) THEN
26556 CSFAC(I)=-GFACTR*HWHIGT( EMH)*XLMIN
26557 & *HWUALF(1,EMH)**2*EMFAC
26558 ELSEIF (I.GT.6) THEN
26559 CSFAC(I)=CSFAC(I-6)
26560 ELSE
26561 EMQ=RQM(I)
26562 IF (EMQ.GT.ZERO.AND.EMH.GT.TWO*EMQ) THEN
26563 CSFAC(I)=-GFACTR*96.*PIFAC**2 *(1-(TWO*EMQ/EMH)**2)
26564 & *(EMQ/EMH)**2 *XLMIN *EMFAC*ENHANC(I)**2
26565 ELSE
26566 CSFAC(I)=0
26567 ENDIF
26568 ENDIF
26569C--END MOD
26570 20 CONTINUE
26571C INCLUDE BRANCHING RATIO OF HIGGS
26572 IDEC=MOD(IPROC,100)
26573 BR=1
26574 IF(IMSSM.EQ.0)THEN
26575C SM case
26576 IF (IDEC.EQ.0) THEN
26577 BRHIGQ=0
26578 DO 30 I=1,6
26579 30 BRHIGQ=BRHIGQ+BRHIG(I)
26580 BR=BRHIGQ
26581 ELSEIF (IDEC.EQ.10) THEN
26582 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
26583 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
26584 BR=BR*BRHIG(IDEC)
26585 ELSEIF (IDEC.EQ.11) THEN
26586 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26587 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26588 BR=BR*BRHIG(IDEC)
26589 ELSEIF (IDEC.LE.12) THEN
26590 BR=BRHIG(IDEC)
26591 ENDIF
26592 ENDIF
26593 ENDIF
26594 CALL HWSGEN(.TRUE.)
26595 EVWGT=0
26596 E1=PHEP(4,MAX(1,JDAHEP(1,1)))
26597 E2=PHEP(4,MAX(2,JDAHEP(1,2)))
26598 DO 40 I=1,13
26599 EMQ=RMASS(I)
26600 IF (EMH.GT.2*EMQ) THEN
26601 J=13
26602 IF (I.LE.12) J=I-6
26603 IF (I.LE. 6) J=I+6
26604 IF (XX(1).LT.0.5*(1-EMQ/E1+HWUSQR(1-2*EMQ/E1)) .AND.
26605 & XX(2).LT.0.5*(1-EMQ/E2+HWUSQR(1-2*EMQ/E2)))
26606 & EVWGT=EVWGT+DISF(I,1)*DISF(J,2)*CSFAC(I)*BR
26607 ENDIF
26608 EVSUM(I)=EVWGT
26609 40 CONTINUE
26610 ENDIF
26611 END
26612CDECK ID>, HWHIGT.
26613*CMZ :- -02/04/98 15.00.39 by Mike Seymour
26614*-- Author : Mike Seymour
26615C-----------------------------------------------------------------------
26616 FUNCTION HWHIGT(EMH)
26617C-----------------------------------------------------------------------
26618C CALCULATE MOD SQUARED I DEFINED AS IN BARGER & PHILLIPS p433
26619C WARNING: THIS IS A FACTOR OF 3 GREATER THAN EHLQ'S ETA FUNCTION
26620C PARITY=+1 FOR SCALAR AND -1 FOR PSEUDOSCALAR
26621C-----------------------------------------------------------------------
c63d70bc 26622 INCLUDE 'herwig65.inc'
65767955 26623 DOUBLE PRECISION HWHIGT,RATIO,RAT2,EMH,FREAL,FIMAG,ETALOG,AIREAL,
26624 & AIIMAG
26625 INTEGER I,J,K,L
26626 HWHIGT=0
26627 IF (ABS(PARITY).NE.1) CALL HWWARN('HWHIGT',500)
26628 AIREAL=0
26629 AIIMAG=0
26630C---CONTRIBUTION FROM QUARK LOOPS
26631 DO 100 I=1,NFLAV
26632 RATIO=RMASS(I)/EMH
26633 RAT2=RATIO**2
26634 IF (RAT2.GT.0.25) THEN
26635 FREAL=-2.*ASIN(0.5/RATIO)**2
26636 FIMAG=0
26637 ELSEIF (RAT2.LT.0.25) THEN
26638 ETALOG=LOG( (0.5+SQRT(0.25-RAT2)) / (0.5-SQRT(0.25-RAT2)) )
26639 FREAL=0.5 * (ETALOG**2 - PIFAC**2)
26640 FIMAG=PIFAC * ETALOG
26641 ELSE
26642 FREAL=0.5 * ( - PIFAC**2)
26643 FIMAG=0
26644 ENDIF
26645 IF (PARITY.EQ.1) THEN
26646 AIREAL=AIREAL+3*RAT2*(2 + (4*RAT2-1)*FREAL)*ENHANC(I)
26647 AIIMAG=AIIMAG+3*RAT2*( (4*RAT2-1)*FIMAG)*ENHANC(I)
26648 ELSE
26649 AIREAL=AIREAL-2*RAT2*(FREAL)*ENHANC(I)
26650 AIIMAG=AIIMAG-2*RAT2*(FIMAG)*ENHANC(I)
26651 ENDIF
26652 100 CONTINUE
26653C---CONTRIBUTION FROM SQUARK LOOPS
26654 DO 200 I=1,12
26655 J=I/7
26656 K=6*J+I
26657 L=K
26658 IF(K.GT.6)L=K-12
26659 RATIO=RMASS(L)/EMH
26660 RAT2=RATIO**2
26661 IF (RAT2.GT.0.25) THEN
26662 FREAL=-2.*ASIN(0.5/RATIO)**2
26663 FIMAG=0
26664 ELSEIF (RAT2.LT.0.25) THEN
26665 ETALOG=LOG( (0.5+SQRT(0.25-RAT2)) / (0.5-SQRT(0.25-RAT2)) )
26666 FREAL=0.5 * (ETALOG**2 - PIFAC**2)
26667 FIMAG=PIFAC * ETALOG
26668 ELSE
26669 FREAL=0.5 * ( - PIFAC**2)
26670 FIMAG=0
26671 ENDIF
26672 IF (PARITY.EQ.1) THEN
26673 AIREAL=AIREAL-3*RAT2*(1 + 2*RAT2*FREAL)*SENHNC(K)
26674 AIIMAG=AIIMAG-3*RAT2*( 2*RAT2*FIMAG)*SENHNC(K)
26675 ENDIF
26676 200 CONTINUE
26677C---FUNCTION RETURNS MOD-SQUARED OF SUM
26678 HWHIGT=AIREAL**2 + AIIMAG**2
26679 END
26680CDECK ID>, HWHIGV.
26681*CMZ :- -26/11/00 17.21.55 by Bryan Webber
26682*-- Author : Stefano Moretti
26683C-----------------------------------------------------------------------
26684C...Generate completely differential cross section (EVWGT) in the variables
26685C...X(I) with I=1,4 (see below) for the processes of ther series
26686C...IPROC=2600,2700 as described in the HERWIG 6 documentation file.
26687C...It includes interface to PDFs and takes into account color connections
26688C...among partons.
26689C
26690C...First release: 8-APR-1999 by Stefano Moretti
26691C
26692 SUBROUTINE HWHIGV
26693C-----------------------------------------------------------------------
26694C MSSM NEUTRAL HIGGS PRODUCTION IN ASSOCIATION WITH GAUGE BOSON
26695C--BRW fix 27/8/04: corrected off-shell gauge boson mass dependence
26696C-----------------------------------------------------------------------
c63d70bc 26697 INCLUDE 'herwig65.inc'
65767955 26698 INTEGER I,J,K,L,M,N
26699 INTEGER IV,IDEC
26700 INTEGER ID1,ID2
26701 DOUBLE PRECISION CV,CA,BR
26702 DOUBLE PRECISION BRHIGQ,EMH,EMHWT,EMV,RMV,GAMV,RMH
26703 DOUBLE PRECISION X(4),XL(4),XU(4)
26704 DOUBLE PRECISION CT,ST,CCT
26705 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3)
26706 DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
26707 DOUBLE PRECISION EMIN,PCM2,PCM,RCM2,RCM
26708 DOUBLE PRECISION QQV(12,12),C4W,VQ(12),AQ(12)
26709 DOUBLE PRECISION M2,M2L,M2T
26710 DOUBLE PRECISION ALPHA,EMSC2
26711 DOUBLE PRECISION HWRGEN,HWUAEM
26712 DOUBLE PRECISION RNMIN,RNMAX,THETA_MIN,THETA_MAX
26713 DOUBLE PRECISION EPS,HCS,RCS,FACT,DIST
26714 DOUBLE PRECISION WEIGHT
26715 DOUBLE PRECISION VSAVE,HSAVE,CFT,QR,QL
26716 SAVE EMH,EMV,HCS,M2,M2L,M2T,FACT,QQV,S,CT
26717 LOGICAL HWRLOG
26718 EXTERNAL HWHIGM,HWRGEN,HWUAEM,HWH2VH,HWETWO,HWRLOG
26719 PARAMETER (EPS=1.D-9)
26720 IF(IMSSM.EQ.0)THEN
26721 IF(IPRO.EQ.26)IV=0
26722 IF(IPRO.EQ.27)IV=1
26723 ELSE
26724 IF((MOD(IPROC,10000).EQ.3310).OR.
26725 & (MOD(IPROC,10000).EQ.3320))THEN
26726 IV=0
26727 ELSEIF((MOD(IPROC,10000).EQ.3360).OR.
26728 & (MOD(IPROC,10000).EQ.3370))THEN
26729 IV=1
26730 END IF
26731 END IF
26732 IF(GENEV)THEN
26733 RCS=HCS*HWRGEN(0)
26734 ELSE
26735 HCS=0.
26736 EVWGT=0.
26737C...assign final state masses.
26738 RMV=RMASS(198+2*IV)
26739 RMH=RMASS(201+IHIGGS)
26740 IF(IV.EQ.0)GAMV=GAMW
26741 IF(IV.EQ.1)GAMV=GAMZ
26742 EMH=RMH
26743 EMHWT=1.D0
26744 IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMHWT)
26745C...energy at hadron level.
26746 ECM_MAX=PBEAM1+PBEAM2
26747 S=ECM_MAX*ECM_MAX
26748C...phase space variables.
26749C...X(1)=COS(THETA_CM),
26750C...X(2)=(1./SHAT-1./ECM_MAX**2)/(1./(EMV+EMH)**2-1./ECM_MAX**2),
26751C...X(3)=(LOG(TAU)-LOG(X1))/LOG(TAU),
26752C...X(4)=(THETA-THETA_MIN)/(THETA_MAX-THETA_MIN),
26753C...where THETA=ATAN((EMV*EMV-RMV*RMV)/RMV/GAMV);
26754C...phase space borders.
26755 XL(1)=-1.
26756 XU(1)=1.
26757 XL(2)=0.
26758 XU(2)=1.
26759 XL(3)=0.
26760 XU(3)=1.
26761 XL(4)=0.
26762 XU(4)=1.
26763C...single phase space point.
26764 WEIGHT=1.
26765 DO I=1,4
26766 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
26767 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
26768 END DO
26769C...resonant boson mass.
26770 RNMIN=RMV-GAMMAX*GAMV
26771 THETA_MIN=ATAN((RNMIN*RNMIN-RMV*RMV)/RMV/GAMV)
26772 RNMAX=ECM_MAX-EMH
26773 THETA_MAX=ATAN((RNMAX*RNMAX-RMV*RMV)/RMV/GAMV)
26774 EMV=SQRT((TAN(X(4)*(THETA_MAX-THETA_MIN)+THETA_MIN))
26775 & *RMV*GAMV+RMV*RMV)
26776C...energy at parton level.
26777 ECM=SQRT(1./(X(2)*(1./(EMV+EMH)**2-1./ECM_MAX**2)
26778 & +1./ECM_MAX**2))
26779 IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
26780 SHAT=ECM*ECM
26781 TAU=SHAT/S
26782C...momentum fractions X1 and X2.
26783 XX(1)=EXP(LOG(TAU)*(1.-X(3)))
26784 XX(2)=TAU/XX(1)
26785C...two particle kinematics.
26786 CT=X(1)
26787 IF(HWRLOG(HALF))THEN
26788 ST=+SQRT(1.-CT*CT)
26789 ELSE
26790 ST=-SQRT(1.-CT*CT)
26791 END IF
26792C...single phase space point.
26793 RCM2=((SHAT-EMV*EMV-EMH*EMH)**2
26794 & -(2.*EMV*EMH)**2)/(4.*SHAT)
26795 RCM=SQRT(RCM2)
26796 P3(0)=SQRT(RCM2+EMV*EMV)
26797 P3(1)=0.
26798 P3(2)=RCM*ST
26799 P3(3)=RCM*CT
26800 P4(0)=SQRT(RCM2+EMH*EMH)
26801 P4(1)=0.
26802 P4(2)=-RCM*ST
26803 P4(3)=-RCM*CT
26804C...incoming partons: massless.
26805 EMIN=0.
26806C...initial state momenta in the partonic CM.
26807 PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
26808 & -(2.*EMIN*EMIN)**2)/(4.*SHAT)
26809 PCM=SQRT(PCM2)
26810 P1(0)=SQRT(PCM2+EMIN*EMIN)
26811 P1(1)=0.
26812 P1(2)=0.
26813 P1(3)=PCM
26814 P2(0)=SQRT(PCM2+EMIN*EMIN)
26815 P2(1)=0.
26816 P2(2)=0.
26817 P2(3)=-PCM
26818C...color structured ME summed/averaged over final/initial spins and colors.
26819 CALL HWH2VH(P1,P2,P3,P4,EMV,M2,M2L,M2T)
26820 IF(M2.LE.0.)RETURN
26821C...vector-axial couplings of V to qq'/qq.
26822 IF(IV.EQ.0)THEN
26823 DO I=2,12,2
26824 K=I
26825 IF(I.GT.6)K=I-6
26826 M=K/2
26827 N=0
26828 DO J=1,11,2
26829 L=J
26830 IF(J.GT.6)L=J-6
26831 N=L-N
26832c bug fix 20/05/01 SM.
26833 QQV(I,J)=VCKM(M,N)
26834c end of bug fix.
26835 QQV(J,I)=QQV(I,J)
26836 IF(N.EQ.3)N=0
26837 END DO
26838 END DO
26839 ELSE IF(IV.EQ.1)THEN
26840 C4W=(1.-SWEIN)*(1.-SWEIN)
26841 DO I=1,11,2
26842 VQ(I)=2.*VFCH(1,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26843 AQ(I)=2.*AFCH(1,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26844 J=I+6
26845 IF(J.GT.12)J=J-12
26846 QQV(I,J)=(VQ(I)*VQ(I)+AQ(I)*AQ(I))/C4W
26847 END DO
26848 DO I=2,12,2
26849 VQ(I)=2.*VFCH(2,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26850 AQ(I)=2.*AFCH(2,1)*SQRT(SWEIN)*SQRT(1.-SWEIN)
26851 J=I+6
26852 IF(J.GT.12)J=J-12
26853 QQV(I,J)=(VQ(I)*VQ(I)+AQ(I)*AQ(I))/C4W
26854 END DO
26855 END IF
26856C...constant factors: phi along beam and conversion GeV^2->nb.
26857 FACT=2.*PIFAC*GEV2NB
26858C...Jacobians from X1,X2 to X(2),X(3)
26859 FACT=FACT/S*(-LOG(TAU))*(1./(EMV+EMH)**2-1./ECM_MAX**2)
26860C...phase space Jacobians, pi's and flux.
26861 FACT=FACT/64./PIFAC/PIFAC*RCM/PCM
26862C...EW couplings.
26863 EMSCA=RMV+RMH
26864 EMSC2=EMSCA*EMSCA
26865 ALPHA=HWUAEM(EMSC2)
26866C--BRW fix 27/8/04: RMV*RMV --> EMV*EMV
26867 FACT=FACT*16.*PIFAC**2*ALPHA**2/SWEIN/SWEIN*EMV*EMV
26868C...enhancement factor for MSSM.
26869 FACT=FACT*ENHANC(10+IV)*ENHANC(10+IV)
26870C...Higgs resonance.
26871 FACT=FACT*EMHWT
26872C...vector boson resonance.
26873 FACT=FACT*(THETA_MAX-THETA_MIN)/PIFAC
26874C...constant weight.
26875 FACT=FACT*WEIGHT
26876C...include BR of Higgs.
26877 IF(IMSSM.EQ.0)THEN
26878 IDEC=MOD(IPROC,100)
26879 IF (IDEC.GT.0.AND.IDEC.LE.12) FACT=FACT*BRHIG(IDEC)
26880 IF (IDEC.EQ.0) THEN
26881 BRHIGQ=0.D0
26882 DO I=1,6
26883 BRHIGQ=BRHIGQ+BRHIG(I)
26884 END DO
26885 FACT=FACT*BRHIGQ
26886 ENDIF
26887c bug fix 11/10/02 SM.
26888 IF (IDEC.EQ.10) THEN
26889 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
26890 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
26891 FACT=FACT*BR
26892 ELSEIF (IDEC.EQ.11) THEN
26893 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26894 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
26895 FACT=FACT*BR
26896 ENDIF
26897c end of bug fix.
26898 END IF
26899 END IF
26900C...set up PDFs.
26901 HCS=0.
26902 CALL HWSGEN(.FALSE.)
26903 DO I=1,12
26904 IF(DISF(I,1).LT.EPS)THEN
26905 GOTO 200
26906 END IF
26907 K=I/7
26908 L=+1-2*K
26909 IF(IV.EQ.0)THEN
26910 J=I+L*6+(-1)**(I+1)
26911 ELSE IF(IV.EQ.1)THEN
26912 J=I+L*6
26913 END IF
26914 IF(DISF(J,2).LT.EPS)THEN
26915 GOTO 200
26916 END IF
26917 DIST=DISF(I,1)*DISF(J,2)*S
26918C...QQV vector and axial couplings.
26919 DIST=DIST*QQV(I,J)
26920C...no need to set up color connections.
26921 HCS=HCS+M2*DIST*FACT
26922 IF(GENEV.AND.HCS.GT.RCS)THEN
26923C...generate event.
26924 IDN(1)=I
26925 IDN(2)=J
26926 IF(IV.EQ.0)
26927 & IDN(3)=NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))+ICHRG(IDN(2))))
26928 IF(IV.EQ.1)IDN(3)=200
26929 IDN(4)=201+IHIGGS
26930 COSTH=CT
26931 IDCMF=15
26932 ICO(1)=2
26933 ICO(2)=1
26934 ICO(3)=3
26935 ICO(4)=4
26936C...trick HWETWO in using off-shell V and H masses.
26937 VSAVE=RMASS(IDN(3))
26938 HSAVE=RMASS(IDN(4))
26939 RMASS(IDN(3))=EMV
26940 RMASS(IDN(4))=EMH
26941C-- BRW fix 27/8/04: avoid double smearing of W and H masses
26942 CALL HWETWO(.FALSE.,.FALSE.)
26943 RMASS(IDN(3))=VSAVE
26944 RMASS(IDN(4))=HSAVE
26945 IF(AZSPIN)THEN
26946C...set to zero the coefficients of the spin density matrices.
26947 CALL HWVZRO(7,GCOEF)
26948 END IF
26949C...calculates exactly polarized decay matrix of gauge boson.
26950 IF(IERROR.NE.0)RETURN
26951 CCT=CT
26952 IF(I.GT.6)CCT=-CT
26953 IF(M2L.LT.0.)M2L=0.
26954 IF(M2T.LT.0.)M2T=0.
26955 RHOHEP(2,NHEP-1)=M2L/M2
26956 CFT=(M2-M2L)/(1.+CCT**2)/2.
26957 IF(IV.EQ.0)THEN
26958 RHOHEP(1,NHEP-1)=CFT*(1.+CCT)**2/M2
26959 RHOHEP(3,NHEP-1)=CFT*(1.-CCT)**2/M2
26960 ELSE IF(IV.EQ.1)THEN
26961 QR=(VQ(I)-AQ(I))/2.
26962 QL=(VQ(I)+AQ(I))/2.
26963 RHOHEP(1,NHEP-1)=CFT*(QR**2*(1.-CCT)**2+QL**2*(1.+CCT)**2)
26964 & /(QR**2+QL**2)/M2
26965 RHOHEP(3,NHEP-1)=CFT*(QR**2*(1.+CCT)**2+QL**2*(1.-CCT)**2)
26966 & /(QR**2+QL**2)/M2
26967 END IF
26968 RETURN
26969 END IF
26970 200 CONTINUE
26971 END DO
26972 EVWGT=HCS
26973 END
26974CDECK ID>, HWHIGW.
26975*CMZ :- -26/04/91 14.55.44 by Federico Carminati
26976*-- Author : Mike Seymour, modified by Stefano Moretti
26977C-----------------------------------------------------------------------
26978 SUBROUTINE HWHIGW
26979C-----------------------------------------------------------------------
26980C HIGGS PRODUCTION VIA W/Z BOSON FUSION
26981C MEAN EVWGT = HIGGS PRODN C-S * BRANCHING FRACTION IN NB
26982C-----------------------------------------------------------------------
c63d70bc 26983 INCLUDE 'herwig65.inc'
65767955 26984 DOUBLE PRECISION HWULDO,HWRUNI,HWRGEN,HWUAEM,K1MAX2,K1MIN2,K12,
26985 & K2MAX2,K2MIN2,K22,EMW2,EMW,ROOTS,EMH2,EMH,ROOTS2,P1,PHI1,PHI2,
26986 & COSPHI,COSTH1,SINTH1,COSTH2,SINTH2,P2,WEIGHT,TAU,TAULN,CSFAC,
26987 & PSUM,PROB,Q1(5),Q2(5),H(5),A,B,C,TERM2,BRHIGQ,G1WW,G2WW,G1ZZ(6),
26988 & G2ZZ(6),AWW,AZZ(6),PWW,PZZ(6),EMZ,EMZ2,RSUM,GLUSQ,GRUSQ,GLDSQ,
26989 & GRDSQ,GLESQ,GRESQ,CW,CZ,EMFAC,CV,CA,BR,X2,ETA,P1JAC,FACTR,EH2
26990 INTEGER HWRINT,IDEC,I,ID1,ID2,IHAD
26991 LOGICAL EE,EP
26992 EXTERNAL HWULDO,HWRUNI,HWRGEN,HWUAEM,HWRINT
26993 SAVE EMW2,EMZ2,EE,GLUSQ,GRUSQ,GLDSQ,GRDSQ,GLESQ,GRESQ,G1ZZ,G2ZZ,
26994 & G1WW,G2WW,CW,CZ,PSUM,AWW,PWW,AZZ,PZZ,ROOTS,Q1,Q2,H,FACTR
26995 EQUIVALENCE (EMW,RMASS(198)),(EMZ,RMASS(200))
26996 IHAD=2
26997 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
26998 IF (FSTWGT) THEN
26999 EMW2=EMW**2
27000 EMZ2=EMZ**2
27001 GLUSQ=(VFCH(2,1)+AFCH(2,1))**2
27002 GRUSQ=(VFCH(2,1)-AFCH(2,1))**2
27003 GLDSQ=(VFCH(1,1)+AFCH(1,1))**2
27004 GRDSQ=(VFCH(1,1)-AFCH(1,1))**2
27005 GLESQ=(VFCH(11,1)+AFCH(11,1))**2
27006 GRESQ=(VFCH(11,1)-AFCH(11,1))**2
27007 G1ZZ(1)=GLUSQ*GLUSQ+GRUSQ*GRUSQ
27008 G2ZZ(1)=GLUSQ*GRUSQ+GRUSQ*GLUSQ
27009 G1ZZ(2)=GLUSQ*GLDSQ+GRUSQ*GRDSQ
27010 G2ZZ(2)=GLUSQ*GRDSQ+GRUSQ*GLDSQ
27011 G1ZZ(3)=GLDSQ*GLDSQ+GRDSQ*GRDSQ
27012 G2ZZ(3)=GLDSQ*GRDSQ+GRDSQ*GLDSQ
27013 G1ZZ(4)=GLESQ*GLESQ+GRESQ*GRESQ
27014 G2ZZ(4)=GLESQ*GRESQ+GRESQ*GLESQ
27015 G1ZZ(5)=GLESQ*GLUSQ+GRESQ*GRUSQ
27016 G2ZZ(5)=GLESQ*GRUSQ+GRESQ*GLUSQ
27017 G1ZZ(6)=GLESQ*GLDSQ+GRESQ*GRDSQ
27018 G2ZZ(6)=GLESQ*GRDSQ+GRESQ*GLDSQ
27019 G1WW=0.25
27020 G2WW=0
27021 FACTR=GEV2NB/(128.*PIFAC**3)
27022 EH2=RMASS(201+IHIGGS)**2
27023 CW=256*(PIFAC*HWUAEM(EH2)/SWEIN)**3*EMW2
27024 CZ=256.*(PIFAC*HWUAEM(EH2))**3*EMZ2/(SWEIN*(1.-SWEIN))
27025 ENDIF
27026 EE=IPRO.LE.12
27027 EP=IPRO.GE.90
27028 IF (.NOT.GENEV) THEN
27029C---CHOOSE PARAMETERS
27030 EVWGT=0.
27031 EMH=RMASS(201+IHIGGS)
27032 EMFAC=ONE
27033 IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC)
27034 IF (EMH.LE.ZERO .OR. EMH.GE.PHEP(5,3)) RETURN
27035 EMSCA=EMH
27036 IF (EE) THEN
27037 ROOTS=PHEP(5,3)
27038 ELSE
27039 TAU=(EMH/PHEP(5,3))**2
27040 TAULN=LOG(TAU)
27041 ROOTS=PHEP(5,3)*SQRT(EXP(HWRUNI(0,-1D-10,TAULN)))
27042 ENDIF
27043 EMH2=EMH**2
27044 ROOTS2=ROOTS**2
27045C---CHOOSE P1 ACCORDING TO (1-ETA)*(ETA-X2)/ETA**2
27046C WHERE ETA=1-2P1/ROOTS AND X2=EMH**2/S
27047 X2=EMH2/ROOTS2
27048 1 ETA=X2**HWRGEN(0)
27049 IF (HWRGEN(0)*(1-EMH/ROOTS)**2*ETA.GT.(1-ETA)*(ETA-X2))GOTO 1
27050 P1JAC=0.5*ROOTS*ETA**2/((1-ETA)*(ETA-X2))
27051 & *(-LOG(X2)*(1+X2)-2*(1-X2))
27052 P1=0.5*ROOTS*(1-ETA)
27053C---CHOOSE PHI1,2 UNIFORMLY
27054 PHI1=2*PIFAC*HWRGEN(0)
27055 PHI2=2*PIFAC*HWRGEN(0)
27056 COSPHI=COS(PHI2-PHI1)
27057C---CHOOSE K1^2, ON PROPAGATOR FACTOR
27058 K1MAX2=2*P1*ROOTS
27059 K1MIN2=0
27060 K12=EMW2-(EMW2+K1MAX2)*(EMW2+K1MIN2)/
27061 & ((K1MAX2-K1MIN2)*HWRGEN(0)+(EMW2+K1MIN2))
27062C---CALCULATE COSTH1 FROM K1^2
27063 COSTH1=1+K12/(P1*ROOTS)
27064 SINTH1=SQRT(1-COSTH1**2)
27065C---CHOOSE K2^2
27066 K2MAX2=ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)*(ROOTS-P1-P1*COSTH1)
27067 & /((ROOTS-P1)**2-(P1*COSTH1)**2-(P1*SINTH1*COSPHI)**2)
27068 K2MIN2=0
27069 K22=EMW2-(EMW2+K2MAX2)*(EMW2+K2MIN2)/
27070 & ((K2MAX2-K2MIN2)*HWRGEN(0)+(EMW2+K2MIN2))
27071C---CALCULATE A,B,C FACTORS, AND...
27072 A=-2*K22*P1*COSTH1 - ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)
27073 B=-2*K22*P1*SINTH1*COSPHI
27074 C=+2*K22*P1 - 2*ROOTS*K22 - ROOTS*(ROOTS2-EMH2-2*ROOTS*P1)
27075C---SOLVE A*COSTH2 + B*SINTH2 + C = 0 FOR COSTH2
27076 TERM2=B**2 + A**2 - C**2
27077 IF (TERM2.LT.ZERO) RETURN
27078 TERM2=B*SQRT(TERM2)
27079 IF (A.GE.ZERO) RETURN
27080 COSTH2=(-A*C + TERM2)/(A**2+B**2)
27081 SINTH2=SQRT(1-COSTH2**2)
27082C---FINALLY, GET P2
27083 IF (COSTH2.EQ.-ONE) RETURN
27084 P2=-K22/(ROOTS*(1+COSTH2))
27085C---LOAD UP CMF MOMENTA
27086 Q1(1)=P1*SINTH1*COS(PHI1)
27087 Q1(2)=P1*SINTH1*SIN(PHI1)
27088 Q1(3)=P1*COSTH1
27089 Q1(4)=P1
27090 Q1(5)=0
27091 Q2(1)=P2*SINTH2*COS(PHI2)
27092 Q2(2)=P2*SINTH2*SIN(PHI2)
27093 Q2(3)=P2*COSTH2
27094 Q2(4)=P2
27095 Q2(5)=0
27096 H(1)=-Q1(1)-Q2(1)
27097 H(2)=-Q1(2)-Q2(2)
27098 H(3)=-Q1(3)-Q2(3)
27099 H(4)=-Q1(4)-Q2(4)+ROOTS
27100 CALL HWUMAS(H)
27101C---CALCULATE MATRIX ELEMENTS SQUARED
27102 AWW=ENHANC(10)**2 * CW*(ROOTS2/2*HWULDO(Q1,Q2)*G1WW
27103 & +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G2WW)
27104 DO 10 I=1,6
27105 AZZ(I)=ENHANC(11)**2 * CZ*(ROOTS2/2*HWULDO(Q1,Q2)*G1ZZ(I)
27106 & +ROOTS2/4*P1*P2*(1+COSTH1)*(1-COSTH2)*G2ZZ(I))
27107 & *((K12-EMW2)/(K12-EMZ2)*(K22-EMW2)/(K22-EMZ2))**2
27108 10 CONTINUE
27109C---CALCULATE WEIGHT IN INTEGRAL
27110 WEIGHT=FACTR*P2*P1JAC/(ROOTS2**2*HWULDO(H,Q2))
27111 & *(K1MAX2-K1MIN2)/((K1MAX2+EMW2)*(K1MIN2+EMW2))
27112 & *(K2MAX2-K2MIN2)/((K2MAX2+EMW2)*(K2MIN2+EMW2))
27113 & * EMFAC
27114 EMSCA=EMW
27115 XXMIN=(ROOTS/PHEP(5,3))**2
27116 XLMIN=LOG(XXMIN)
27117C---INCLUDE BRANCHING RATIO OF HIGGS
27118 IF(IMSSM.EQ.0)THEN
27119 IDEC=MOD(IPROC,100)
27120 IF (IDEC.GT.0.AND.IDEC.LE.12) WEIGHT=WEIGHT*BRHIG(IDEC)
27121 IF (IDEC.EQ.0) THEN
27122 BRHIGQ=0
27123 DO 20 I=1,6
27124 20 BRHIGQ=BRHIGQ+BRHIG(I)
27125 WEIGHT=WEIGHT*BRHIGQ
27126 ENDIF
27127 IF (IDEC.EQ.10) THEN
27128 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
27129 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
27130 WEIGHT=WEIGHT*BR
27131 ELSEIF (IDEC.EQ.11) THEN
27132 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
27133 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
27134 WEIGHT=WEIGHT*BR
27135 ENDIF
27136 END IF
27137 IF (EE) THEN
27138 CSFAC=WEIGHT
27139 PSUM=AWW+AZZ(4)
27140 EVWGT=CSFAC*PSUM
27141 ELSEIF (EP) THEN
27142 CSFAC=-WEIGHT*TAULN
27143 XX(1)=ONE
27144 XX(2)=XXMIN
27145 CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD),NSTRU,DISF(1,2),2)
27146 IF (IDHW(1).LE.126) THEN
27147 PWW=(DISF(2,2)+DISF(4,2)+DISF(7,2)+DISF( 9,2))*AWW
27148 ELSE
27149 PWW=(DISF(1,2)+DISF(3,2)+DISF(8,2)+DISF(10,2))*AWW
27150 ENDIF
27151 PZZ(5)=(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2))*AZZ(5)
27152 PZZ(6)=(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF( 9,2))*AZZ(6)
27153 PSUM=PWW+PZZ(5)+PZZ(6)
27154 EVWGT=CSFAC*PSUM
27155 ELSE
27156 CSFAC=WEIGHT*TAULN*XLMIN
27157 CALL HWSGEN(.TRUE.)
27158 PWW=((DISF(2,1)+DISF(4, 1)+DISF(7,1)+DISF(9,1))
27159 & *(DISF(8,2)+DISF(10,2)+DISF(1,2)+DISF(3,2))
27160 & +(DISF(8,1)+DISF(10,1)+DISF(1,1)+DISF(3,1))
27161 & *(DISF(2,2)+DISF(4, 2)+DISF(7,2)+DISF(9,2)))
27162 & *AWW
27163 PZZ(1)=((DISF(2,1)+DISF(4,1)+DISF(8,1)+DISF(10,1))
27164 & *(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2)))
27165 & *AZZ(1)
27166 PZZ(2)=((DISF(2,1)+DISF(4,1)+DISF(8,1)+DISF(10,1))
27167 & *(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF(9, 2))
27168 & +(DISF(1,1)+DISF(3,1)+DISF(7,1)+DISF(9, 1))
27169 & *(DISF(2,2)+DISF(4,2)+DISF(8,2)+DISF(10,2)))
27170 & *AZZ(2)
27171 PZZ(3)=((DISF(1,1)+DISF(3,1)+DISF(7,1)+DISF(9,1))
27172 & *(DISF(1,2)+DISF(3,2)+DISF(7,2)+DISF(9,2)))
27173 & *AZZ(3)
27174 PSUM=PWW+PZZ(1)+PZZ(2)+PZZ(3)
27175C---EVENT WEIGHT IS SUM OVER ALL COMBINATIONS
27176 EVWGT=CSFAC*PSUM
27177 ENDIF
27178 ELSE
27179C---GENERATE EVENT
27180C---CHOOSE EVENT TYPE
27181 RSUM=PSUM*HWRGEN(0)
27182C---ELECTRON BEAMS?
27183 IF (EE) THEN
27184 IDN(1)=IDHW(1)
27185 IDN(2)=IDHW(2)
27186C---WW FUSION?
27187 IF (RSUM.LT.AWW) THEN
27188 IDN(3)=IDN(1)+1
27189 IDN(4)=IDN(2)+1
27190C---ZZ FUSION?
27191 ELSE
27192 IDN(3)=IDN(1)
27193 IDN(4)=IDN(2)
27194 ENDIF
27195C---LEPTON-HADRON COLLISION?
27196 ELSEIF (EP) THEN
27197C---WW FUSION?
27198 IDN(1)=IDHW(1)
27199 IF (RSUM.LT.PWW) THEN
27200 24 IDN(2)=HWRINT(1,8)
27201 IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
27202 IF (ICHRG(IDN(1))*ICHRG(IDN(2)).GT.0) GOTO 24
27203 PROB=DISF(IDN(2),2)*AWW/PWW
27204 IF (HWRGEN(0).GT.PROB) GOTO 24
27205 IDN(3)=IDN(1)+1
27206 IF (HWRGEN(0).GT.SCABI) THEN
27207 IDN(4)= 4*INT((IDN(2)-1)/2)-IDN(2)+3
27208 ELSE
27209 IDN(4)=12*INT((IDN(2)-1)/6)-IDN(2)+5
27210 ENDIF
27211C---ZZ FUSION FROM U-TYPE QUARK?
27212 ELSEIF (RSUM.LT.PWW+PZZ(5)) THEN
27213 26 IDN(2)=2*HWRINT(1,4)
27214 IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
27215 PROB=DISF(IDN(2),2)*AZZ(5)/PZZ(5)
27216 IF (HWRGEN(0).GT.PROB) GOTO 26
27217 IDN(3)=IDN(1)
27218 IDN(4)=IDN(2)
27219C---ZZ FUSION FROM D-TYPE QUARK?
27220 ELSE
27221 28 IDN(2)=2*HWRINT(1,4)-1
27222 IF (IDN(2).GE.5) IDN(2)=IDN(2)+2
27223 PROB=DISF(IDN(2),2)*AZZ(6)/PZZ(6)
27224 IF (HWRGEN(0).GT.PROB) GOTO 28
27225 IDN(3)=IDN(1)
27226 IDN(4)=IDN(2)
27227 ENDIF
27228C---HADRON BEAMS?
27229 ELSE
27230C---WW FUSION?
27231 IF (RSUM.LT.PWW) THEN
27232 31 DO 32 I=1,2
27233 IDN(I)=HWRINT(1,8)
27234 IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
27235 32 CONTINUE
27236 IF (ICHRG(IDN(1))*ICHRG(IDN(2)).GT.0) GOTO 31
27237 PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AWW/PWW
27238 IF (HWRGEN(0).GT.PROB) GOTO 31
27239C---CHOOSE OUTGOING QUARKS
27240 DO 33 I=1,2
27241 IF (HWRGEN(0).GT.SCABI) THEN
27242 IDN(I+2)=4*INT((IDN(I)-1)/2)-IDN(I)+3
27243 ELSE
27244 IDN(I+2)=12*INT((IDN(I)-1)/6)-IDN(I)+5
27245 ENDIF
27246 33 CONTINUE
27247C---ZZ FUSION FROM U-TYPE QUARKS?
27248 ELSEIF (RSUM.LT.PWW+PZZ(1)) THEN
27249 41 DO 42 I=1,2
27250 IDN(I)=2*HWRINT(1,4)
27251 IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
27252 42 CONTINUE
27253 PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(1)/PZZ(1)
27254 IF (HWRGEN(0).GT.PROB) GOTO 41
27255 IDN(3)=IDN(1)
27256 IDN(4)=IDN(2)
27257C---ZZ FUSION FROM D-TYPE QUARKS?
27258 ELSEIF (RSUM.LT.PWW+PZZ(1)+PZZ(3)) THEN
27259 51 DO 52 I=1,2
27260 IDN(I)=2*HWRINT(1,4)-1
27261 IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
27262 52 CONTINUE
27263 PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(3)/PZZ(3)
27264 IF (HWRGEN(0).GT.PROB) GOTO 51
27265 IDN(3)=IDN(1)
27266 IDN(4)=IDN(2)
27267C---ZZ FUSION FROM UD-TYPE PAIRS?
27268 ELSE
27269 61 IF (HWRGEN(0).GT.HALF) THEN
27270 IDN(1)=2*HWRINT(1,4)-1
27271 IDN(2)=2*HWRINT(1,4)
27272 ELSE
27273 IDN(1)=2*HWRINT(1,4)
27274 IDN(2)=2*HWRINT(1,4)-1
27275 ENDIF
27276 DO 62 I=1,2
27277 62 IF (IDN(I).GE.5) IDN(I)=IDN(I)+2
27278 PROB=DISF(IDN(1),1)*DISF(IDN(2),2)*AZZ(2)/PZZ(2)
27279 IF (HWRGEN(0).GT.PROB) GOTO 61
27280 IDN(3)=IDN(1)
27281 IDN(4)=IDN(2)
27282 ENDIF
27283 ENDIF
27284C---NOW BOOST TO LAB, AND SET UP STATUS CODES etc
27285 IDCMF=15
27286C---INCOMING
27287 IF (.NOT.EE) CALL HWEONE
27288C---CMF POINTERS
27289 JDAHEP(1,NHEP)=NHEP+1
27290 JDAHEP(2,NHEP)=NHEP+3
27291 JMOHEP(1,NHEP+1)=NHEP
27292 JMOHEP(1,NHEP+2)=NHEP
27293 JMOHEP(1,NHEP+3)=NHEP
27294C---OUTGOING MOMENTA (GIVE QUARKS MASS NON-COVARIANTLY!)
27295 Q1(5)=RMASS(IDN(1))
27296 Q1(4)=SQRT(Q1(4)**2+Q1(5)**2)
27297 Q2(5)=RMASS(IDN(2))
27298 Q2(4)=SQRT(Q2(4)**2+Q2(5)**2)
27299 H(4)=-Q1(4)-Q2(4)+PHEP(5,NHEP)
27300 CALL HWUMAS(H)
27301 CALL HWULOB(PHEP(1,NHEP),Q1,PHEP(1,NHEP+1))
27302 CALL HWULOB(PHEP(1,NHEP),Q2,PHEP(1,NHEP+2))
27303 CALL HWULOB(PHEP(1,NHEP),H,PHEP(1,NHEP+3))
27304C---STATUS AND IDs
27305 ISTHEP(NHEP+1)=113
27306 ISTHEP(NHEP+2)=114
27307 ISTHEP(NHEP+3)=114
27308 IDHW(NHEP+1)=IDN(3)
27309 IDHEP(NHEP+1)=IDPDG(IDN(3))
27310 IDHW(NHEP+2)=IDN(4)
27311 IDHEP(NHEP+2)=IDPDG(IDN(4))
27312 IDHW(NHEP+3)=201+IHIGGS
27313 IDHEP(NHEP+3)=IDPDG(201+IHIGGS)
27314C---COLOUR LABELS
27315 JMOHEP(2,NHEP+1)=NHEP-2
27316 JMOHEP(2,NHEP+2)=NHEP-1
27317 JMOHEP(2,NHEP-1)=NHEP+2
27318 JMOHEP(2,NHEP-2)=NHEP+1
27319 JMOHEP(2,NHEP+3)=NHEP+3
27320 JDAHEP(2,NHEP+1)=NHEP-2
27321 JDAHEP(2,NHEP+2)=NHEP-1
27322 JDAHEP(2,NHEP-1)=NHEP+2
27323 JDAHEP(2,NHEP-2)=NHEP+1
27324 JDAHEP(2,NHEP+3)=NHEP+3
27325 NHEP=NHEP+3
27326 ENDIF
27327 END
27328CDECK ID>, HWHIGY.
27329*CMZ :- -26/04/91 13.37.37 by Federico Carminati
27330*-- Author : Mike Seymour
27331C-----------------------------------------------------------------------
27332 FUNCTION HWHIGY(A,B,XP)
27333C-----------------------------------------------------------------------
27334C CALCULATE THE INTEGRAL OF BERENDS AND KLEISS APPENDIX B
27335C-----------------------------------------------------------------------
27336 IMPLICIT NONE
27337 DOUBLE COMPLEX XQ,Z1,Z2,Z3,Z4,C0,C1,C2,C3,C4,C5,C6,C7,C8,FUN,Z
27338 DOUBLE PRECISION HWHIGY,TWO,A,B,XP,Y
27339 PARAMETER (TWO=2.D0)
27340C---DECLARE ALL THE STATEMENT-FUNCTION DEFINITIONS
27341 C0(Z,A)=(Z**2-A)**2*((Z**2+A)**2-24*Z*(Z**2+A)+8*Z**2*(A+6))/Z**4
27342 C1(Z,A)=A**4/(3*Z)
27343 C2(Z,A)=-A**3*(24*Z-A)/(2*Z**2)
27344 C3(Z,A)=A**2*(8*Z**2*(A+6)-24*A*Z+A**2)/Z**3
27345 C4(Z,A)=-A**2*(24*Z**3+8*Z**2*(A+6)-24*A*Z+A**2)/Z**4
27346 C5(Z,A)=Z**3-24*Z**2+8*Z*(A+6)+24*A
27347 C6(Z,A)=0.5*Z**2-12*Z+4*(A+6)
27348 C7(Z,A)=Z/3-8
27349 C8(Z,A)=0.25
27350 FUN(Z,Y,A)=C0(Z,A)*LOG(Y-Z)
27351 & +C1(Z,A)/Y**3
27352 & +C2(Z,A)/Y**2
27353 & +C3(Z,A)/Y
27354 & +C4(Z,A)*LOG(Y)
27355 & +C5(Z,A)*Y
27356 & +C6(Z,A)*Y**2
27357 & +C7(Z,A)*Y**3
27358 & +C8(Z,A)*Y**4
27359C---NOW EVALUATE THE INTEGRAL
27360 HWHIGY=0
27361 IF (A.GT.4) RETURN
27362 XQ=DCMPLX(XP,B)
27363 Z1=XQ+SQRT(XQ**2-A)
27364 Z2=XQ-SQRT(XQ**2-A)
27365 Z3=FUN(Z1,TWO,A)-FUN(Z1,SQRT(A),A)
27366 Z4=FUN(Z2,TWO,A)-FUN(Z2,SQRT(A),A)
27367 HWHIGY=DIMAG((Z3-Z4)/(Z1-Z2))/(8*B)
27368 END
27369CDECK ID>, HWHIGZ.
27370*CMZ :- -02/05/91 11.18.44 by Federico Carminati
27371*-- Author : Mike Seymour, modified by Stefano Moretti
27372C-----------------------------------------------------------------------
27373 SUBROUTINE HWHIGZ
27374C-----------------------------------------------------------------------
27375C HIGGS PRODUCTION VIA THE BJORKEN PROCESS: E+E- --> Z(*) --> Z(*)H
27376C WHERE ONE OR BOTH OF THE Zs IS OFF-SHELL
27377C USES ALGORITHM OF BERENDS AND KLEISS: NUCL.PHYS. B260(1985)32
27378C
27379C MEAN EVWGT = CROSS-SECTION (IN NB) * HIGGS BRANCHING FRACTION
27380C-----------------------------------------------------------------------
c63d70bc 27381 INCLUDE 'herwig65.inc'
65767955 27382 DOUBLE PRECISION HWUAEM,HWHIGY,HWRUNI,HWRGEN,HWULDO,EMZ,CVE,CAE,
27383 & POL1,POL2,CE1,CE2,CE3,PMAX,EMZ2,S,B,FACTR,EMH,EMFAC,EMH2,A,XP,
27384 & CV,CA,BRHIGQ,BR,X1,X2,FAC1,FAC2,XPP,XPPSQ,COEF,X,XSQ,PROB,C1,C2,
27385 & CHIGG,PTHETA,SHIGG,C3,PHIMAX,CPHI,SPHI,C2PHI,S2PHI,PCM,ELST
27386 INTEGER IDEC,I,NLOOP,ICMF,IHIG,IZED,IFER,IANT,ID1,ID2,IN1,IN2
27387 EXTERNAL HWUAEM,HWHIGY,HWRUNI,HWRGEN,HWULDO
27388 SAVE CVE,CAE,CE1,CE2,CE3,PMAX,EMZ2,S,EMH,B,FACTR,A,EMH2
27389 EQUIVALENCE (EMZ,RMASS(200))
27390 SAVE ELST
27391 DATA ELST/0/
27392C---SET UP CONSTANTS
27393 IN1=1
27394 IF (JDAHEP(1,IN1).NE.0) IN1=JDAHEP(1,IN1)
27395 IN2=2
27396 IF (JDAHEP(1,IN2).NE.0) IN2=JDAHEP(1,IN2)
27397 IF (FSTWGT.OR.ELST.NE.PHEP(5,3)) THEN
27398 ELST=PHEP(5,3)
27399 CVE=VFCH(11,1)
27400 CAE=AFCH(11,1)
27401 POL1=1.-EPOLN(3)*PPOLN(3)
27402 POL2=EPOLN(3)-PPOLN(3)
27403 CE1=(POL1*(CVE**2+CAE**2)+POL2*2.*CVE*CAE)
27404 CE2=(POL1*2.*CVE*CAE+POL2*(CVE**2+CAE**2))
27405 IF ((IDHW(IN1).GT.IDHW(IN2).AND.PHEP(3,IN1).LT.ZERO).OR.
27406 & (IDHW(IN2).GT.IDHW(IN1).AND.PHEP(3,IN2).LT.ZERO)) CE2=-CE2
27407 IF (TPOL) CE3=(CVE**2-CAE**2)
27408 PMAX=4
27409 EMZ2=EMZ**2
27410 S=PHEP(5,3)**2
27411 B=EMZ*GAMZ/S
27412 FACTR=GEV2NB*CE1*(HWUAEM(RMASS(201+IHIGGS)**2)*ENHANC(11))**2
27413 & /(12.*S*SWEIN*(1.-SWEIN))*B/((1-EMZ2/S)**2+B**2)
27414 ENDIF
27415 IF (.NOT.GENEV) THEN
27416C---CHOOSE HIGGS MASS, AND CALCULATE EVENT WEIGHT
27417 EVWGT=0D0
27418 EMH=RMASS(201+IHIGGS)
27419 EMFAC=ONE
27420 IF(IMSSM.EQ.0)CALL HWHIGM(EMH,EMFAC)
27421 IF (EMH.LE.ZERO .OR. EMH.GT.PHEP(5,3)) RETURN
27422 EMSCA=EMH
27423 EMH2=EMH**2
27424 A=4*EMH2/S
27425 XP=1+(EMH2-EMZ2)/S
27426 EVWGT=FACTR*HWHIGY(A,B,XP)*EMFAC
27427C---INCLUDE BRANCHING RATIO OF HIGGS
27428 IF(IMSSM.EQ.0)THEN
27429 IDEC=MOD(IPROC,100)
27430 IF (IDEC.GT.0.AND.IDEC.LE.12) EVWGT=EVWGT*BRHIG(IDEC)
27431 IF (IDEC.EQ.0) THEN
27432 BRHIGQ=0
27433 DO 10 I=1,6
27434 10 BRHIGQ=BRHIGQ+BRHIG(I)
27435 EVWGT=EVWGT*BRHIGQ
27436 ENDIF
27437C Add Z branching fractions
27438 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,0)
27439 EVWGT=EVWGT*BR
27440 IF (IDEC.EQ.10) THEN
27441 CALL HWDBOZ(198,ID1,ID2,CV,CA,BR,1)
27442 CALL HWDBOZ(199,ID1,ID2,CV,CA,BR,1)
27443 EVWGT=EVWGT*BR
27444 ELSEIF (IDEC.EQ.11) THEN
27445 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
27446 CALL HWDBOZ(200,ID1,ID2,CV,CA,BR,1)
27447 EVWGT=EVWGT*BR
27448 ENDIF
27449 END IF
27450 ELSE
27451C---GENERATE EVENT
27452 ICMF=NHEP+1
27453 IHIG=NHEP+2
27454 IZED=NHEP+3
27455 IFER=NHEP+4
27456 IANT=NHEP+5
27457 CALL HWVEQU(5,PHEP(1,3),PHEP(1,ICMF))
27458 NHEP=NHEP+5
27459C---CHOOSE ENERGY FRACTION OF HIGGS
27460 X1=SQRT(A)
27461 X2=1+0.25*A
27462 XP=1+(EMH2-EMZ2)/S
27463 FAC1=ATAN((X1-XP)/B)
27464 FAC2=ATAN((X2-XP)/B)
27465 XPP=MIN(X2,MAX(X1+B,XP))
27466 XPPSQ=XPP**2
27467 NLOOP=0
27468 COEF=1./((12+2*A-12*XPP+XPPSQ)*SQRT(XPPSQ-A))
27469 20 NLOOP=NLOOP+1
27470 IF (NLOOP.GT.NBTRY) THEN
27471 CALL HWWARN('HWHIGZ',101)
27472 GOTO 999
27473 ENDIF
27474 X=XP+B*TAN(HWRUNI(1,FAC1,FAC2))
27475 XSQ=X**2
27476 PROB=COEF*((12+2*A-12*X+XSQ)*SQRT(XSQ-A))
27477 IF (PROB.GT.PMAX) THEN
27478 PMAX=1.1*PROB
27479 CALL HWWARN('HWHIGZ',1)
27480 WRITE (6,21) PMAX
27481 21 FORMAT(7X,'NEW HWHIGZ MAX WEIGHT =',F8.4)
27482 ENDIF
27483 IF (PROB.LT.PMAX*HWRGEN(0)) GOTO 20
27484C Choose Z decay mode
27485 CALL HWDBOZ(200,IDHW(IFER),IDHW(IANT),CV,CA,BR,0)
27486 C1=CE1*(CV**2+CA**2)
27487 C2=CE2*2.*CV*CA
27488C---CHOOSE HIGGS DIRECTION
27489C First polar angle
27490 NLOOP=0
27491 COEF=(XSQ-A)/(8.*(1.-X)+XSQ+A)
27492 30 NLOOP=NLOOP+1
27493 IF (NLOOP.GT.NBTRY) THEN
27494 CALL HWWARN('HWHIGZ',102)
27495 GOTO 999
27496 ENDIF
27497 CHIGG=HWRUNI(2,-ONE, ONE)
27498 PTHETA=1-COEF*CHIGG**2
27499 IF (PTHETA.LT.HWRGEN(1)) GOTO 30
27500 SHIGG=SQRT(1-CHIGG**2)
27501C Now azimuthal angle
27502 IF (TPOL) THEN
27503 C3=CE3*(CV*2+CA**2)
27504 COEF=COEF*SHIGG**2*C3/C1
27505 PHIMAX=PTHETA+ABS(COEF)
27506 40 CALL HWRAZM(ONE,CPHI,SPHI)
27507 C2PHI=2.*CPHI**2-1.
27508 S2PHI=2.*CPHI*SPHI
27509 PROB=PTHETA-COEF*(C2PHI*COSS+S2PHI*SINS)
27510 IF (PROB.LT.HWRGEN(1)*PHIMAX) GOTO 40
27511 ELSE
27512 CALL HWRAZM(ONE,CPHI,SPHI)
27513 ENDIF
27514C Construct Higgs and Z momenta
27515 PHEP(5,IHIG)=EMH
27516 PHEP(4,IHIG)=X*PHEP(5,ICMF)/2
27517 PCM=SQRT(PHEP(4,IHIG)**2-EMH2)
27518 PHEP(3,IHIG)=CHIGG*PCM
27519 PHEP(1,IHIG)=SHIGG*PCM*CPHI
27520 PHEP(2,IHIG)=SHIGG*PCM*SPHI
27521 CALL HWVDIF(4,PHEP(1,ICMF),PHEP(1,IHIG),PHEP(1,IZED))
27522 CALL HWUMAS(PHEP(1,IZED))
27523C Choose orientation of Z decay
27524 NLOOP=0
27525 COEF=2.*(C1+ABS(C2))*HWULDO(PHEP(1,IN1),PHEP(1,IZED))
27526 & *HWULDO(PHEP(1,IN2),PHEP(1,IZED))/S
27527 IF (TPOL) COEF=COEF*(C1+ABS(C2)+ABS(C3))/(C1+ABS(C2))
27528 PCM=PHEP(5,IZED)/2
27529 PHEP(5,IFER)=0
27530 PHEP(5,IANT)=0
27531 50 NLOOP=NLOOP+1
27532 IF (NLOOP.GT.NBTRY) THEN
27533 CALL HWWARN('HWHIGZ',103)
27534 GOTO 999
27535 ENDIF
27536 CALL HWDTWO(PHEP(1,IZED),PHEP(1,IFER),PHEP(1,IANT),
27537 & PCM,TWO,.TRUE.)
27538 PROB=C1*(PHEP(4,IFER)*PHEP(4,IANT)-PHEP(3,IFER)*PHEP(3,IANT))
27539 & +C2*(PHEP(4,IFER)*PHEP(3,IANT)-PHEP(3,IFER)*PHEP(4,IANT))
27540 IF (TPOL) PROB=PROB+C3*
27541 & (COSS*(PHEP(1,IFER)*PHEP(1,IANT)-PHEP(2,IFER)*PHEP(2,IANT))
27542 & +SINS*(PHEP(1,IFER)*PHEP(2,IANT)+PHEP(2,IFER)*PHEP(1,IANT)))
27543 IF (PROB.LT.HWRGEN(2)*COEF) GOTO 50
27544C---SET UP STATUS CODES,
27545 ISTHEP(ICMF)=120
27546 ISTHEP(IHIG)=190
27547 ISTHEP(IZED)=195
27548 ISTHEP(IFER)=113
27549 ISTHEP(IANT)=114
27550C---COLOR CONNECTIONS,
27551 JMOHEP(1,ICMF)=1
27552 JMOHEP(2,ICMF)=2
27553 JDAHEP(1,ICMF)=IHIG
27554 JDAHEP(2,ICMF)=IZED
27555 JMOHEP(1,IHIG)=ICMF
27556 JMOHEP(1,IZED)=ICMF
27557 JMOHEP(1,IFER)=IZED
27558 JMOHEP(1,IANT)=IZED
27559 JMOHEP(2,IFER)=IANT
27560 JMOHEP(2,IANT)=IFER
27561 JDAHEP(1,IZED)=IFER
27562 JDAHEP(2,IZED)=IANT
27563 JDAHEP(2,IFER)=IANT
27564 JDAHEP(2,IANT)=IFER
27565C---IDENTITY CODES
27566 IDHW(ICMF)=200
27567 IDHW(IHIG)=201+IHIGGS
27568 IDHW(IZED)=200
27569 IDHEP(ICMF)=IDPDG(IDHW(ICMF))
27570 IDHEP(IHIG)=IDPDG(IDHW(IHIG))
27571 IDHEP(IZED)=IDPDG(IDHW(IZED))
27572 IDHEP(IFER)=IDPDG(IDHW(IFER))
27573 IDHEP(IANT)=IDPDG(IDHW(IANT))
27574 ENDIF
27575 999 RETURN
27576 END
27577CDECK ID>, HWHIHH.
27578*CMZ :- -25/11/01 17.11.33 by Stefano Moretti
27579*-- Author : Kosuke Odagiri, modified by Stefano Moretti
27580C-----------------------------------------------------------------------
27581C...Generate completely differential cross section (EVWGT) in the variable
27582C...X(I) with I=1 (see below) for the processes IPROC=955,965,975 as
27583C...described in the HERWIG 6 documentation file.
27584C
27585C...First release: 12-NOV-2001 by Stefano Moretti
27586C
27587C-----------------------------------------------------------------------
27588 SUBROUTINE HWHIHH
27589C-----------------------------------------------------------------------
27590C PRODUCTION OF MSSM HIGGS PAIRS IN L+L- (L=E,MU)
27591C-----------------------------------------------------------------------
c63d70bc 27592 INCLUDE 'herwig65.inc'
65767955 27593 DOUBLE PRECISION HWRGEN, HWUAEM, HCS, RCS, S, PF, QPE,
27594 & FACTR, SN2TH, MZ, MNN(2), MCC, EMSC2, GZ2,
27595 & GHH(4), XWEIN, S2W, X(1), XL(1),
27596 & XU(1), WEIGHT, ECM, RMH1, RMH2, EMH1, EMH2,
27597 & EMHWT1, EMHWT2, EMHHWT, SHAT
27598 INTEGER I, ID1, ID2, IH1, IH2, IH, JH
27599 EXTERNAL HWRGEN, HWUAEM
27600 SAVE HCS,MNN,MCC,EMHHWT,S,SHAT
27601 DOUBLE COMPLEX Z, GZ, A, D, E
27602 PARAMETER (Z = (0.D0,1.D0))
27603 EQUIVALENCE (MZ, RMASS(200))
27604C...process event.
27605 IF (GENEV) THEN
27606 RCS = HCS*HWRGEN(0)
27607 ELSE
27608 HCS = ZERO
27609 EVWGT = ZERO
27610C...energy at parton level.
27611 ECM = PBEAM1+PBEAM2
27612 S = ECM*ECM
27613 SHAT = S
27614C...phase space variables.
27615C...X(1)=COS(THETA_CM),
27616C...phase space borders.
27617 XL(1)= -1.
27618 XU(1)= 1.
27619C...single phase space point.
27620 WEIGHT=1.
27621 DO I=1,1
27622 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
27623 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
27624 END DO
27625C...final state masses.
27626 IF((MOD(IPROC,10000).EQ.965).OR.
27627 & (MOD(IPROC,10000).EQ.975))THEN
27628 JH = IHIGGS-1
27629 ID1 = 205
27630 ID2 = 202 + JH
27631 ELSE IF(MOD(IPROC,10000).EQ.955)THEN
27632 JH = 4
27633 ID1 = 206
27634 ID2 = 207
27635 END IF
27636 RMH1=RMASS(ID1)
27637 RMH2=RMASS(ID2)
27638 EMH1=RMH1
27639 EMH2=RMH2
27640 EMHWT1=1.
27641 EMHWT2=1.
27642 EMHHWT=EMHWT1*EMHWT2
27643C...polar angle.
27644 COSTH = X(1)
27645 SN2TH = 0.25D0 - 0.25D0*COSTH**2
27646 EMSCA = EMH1+EMH2
27647 EMSC2 = EMSCA*EMSCA
27648 EVWGT = ZERO
27649 FACTR = GEV2NB*PIFAC*(HWUAEM(EMSC2))**2/SHAT*SN2TH/2.
27650C...constant weight.
27651 FACTR = FACTR*WEIGHT
27652C...couplings and propagators.
27653 XWEIN = TWO*SWEIN
27654 S2W = DSQRT(XWEIN*(TWO-XWEIN))
27655 GZ = S2W*(SHAT-MZ**2+Z*SHAT*GAMZ/MZ)/SHAT
27656 GZ2 = DREAL(DCONJG(GZ)*GZ)
27657C...labels: 1 = h0, 2 = H0, 3 = A0, 4 = H+, 5 = H-.
27658 GHH(1)= COSBMA
27659 GHH(2)= SINBMA
27660 GHH(3)= ONE
27661 GHH(4)= ONE-XWEIN
27662C...set to zero all MEs.
27663 DO I=1,2
27664 MNN(I)=ZERO
27665 END DO
27666 MCC=ZERO
27667C...start subprocesses.
27668 IF((MOD(IPROC,10000).EQ.965).OR.
27669 & (MOD(IPROC,10000).EQ.975))THEN
27670c
27671c - + o o o
27672c l l -> A h / H
27673c
27674 DO IH = JH,JH
27675 QPE = SHAT-(EMH1+EMH2)**2
27676 IF (QPE.GT.ZERO) THEN
27677 PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
27678 MNN(IH) =
27679 & FACTR*PF**3*GHH(IH)**2*(LFCH(11)**2+RFCH(11)**2)/GZ2
27680 ELSE
27681 CONTINUE
27682 END IF
27683 END DO
27684 ELSE IF(MOD(IPROC,10000).EQ.955)THEN
27685c
27686c - + + -
27687c l l -> H H
27688c
27689 IH = JH
27690 QPE = SHAT-(EMH1+EMH2)**2
27691 IF (QPE.GT.ZERO) THEN
27692 PF = SQRT(QPE*(SHAT-(EMH1-EMH2)**2))/SHAT
27693 A = GHH(IH)/GZ
27694 D = QFCH(11)+A*LFCH(11)
27695 E = QFCH(11)+A*RFCH(11)
27696 MCC=FACTR*PF**3*DREAL(DCONJG(D)*D+DCONJG(E)*E)
27697 ELSE
27698 CONTINUE
27699 END IF
27700 END IF
27701 END IF
27702 HCS = ZERO
27703 IF(MOD(IPROC,10000).EQ.965)THEN
27704 IH1 = 205
27705 IH2 = 203
27706 HCS = HCS + EMHHWT*MNN(1)
27707 ELSE IF(MOD(IPROC,10000).EQ.975)THEN
27708 IH1 = 205
27709 IH2 = 204
27710 HCS = HCS + EMHHWT*MNN(2)
27711 ELSE IF(MOD(IPROC,10000).EQ.955)THEN
27712 IH1 = 206
27713 IH2 = 207
27714 HCS = HCS + EMHHWT*MCC
27715 END IF
27716 IF (GENEV.AND.HCS.GT.RCS) THEN
27717C...generate event.
27718 IDN(1)=IDHW(1)
27719 IDN(2)=IDHW(2)
27720 IDN(3)=IH1
27721 IDN(4)=IH2
27722 IDCMF=15
27723 XX(1) = ONE
27724 XX(2) = ONE
27725 CALL HWETWO(.TRUE.,.TRUE.)
27726 IF (AZSPIN) THEN
27727 CALL HWVZRO(7,GCOEF)
27728 END IF
27729 END IF
27730 EVWGT = HCS
27731 END
27732CDECK ID>, HWHISQ.
27733*CMZ :- -30/06/01 18.41.23 by Stefano Moretti
27734*-- Author : Stefano Moretti
27735C-----------------------------------------------------------------------
27736C...Generate completely differential cross section (EVWGT) in the variables
27737C...X(I) with I=1,6 (see below) for the processes from IPROC=3110
27738C...to IPROC=3298, as described in the HERWIG 6 documentation file.
27739C...It includes interface to PDFs and takes into account color connections
27740C...among partons.
27741C
27742C...First release: 08-APR-2000 by Stefano Moretti
27743C...Last modified: 29-JUN-2001 by Stefano Moretti
27744C
27745C-----------------------------------------------------------------------
27746 SUBROUTINE HWHISQ
27747C-----------------------------------------------------------------------
27748C PRODUCTION OF MSSM HIGGSES IN ASSOCIATION WITH B,T-SQUARK PAIRS
27749C-----------------------------------------------------------------------
c63d70bc 27750 INCLUDE 'herwig65.inc'
65767955 27751 COMMON/SQSQH/JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
27752 INTEGER JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
27753 INTEGER I,J,K,L,M,N
27754 INTEGER IQMIN,IQMAX,IGG,IQQ,JPP
27755 INTEGER NC,FLIP
27756 INTEGER IF1,IF2
27757 INTEGER JHH,IMIX1,IMIX2
27758 INTEGER JSQ,JSQ1,JSQ2
27759 INTEGER IME,JME
27760 DOUBLE PRECISION EMSQ1,EMSQ2,GAMSQ1,GAMSQ2,EMSQQ,EMH,EMHWT
27761 DOUBLE PRECISION GSQ1,GSQ2
27762 DOUBLE PRECISION X(6),XL(6),XU(6)
27763 DOUBLE PRECISION Q4(0:3),Q34(0:3)
27764 DOUBLE PRECISION CT5,ST5,CT4,ST4,CF4,SF4,RQ52,RQ5,RQ42,RQ4,PQ4
27765 DOUBLE PRECISION P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
27766 DOUBLE PRECISION ECM_MAX,ECM,SHAT,S,TAU
27767 DOUBLE PRECISION EMIN,EMIN1,EMIN2,PCM2,PCM
27768 DOUBLE PRECISION GGSQHT,GGSQHU,GGSQHN,QQSQH
27769 DOUBLE PRECISION M2GG(8),M2GGPL(8),M2GGMN(8),M2QQ(8)
27770 DOUBLE PRECISION ALPHA,ALPHAS,EMSC2
27771 DOUBLE PRECISION HWRGEN,HWUAEM,HWUALF
27772 DOUBLE PRECISION PHI,CPHI,SPHI,ROT(3,3)
27773 DOUBLE PRECISION VCOL,GCOL,QAUX(0:3)
27774 DOUBLE PRECISION EPS,HCS,RCS,GACT,FACT(8),DIST
27775 DOUBLE PRECISION WEIGHT
27776 SAVE HCS,M2QQ,M2GG,M2GGPL,M2GGMN,FACT,S,SHAT,P3,P4,P5
27777 SAVE IME,JSQ1,JSQ2
27778 LOGICAL HWRLOG
27779 EXTERNAL HWRGEN,HWUAEM,HWUALF,HWHQCP,HWH2SH,HWETWO,HWRLOG
27780 PARAMETER (EPS=1.D-9)
27781 EQUIVALENCE (NC,NCOLO)
27782C...process the event.
27783 IF(GENEV)THEN
27784 RCS=HCS*HWRGEN(0)
27785 ELSE
27786 HCS=0.
27787 EVWGT=0.
27788C...loop over final state flavours.
27789 IME=0
27790 DO I=1,8
27791 M2GG(I)=0.
27792 M2GGPL(I)=0.
27793 M2GGMN(I)=0.
27794 M2QQ(I)=0.
27795 FACT(I)=0.
27796 END DO
27797 DO 2 IF1=IF1MIN,IF1MAX
27798 IF((IF1.GE.407).AND.(IF1.LE.416))GOTO 2
27799 DO 1 IF2=IF2MIN,IF2MAX
27800 IF((IF2.GE.413).AND.(IF2.LE.422))GOTO 1
27801C...assign squark flavour.
27802 JSQ1=IF1
27803 JSQ2=IF2
27804C...check charge.
27805 IF((ICHRG(JSQ1)+ICHRG(JSQ2))/3.NE.-ICHRG(201+JHIGGS+1))GOTO 1
27806 IME=IME+1
27807 IF((IME.LE.0).OR.(IME.GT.8)) THEN
27808 CALL HWWARN('HWHISQ',100)
27809 GOTO 999
27810 ENDIF
27811C...assign final state masses and widths.
27812 EMSQ1=RMASS(JSQ1)
27813 EMSQ2=RMASS(JSQ2)
27814 GAMSQ1=HBAR/RLTIM(JSQ1)
27815 GAMSQ2=HBAR/RLTIM(JSQ2)
27816 EMH=RMASS(201+JHIGGS+1)
27817 EMHWT=1.
27818C...energy at hadron level.
27819 ECM_MAX=PBEAM1+PBEAM2
27820 S=ECM_MAX*ECM_MAX
27821C...phase space variables.
27822C...X(1)=(EMSQQ-EMSQ1-EMSQ2)/(ECM-EMSQ1-EMSQ2-EMH),
27823C...X(2)=COS(THETA5_CM),X(3)=COS(THETA4_CM_34),X(4)=FI4_CM_34,
27824C...X(5)=(1./SHAT-1./ECM_MAX**2)/(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2),
27825C...X(6)=(LOG(TAU)-LOG(X1))/LOG(TAU);
27826C...phase space borders.
27827 XL(1)=0.
27828 XU(1)=1.
27829 XL(2)=-1.
27830 XU(2)=1.
27831 XL(3)=-1.
27832 XU(3)=1.
27833 XL(4)=0.
27834 XU(4)=2.*PIFAC
27835 XL(5)=0.
27836 XU(5)=1.
27837 XL(6)=0.
27838 XU(6)=1.
27839C...single phase space point.
27840 100 CONTINUE
27841 WEIGHT=1.
27842 DO I=1,6
27843 X(I)=XL(I)+(XU(I)-XL(I))*HWRGEN(0)
27844 WEIGHT=WEIGHT*ABS(XU(I)-XL(I))
27845 END DO
27846C...energy at parton level.
27847 ECM=SQRT(1./(X(5)*(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2)
27848 & +1./ECM_MAX**2))
27849 IF((EMH.LE.0.).OR.(EMH.GE.ECM))RETURN
27850 SHAT=ECM*ECM
27851 TAU=SHAT/S
27852C...momentum fractions X1 and X2.
27853 XX(1)=EXP(LOG(TAU)*(1.-X(6)))
27854 XX(2)=TAU/XX(1)
27855C...three particle kinematics.
27856 EMSQQ=X(1)*(ECM-EMSQ1-EMSQ2-EMH)+EMSQ1+EMSQ2
27857 CT5=X(2)
27858 IF(HWRLOG(HALF))THEN
27859 ST5=+SQRT(1.-CT5*CT5)
27860 ELSE
27861 ST5=-SQRT(1.-CT5*CT5)
27862 END IF
27863 CT4=X(3)
27864 ST4=SQRT(1.-CT4*CT4)
27865 CF4=COS(X(4))
27866 SF4=SIN(X(4))
27867 RQ52=((ECM*ECM-EMH*EMH-EMSQQ*EMSQQ)**2-(2.*EMH*EMSQQ)**2)/
27868 & (4.*ECM*ECM)
27869 IF(RQ52.LT.0.)THEN
27870 GOTO 100
27871 ELSE
27872 RQ5=SQRT(RQ52)
27873 ENDIF
27874 P5(1)=0.
27875 P5(2)=RQ5*ST5
27876 P5(3)=RQ5*CT5
27877 P5(0)=SQRT(RQ52+EMH*EMH)
27878 DO I=1,3
27879 Q34(I)=-P5(I)
27880 END DO
27881 Q34(0)=SQRT(RQ52+EMSQQ*EMSQQ)
27882 RQ42=((EMSQQ*EMSQQ-EMSQ1*EMSQ1-EMSQ2*EMSQ2)**2
27883 & -(2.*EMSQ1*EMSQ2)**2)/
27884 & (4.*EMSQQ*EMSQQ)
27885 IF(RQ42.LT.0.)THEN
27886 GOTO 100
27887 ELSE
27888 RQ4=SQRT(RQ42)
27889 ENDIF
27890 Q4(1)=RQ4*ST4*CF4
27891 Q4(2)=RQ4*ST4*SF4
27892 Q4(3)=RQ4*CT4
27893 Q4(0)=SQRT(RQ42+EMSQ2*EMSQ2)
27894 PQ4=0.
27895 DO I=1,3
27896 PQ4=PQ4+Q34(I)*Q4(I)
27897 END DO
27898 P4(0)=(Q34(0)*Q4(0)+PQ4)/EMSQQ
27899 P3(0)=Q34(0)-P4(0)
27900 DO I=1,3
27901 P4(I)=Q4(I)+Q34(I)*(P4(0)+Q4(0))/(Q34(0)+EMSQQ)
27902 P3(I)=Q34(I)-P4(I)
27903 END DO
27904C...incoming partons: all massless.
27905 EMIN=0.
27906C...initial state momenta in the partonic CM.
27907 PCM2=((SHAT-EMIN*EMIN-EMIN*EMIN)**2
27908 & -(2.*EMIN*EMIN)**2)/(4.*SHAT)
27909 PCM=SQRT(PCM2)
27910 P1(0)=SQRT(PCM2+EMIN*EMIN)
27911 P1(1)=0.
27912 P1(2)=0.
27913 P1(3)=PCM
27914 P2(0)=SQRT(PCM2+EMIN*EMIN)
27915 P2(1)=0.
27916 P2(2)=0.
27917 P2(3)=-PCM
27918C...color structured ME summed/averaged over final/initial spins and colors.
27919 IGG=1
27920 IQQ=1
27921 JPP=(MOD(IPROC,10000)/10-ILBL/10)
27922 IF((JPP.EQ.4).OR.(JPP.EQ.5).OR.(JPP.EQ.6))IQQ=0
27923 IF((JPP.EQ.7).OR.(JPP.EQ.8).OR.(JPP.EQ.9))IGG=0
27924 GSQ1=GAMSQ1*EMSQ1
27925 GSQ2=GAMSQ2*EMSQ2
27926 CALL HWH2SH(ECM,P1,P2,P3,P4,P5,EMSQ1,EMSQ2,EMH,GSQ1,GSQ2,
27927 & IGG,IQQ,GGSQHT,GGSQHU,GGSQHN,QQSQH)
27928 M2GG(IME)=GGSQHN/(8.*CFFAC)
27929 M2GGPL(IME)=GGSQHT/(8.*CFFAC)
27930 M2GGMN(IME)=GGSQHU/(8.*CFFAC)
27931 M2QQ(IME)=QQSQH*(1.-1./CAFAC**2)/4.
27932C...constant factors: phi along beam and conversion GeV^2->nb.
27933 GACT=2.*PIFAC*GEV2NB
27934C...Jacobians from X1,X2 to X(5),X(6)
27935 GACT=GACT/S*(-LOG(TAU))*(1./(EMSQ1+EMSQ2+EMH)**2-1./ECM_MAX**2)
27936C...phase space Jacobians, pi's and flux.
27937 GACT=GACT*RQ4*RQ5/PCM/32./(2.*PIFAC)**5
27938 & *(ECM-EMSQ1-EMSQ2-EMH)
27939C...EW and QCD couplings.
27940 EMSCA=EMSQ1+EMSQ2+EMH
27941 EMSC2=EMSCA*EMSCA
27942 ALPHA=HWUAEM(EMSC2)
27943 ALPHAS=HWUALF(1,EMSCA)
27944 GACT=GACT*4.*PIFAC*ALPHA/SWEIN
27945 GACT=GACT*16.*PIFAC**2*ALPHAS**2
27946C...enhancement factor for MSSM.
27947 JHH=JHIGGS
27948 IF(JHIGGS.EQ.5)JHH=4
27949 JSQ=JSQ1-400
27950 IF(JSQ1.GT.412)JSQ=JSQ1-412
27951 IMIX1=1
27952 IMIX2=1
27953 IF(JSQ1.GT.412)IMIX1=2
27954 IF(JSQ2.GT.418)IMIX2=2
27955 SENHNC(JSQ)=GHSQSS(JHH,JSQ,IMIX1,IMIX2)
27956 GACT=GACT*SENHNC(JSQ)*SENHNC(JSQ)
27957C...Higgs resonance.
27958 GACT=GACT*EMHWT
27959C...constant weight.
27960 GACT=GACT*WEIGHT
27961C...collects it.
27962 FACT(IME)=GACT
27963 1 CONTINUE
27964 2 CONTINUE
27965 END IF
27966C...set up flavours in final state.
27967 FLIP=0
27968C...set up PDFs.
27969 HCS=0.
27970 CALL HWSGEN(.FALSE.)
27971 IQMAX=13
27972 IF(MOD(IPROC,10000)-ILBL.GE.70)IQMAX=12
27973 IQMIN=1
27974 IF(MOD(IPROC,10000)-ILBL.GE.40)IQMIN=13
27975 IF(MOD(IPROC,10000)-ILBL.GE.70)IQMIN=1
27976 DO 3 JME=1,IME
27977 IF((M2GGPL(JME)+M2GGMN(JME)).EQ.0.)GOTO 3
27978 DO I=IQMIN,IQMAX
27979 IF(DISF(I,1).LT.EPS)THEN
27980 GOTO 200
27981 END IF
27982 K=I/7
27983 L=+1-2*K
27984 IF(I.EQ.13)L=0
27985 J=I+L*6
27986 IF(DISF(J,2).LT.EPS)THEN
27987 GOTO 200
27988 END IF
27989 DIST=DISF(I,1)*DISF(J,2)*S
27990 IF(I.LT.13)THEN
27991C...set up color connections: qq-scattering.
27992 IF(J.EQ.I+6)THEN
27993 HCS=HCS+M2QQ(JME)*DIST*FACT(JME)
27994 IF(GENEV.AND.HCS.GT.RCS)THEN
27995 CONTINUE
27996 CALL HWHQCP(JSQ1,JSQ2,2413, 4)
27997 GOTO 9
27998 END IF
27999 ELSE IF(I.EQ.J+6)THEN
28000 HCS=HCS+M2QQ(JME)*DIST*FACT(JME)
28001 IF(GENEV.AND.HCS.GT.RCS)THEN
28002 FLIP=1
28003 CALL HWHQCP(JSQ2,JSQ1,3142,12)
28004 GOTO 9
28005 END IF
28006 END IF
28007 ELSE
28008C...set up color connections: gg-scattering.
28009 HCS=HCS
28010 & +(M2GGPL(JME)-M2GG(JME)*M2GGPL(JME)
28011 & /(M2GGPL(JME)+M2GGMN(JME))/FLOAT(NC)**2)*DIST*FACT(JME)
28012 IF(GENEV.AND.HCS.GT.RCS) THEN
28013 CALL HWHQCP(JSQ1,JSQ2,2413,27)
28014 GOTO 9
28015 ENDIF
28016 HCS=HCS
28017 & +(M2GGMN(JME)-M2GG(JME)*M2GGMN(JME)
28018 & /(M2GGPL(JME)+M2GGMN(JME))/FLOAT(NC)**2)*DIST*FACT(JME)
28019 IF(GENEV.AND.HCS.GT.RCS) THEN
28020 CALL HWHQCP(JSQ1,JSQ2,4123,28)
28021 GOTO 9
28022 ENDIF
28023 END IF
28024 200 CONTINUE
28025 END DO
28026 3 CONTINUE
28027 EVWGT=HCS
28028 RETURN
28029C...generate event.
28030 9 IDN(1)=I
28031 IDN(2)=J
28032 IDN(5)=JH
28033C...incoming partons: now massive.
28034 EMIN1=RMASS(IDN(1))
28035 EMIN2=RMASS(IDN(2))
28036C...redo initial state momenta in the partonic CM.
28037 PCM2=((SHAT-EMIN1*EMIN1-EMIN2*EMIN2)**2
28038 & -(2.*EMIN1*EMIN2)**2)/(4.*SHAT)
28039 PCM=SQRT(PCM2)
28040 P1(0)=SQRT(PCM2+EMIN1*EMIN1)
28041 P1(1)=0.
28042 P1(2)=0.
28043 P1(3)=PCM
28044 P2(0)=SQRT(PCM2+EMIN2*EMIN2)
28045 P2(1)=0.
28046 P2(2)=0.
28047 P2(3)=-PCM
28048C...randomly rotate final state momenta around beam axis.
28049 PHI=2.*PIFAC*HWRGEN(0)
28050 CPHI=COS(PHI)
28051 SPHI=SIN(PHI)
28052 ROT(1,1)=+CPHI
28053 ROT(1,2)=+SPHI
28054 ROT(1,3)=0.
28055 ROT(2,1)=-SPHI
28056 ROT(2,2)=+CPHI
28057 ROT(2,3)=0.
28058 ROT(3,1)=0.
28059 ROT(3,2)=0.
28060 ROT(3,3)=1.
28061 DO L=1,3
28062 DO M=1,3
28063 QAUX(M)=0.
28064 DO N=1,3
28065 IF(L.EQ.1)QAUX(M)=QAUX(M)+ROT(M,N)*P3(N)
28066 IF(L.EQ.2)QAUX(M)=QAUX(M)+ROT(M,N)*P4(N)
28067 IF(L.EQ.3)QAUX(M)=QAUX(M)+ROT(M,N)*P5(N)
28068 END DO
28069 END DO
28070 DO M=1,3
28071 IF(L.EQ.1)P3(M)=QAUX(M)
28072 IF(L.EQ.2)P4(M)=QAUX(M)
28073 IF(L.EQ.3)P5(M)=QAUX(M)
28074 END DO
28075 END DO
28076C...use HWETWO only to set up status and IDs of (s)quarks.
28077 COSTH=0.
28078 IDCMF=15
28079 CALL HWETWO(.TRUE.,.TRUE.)
28080C...do real incoming, outgoing momenta in the lab frame.
28081 VCOL=(XX(1)-XX(2))/(XX(1)+XX(2))
28082 GCOL=(XX(1)+XX(2))/2./SQRT(XX(1)*XX(2))
28083 DO M=NHEP-4,NHEP+1
28084 IF(M.EQ.NHEP-2)GO TO 888
28085 DO N=0,3
28086 IF(M.EQ.NHEP-4)QAUX(N)=P1(N)
28087 IF(M.EQ.NHEP-3)QAUX(N)=P2(N)
28088 IF(M.EQ.NHEP-1)QAUX(N)=P3(N)*(1-FLIP)+P4(N)*FLIP
28089 IF(M.EQ.NHEP )QAUX(N)=P4(N)*(1-FLIP)+P3(N)*FLIP
28090 IF(M.EQ.NHEP+1)QAUX(N)=P5(N)
28091 END DO
28092C...perform boost.
28093 PHEP(4,M)=GCOL*(QAUX(0)+VCOL*QAUX(3))
28094 PHEP(3,M)=GCOL*(QAUX(3)+VCOL*QAUX(0))
28095 PHEP(2,M)=QAUX(2)
28096 PHEP(1,M)=QAUX(1)
28097 888 CONTINUE
28098 END DO
28099C...needs to set all final state masses.
28100 PHEP(5,NHEP-1)=SQRT(ABS(PHEP(4,NHEP-1)**2
28101 & -PHEP(3,NHEP-1)**2
28102 & -PHEP(2,NHEP-1)**2
28103 & -PHEP(1,NHEP-1)**2))
28104 PHEP(5,NHEP )=SQRT(ABS(PHEP(4,NHEP )**2
28105 & -PHEP(3,NHEP )**2
28106 & -PHEP(2,NHEP )**2
28107 & -PHEP(1,NHEP )**2))
28108 PHEP(5,NHEP+1)=SQRT(ABS(PHEP(4,NHEP+1)**2
28109 & -PHEP(3,NHEP+1)**2
28110 & -PHEP(2,NHEP+1)**2
28111 & -PHEP(1,NHEP+1)**2))
28112C...sets CMF.
28113 DO I=1,4
28114 PHEP(I,NHEP-2)=PHEP(I,NHEP-4)+PHEP(I,NHEP-3)
28115 END DO
28116 PHEP(5,NHEP-2)=SQRT(ABS(PHEP(4,NHEP-2)**2
28117 & -PHEP(3,NHEP-2)**2
28118 & -PHEP(2,NHEP-2)**2
28119 & -PHEP(1,NHEP-2)**2))
28120C...status and IDs for Higgs.
28121 ISTHEP(NHEP+1)=114
28122 IDHW(NHEP+1)=IDN(5)
28123 IDHEP(NHEP+1)=IDPDG(IDN(5))
28124C...Higgs colour (self-)connections.
28125 JMOHEP(1,NHEP+1)=NHEP-2
28126 JMOHEP(2,NHEP+1)=NHEP+1
28127 JDAHEP(2,NHEP+1)=NHEP+1
28128 JDAHEP(2,NHEP-2)=NHEP+1
28129 NHEP=NHEP+1
28130 IF(AZSPIN)THEN
28131C...set to zero the coefficients of the spin density matrices.
28132 CALL HWVZRO(7,GCOEF)
28133 END IF
28134 999 RETURN
28135 END
28136CDECK ID>, HWHPH2.
28137*CMZ :- -12/01/93 10.12.43 by Bryan Webber
28138*-- Author : Ian Knowles
28139C-----------------------------------------------------------------------
28140 SUBROUTINE HWHPH2
28141C-----------------------------------------------------------------------
28142C QQD direct photon pair production: mean EVWGT = sigma in nb
28143C-----------------------------------------------------------------------
c63d70bc 28144 INCLUDE 'herwig65.inc'
65767955 28145 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWHPPB,EPS,RCS,ET,EJ,KK,KK2,
28146 & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,FACTR,RS,S,T,U,CSTU,TQSQ,
28147 & DSTU,HCS
28148 INTEGER ID,ID1,ID2
28149 EXTERNAL HWRGEN,HWRUNI,HWUALF,HWHPPB
28150 SAVE HCS,CSTU,DSTU,FACT
28151 PARAMETER (EPS=1.D-9)
28152 IF (GENEV) THEN
28153 RCS=HCS*HWRGEN(0)
28154 ELSE
28155 EVWGT=0.
28156 CALL HWRPOW(ET,EJ)
28157 KK=ET/PHEP(5,3)
28158 KK2=KK**2
28159 IF (KK.GE.ONE) RETURN
28160 YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
28161 YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
28162 IF (YJ1INF.GE.YJ1SUP) RETURN
28163 Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
28164 YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
28165 YJ2SUP=MIN( YJMAX , LOG(2./KK-Z1) )
28166 IF (YJ2INF.GE.YJ2SUP) RETURN
28167 Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
28168 XX(1)=0.5*(Z1+Z2)*KK
28169 IF (XX(1).GE.ONE) RETURN
28170 XX(2)=XX(1)/(Z1*Z2)
28171 IF (XX(2).GE.ONE) RETURN
28172 COSTH=(Z1-Z2)/(Z1+Z2)
28173 S=XX(1)*XX(2)*PHEP(5,3)**2
28174 RS=0.5*SQRT(S)
28175 T=-0.5*S*(1.-COSTH)
28176 U=-S-T
28177 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28178 FACT=GEV2NB*PIFAC*0.5*ET*EJ*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
28179 & *(ALPHEM/S)**2
28180 CALL HWSGEN(.FALSE.)
28181 CSTU=2.*(U/T+T/U)/CAFAC
28182 IF (DISF(13,1).GT.EPS.AND.DISF(13,2).GT.EPS) THEN
28183 TQSQ=0.
28184 DO 10 ID=1,6
28185 10 IF (RMASS(ID).LT.RS) TQSQ=TQSQ+QFCH(ID)**2
28186 DSTU=DISF(13,1)*DISF(13,2)*FACT*HWHPPB(S,T,U)
28187 & /64.*(HWUALF(1,EMSCA)*TQSQ/PIFAC)**2
28188 ELSE
28189 DSTU=0
28190 ENDIF
28191 ENDIF
28192 HCS=0.
28193 DO 30 ID=1,6
28194 FACTR=FACT*CSTU*QFCH(ID)**4
28195C q+qbar ---> gamma+gamma
28196 ID1=ID
28197 ID2=ID+6
28198 IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 20
28199 HCS=HCS+FACTR*DISF(ID1,1)*DISF(ID2,2)
28200 IF (GENEV.AND.HCS.GT.RCS) THEN
28201 CALL HWHQCP(59,59,2134,61)
28202 GOTO 99
28203 ENDIF
28204C qbar+q ---> gamma+gamma
28205 20 ID1=ID+6
28206 ID2=ID
28207 IF (DISF(ID1,1).LT.EPS.OR.DISF(ID2,2).LT.EPS) GOTO 30
28208 HCS=HCS+FACTR*DISF(ID1,1)*DISF(ID2,2)
28209 IF (GENEV.AND.HCS.GT.RCS) THEN
28210 CALL HWHQCP(59,59,2134,62)
28211 GOTO 99
28212 ENDIF
28213 30 CONTINUE
28214C g+g ---> gamma+gamma
28215 ID1=13
28216 ID2=13
28217 HCS=HCS+DSTU
28218 IF (GENEV.AND.HCS.GT.RCS) THEN
28219 CALL HWHQCP(59,59,2134,63)
28220 GOTO 99
28221 ENDIF
28222 EVWGT=HCS
28223 RETURN
28224C Generate event
28225 99 IDN(1)=ID1
28226 IDN(2)=ID2
28227 IDCMF=15
28228 CALL HWETWO(.TRUE.,.TRUE.)
28229 END
28230CDECK ID>, HWHPHO.
28231*CMZ :- -26/04/91 14.55.45 by Federico Carminati
28232*-- Author : Bryan Webber
28233C-----------------------------------------------------------------------
28234 SUBROUTINE HWHPHO
28235C-----------------------------------------------------------------------
28236C QCD DIRECT PHOTON + JET PRODUCTION: MEAN EVWGT = SIGMA IN NB
28237C-----------------------------------------------------------------------
c63d70bc 28238 INCLUDE 'herwig65.inc'
65767955 28239 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,HWHPPB,EPS,RCS,ET,EJ,KK,KK2,
28240 & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,FACTR,FACTF,RS,S,T,U,CF,
28241 & AF,CSTU,CTSU,CUST,DSTU,HCS,TQCH
28242 INTEGER ID,ID1,ID2
28243 EXTERNAL HWRGEN,HWRUNI,HWUALF,HWHPPB
28244 SAVE HCS,FACT,CSTU,CTSU,CUST,DSTU
28245 PARAMETER (EPS=1.D-9)
28246 IF (GENEV) THEN
28247 RCS=HCS*HWRGEN(0)
28248 ELSE
28249 EVWGT=0.
28250 CALL HWRPOW(ET,EJ)
28251 KK=ET/PHEP(5,3)
28252 KK2=KK**2
28253 IF (KK.GE.ONE) RETURN
28254 YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
28255 YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
28256 IF (YJ1INF.GE.YJ1SUP) RETURN
28257 Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
28258 YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
28259 YJ2SUP=MIN( YJMAX , LOG(2./KK-Z1) )
28260 IF (YJ2INF.GE.YJ2SUP) RETURN
28261 Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
28262 XX(1)=0.5*(Z1+Z2)*KK
28263 IF (XX(1).GE.ONE) RETURN
28264 XX(2)=XX(1)/(Z1*Z2)
28265 IF (XX(2).GE.ONE) RETURN
28266 COSTH=(Z1-Z2)/(Z1+Z2)
28267 S=XX(1)*XX(2)*PHEP(5,3)**2
28268 RS=0.5*SQRT(S)
28269 T=-0.5*S*(1.-COSTH)
28270 U=-S-T
28271C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
28272 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28273 FACT=GEV2NB*PIFAC*0.5*ET*EJ*ALPHEM
28274 & *HWUALF(1,EMSCA)*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)/S**2
28275 CALL HWSGEN(.FALSE.)
28276C
28277 CF=2.*CFFAC/CAFAC
28278 AF=-1./CAFAC
28279 CSTU=CF*(U/T+T/U)
28280 CTSU=AF*(U/S+S/U)
28281 CUST=AF*(T/S+S/T)
28282 IF (DISF(13,1).GT.EPS.AND.DISF(13,2).GT.EPS) THEN
28283 TQCH=0.
28284 DO 10 ID=1,6
28285 10 IF (RMASS(ID).LT.RS) TQCH=TQCH+QFCH(ID)
28286 DSTU=DISF(13,1)*DISF(13,2)*FACT*HWHPPB(S,T,U)
28287 & *5./768.*(HWUALF(1,EMSCA)*TQCH/PIFAC)**2
28288 ELSE
28289 DSTU=0
28290 ENDIF
28291 ENDIF
28292C
28293 HCS=0.
28294 DO 30 ID=1,6
28295 FACTR=FACT*QFCH(ID)**2
28296C---QUARK FIRST
28297 ID1=ID
28298 IF (DISF(ID1,1).LT.EPS) GOTO 20
28299 ID2=ID1+6
28300 HCS=HCS+CSTU*FACTR*DISF(ID1,1)*DISF(ID2,2)
28301 IF (GENEV.AND.HCS.GT.RCS) THEN
28302 CALL HWHQCP( 13, 59,2314,41)
28303 GOTO 9
28304 ENDIF
28305 ID2=13
28306 HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2)
28307 IF (GENEV.AND.HCS.GT.RCS) THEN
28308 CALL HWHQCP(ID1, 59,3124,42)
28309 GOTO 9
28310 ENDIF
28311C---QBAR FIRST
28312 20 ID1=ID+6
28313 IF (DISF(ID1,1).LT.EPS) GOTO 30
28314 ID2=ID
28315 HCS=HCS+CSTU*FACTR*DISF(ID1,1)*DISF(ID2,2)
28316 IF (GENEV.AND.HCS.GT.RCS) THEN
28317 CALL HWHQCP( 13, 59,3124,43)
28318 GOTO 9
28319 ENDIF
28320 ID2=13
28321 HCS=HCS+CTSU*FACTR*DISF(ID1,1)*DISF(ID2,2)
28322 IF (GENEV.AND.HCS.GT.RCS) THEN
28323 CALL HWHQCP(ID1, 59,2314,44)
28324 GOTO 9
28325 ENDIF
28326 30 CONTINUE
28327C---GLUON FIRST
28328 ID1=13
28329 FACTF=FACT*CUST*DISF(ID1,1)
28330 DO 50 ID=1,6
28331 FACTR=FACTF*QFCH(ID)**2
28332 ID2=ID
28333 IF (DISF(ID2,2).LT.EPS) GOTO 40
28334 HCS=HCS+FACTR*DISF(ID2,2)
28335 IF (GENEV.AND.HCS.GT.RCS) THEN
28336 CALL HWHQCP(ID2, 59,2314,45)
28337 GOTO 9
28338 ENDIF
28339 40 ID2=ID+6
28340 IF (DISF(ID2,2).LT.EPS) GOTO 50
28341 HCS=HCS+FACTR*DISF(ID2,2)
28342 IF (GENEV.AND.HCS.GT.RCS) THEN
28343 CALL HWHQCP(ID2, 59,3124,46)
28344 GOTO 9
28345 ENDIF
28346 50 CONTINUE
28347C g+g ---> g+gamma
28348 ID2=13
28349 HCS=HCS+DSTU
28350 IF (GENEV.AND.HCS.GT.RCS) THEN
28351 CALL HWHQCP( 13, 59,2314,47)
28352 GOTO 9
28353 ENDIF
28354 EVWGT=HCS
28355 RETURN
28356C---GENERATE EVENT
28357 9 IDN(1)=ID1
28358 IDN(2)=ID2
28359 IDCMF=15
28360 CALL HWETWO(.TRUE.,.TRUE.)
28361 END
28362CDECK ID>, HWHPPB.
28363*CMZ :- -12/01/93 10.12.43 by Bryan Webber
28364*-- Author : Ian Knowles
28365C-----------------------------------------------------------------------
28366 FUNCTION HWHPPB(S,T,U)
28367C-----------------------------------------------------------------------
28368C Quark box diagram contribution to photon/gluon scattering
28369C Internal quark mass neglected: m_q << U,T,S
28370C-----------------------------------------------------------------------
28371 IMPLICIT NONE
28372 DOUBLE PRECISION HWHPPB,S,T,U,S2,T2,U2,PI2,ALNTU,ALNST,ALNSU
28373 PI2=ACOS(-1.D0)**2
28374 S2=S**2
28375 T2=T**2
28376 U2=U**2
28377 ALNTU=LOG(T/U)
28378 ALNST=LOG(-S/T)
28379 ALNSU=ALNST+ALNTU
28380 HWHPPB=5.*4.
28381 & +((2.*S2+2.*(U2-T2)*ALNTU+(T2+U2)*(ALNTU**2+PI2))/S2)**2
28382 & +((2.*U2+2.*(T2-S2)*ALNST+(T2+S2)* ALNST**2 )/U2)**2
28383 & +((2.*T2+2.*(U2-S2)*ALNSU+(U2+S2)* ALNSU**2 )/T2)**2
28384 & +4.*PI2*(((T2-S2+(T2+S2)*ALNST)/U2)**2
28385 & +((U2-S2+(U2+S2)*ALNSU)/T2)**2)
28386 END
28387CDECK ID>, HWHPPE.
28388*CMZ :- -12/01/93 10.12.43 by Bryan Webber
28389*-- Author : Ian Knowles
28390C-----------------------------------------------------------------------
28391 SUBROUTINE HWHPPE
28392C-----------------------------------------------------------------------
28393C point-like photon/QCD heavy flavour single excitation, using exact
28394C massive lightcone kinematics, mean EVWGT = sigma in nb.
28395C-----------------------------------------------------------------------
c63d70bc 28396 INCLUDE 'herwig65.inc'
65767955 28397 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,PP1,PP2,QM2,FACTR,
28398 & PT,PJ,PT2,PTM,EXY,T,CC,EXY2,S,U,C,SIGE,HCS,RCS
28399 INTEGER IQ1,IQ2,ID1,ID2,IHAD1,IHAD2
28400 EXTERNAL HWRGEN,HWRUNI,HWUALF
28401 SAVE PP1,PP2,IQ1,IQ2,QM2,FACTR,SIGE,HCS
28402 PARAMETER (EPS=1.E-9)
28403 IHAD1=1
28404 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28405 IHAD2=2
28406 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28407 IF (FSTWGT.OR.IHAD1.NE.1.OR.IHAD2.NE.2) THEN
28408 PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
28409 PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
28410 XX(1)=1.
28411 IQ1=MOD(IPROC,100)
28412 IQ2=IQ1+6
28413 QM2=RMASS(IQ1)**2
28414 FACTR=GEV2NB*(YJMAX-YJMIN)*4.*PIFAC*CFFAC*PP1
28415 & *ALPHEM*QFCH(IQ1)**2
28416 ENDIF
28417 IF (GENEV) THEN
28418 RCS=HCS*HWRGEN(0)
28419 ELSE
28420 EVWGT=0.
28421 CALL HWRPOW(PT,PJ)
28422 PT2=PT**2
28423 PTM=SQRT(PT2+QM2)
28424 EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
28425 T=-PP1*PT/EXY
28426 CC=T**2-4.*QM2*(PT2+T)
28427 IF (CC.LT.ZERO) RETURN
28428 EXY2=(2.*PT2+T-SQRT(CC))*PP1/(2.*T*PTM)
28429 IF (EXY2.LT.EXP(YJMIN).OR.EXY2.GT.EXP(YJMAX)) RETURN
28430 XX(2)=(PT/EXY+PTM/EXY2)/PP2
28431 IF (XX(2).GT.ONE) RETURN
28432C define: S=Shat-M**2, T=That ,U=Uhat-M**2 (2p.Q, -2p.g, -2p.Q')
28433 S=XX(2)*PP1*PP2
28434 U=-S-T
28435 COSTH=(1.+QM2/S)*(T-U)/S-QM2/S
28436C Set hard process scale (Approx ET-jet)
28437 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28438 C=QM2*T/(U*S)
28439 SIGE=-FACTR*PT*PJ*HWUALF(1,EMSCA)*(S/U+U/S+4.*C*(1.-C))
28440 & /(S**2*EXY2*PTM*(1-QM2/(XX(2)*PP2*EXY2)**2))
28441 CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
28442 ENDIF
28443 HCS=0.
28444 ID1=59
28445C photon+Q ---> g+Q
28446 ID2=IQ1
28447 IF (DISF(ID2,2).LT.EPS) GOTO 10
28448 HCS=HCS+SIGE*DISF(ID2,2)
28449 IF (GENEV.AND.HCS.GT.RCS) THEN
28450 CALL HWHQCP(13,ID2,1423,51)
28451 GOTO 99
28452 ENDIF
28453C photon+Qbar ---> g+Qbar
28454 10 ID2=IQ2
28455 IF (DISF(ID2,2).LT.EPS) GOTO 20
28456 HCS=HCS+SIGE*DISF(ID2,2)
28457 IF (GENEV.AND.HCS.GT.RCS) THEN
28458 CALL HWHQCP(13,ID2,1342,52)
28459 GOTO 99
28460 ENDIF
28461 20 EVWGT=HCS
28462 RETURN
28463C Generate event
28464 99 IDN(1)=ID1
28465 IDN(2)=ID2
28466 IDCMF=15
28467 CALL HWETWO(.TRUE.,.TRUE.)
28468 END
28469CDECK ID>, HWHPPH.
28470*CMZ :- -12/01/93 10.12.43 by Bryan Webber
28471*-- Author : Ian Knowles
28472C-----------------------------------------------------------------------
28473 SUBROUTINE HWHPPH
28474C-----------------------------------------------------------------------
28475C Point-like photon/gluon heavy flavour pair production, with
28476C exact lightcone massive kinematics, mean EVWGT = sigma in nb.
28477C-----------------------------------------------------------------------
c63d70bc 28478 INCLUDE 'herwig65.inc'
65767955 28479 DOUBLE PRECISION HWRUNI,HWUALF,EPS,PP1,PP2,QM2,FACTR,ET,EJ,ET2,
28480 & EXY,EXY2,S,T,U,C
28481 INTEGER IQ1,IHAD1,IHAD2
28482 EXTERNAL HWRUNI,HWUALF
28483 SAVE PP1,PP2,IQ1,QM2,FACTR
28484 PARAMETER (EPS=1.E-9)
28485 IHAD1=1
28486 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28487 IHAD2=2
28488 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28489 IF (FSTWGT.OR.IHAD1.NE.1.OR.IHAD2.NE.2) THEN
28490 PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
28491 PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
28492 XX(1)=1.
28493 IQ1=MOD(IPROC,100)
28494 QM2=RMASS(IQ1)**2
28495 IHPRO=53
28496 FACTR=-GEV2NB*(YJMAX-YJMIN)*.5*PIFAC*ALPHEM*QFCH(IQ1)**2
28497 ENDIF
28498 IF (GENEV) THEN
28499C Generate event
28500 IDN(1)=59
28501 IDN(2)=13
28502 IDN(3)=IQ1
28503 IDN(4)=IQ1+6
28504 ICO(1)=1
28505 ICO(2)=4
28506 ICO(3)=2
28507 ICO(4)=3
28508 IDCMF=15
28509 CALL HWETWO(.TRUE.,.TRUE.)
28510 ELSE
28511C Select kinematics
28512 EVWGT=0.
28513 CALL HWRPOW(ET,EJ)
28514 ET2=ET**2
28515 EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
28516 EXY2=2.*PP1/ET-EXY
28517 IF (EXY2.LT.EXP(YJMIN).OR.EXY2.GT.EXP(YJMAX)) RETURN
28518 XX(2)=.5*ET*(1./EXY+1./EXY2)/PP2
28519 IF (XX(2).LT.ZERO.OR.XX(2).GT.ONE) RETURN
28520 S=XX(2)*PP1*PP2
28521 IF (S.LT.ET2) RETURN
28522C define: S=Shat, T=That-M**2, U=Uhat-M**2 (2p.g, -2p.Q, -2p.QBar)
28523 T=-.5*PP1*ET/EXY
28524 U=-S-T
28525 COSTH=(T-U)/(S*SQRT(1.-4.*QM2/S))
28526 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28527 CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
28528C photon+g ---> Q+Qbar
28529 IF (DISF(13,2).LT.EPS) THEN
28530 EVWGT=0.
28531 ELSE
28532 C=QM2*S/(U*T)
28533 EVWGT=FACTR*EJ*ET*HWUALF(1,EMSCA)
28534 & *DISF(13,2)*(T/U+U/T+4.*C*(1.-C))/(S*T)
28535 ENDIF
28536 ENDIF
28537 END
28538CDECK ID>, HWHPPM.
28539*CMZ :- -09/12/93 15.50.26 by Mike Seymour
28540*-- Author : Ian Knowles & Mike Seymour
28541C-----------------------------------------------------------------------
28542 SUBROUTINE HWHPPM
28543C-----------------------------------------------------------------------
28544C Point-like photon/QCD direct meson production
28545C See M. Benayoun, et al., Nucl. Phys. B282 (1987) 653 for details.
28546C mean EVWGT = sigma in nb
28547C-----------------------------------------------------------------------
c63d70bc 28548 INCLUDE 'herwig65.inc'
65767955 28549 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,PP1,PP2,ET,EJ,EXY,EXY2,
28550 & FACT,FACTR,S,T,U,REDS,DELT(3,3),C1STU,C3STU,HCS,RCS,CMIX,SMIX,
28551 & C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1,FPI2,FETA2(3),FETAP2(3),
28552 7 FRHO2,FPHI2(3),FOMEG2(3)
28553 INTEGER MNAME(3,3,2),N4(3),I,J,ID2,ID4,I2,I4,M1,M2,IHAD1,IHAD2
28554 LOGICAL SPIN0,SPIN1
28555 EXTERNAL HWRGEN,HWRUNI,HWUALF
28556 SAVE FPI2,FETA2,FETAP2,FRHO2,FPHI2,FOMEG2,HCS,REDS,FACT,DELT,
28557 & C1STU,C3STU
28558 PARAMETER (EPS=1.D-20)
28559 SAVE MNAME,N4,SPIN0,SPIN1,C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1
28560 DATA MNAME/21,38,42,30,21,34,50,46,0,23,39,43,31,23,35,51,47,0/
28561 DATA N4,SPIN0,SPIN1/3,3,2,.TRUE.,.TRUE./
28562 DATA C1WVFN,FPI,FETA8,FETA1,FRHO,FPHI8,FPHI1
28563 & /1.D0,3*0.093D0,3*0.107D0/
28564 IF (FSTWGT) THEN
28565 FPI2=FPI**2
28566 CMIX=COS(ETAMIX*PIFAC/180.D0)
28567 SMIX=SIN(ETAMIX*PIFAC/180.D0)
28568 FETA2(1) =(+CMIX*FETA8/SQRT(TWO)-SMIX*FETA1)**2/THREE
28569 FETA2(2) =FETA2(1)
28570 FETA2(3) =(-CMIX*FETA8*SQRT(TWO)-SMIX*FETA1)**2/THREE
28571 FETAP2(1)=(+SMIX*FETA8/SQRT(TWO)+CMIX*FETA1)**2/THREE
28572 FETAP2(2)=FETAP2(1)
28573 FETAP2(3)=(-SMIX*FETA8*SQRT(TWO)+CMIX*FETA1)**2/THREE
28574 FRHO2=FRHO**2
28575 CMIX=COS(PHIMIX*PIFAC/180.D0)
28576 SMIX=SIN(PHIMIX*PIFAC/180.D0)
28577 FPHI2(1) =(+CMIX*FPHI8/SQRT(TWO)-SMIX*FPHI1)**2/THREE
28578 FPHI2(2) =FPHI2(1)
28579 FPHI2(3) =(-CMIX*FPHI8*SQRT(TWO)-SMIX*FPHI1)**2/THREE
28580 FOMEG2(1)=(+SMIX*FPHI8/SQRT(TWO)+CMIX*FPHI1)**2/THREE
28581 FOMEG2(2)=FOMEG2(1)
28582 FOMEG2(3)=(-SMIX*FPHI8*SQRT(TWO)+CMIX*FPHI1)**2/THREE
28583 ENDIF
28584 SPIN0=.NOT.(MOD(IPROC/10,10).EQ.2)
28585 SPIN1=.NOT.(MOD(IPROC/10,10).EQ.1)
28586 IF (GENEV) THEN
28587 RCS=HCS*HWRGEN(0)
28588 ELSE
28589 EVWGT=ZERO
28590 IHAD1=1
28591 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28592 IHAD2=2
28593 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28594 PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
28595 PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
28596 XX(1)=ONE
28597 CALL HWRPOW(ET,EJ)
28598 EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
28599 EXY2=TWO*PP1/ET-EXY
28600 IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
28601 XX(2)=PP1/(PP2*EXY*EXY2)
28602 IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
28603 S=XX(2)*PP1*PP2
28604 REDS=SQRT(S-ET*SQRT(S))
28605 T=-HALF*PP1*ET/EXY
28606 U=-S-T
28607 COSTH=(T-U)/S
28608C Set EMSCA to hard process scale (Approx ET-jet)
28609 EMSCA=SQRT(TWO*S*T*U/(S*S+T*T+U*U))
28610 FACT=-GEV2NB*ET*EJ*(YJMAX-YJMIN)*ALPHEM*CFFAC
28611 & *(HWUALF(1,EMSCA)*PIFAC*C1WVFN)**2*32.D0/(THREE*S*T)
28612 CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
28613 DO 10 I=1,3
28614 DO 10 J=1,3
28615 10 DELT(I,J)=(QFCH(I)*U+QFCH(J)*S)**2
28616 C1STU=-(S**2+U**2)/(T*S**2*U**2)
28617 C3STU=-8.D0*T/(S**2*U**2)
28618 ENDIF
28619 HCS=ZERO
28620 DO 50 I2=1,3
28621C Quark initiated processes
28622 ID2=I2
28623 IF (DISF(ID2,2).LT.EPS) GOTO 30
28624 DO 20 ID4=1,N4(I2)
28625 M1=MNAME(ID2,ID4,1)
28626 FACTR=FACT*DELT(ID2,ID4)*DISF(ID2,2)
28627 IF (ID2.EQ.ID4) FACTR=HALF*FACTR
28628 IF (SPIN0.AND.REDS.GT.RMASS(M1)) THEN
28629C photon+q --> meson_0+q'
28630 HCS=HCS+HALF*FACTR*C1STU*FPI2
28631 IF (GENEV.AND.HCS.GT.RCS) THEN
28632 CALL HWHQCP(M1,ID4,1432,71)
28633 GOTO 99
28634 ENDIF
28635 ENDIF
28636 M2=MNAME(ID2,ID4,2)
28637 IF (SPIN1.AND.REDS.GT.RMASS(M2)) THEN
28638C photon+q --> meson_L+q'
28639 HCS=HCS+FACTR*C1STU*FRHO2
28640 IF (GENEV.AND.HCS.GT.RCS) THEN
28641 CALL HWHQCP(M2,ID4,1432,72)
28642 GOTO 99
28643 ENDIF
28644C photon+q --> meson_T+q'
28645 HCS=HCS+FACTR*C3STU*FRHO2
28646 IF (GENEV.AND.HCS.GT.RCS) THEN
28647 CALL HWHQCP(M2,ID4,1432,73)
28648 GOTO 99
28649 ENDIF
28650 ENDIF
28651 20 CONTINUE
28652 FACTR=FACT*DELT(I2,I2)*DISF(ID2,2)
28653 IF (SPIN0.AND.REDS.GT.RMASS(22)) THEN
28654C photon+q -->eta+q
28655 HCS=HCS+HALF*FACTR*C1STU*FETA2(I2)
28656 IF (GENEV.AND.HCS.GT.RCS) THEN
28657 CALL HWHQCP(22,ID2,1432,71)
28658 GOTO 99
28659 ENDIF
28660 ENDIF
28661 IF (SPIN0.AND.REDS.GT.RMASS(25)) THEN
28662C photon+q -->eta'+q
28663 HCS=HCS+HALF*FACTR*C1STU*FETAP2(I2)
28664 IF (GENEV.AND.HCS.GT.RCS) THEN
28665 CALL HWHQCP(25,ID2,1432,71)
28666 GOTO 99
28667 ENDIF
28668 ENDIF
28669 IF (SPIN1.AND.REDS.GT.RMASS(56)) THEN
28670C photon+q -->phi_L+q
28671 HCS=HCS+FACTR*C1STU*FPHI2(I2)
28672 IF (GENEV.AND.HCS.GT.RCS) THEN
28673 CALL HWHQCP(56,ID2,1432,72)
28674 GOTO 99
28675 ENDIF
28676C photon+q -->phi_T+q
28677 HCS=HCS+FACTR*C3STU*FPHI2(I2)
28678 IF (GENEV.AND.HCS.GT.RCS) THEN
28679 CALL HWHQCP(56,ID2,1432,73)
28680 GOTO 99
28681 ENDIF
28682 ENDIF
28683 IF (SPIN1.AND.REDS.GT.RMASS(24)) THEN
28684C photon+q -->omega_L+q
28685 HCS=HCS+FACTR*C1STU*FOMEG2(I2)
28686 IF (GENEV.AND.HCS.GT.RCS) THEN
28687 CALL HWHQCP(24,ID2,1432,72)
28688 GOTO 99
28689 ENDIF
28690C photon+q -->omega_T+q
28691 HCS=HCS+FACTR*C3STU*FOMEG2(I2)
28692 IF (GENEV.AND.HCS.GT.RCS) THEN
28693 CALL HWHQCP(24,ID2,1432,73)
28694 GOTO 99
28695 ENDIF
28696 ENDIF
28697C Anti-quark initiated processes
28698 30 ID2=I2+6
28699 IF (DISF(ID2,2).LT.EPS) GOTO 50
28700 DO 40 I4=1,N4(I2)
28701 ID4=I4+6
28702 FACTR=FACT*DELT(I2,I4)*DISF(ID2,2)
28703 IF (ID2.EQ.ID4) FACTR=HALF*FACTR
28704 M1=MNAME(I4,I2,1)
28705 IF (SPIN0.AND.REDS.GT.RMASS(M1)) THEN
28706C photon+qbar --> meson_0+qbar'
28707 HCS=HCS+HALF*FACTR*C1STU*FPI2
28708 IF (GENEV.AND.HCS.GT.RCS) THEN
28709 CALL HWHQCP(M1,ID4,1432,74)
28710 GOTO 99
28711 ENDIF
28712 ENDIF
28713 M2=MNAME(I4,I2,2)
28714 IF (SPIN1.AND.REDS.GT.RMASS(M2)) THEN
28715C photon+qbar --> meson_L+qbar'
28716 HCS=HCS+FACTR*C1STU*FRHO2
28717 IF (GENEV.AND.HCS.GT.RCS) THEN
28718 CALL HWHQCP(M2,ID4,1432,75)
28719 GOTO 99
28720 ENDIF
28721C photon+qbar --> meson_T+qbar'
28722 HCS=HCS+FACTR*C3STU*FRHO2
28723 IF (GENEV.AND.HCS.GT.RCS) THEN
28724 CALL HWHQCP(M2,ID4,1432,76)
28725 GOTO 99
28726 ENDIF
28727 ENDIF
28728 40 CONTINUE
28729 FACTR=FACT*DELT(I2,I2)*DISF(ID2,2)
28730 IF (SPIN0.AND.REDS.GT.RMASS(22)) THEN
28731C photon+qbar -->eta+qbar
28732 HCS=HCS+HALF*FACTR*C1STU*FETA2(I2)
28733 IF (GENEV.AND.HCS.GT.RCS) THEN
28734 CALL HWHQCP(22,ID2,1432,74)
28735 GOTO 99
28736 ENDIF
28737 ENDIF
28738 IF (SPIN0.AND.REDS.GT.RMASS(25)) THEN
28739C photon+qbar -->eta'+qbar
28740 HCS=HCS+HALF*FACTR*C1STU*FETAP2(I2)
28741 IF (GENEV.AND.HCS.GT.RCS) THEN
28742 CALL HWHQCP(25,ID2,1432,74)
28743 GOTO 99
28744 ENDIF
28745 ENDIF
28746 IF (SPIN1.AND.REDS.GT.RMASS(56)) THEN
28747C photon+qbar -->phi_L+qbar
28748 HCS=HCS+FACTR*C1STU*FPHI2(I2)
28749 IF (GENEV.AND.HCS.GT.RCS) THEN
28750 CALL HWHQCP(56,ID2,1432,75)
28751 GOTO 99
28752 ENDIF
28753C photon+qbar -->phi_T+qbar
28754 HCS=HCS+FACTR*C3STU*FPHI2(I2)
28755 IF (GENEV.AND.HCS.GT.RCS) THEN
28756 CALL HWHQCP(56,ID2,1432,76)
28757 GOTO 99
28758 ENDIF
28759 ENDIF
28760 IF (SPIN1.AND.REDS.GT.RMASS(24)) THEN
28761C photon+qbar -->omega_L+qbar
28762 HCS=HCS+FACTR*C1STU*FOMEG2(I2)
28763 IF (GENEV.AND.HCS.GT.RCS) THEN
28764 CALL HWHQCP(24,ID2,1432,75)
28765 GOTO 99
28766 ENDIF
28767C photon+qbar -->omega_T+qbar
28768 HCS=HCS+FACTR*C3STU*FOMEG2(I2)
28769 IF (GENEV.AND.HCS.GT.RCS) THEN
28770 CALL HWHQCP(24,ID2,1432,76)
28771 GOTO 99
28772 ENDIF
28773 ENDIF
28774 50 CONTINUE
28775 EVWGT=HCS
28776 RETURN
28777C Generate event
28778 99 IDN(1)=59
28779 IDN(2)=ID2
28780 IDCMF=15
28781 CALL HWETWO(.TRUE.,.TRUE.)
28782C Set polarization vector
28783 IF (IHPRO.EQ.72.OR.IHPRO.EQ.75) THEN
28784 RHOHEP(2,NHEP-1)=ONE
28785 ELSEIF (IHPRO.EQ.73.OR.IHPRO.EQ.76) THEN
28786 RHOHEP(1,NHEP-1)=HALF
28787 RHOHEP(3,NHEP-1)=HALF
28788 ENDIF
28789 END
28790CDECK ID>, HWHPPT.
28791*CMZ :- -12/01/93 10.12.43 by Bryan Webber
28792*-- Author : Ian Knowles
28793C-----------------------------------------------------------------------
28794 SUBROUTINE HWHPPT
28795C-----------------------------------------------------------------------
28796C point-like photon/QCD di-jet production: mean EVWGT = sigma in nb
28797C-----------------------------------------------------------------------
c63d70bc 28798 INCLUDE 'herwig65.inc'
65767955 28799 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,EPS,RCS,PP1,PP2,ET,EJ,
28800 & EXY,EXY2,FACTR,RS,S,T,U,CSTU,CTSU,HCS
28801 INTEGER ID1,ID2,ID3,ID4,IHAD1,IHAD2
28802 EXTERNAL HWRGEN,HWRUNI,HWUALF
28803 SAVE CSTU,CTSU,HCS,FACTR,RS
28804 PARAMETER (EPS=1.E-9)
28805 IHAD1=1
28806 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28807 IHAD2=2
28808 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28809 IF (GENEV) THEN
28810 RCS=HCS*HWRGEN(0)
28811 ELSE
28812 EVWGT=0.
28813 PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
28814 PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
28815 XX(1)=1.
28816 CALL HWRPOW(ET,EJ)
28817 EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
28818 EXY2=2.*PP1/ET-EXY
28819 IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
28820 XX(2)=PP1/(PP2*EXY*EXY2)
28821 IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
28822 S=XX(2)*PP1*PP2
28823 RS=.5*SQRT(S)
28824 T=-PP1*0.5*ET/EXY
28825 U=-S-T
28826 COSTH=(T-U)/S
28827C Set EMSCA to hard process scale (Approx ET-jet)
28828 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28829 FACTR=-GEV2NB*0.5*EJ*(YJMAX-YJMIN)*ET*PIFAC*ALPHEM
28830 & *HWUALF(1,EMSCA)/(S*T)
28831 CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
28832 CSTU=U/T+T/U
28833 CTSU=-2.*CFFAC*(U/S+S/U)
28834 ENDIF
28835 HCS=0.
28836 ID1=59
28837 DO 20 ID2=1,13
28838 IF (DISF(ID2,2).LT.EPS) GOTO 20
28839 IF (ID2.LT.7) THEN
28840C photon+q ---> g+q
28841 HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2)**2
28842 IF (GENEV.AND.HCS.GT.RCS) THEN
28843 CALL HWHQCP( 13,ID2,1423,51)
28844 GOTO 99
28845 ENDIF
28846 ELSEIF (ID2.LT.13) THEN
28847C photon+qbar ---> g+qbar
28848 HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2-6)**2
28849 IF (GENEV.AND.HCS.GT.RCS) THEN
28850 CALL HWHQCP( 13,ID2,1342,52)
28851 GOTO 99
28852 ENDIF
28853 ELSE
28854C photon+g ---> q+qbar
28855 DO 10 ID3=1,6
28856 IF (RS.GT.RMASS(ID3)) THEN
28857 ID4=ID3+6
28858 HCS=HCS+CSTU*DISF(ID2,2)*QFCH(ID3)**2
28859 IF (GENEV.AND.HCS.GT.RCS) THEN
28860 CALL HWHQCP(ID3,ID4,1423,53)
28861 GOTO 99
28862 ENDIF
28863 ENDIF
28864 10 CONTINUE
28865 ENDIF
28866 20 CONTINUE
28867 EVWGT=FACTR*HCS
28868 RETURN
28869C Generate event
28870 99 IDN(1)=ID1
28871 IDN(2)=ID2
28872 IDCMF=15
28873 CALL HWETWO(.TRUE.,.TRUE.)
28874 END
28875CDECK ID>, HWHPQS.
28876*CMZ :- -27/03/95 13.27.22 by Mike Seymour
28877*-- Author : Ian Knowles
28878C-----------------------------------------------------------------------
28879 SUBROUTINE HWHPQS
28880C-----------------------------------------------------------------------
28881C Compton scattering of point-like photon and (anti)quark
28882C mean EVWGT = sigma in nb
28883C-----------------------------------------------------------------------
c63d70bc 28884 INCLUDE 'herwig65.inc'
65767955 28885 DOUBLE PRECISION HWRGEN,HWRUNI,EPS,RCS,PP1,PP2,ET,EJ,EXY,EXY2,
28886 & FACTR,S,T,U,CTSU,HCS
28887 INTEGER ID1,ID2,IHAD1,IHAD2
28888 EXTERNAL HWRGEN,HWRUNI
28889 SAVE CTSU,HCS,FACTR
28890 PARAMETER (EPS=1.E-9)
28891 IHAD1=1
28892 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
28893 IHAD2=2
28894 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
28895 IF (GENEV) THEN
28896 RCS=HCS*HWRGEN(0)
28897 ELSE
28898 EVWGT=0.
28899 PP1=PHEP(4,IHAD1)+ABS(PHEP(3,IHAD1))
28900 PP2=PHEP(4,IHAD2)+ABS(PHEP(3,IHAD2))
28901 XX(1)=1.
28902 CALL HWRPOW(ET,EJ)
28903 EXY=EXP(HWRUNI(1,YJMIN,YJMAX))
28904 EXY2=2.*PP1/ET-EXY
28905 IF (EXY2.LE.EXP(YJMIN).OR.EXY2.GE.EXP(YJMAX)) RETURN
28906 XX(2)=PP1/(PP2*EXY*EXY2)
28907 IF (XX(2).LE.ZERO.OR.XX(2).GE.ONE) RETURN
28908 S=XX(2)*PP1*PP2
28909 T=-PP1*0.5*ET/EXY
28910 U=-S-T
28911 COSTH=(T-U)/S
28912C Set EMSCA to hard process scale (Approx ET-jet)
28913 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
28914 FACTR=-GEV2NB*0.5*EJ*(YJMAX-YJMIN)*ET*PIFAC*ALPHEM**2/(S*T)
28915 CALL HWSFUN(XX(2),EMSCA,IDHW(IHAD2),NSTRU,DISF(1,2),2)
28916 CTSU=-2.*(U/S+S/U)
28917 ENDIF
28918 HCS=0.
28919 ID1=59
28920 DO 20 ID2=1,12
28921 IF (DISF(ID2,2).LT.EPS) GOTO 20
28922 IF (ID2.LT.7) THEN
28923C photon+q ---> photon+q
28924 HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2)**4
28925 IF (GENEV.AND.HCS.GT.RCS) THEN
28926 CALL HWHQCP( 59,ID2,1432,66)
28927 GOTO 99
28928 ENDIF
28929 ELSE
28930C photon+qbar ---> photon+qbar
28931 HCS=HCS+CTSU*DISF(ID2,2)*QFCH(ID2-6)**4
28932 IF (GENEV.AND.HCS.GT.RCS) THEN
28933 CALL HWHQCP( 59,ID2,1432,67)
28934 GOTO 99
28935 ENDIF
28936 ENDIF
28937 20 CONTINUE
28938 EVWGT=FACTR*HCS
28939 RETURN
28940C Generate event
28941 99 IDN(1)=ID1
28942 IDN(2)=ID2
28943 IDCMF=15
28944 CALL HWETWO(.TRUE.,.TRUE.)
28945 END
28946CDECK ID>, HWHQCD.
28947*CMZ :- -20/05/99 12.39.45 by Kosuke Odagiri
28948*-- Author : Bryan Webber
28949C-----------------------------------------------------------------------
28950 SUBROUTINE HWHQCD
28951C-----------------------------------------------------------------------
28952C QCD HARD 2->2 PROCESSES: MEAN EVWGT = SIGMA IN NB
28953C-----------------------------------------------------------------------
c63d70bc 28954 INCLUDE 'herwig65.inc'
65767955 28955 DOUBLE PRECISION HWRGEN,HWRUNI,HWUALF,RS,EPS,HF,RCS,Z1,Z2,ET,EJ,
28956 & FACTR,S,T,U,ST,TU,US,STU,TUS,UST,EN,RN,GFLA,AF,ASTU,ASUT,AUST,
28957 & BF,BSTU,BSUT,BUST,BUTS,CF,CSTU,CSUT,CTSU,CTUS,DF,DSTU,DTSU,DUTS,
28958 & DIST,HCS,UT,SU,GT,KK,KK2,YJ1INF,YJ1SUP,YJ2INF,YJ2SUP
28959 INTEGER ID1,ID2,I
28960 EXTERNAL HWRGEN,HWRUNI,HWUALF
28961 SAVE HCS,ASTU,AUST,BSTU,BSUT,BUST,BUTS,CSTU,CSUT,CTSU,CTUS,
28962 & DSTU,DTSU,DUTS,GFLA,RCS,S,T,TU,U,US
28963 PARAMETER (EPS=1.E-9,HF=0.5)
28964 IF (GENEV) THEN
28965 RCS=HCS*HWRGEN(0)
28966 ELSE
28967 EVWGT=0.
28968 CALL HWRPOW(ET,EJ)
28969 KK = ET/PHEP(5,3)
28970 KK2=KK**2
28971 IF (KK.GE.ONE) RETURN
28972 YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
28973 YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
28974 IF (YJ1INF.GE.YJ1SUP) RETURN
28975 Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
28976 YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
28977 YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
28978 IF (YJ2INF.GE.YJ2SUP) RETURN
28979 Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
28980 XX(1)=.5*(Z1+Z2)*KK
28981 IF (XX(1).GE.ONE) RETURN
28982 XX(2)=XX(1)/(Z1*Z2)
28983 IF (XX(2).GE.ONE) RETURN
28984 COSTH=(Z1-Z2)/(Z1+Z2)
28985 S=XX(1)*XX(2)*PHEP(5,3)**2
28986 RS=HF*SQRT(S)
28987 DO 3 I=1,NFLAV
28988 IF (RS.LT.RMASS(I)) GOTO 4
28989 3 CONTINUE
28990 I=NFLAV+1
28991 4 MAXFL=I-1
28992 IF (MAXFL.EQ.0) THEN
28993 CALL HWWARN('HWHQCD',100)
28994 GOTO 999
28995 ENDIF
28996C
28997 T=-HF*S*(1.-COSTH)
28998 U=-S-T
28999C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
29000 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
29001 FACTR = GEV2NB*.5*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2
29002 & * (YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
29003 CALL HWSGEN(.FALSE.)
29004C
29005 ST=S/T
29006 TU=T/U
29007 US=U/S
29008 STU=TU/US
29009 TUS=US/ST
29010 UST=ST/TU
29011C
29012 EN=CAFAC
29013 RN=CFFAC/EN
29014 GFLA=HF*FLOAT(MAXFL)/(EN*RN)**2
29015 AF=FACTR*RN
29016 ASTU=AF*(1.-2.*UST)
29017 ASUT=AF*(1.-2.*STU)
29018 AUST=AF*(1.-2.*TUS)
29019C-----------------------------------------------------------------------
29020C---Colour decomposition modifications below (KO)
29021C-----------------------------------------------------------------------
29022 BF=HF-AF/EN/TUS/(ASTU+ASUT)
29023 BSTU=BF*ASTU
29024 BSUT=BF*ASUT
29025 BF=ONE-TWO*AF/EN/STU/(AUST+ASTU)
29026 BUST=BF*AUST
29027 BUTS=BF*ASTU
29028C-----------------------------------------------------------------------
29029C BF=2.*AF/EN
29030C BSTU=HF*(ASTU+BF*ST)
29031C BSUT=HF*(ASUT+BF/US)
29032C BUST=AUST+BF*US
29033C BUTS=ASTU+BF/TU
29034C-----------------------------------------------------------------------
29035 CF=AF*EN
29036 CSTU=(CF*(RN-TUS))/TU
29037 CSUT=(CF*(RN-TUS))*TU
29038 CTSU=(FACTR*(UST-RN))*US
29039 CTUS=(FACTR*(UST-RN))/US
29040 DF=HF*FACTR/RN
29041 DSTU=DF*(1.+1./TUS-STU-UST)
29042 DTSU=DF*(1.+1./UST-STU-TUS)
29043 DUTS=DF*(1.+1./STU-UST-TUS)
29044 ENDIF
29045C
29046 HCS=0.
29047 DO 6 ID1=1,13
29048 IF (DISF(ID1,1).LT.EPS) GOTO 6
29049 DO 5 ID2=1,13
29050 IF (DISF(ID2,2).LT.EPS) GOTO 5
29051 DIST=DISF(ID1,1)*DISF(ID2,2)
29052 IF (ID1.LT.7) THEN
29053C---QUARK FIRST
29054 IF (ID2.LT.7) THEN
29055 IF (ID1.NE.ID2) THEN
29056 HCS=HCS+ASTU*DIST
29057 IF (GENEV.AND.HCS.GT.RCS) THEN
29058 CALL HWHQCP(ID1,ID2,3421, 3)
29059 GOTO 9
29060 ENDIF
29061 ELSE
29062 HCS=HCS+BSTU*DIST
29063 IF (GENEV.AND.HCS.GT.RCS) THEN
29064 CALL HWHQCP(ID1,ID2,3421, 1)
29065 GOTO 9
29066 ENDIF
29067 HCS=HCS+BSUT*DIST
29068 IF (GENEV.AND.HCS.GT.RCS) THEN
29069 CALL HWHQCP(ID1,ID2,4312, 2)
29070 GOTO 9
29071 ENDIF
29072 ENDIF
29073 ELSEIF (ID2.NE.13) THEN
29074 IF (ID2.NE.ID1+6) THEN
29075 HCS=HCS+ASTU*DIST
29076 IF (GENEV.AND.HCS.GT.RCS) THEN
29077 CALL HWHQCP(ID1,ID2,3142, 9)
29078 GOTO 9
29079 ENDIF
29080 ELSE
29081 HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST
29082 IF (GENEV.AND.HCS.GT.RCS) THEN
29083 CALL HWHQCP(-ID1, 0,2413, 4)
29084 GOTO 9
29085 ENDIF
29086 HCS=HCS+BUTS*DIST
29087 IF (GENEV.AND.HCS.GT.RCS) THEN
29088 CALL HWHQCP(ID1,ID2,3142, 5)
29089 GOTO 9
29090 ENDIF
29091 HCS=HCS+BUST*DIST
29092 IF (GENEV.AND.HCS.GT.RCS) THEN
29093 CALL HWHQCP(ID1,ID2,2413, 6)
29094 GOTO 9
29095 ENDIF
29096 HCS=HCS+CSTU*DIST
29097 IF (GENEV.AND.HCS.GT.RCS) THEN
29098 CALL HWHQCP( 13, 13,2413, 7)
29099 GOTO 9
29100 ENDIF
29101 HCS=HCS+CSUT*DIST
29102 IF (GENEV.AND.HCS.GT.RCS) THEN
29103 CALL HWHQCP( 13, 13,2341, 8)
29104 GOTO 9
29105 ENDIF
29106 ENDIF
29107 ELSE
29108 HCS=HCS+CTSU*DIST
29109 IF (GENEV.AND.HCS.GT.RCS) THEN
29110 CALL HWHQCP(ID1,ID2,3142,10)
29111 GOTO 9
29112 ENDIF
29113 HCS=HCS+CTUS*DIST
29114 IF (GENEV.AND.HCS.GT.RCS) THEN
29115 CALL HWHQCP(ID1,ID2,3421,11)
29116 GOTO 9
29117 ENDIF
29118 ENDIF
29119 ELSEIF (ID1.NE.13) THEN
29120C---QBAR FIRST
29121 IF (ID2.LT.7) THEN
29122 IF (ID1.NE.ID2+6) THEN
29123 HCS=HCS+ASTU*DIST
29124 IF (GENEV.AND.HCS.GT.RCS) THEN
29125 CALL HWHQCP(ID1,ID2,2413,17)
29126 GOTO 9
29127 ENDIF
29128 ELSE
29129 HCS=HCS+FLOAT(MAXFL-1)*AUST*DIST
29130 IF (GENEV.AND.HCS.GT.RCS) THEN
29131 CALL HWHQCP(-ID1, 0,3142,12)
29132 GOTO 9
29133 ENDIF
29134 HCS=HCS+BUTS*DIST
29135 IF (GENEV.AND.HCS.GT.RCS) THEN
29136 CALL HWHQCP(ID1,ID2,2413,13)
29137 GOTO 9
29138 ENDIF
29139 HCS=HCS+BUST*DIST
29140 IF (GENEV.AND.HCS.GT.RCS) THEN
29141 CALL HWHQCP(ID1,ID2,3142,14)
29142 GOTO 9
29143 ENDIF
29144 HCS=HCS+CSTU*DIST
29145 IF (GENEV.AND.HCS.GT.RCS) THEN
29146 CALL HWHQCP( 13, 13,3142,15)
29147 GOTO 9
29148 ENDIF
29149 HCS=HCS+CSUT*DIST
29150 IF (GENEV.AND.HCS.GT.RCS) THEN
29151 CALL HWHQCP( 13, 13,4123,16)
29152 GOTO 9
29153 ENDIF
29154 ENDIF
29155 ELSEIF (ID2.NE.13) THEN
29156 IF (ID1.NE.ID2) THEN
29157 HCS=HCS+ASTU*DIST
29158 IF (GENEV.AND.HCS.GT.RCS) THEN
29159 CALL HWHQCP(ID1,ID2,4312,20)
29160 GOTO 9
29161 ENDIF
29162 ELSE
29163 HCS=HCS+BSTU*DIST
29164 IF (GENEV.AND.HCS.GT.RCS) THEN
29165 CALL HWHQCP(ID1,ID2,4312,18)
29166 GOTO 9
29167 ENDIF
29168 HCS=HCS+BSUT*DIST
29169 IF (GENEV.AND.HCS.GT.RCS) THEN
29170 CALL HWHQCP(ID1,ID2,3421,19)
29171 GOTO 9
29172 ENDIF
29173 ENDIF
29174 ELSE
29175 HCS=HCS+CTSU*DIST
29176 IF (GENEV.AND.HCS.GT.RCS) THEN
29177 CALL HWHQCP(ID1,ID2,2413,21)
29178 GOTO 9
29179 ENDIF
29180 HCS=HCS+CTUS*DIST
29181 IF (GENEV.AND.HCS.GT.RCS) THEN
29182 CALL HWHQCP(ID1,ID2,4312,22)
29183 GOTO 9
29184 ENDIF
29185 ENDIF
29186 ELSE
29187C---GLUON FIRST
29188 IF (ID2.LT.7) THEN
29189 HCS=HCS+CTSU*DIST
29190 IF (GENEV.AND.HCS.GT.RCS) THEN
29191 CALL HWHQCP(ID1,ID2,2413,23)
29192 GOTO 9
29193 ENDIF
29194 HCS=HCS+CTUS*DIST
29195 IF (GENEV.AND.HCS.GT.RCS) THEN
29196 CALL HWHQCP(ID1,ID2,3421,24)
29197 GOTO 9
29198 ENDIF
29199 ELSEIF (ID2.LT.13) THEN
29200 HCS=HCS+CTSU*DIST
29201 IF (GENEV.AND.HCS.GT.RCS) THEN
29202 CALL HWHQCP(ID1,ID2,3142,25)
29203 GOTO 9
29204 ENDIF
29205 HCS=HCS+CTUS*DIST
29206 IF (GENEV.AND.HCS.GT.RCS) THEN
29207 CALL HWHQCP(ID1,ID2,4312,26)
29208 GOTO 9
29209 ENDIF
29210 ELSE
29211 HCS=HCS+GFLA*CSTU*DIST
29212 IF (GENEV.AND.HCS.GT.RCS) THEN
29213 CALL HWHQCP( 0, 0,2413,27)
29214 GOTO 9
29215 ENDIF
29216 HCS=HCS+GFLA*CSUT*DIST
29217 IF (GENEV.AND.HCS.GT.RCS) THEN
29218 CALL HWHQCP( 0, 0,4123,28)
29219 GOTO 9
29220 ENDIF
29221 HCS=HCS+DTSU*DIST
29222 IF (GENEV.AND.HCS.GT.RCS) THEN
29223 CALL HWHQCP(ID1,ID2,2341,29)
29224 GOTO 9
29225 ENDIF
29226 HCS=HCS+DSTU*DIST
29227 IF (GENEV.AND.HCS.GT.RCS) THEN
29228 CALL HWHQCP(ID1,ID2,3421,30)
29229 GOTO 9
29230 ENDIF
29231 HCS=HCS+DUTS*DIST
29232 IF (GENEV.AND.HCS.GT.RCS) THEN
29233 CALL HWHQCP(ID1,ID2,2413,31)
29234 GOTO 9
29235 ENDIF
29236 ENDIF
29237 ENDIF
29238 5 CONTINUE
29239 6 CONTINUE
29240 EVWGT=HCS
29241 RETURN
29242C---GENERATE EVENT
29243 9 IDN(1)=ID1
29244 IDN(2)=ID2
29245 IDCMF=15
29246 CALL HWETWO(.TRUE.,.TRUE.)
29247 IF (AZSPIN) THEN
29248C Calculate coefficients for constructing spin density matrices
29249 IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR.
29250 & IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN
29251C qqbar-->gg or qbarq-->gg
29252 UT=1./TU
29253 GCOEF(1)=UT+TU
29254 GCOEF(2)=-2.
29255 GCOEF(3)=0.
29256 GCOEF(4)=0.
29257 GCOEF(5)=GCOEF(1)
29258 GCOEF(6)=UT-TU
29259 GCOEF(7)=-GCOEF(6)
29260 ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR.
29261 & IHPRO.EQ.21.OR.IHPRO.EQ.22.OR.
29262 & IHPRO.EQ.23.OR.IHPRO.EQ.24.OR.
29263 & IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN
29264C qg-->qg or qbarg-->qbarg or gq-->gq or gqbar-->gqbar
29265 SU=1./US
29266 GCOEF(1)=-(SU+US)
29267 GCOEF(2)=0.
29268 GCOEF(3)=2.
29269 GCOEF(4)=0.
29270 GCOEF(5)=SU-US
29271 GCOEF(6)=GCOEF(1)
29272 GCOEF(7)=-GCOEF(5)
29273 ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN
29274C gg-->qqbar
29275 UT=1./TU
29276 GCOEF(1)=TU+UT
29277 GCOEF(2)=-2.
29278 GCOEF(3)=0.
29279 GCOEF(4)=0.
29280 GCOEF(5)=GCOEF(1)
29281 GCOEF(6)=TU-UT
29282 GCOEF(7)=-GCOEF(6)
29283 ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR.
29284 & IHPRO.EQ.31) THEN
29285C gg-->gg
29286 GT=S*S+T*T+U*U
29287 GCOEF(2)=2.*U*U*T*T
29288 GCOEF(3)=2.*S*S*U*U
29289 GCOEF(4)=2.*S*S*T*T
29290 GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4)
29291 GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2)
29292 GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3)
29293 GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4)
29294 ELSE
29295 CALL HWVZRO(7,GCOEF)
29296 ENDIF
29297 ENDIF
29298 999 RETURN
29299 END
29300CDECK ID>, HWHQCP.
29301*CMZ :- -26/04/91 10.18.57 by Bryan Webber
29302*-- Author : Bryan Webber
29303C-----------------------------------------------------------------------
29304 SUBROUTINE HWHQCP(ID3,ID4,IPERM,IHPR)
29305C-----------------------------------------------------------------------
29306C IDENTIFIES HARD SUBPROCESS
29307C-----------------------------------------------------------------------
c63d70bc 29308 INCLUDE 'herwig65.inc'
65767955 29309 INTEGER HWRINT,ID3,ID4,IPERM,IHPR,ND3
29310 EXTERNAL HWRINT
29311 IHPRO=IHPR
29312 IF (ID3.GT.0) THEN
29313 IDN(3)=ID3
29314 IDN(4)=ID4
29315 ELSE
29316 ND3=-ID3
29317 IF (ID3.GT.-7) THEN
29318 1 IDN(3)=HWRINT(1,MAXFL)
29319 IF (IDN(3).EQ.ND3) GOTO 1
29320 IDN(4)=IDN(3)+6
29321 ELSE
29322 2 IDN(3)=HWRINT(1,MAXFL)+6
29323 IF (IDN(3).EQ.ND3) GOTO 2
29324 IDN(4)=IDN(3)-6
29325 ENDIF
29326 ENDIF
29327 ICO(1)=IPERM/1000
29328 ICO(2)=IPERM/100-10*ICO(1)
29329 ICO(3)=IPERM/10 -10*(IPERM/100)
29330 ICO(4)=IPERM -10*(IPERM/10)
29331 END
29332CDECK ID>, HWHQPM.
29333*CMZ :- -27/07/95 14.13.56 by Mike Seymour
29334*-- Author : Mike Seymour
29335C-----------------------------------------------------------------------
29336 SUBROUTINE HWHQPM
29337C HARD PROCESS: GAMGAM --> QQBAR/LLBAR/W+W-
29338C MEAN EVENT WEIGHT = CROSS-SECTION IN NB AFTER CUTS ON PT
29339C-----------------------------------------------------------------------
c63d70bc 29340 INCLUDE 'herwig65.inc'
65767955 29341 DOUBLE PRECISION RCS,HCS,RS,S,EMSQ,BE,TMIN,TMAX,T,U,FACTR,Q,CFAC,
29342 $ HWRGEN
29343 INTEGER IHAD1,IHAD2,HQ,ID3,ID4,I1,I2
29344 SAVE HCS,FACTR,HQ,RS
29345 IHAD1=1
29346 IF (JDAHEP(1,IHAD1).NE.0) IHAD1=JDAHEP(1,IHAD1)
29347 IHAD2=2
29348 IF (JDAHEP(1,IHAD2).NE.0) IHAD2=JDAHEP(1,IHAD2)
29349 IF (GENEV) THEN
29350 RCS=HCS*HWRGEN(0)
29351 ELSE
29352 EVWGT=0.
29353 RS=PHEP(5,3)
29354 S=RS**2
29355 HQ=MOD(IPROC,100)
29356 IF (HQ.EQ.0) THEN
29357 EMSQ=0
29358 BE=1
29359 CFAC=3
29360 ELSE
29361 IF (HQ.GT.6) HQ=2*HQ+107
29362 IF (HQ.EQ.127) HQ=198
29363 EMSQ=RMASS(HQ)**2
29364 BE=1-4*EMSQ/S
29365 IF (BE.LT.ZERO) RETURN
29366 BE=SQRT(BE)
29367 CFAC=1
29368 IF (HQ.LE.6) CFAC=3
29369 ENDIF
29370 TMIN=S/2*(1-SQRT(MAX(1-4*(EMSQ+PTMIN**2)/S,ZERO)))
29371 TMAX=S/2*(1-SQRT(MAX(1-4*(EMSQ+PTMAX**2)/S,ZERO)))
29372 IF (TMIN.GE.TMAX) RETURN
29373 T=-(TMAX/TMIN)**HWRGEN(1)*TMIN
29374 IF (HWRGEN(2).GT.HALF) T=-S-T
29375 U=-S-T
29376 COSTH=(T-U)/(BE*S)
29377 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
29378 IF (HQ.NE.198) THEN
29379 FACTR=-GEV2NB*2*LOG(TMAX/TMIN)*MAX(T,U)
29380 $ *2*PIFAC*CFAC*ALPHEM**2/S**2
29381 $ *((U-4*EMSQ)/T+(T-4*EMSQ)/U-4*(EMSQ/T+EMSQ/U)**2)
29382 ELSE
29383 FACTR=-GEV2NB*2*LOG(TMAX/TMIN)*MAX(T,U)
29384 $ *6*PIFAC*CFAC*ALPHEM**2/S**2
29385 $ *(1-S/(T*U)*(4D0/3*S+2*EMSQ)
29386 $ +(S/(T*U))**2*(2D0/3*S**2+2*EMSQ**2))
29387 ENDIF
29388 ENDIF
29389 HCS=0.
29390 XX(1)=1.
29391 XX(2)=1.
29392 IF (HQ.EQ.0) THEN
29393 I1=1
29394 I2=6
29395 ELSE
29396 I1=HQ
29397 I2=HQ
29398 ENDIF
29399 DO 10 ID3=I1,I2
29400 IF (RS.GT.2*RMASS(ID3)) THEN
29401 Q=ICHRG(ID3)
29402 IF (HQ.LE.6) Q=Q/THREE
29403 ID4=ID3+6
29404 IF (HQ.EQ.198) ID4=199
29405 HCS=HCS+Q**4
29406 IF (GENEV.AND.HCS.GT.RCS) THEN
29407 CALL HWHQCP(ID3,ID4,1243,61)
29408 GOTO 99
29409 ENDIF
29410 ENDIF
29411 10 CONTINUE
29412 EVWGT=FACTR*HCS
29413 RETURN
29414 99 IDN(1)=59
29415 IDN(2)=59
29416 IDCMF=15
29417 CALL HWETWO(.TRUE.,.TRUE.)
29418 END
29419CDECK ID>, HWHRBB.
29420*CMZ :- -20/10/99 09:46:43 by Peter Richardson
29421*-- Author : Peter Richardson
29422C-----------------------------------------------------------------------
29423 SUBROUTINE HWHRBB
29424C-----------------------------------------------------------------------
29425C Subroutine for 2 parton -> 2 parton via UDD resonant squarks
29426C-----------------------------------------------------------------------
c63d70bc 29427 INCLUDE 'herwig65.inc'
65767955 29428 DOUBLE PRECISION HCS,S,RCS,HWRGEN,MQ1,MQ2,TAU,LOWTLM,UPPTLM,RTAB,
29429 & SQSH,MATELM,SCF(12),CHANPB(2),HWRUNI,PCM,MIX(12),
29430 & ME(2,3,3,3,3),WD,MS(12),SWD(12),RAND,TAUA,
29431 & CHAN(12),EPS,SH,FAC,TAUB,LAM(6,3,3,3,3),
29432 & XMIN,XMAX,XPOW,XUPP,MS2(12),MSWD(12)
29433 INTEGER I,J,K,L,I1,J1,K1,L1,N,THEP,CONECT(4,5),HWRINT,
29434 & GENR,GN,MIG,MXG,GEN
29435 LOGICAL FIRST
29436 EXTERNAL HWRGEN,HWRUNI
29437 PARAMETER(EPS=1D-20)
29438 COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
29439 SAVE HCS,ME,MS,SWD,CHAN,LAM,MIX,FAC,SH,SQSH,SCF,MS2,MSWD
29440 SAVE CONECT
29441 DATA CONECT/1,1,3,4,-1,-1,2,3,0,0,0,0,1,1,-2,-3,-1,-1,-3,-4/
29442 IF(GENEV) THEN
29443 RCS = HCS*HWRGEN(0)
29444 ELSE
29445 IF(FSTWGT) THEN
29446C--Extract masses and width's needed
29447 DO I=1,3
29448 MS(2*I-1) = RMASS(399+2*I)
29449 MS(2*I) = RMASS(411+2*I)
29450 MS(2*I+5) = RMASS(400+2*I)
29451 MS(2*I+6) = RMASS(412+2*I)
29452 SWD(2*I-1) = HBAR/RLTIM(399+2*I)
29453 SWD(2*I) = HBAR/RLTIM(411+2*I)
29454 SWD(2*I+5) = HBAR/RLTIM(400+2*I)
29455 SWD(2*I+6) = HBAR/RLTIM(412+2*I)
29456 ENDDO
29457 DO I=1,12
29458 MS2(I) = MS(I)**2
29459 MSWD(I) = MS(I)*SWD(I)
29460 ENDDO
29461C--Now set up the parmaters for multichannel integration
29462 RAND = ZERO
29463 DO K=1,3
29464 CHANPB(1) = ZERO
29465 CHANPB(2) = ZERO
29466 DO I=1,3
29467 DO J=1,3
29468 CHANPB(1)=CHANPB(1)+LAMDA3(I,J,K)**2
29469 CHANPB(2)=CHANPB(2)+LAMDA3(K,I,J)**2
29470 ENDDO
29471 ENDDO
29472 RAND=RAND+CHANPB(1)+CHANPB(2)
29473 DO J=1,2
29474 CHAN(2*K-2+J) = CHANPB(1)*QMIXSS(2*K-1,2,J)**2
29475 CHAN(2*K+4+J) = CHANPB(2)*QMIXSS(2*K ,2,J)**2
29476 MIX(2*K-2+J) = QMIXSS(2*K-1,2,J)**2
29477 MIX(2*K+4+J) = QMIXSS(2*K,2,J)**2
29478 ENDDO
29479 ENDDO
29480 IF(RAND.GT.ZERO) THEN
29481 DO I=1,12
29482 CHAN(I)=CHAN(I)/RAND
29483 ENDDO
29484 ELSE
29485 HCS =ZERO
29486 CALL HWWARN('HWHRBB',500)
29487 ENDIF
29488C--find the couplings
29489 DO GN=1,3
29490 DO I=1,3
29491 DO J=1,3
29492 DO K=1,3
29493 DO L=1,3
29494 LAM(GN,I,J,K,L) =LAMDA3(I,J,GN)*LAMDA3(K,L,GN)
29495 LAM(GN+3,I,J,K,L)=LAMDA3(GN,I,J)*LAMDA3(GN,K,L)
29496 ENDDO
29497 ENDDO
29498 ENDDO
29499 ENDDO
29500 ENDDO
29501 ENDIF
29502 EVWGT = ZERO
29503 S = PHEP(5,3)**2
29504 COSTH = HWRUNI(0,-ONE,ONE)
29505C--Generate the smoothing
29506 RAND=HWRUNI(0,ZERO,ONE)
29507 DO I=1,12
29508 IF(CHAN(I).GT.RAND) GOTO 20
29509 RAND=RAND-CHAN(I)
29510 ENDDO
29511 20 GENR=I
29512C--Calculate hard scale and obtain parton distributions
29513 TAUA = MS2(GENR)/S
29514 TAUB = SWD(GENR)**2/S
29515 RTAB = SQRT(TAUA*TAUB)
29516 XUPP = XMAX
29517 IF(XMAX**2.GT.S) XUPP = SQRT(S)
29518 LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
29519 UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
29520 TAU = HWRUNI(0,LOWTLM,UPPTLM)
29521 TAU = RTAB*TAN(RTAB*TAU)+TAUA
29522 SH = S*TAU
29523 SQSH = SQRT(SH)
29524 EMSCA = SQSH
29525 XX(1) = EXP(HWRUNI(0,ZERO,LOG(TAU)))
29526 XX(2) = TAU/XX(1)
29527 CALL HWSGEN(.FALSE.)
29528C--Calculate the prefactor due multichannel approach
29529 FAC = ZERO
29530 DO GN=1,12
29531 SCF(GN)=1/((SH-MS2(GN))**2+MSWD(GN)**2)
29532 FAC=FAC+CHAN(GN)*SCF(GN)
29533 ENDDO
29534 FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
29535 & /(24*PIFAC*SQSH*SH*TAU*FAC*S**2)
29536 ENDIF
29537C--loop over the quarks
29538 HCS = ZERO
29539 DO GN=1,2
29540 IF(GN.EQ.1) THEN
29541 MIG = 1
29542 MXG = 6
29543 ELSE
29544 MIG = 7
29545 MXG = 12
29546 ENDIF
29547 DO K1=1,3
29548 DO 70 L1=1,3
29549 IF(GN.EQ.1) THEN
29550 K = 2*K1
29551 L = 2*L1-1
29552 ELSE
29553 K=2*K1-1
29554 L=2*L1-1
29555 IF(GN.EQ.2.AND.L1.GE.K1) GOTO 70
29556 ENDIF
29557 MQ1=RMASS(K)
29558 MQ2=RMASS(L)
29559 IF(SQSH.GT.(MQ1+MQ2)) THEN
29560 PCM=SQRT((SH-(MQ1+MQ2)**2)*(SH-(MQ1-MQ2)**2)/(4*SH))
29561 WD = SH*(SH-MQ1**2-MQ2**2)*PCM
29562 ELSE
29563 GOTO 70
29564 ENDIF
29565 DO I1=1,3
29566 DO 60 J1=1,3
29567 IF(GN.EQ.1) THEN
29568 I = 2*I1
29569 J = 2*J1-1
29570 ELSE
29571 I=2*I1-1
29572 J=2*J1-1
29573 IF(J1.GT.I1) GOTO 60
29574 ENDIF
29575 IF(GENEV) GOTO 50
29576 MATELM = ZERO
29577 DO 40 GEN=MIG,MXG
29578 IF(ABS(MIX(GEN)).LT.EPS.OR.
29579 & ABS(LAM(INT((GEN+1)/2),I1,J1,K1,L1)).LT.EPS) GOTO 40
29580 DO 30 GENR=MIG,MXG
29581 IF(ABS(LAM(INT((GENR+1)/2),I1,J1,K1,L1)).LT.EPS.
29582 & OR.ABS(MIX(GENR)).LT.EPS) GOTO 30
29583 MATELM =MATELM+SCF(GEN)*SCF(GENR)*WD*
29584 & ((SH-MS2(GEN))*(SH-MS2(GENR))+
29585 & MSWD(GEN)*MSWD(GENR))
29586 & *LAM(INT((GEN+1)/2),I1,J1,K1,L1)*MIX(GEN)
29587 & *LAM(INT((GENR+1)/2),I1,J1,K1,L1)*MIX(GENR)
29588 30 CONTINUE
29589 40 CONTINUE
29590 ME(GN,I1,J1,K1,L1) = MATELM*FAC
29591C--Add up the term to get the cross-section
29592 50 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(I,1)*DISF(J,2)
29593 IF(HCS.GT.RCS.AND.GENEV) THEN
29594 CALL HWHRSS(1,I,J,K,L,0,0)
29595 GOTO 100
29596 ENDIF
29597 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J,1)*DISF(I,2)
29598 IF(HCS.GT.RCS.AND.GENEV) THEN
29599 CALL HWHRSS(2,J,I,K,L,0,0)
29600 GOTO 100
29601 ENDIF
29602 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(I+6,1)*DISF(J+6,2)
29603 IF(HCS.GT.RCS.AND.GENEV) THEN
29604 CALL HWHRSS(1,I,J,K,L,1,0)
29605 GOTO 100
29606 ENDIF
29607 HCS = HCS+ME(GN,I1,J1,K1,L1)*DISF(J+6,1)*DISF(I+6,2)
29608 IF(HCS.GT.RCS.AND.GENEV) THEN
29609 CALL HWHRSS(2,J,I,K,L,1,0)
29610 GOTO 100
29611 ENDIF
29612 60 CONTINUE
29613 ENDDO
29614 70 CONTINUE
29615 ENDDO
29616 ENDDO
29617 100 IF(GENEV) THEN
29618 CALL HWETWO(.TRUE.,.TRUE.)
29619C--first stage of the colour connection corrections
29620 DO THEP=1,5
29621 IF(THEP.NE.3) THEN
29622 JMOHEP(2,THEP+NHEP-5)=NHEP-5+THEP+CONECT(HWRINT(1,4),THEP)
29623 JDAHEP(2,THEP+NHEP-5) = JMOHEP(2,THEP+NHEP-5)
29624 ENDIF
29625 ENDDO
29626 THEP = NHEP-4
29627 IF(HWRINT(1,2).EQ.1) THEN
29628 HRDCOL(2,1) = THEP+3
29629 HRDCOL(2,2) = THEP+4
29630 HRDCOL(1,4) = THEP
29631 HRDCOL(1,5) = THEP+1
29632 ELSE
29633 HRDCOL(2,1) = THEP+4
29634 HRDCOL(2,2) = THEP+3
29635 HRDCOL(1,4) = THEP+1
29636 HRDCOL(1,5) = THEP
29637 ENDIF
29638 DO N=1,5
29639 IF(N.LE.2) THEN
29640 HRDCOL(1,N)=HRDCOL(2,N)
29641 ELSEIF(N.GE.4) THEN
29642 HRDCOL(2,N)=HRDCOL(1,N)
29643 ENDIF
29644 ENDDO
29645 HRDCOL(1,3) = 4
29646 COLUPD = .TRUE.
29647 ELSE
29648 EVWGT = HCS
29649 ENDIF
29650 END
29651CDECK ID>, HWHRBS.
29652*CMZ :- -20/10/99 09:46:43 by Peter Richardson
29653*-- Author : Peter Richardson
29654C-----------------------------------------------------------------------
29655 SUBROUTINE HWHRBS
29656C-----------------------------------------------------------------------
29657C Subroutine for 2 parton -> parton SUSY particle via UDD resonant
29658C squarks.
29659C-----------------------------------------------------------------------
c63d70bc 29660 INCLUDE 'herwig65.inc'
65767955 29661 DOUBLE PRECISION HCS,S,RCS,HWRGEN,ME(4),CW,MER(6),MZ,TAU,TAUA,
29662 & TAUB,LOWTLM,UPPTLM,HWRUNI,SH,SQSH,SCF(12),MW2,
29663 & LAMC(3),CHANPB(2),PCM,ECM,RAND,MEN(7,6,3,3),
29664 & MEC(2,6,3,3),RTAB,MS(12),SWD(12),AS,HWUALF,
29665 & MQ,MN,MQS,TH,UH,FAC,MX(14),CHAN(12),MC(2),
29666 & MNS,HWUAEM,SW,G,EC,MW,A(7,14),B(7,14),EPS,XUPP,
29667 & MEH(3,42),XMIN,XMAX,XPOW,FAC2,MH(4),ZSQU(2,2),
29668 & ZQRK(2),MZ2,GUU(4),GDD(4),ME2,MS2(12),MSWD(12)
29669 INTEGER I,J,K,I1,J1,GEN,THEP,HWRINT,L,GT,GU,GR,I2,
29670 & CONECT(2,6,5),GN,GENR,SP,SPMN,SPMX,CON,CHARMN,CHARMX,
29671 & CM,CN
29672 LOGICAL RAD,NEUT,CHAR,HIGGS,FIRST
29673 EXTERNAL HWRGEN,HWRUNI,HWUAEM,HWUALF,HWRINT
29674 COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
29675 SAVE HCS,MS,SWD,MX,CHAN,A,B,SPMN,SPMX,RAD,MEN,MEC,HIGGS,
29676 & CHARMN,CHARMX,NEUT,CHAR,SQSH,MEH,SW,CW,MW,MZ,MER,SH,MH,
29677 & AS,EC,FAC,G,SCF,ZSQU,ZQRK,MW2,MZ2,MS2,MSWD,GUU,GDD
29678 PARAMETER(EPS=1D-20)
29679 SAVE CONECT
29680 DATA CONECT/ 4, 4, 2, 3, 0, 0, 1,-2,-1,-3,-4,-4,
29681 & 3, 4, 3, 3, 0, 0, 1,-3,-1,-4,-3,-3,
29682 & 1, 4,-1, 3, 0, 0, 1, 1,-3,-4,-1,-1,
29683 & 1, 3,-1, 2, 0, 0,-3,-2, 0, 0, 0, 0,
29684 & 1, 4,-1, 3, 0, 0,-3,-2,-1,-1,-1,-1/
29685 IF(GENEV) THEN
29686 RCS = HCS*HWRGEN(0)
29687 ELSE
29688 IF(FSTWGT) THEN
29689C--Extract masses and width's needed
29690 DO I=1,3
29691 MS(2*I-1) = RMASS(399+2*I)
29692 MS(2*I) = RMASS(411+2*I)
29693 MS(2*I+5) = RMASS(400+2*I)
29694 MS(2*I+6) = RMASS(412+2*I)
29695 SWD(2*I-1) = HBAR/RLTIM(399+2*I)
29696 SWD(2*I) = HBAR/RLTIM(411+2*I)
29697 SWD(2*I+5) = HBAR/RLTIM(400+2*I)
29698 SWD(2*I+6) = HBAR/RLTIM(412+2*I)
29699 ENDDO
29700 DO I=1,12
29701 MS2(I) = MS(I)**2
29702 MSWD(I) = MS(I)*SWD(I)
29703 ENDDO
29704C--Electroweak parameters
29705 SW = SQRT(SWEIN)
29706 CW = SQRT(1-SWEIN)
29707 MW = RMASS(198)
29708 MZ = RMASS(200)
29709 MW2 = MW**2
29710 MZ2 = MZ**2
29711C--Now set up the parmaters for multichannel integration
29712 RAND = ZERO
29713 DO K=1,3
29714 CHANPB(1) = ZERO
29715 CHANPB(2) = ZERO
29716 DO I=1,3
29717 DO J=1,3
29718 CHANPB(1)=CHANPB(1)+LAMDA3(I,J,K)**2
29719 CHANPB(2)=CHANPB(2)+LAMDA3(K,I,J)**2
29720 ENDDO
29721 ENDDO
29722 RAND=RAND+CHANPB(1)+CHANPB(2)
29723 DO J=1,2
29724 CHAN(2*K-2+J) = CHANPB(1)*QMIXSS(2*K-1,2,J)**2
29725 CHAN(2*K+4+J) = CHANPB(2)*QMIXSS(2*K ,2,J)**2
29726 MX(2*K-2+J) = QMIXSS(2*K-1,2,J)
29727 MX(2*K+4+J) = QMIXSS(2*K,2,J)
29728 ENDDO
29729 MX(13) = ZERO
29730 MX(14) = ZERO
29731 ENDDO
29732 IF(RAND.GT.ZERO) THEN
29733 DO I=1,12
29734 CHAN(I)=CHAN(I)/RAND
29735 ENDDO
29736 ELSE
29737 CALL HWWARN('HWHRBS',500)
29738 ENDIF
29739C--Couplings we need for the various processes
29740C--Gluino
29741 DO I=1,3
29742 DO J=1,2
29743 A(1,2*I-2+J) = QMIXSS(2*I-1,2,J)
29744 B(1,2*I-2+J) = -QMIXSS(2*I-1,1,J)
29745 A(1,2*I+4+J) = QMIXSS(2*I,2,J)
29746 B(1,2*I+4+J) = -QMIXSS(2*I,1,J)
29747 ENDDO
29748 ENDDO
29749C--Now the neutralinos
29750 DO L=1,4
29751 MC(1) = ZMIXSS(L,3)/(2*MW*COSB*SW)
29752 MC(2) = ZMIXSS(L,4)/(2*MW*SINB*SW)
29753 DO I=1,3
29754 DO J=1,2
29755 A(L+1,2*I-2+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
29756 & RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
29757 B(L+1,2*I-2+J) = MC(1)*QMIXSS(2*I-1,2,J)*
29758 & RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
29759 A(L+1,2*I+4+J) = ZSGNSS(L)*(MC(2)*QMIXSS(2*I,1,J)*
29760 & RMASS(2*I)+SRFCH(2*I ,L)*QMIXSS(2*I,2,J))
29761 B(L+1,2*I+4+J) = MC(2)*QMIXSS(2*I,2,J)*
29762 & RMASS(2*I)+SLFCH(2*I, L)*QMIXSS(2*I,1,J)
29763 ENDDO
29764 ENDDO
29765 ENDDO
29766C--Now for the charginos
29767 DO L=1,2
29768 MC(1) = 1/(SQRT(2.0D0)*MW*COSB)
29769 MC(2) = 1/(SQRT(2.0D0)*MW*SINB)
29770 DO I=1,3
29771 DO J=1,2
29772 A(5+L,2*I-2+J) = -WSGNSS(L)*WMXVSS(L,2)*MC(2)*
29773 & RMASS(2*I)*QMIXSS(2*I-1,1,J)
29774 B(5+L,2*I-2+J) = WMXUSS(L,1)*QMIXSS(2*I-1,1,J)
29775 & -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)*QMIXSS(2*I-1,2,J)
29776 A(5+L,2*I+4+J) = -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)
29777 & *QMIXSS(2*I,1,J)
29778 B(5+L,2*I+4+J) = WSGNSS(L)*(WMXVSS(L,1)*QMIXSS(2*I,1,J)
29779 & -WMXVSS(L,2)*MC(2)*RMASS(2*I)*QMIXSS(2*I,2,J))
29780 ENDDO
29781 ENDDO
29782 ENDDO
29783C--Zero couplings
29784 DO I=1,7
29785 A(I,13) = ZERO
29786 B(I,13) = ZERO
29787 A(I,14) = ZERO
29788 B(I,14) = ZERO
29789 ENDDO
29790C--Couplings to the Z boson of squarks and right-handed quarks
29791 ZQRK(1) = -SW**2/6.0D0/CW
29792 ZQRK(2) = SW**2/3.0D0/CW
29793 ZSQU(1,1) = HALF*(QMIXSS(5,1,1)**2-2.0D0*SW**2/3.0D0)/CW
29794 ZSQU(1,2) = HALF*QMIXSS(5,1,1)*QMIXSS(5,1,2)/CW
29795 ZSQU(2,1) = -HALF*(QMIXSS(6,1,1)**2-4.0D0*SW**2/3.0D0)/CW
29796 ZSQU(2,2) = -HALF*QMIXSS(6,1,1)*QMIXSS(6,1,2)/CW
29797C--Higgs Masses
29798 DO I=1,4
29799 MH(I) = RMASS(202+I)
29800 ENDDO
29801C--Higgs couplings to quarks
29802 DO I=1,3
29803 GUU(I) = GHUUSS(I)**2*HALF**2/MW2
29804 GDD(I) = GHDDSS(I)**2*HALF**2/MW2
29805 ENDDO
29806 GUU(4) = ONE/TANB**2/MW2/8.0D0
29807 GDD(4) = ONE*TANB**2/MW2/8.0D0
29808C--decide which processes to generate from IPROC
29809 RAD = .FALSE.
29810 NEUT = .FALSE.
29811 CHAR = .FALSE.
29812 HIGGS = .FALSE.
29813 SPMN = 1
29814 SPMX = 5
29815 CHARMN = 1
29816 CHARMX = 2
29817 IF(MOD(IPROC,10000).EQ.4100) THEN
29818 RAD = .TRUE.
29819 NEUT = .TRUE.
29820 CHAR = .TRUE.
29821 HIGGS = .TRUE.
29822 ELSEIF(MOD(IPROC,10000).LT.4120) THEN
29823 SPMN = 2
29824 IF(MOD(IPROC,10000).NE.4110) THEN
29825 SPMN = MOD(IPROC,10)+1
29826 SPMX = SPMN
29827 ENDIF
29828 NEUT=.TRUE.
29829 ELSEIF(MOD(IPROC,10000).LT.4130) THEN
29830 IF(MOD(IPROC,10000).NE.4120) THEN
29831 CHARMN = MOD(IPROC,10)
29832 CHARMX=CHARMN
29833 ENDIF
29834 CHAR = .TRUE.
29835 ELSEIF(MOD(IPROC,10000).EQ.4130) THEN
29836 SPMX = 1
29837 NEUT=.TRUE.
29838 ELSEIF(MOD(IPROC,10000).EQ.4140) THEN
29839 RAD = .TRUE.
29840 ELSEIF(MOD(IPROC,10000).EQ.4150) THEN
29841 HIGGS = .TRUE.
29842 ELSE
29843 CALL HWWARN('HWHRBS',501)
29844 ENDIF
29845 ENDIF
29846 EVWGT = ZERO
29847 S = PHEP(5,3)**2
29848 COSTH = HWRUNI(0,-ONE,ONE)
29849C--zero the array
29850 DO I=1,6
29851 DO J=1,3
29852 DO K=1,3
29853 DO L=1,7
29854 MEN(L,I,J,K)=ZERO
29855 ENDDO
29856 DO L=1,2
29857 MEC(L,I,J,K)=ZERO
29858 ENDDO
29859 ENDDO
29860 ENDDO
29861 ENDDO
29862C--Multichannel peak
29863 RAND=HWRUNI(0,ZERO,ONE)
29864 DO I=1,12
29865 IF(CHAN(I).GT.RAND) GOTO 25
29866 RAND=RAND-CHAN(I)
29867 ENDDO
29868 25 GENR=I
29869C--Calculate the hard scale and obtain parton distributions
29870 TAUA = MS2(GENR)/S
29871 TAUB = SWD(GENR)**2/S
29872 RTAB = SQRT(TAUA*TAUB)
29873 XUPP = XMAX
29874 IF(XMAX**2.GT.S) XUPP = SQRT(S)
29875 LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
29876 UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
29877 TAU = HWRUNI(0,LOWTLM,UPPTLM)
29878 TAU = RTAB*TAN(RTAB*TAU)+TAUA
29879 SH = S*TAU
29880 SQSH = SQRT(SH)
29881 EMSCA = SQSH
29882 XX(1) = EXP(HWRUNI(0,ZERO,LOG(TAU)))
29883 XX(2) = TAU/XX(1)
29884 CALL HWSGEN(.FALSE.)
29885C--Strong, EM coupling and weak couplings
29886 AS = HWUALF(1,EMSCA)
29887 EC = SQRT(4*PIFAC*HWUAEM(SH))
29888 G = EC/SW
29889C--Calculate the prefactor due multichannel approach
29890 FAC = ZERO
29891 DO GN=1,12
29892 SCF(GN)=1/((SH-MS2(GN))**2+MSWD(GN)**2)
29893 FAC=FAC+CHAN(GN)*SCF(GN)
29894 ENDDO
29895 FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
29896 & /(48*PIFAC*SQSH*SH*TAU*FAC*S**2)
29897 ENDIF
29898 HCS = ZERO
29899 IF(.NOT.NEUT) GOTO 200
29900 DO 140 GN=1,6
29901 GR=2*GN
29902 IF(CHAN(GR).LT.EPS) GOTO 140
29903 DO 130 L=SPMN,SPMX
29904 K = 2*GN+5
29905 IF(GN.GT.3) K = 2*GN
29906 MQ = RMASS(K)
29907 MN = ABS(RMASS(448+L))
29908 MQS = MQ**2
29909 MNS = MN**2
29910 IF(SQSH.LT.(MQ+MN)) GOTO 130
29911 PCM=SQRT((SH-(MQ+MN)**2)*(SH-(MQ-MN)**2)/(4*SH))
29912 ECM=SQRT(PCM**2+MQS)
29913 TH = MQS-SQSH*(ECM-PCM*COSTH)
29914 UH = MQS-SQSH*(ECM+PCM*COSTH)
29915 DO I=1,3
29916 DO 120 J=1,3
29917 IF(GN.LE.3) THEN
29918 GU = 6+2*I
29919 I1 = 2*I
29920 LAMC(1) = LAMDA3(I,J,GN)**2
29921 ELSE
29922 GU = 2*I
29923 I1 = 2*I-1
29924 LAMC(1) = LAMDA3(GN-3,I,J)**2
29925 IF(J.GT.I) LAMC(1) = ZERO
29926 ENDIF
29927 GT = 2*J
29928 J1 = 2*J-1
29929C--Now the matrix elements
29930 IF(LAMC(1).LT.EPS) GOTO 120
29931 IF(GENEV) GOTO 110
29932C--S channel
29933 ME(3) = MX(GR)**2*SCF(GR)*SH*((SH-MQS-MNS)*(A(L,GR)**2+
29934 & B(L,GR)**2)-4*MQ*MN*A(L,GR)*B(L,GR))
29935 ME(4) =-TWO*MX(GU)*MX(GT)*(MQS*MNS-UH*TH)*A(L,GT)*A(L,GU)
29936 & /(TH-MS2(GT))/(UH-MS2(GU))
29937 & +TWO*MX(GR)*MX(GU)*(SH-MS2(GR))*SCF(GR)*SH*
29938 & A(L,GU)*(A(L,GR)*UH+B(L,GR)*MQ*MN)/(UH-MS2(GU))
29939 & +TWO*MX(GR)*MX(GT)*(SH-MS2(GR))*SCF(GR)*SH*
29940 & A(L,GT)*(A(L,GR)*TH+B(L,GR)*MQ*MN)/(TH-MS2(GT))
29941C--L/R s channel and interference
29942 IF(ABS(MX(GR-1)).GT.EPS) THEN
29943 ME(3) = ME(3)+
29944 & MX(GR-1)**2*SCF(GR-1)*SH*((SH-MQS-MNS)*(A(L,GR-1)**2
29945 & +B(L,GR-1)**2)-4*MQ*MN*A(L,GR-1)*B(L,GR-1))
29946 & +TWO*MX(GR)*MX(GR-1)*SCF(GR)*SCF(GR-1)*SH*
29947 & ((SH-MS2(GR))*(SH-MS2(GR-1))+MSWD(GR)*MSWD(GR-1))*
29948 & ((SH-MQS-MNS)*(A(L,GR)*A(L,GR-1)
29949 & +B(L,GR)*B(L,GR-1))
29950 & -TWO*MQ*MN*(A(L,GR)*B(L,GR-1)+A(L,GR-1)*B(L,GR)))
29951 ME(4) = ME(4)+TWO*MX(GR-1)*MX(GU)*(SH-MS2(GR-1))
29952 & *SCF(GR-1)*A(L,GU)*SH*(A(L,GR-1)*UH+B(L,GR-1)*MQ*MN)
29953 & /(UH-MS2(GU))
29954 & +TWO*MX(GR-1)*MX(GT)*(SH-MS2(GR-1))*SCF(GR-1)*SH*
29955 & A(L,GT)*(A(L,GR-1)*TH+B(L,GR-1)*MQ*MN)/(TH-MS2(GT))
29956 IF(ABS(MX(GU-1)).GT.EPS) ME(4)=ME(4)+TWO*MX(GR-1)*
29957 & MX(GU-1)*(SH-MS2(GR-1))*SCF(GR-1)*A(L,GU-1)*SH*(
29958 & A(L,GR-1)*UH+B(L,GR-1)*MQ*MN)/(UH-MS2(GU-1))
29959 IF(ABS(MX(GT-1)).GT.EPS) ME(4)=ME(4)+TWO*MX(GR-1)*
29960 & MX(GT-1)*(SH-MS2(GR-1))*SCF(GR-1)*A(L,GT-1)*SH*
29961 & (A(L,GR-1)*TH+B(L,GR-1)*MQ*MN)/(TH-MS2(GT-1))
29962 ENDIF
29963C--u channel and L/R mixing
29964 ME(1)= MX(GU)**2*(MQS-UH)*(MNS-UH)*
29965 & (A(L,GU)**2+B(L,GU)**2)/(UH-MS2(GU))**2
29966 IF(ABS(MX(GU-1)).GT.EPS) THEN
29967 ME(1) = ME(1)+MX(GU-1)**2*(MQS-UH)*(MNS-UH)*
29968 & (A(L,GU-1)**2+B(L,GU-1)**2)/(UH-MS2(GU-1))**2
29969 & +TWO*MX(GU)*MX(GU-1)*(MQS-UH)*(MNS-UH)*
29970 & (A(L,GU)*A(L,GU-1)+B(L,GU)*B(L,GU-1))
29971 & /(UH-MS2(GU))/(UH-MS2(GU-1))
29972 ME(4) =ME(4)+TWO*MX(GR)*MX(GU-1)*(SH-MS2(GR))*
29973 & SCF(GR)*A(L,GU-1)*SH*(A(L,GR)*UH+B(L,GR)*MQ*MN)
29974 & /(UH-MS2(GU-1))
29975 & -2*MX(GU-1)*MX(GT)*(MQS*MNS-UH*TH)*A(L,GT)*
29976 & A(L,GU-1)/(TH-MS2(GT))/(UH-MS2(GU-1))
29977 IF(ABS(MX(GT-1)).GT.EPS) ME(4)=ME(4)-2*MX(GU-1)*MX(GT-1)
29978 & *(MQS*MNS-UH*TH)*A(L,GT-1)*A(L,GU-1)
29979 & /(TH-MS2(GT-1))/(UH-MS2(GU-1))
29980 ENDIF
29981C--t channel and t channel L/R mixing
29982 ME(2) = MX(GT)**2*(MQS-TH)*(MNS-TH)*
29983 & (A(L,GT)**2+B(L,GT)**2)/(TH-MS2(GT))**2
29984 IF(ABS(MX(GT-1)).GT.EPS) THEN
29985 ME(2) = ME(2)+MX(GT-1)**2*(MQS-TH)*(MNS-TH)*
29986 & (A(L,GT-1)**2+B(L,GT-1)**2)/(TH-MS2(GT-1))**2
29987 & +TWO*MX(GT)*MX(GT-1)*(MQS-TH)*(MNS-TH)*(A(L,GT)*
29988 & A(L,GT-1)+ B(L,GT)*B(L,GT-1))
29989 & /(TH-MS2(GT))/(TH-MS2(GT-1))
29990 ME(4)=ME(4)-TWO*MX(GU)*MX(GT-1)*(MQS*MNS-UH*TH)*
29991 & A(L,GT-1)*A(L,GU)/(TH-MS2(GT-1))/(UH-MS2(GU))
29992 & +TWO*MX(GR)*MX(GT-1)*(SH-MS2(GR))*SCF(GR)*
29993 & A(L,GT-1)*SH*(A(L,GR)*TH+B(L,GR)*MQ*MN)
29994 & /(TH-MS2(GT-1))
29995 ENDIF
29996C--Angular ordering and the phase space factors
29997 IF(L.EQ.1) THEN
29998 ME(4)=-HALF*ME(4)/(ME(1)+ME(2)+ME(3))
29999 LAMC(1) = 32.0D0*LAMC(1)*AS*PIFAC/THREE
30000 DO GEN=1,3
30001 MEN(GEN,GN,I,J) = FAC*PCM*LAMC(1)*ME(GEN)*(ONE+ME(4))
30002 ENDDO
30003 ELSE
30004 LAMC(1) = TWO*LAMC(1)*EC**2
30005 MEN(L+2,GN,I,J)=FAC*PCM*LAMC(1)*(ME(1)+ME(2)+ME(3)+ME(4))
30006 ENDIF
30007C--Multiply by the pdf's
30008 110 IF(L.EQ.1) THEN
30009 CM = 1
30010 CN = 3
30011 ELSE
30012 CM = L+2
30013 CN = L+2
30014 ENDIF
30015 DO GEN=CM,CN
30016 CON = 4
30017 IF(GEN.LE.3) CON = GEN
30018 HCS=HCS+MEN(GEN,GN,I,J)*DISF(I1,1)*DISF(J1,2)
30019 IF(GENEV.AND.HCS.GT.RCS) THEN
30020 CALL HWHRSS(3,I1,J1,K,GEN,0,0)
30021 GOTO 900
30022 ENDIF
30023 HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1,1)*DISF(I1,2)
30024 IF(GENEV.AND.HCS.GT.RCS) THEN
30025 CALL HWHRSS(4,J1,I1,K,GEN,0,0)
30026 GOTO 900
30027 ENDIF
30028 HCS=HCS+MEN(GEN,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2)
30029 IF(GENEV.AND.HCS.GT.RCS) THEN
30030 CALL HWHRSS(3,I1,J1,K,GEN,1,0)
30031 GOTO 900
30032 ENDIF
30033 HCS=HCS+MEN(GEN,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2)
30034 IF(GENEV.AND.HCS.GT.RCS) THEN
30035 CALL HWHRSS(4,J1,I1,K,GEN,1,0)
30036 GOTO 900
30037 ENDIF
30038 ENDDO
30039 120 CONTINUE
30040 ENDDO
30041 130 CONTINUE
30042 140 CONTINUE
30043C--Now the chargino processes if wanted
30044 200 IF(.NOT.CHAR) GOTO 300
30045 DO 240 GN=1,6
30046 GR=2*GN
30047 IF(CHAN(GR).LT.EPS) GOTO 240
30048 DO 230 L=CHARMN,CHARMX
30049 SP =5+L
30050 K = 2*GN+6
30051 IF(GN.GT.3) K = 2*GN-1
30052 MQ = RMASS(K)
30053 MN = ABS(RMASS(453+L))
30054 MQS = MQ**2
30055 MNS = MN**2
30056 IF(SQSH.LT.(MQ+MN)) GOTO 230
30057 PCM=SQRT((SH-(MQ+MN)**2)*(SH-(MQ-MN)**2)/(4*SH))
30058 ECM=SQRT(PCM**2+MQS)
30059 TH = MQS-SQSH*(ECM-PCM*COSTH)
30060 UH = MQS-SQSH*(ECM+PCM*COSTH)
30061 DO I=1,3
30062 DO 220 J=1,3
30063 IF(GN.LE.3) THEN
30064 GU = 2*I
30065 GT = 14
30066 I1 = 2*I
30067 LAMC(1) = LAMDA3(I,J,GN)
30068 LAMC(2) = LAMDA3(GN,I,J)
30069 LAMC(3) = ZERO
30070 ELSE
30071 GU = 6+2*I
30072 GT = 6+2*J
30073 I1 = 2*I-1
30074 LAMC(1) = LAMDA3(GN-3,I,J)
30075 LAMC(2) = LAMDA3(I,J,GN-3)
30076 LAMC(3) = LAMDA3(J,GN-3,I)
30077 IF(J.GT.I) LAMC(1) = ZERO
30078 ENDIF
30079 J1 = 2*J-1
30080 IF(ABS(LAMC(1)).LT.EPS) GOTO 220
30081 IF(GENEV) GOTO 210
30082C--Matrix element
30083C--S channel
30084 ME(1) = LAMC(1)**2*MX(GR)**2*SCF(GR)*SH*((SH-MQS-MNS)*
30085 & (A(SP,GR)**2+B(SP,GR)**2)-4*MQ*MN*A(SP,GR)*B(SP,GR))
30086 IF(ABS(MX(GU)).GT.EPS) THEN
30087 ME(1) = ME(1)+LAMC(2)**2*MX(GU)**2*(MQS-UH)*(MNS-UH)*
30088 & (A(SP,GU)**2+B(SP,GU)**2)/(UH-MS2(GU))**2
30089 & +LAMC(1)*LAMC(2)*TWO*MX(GR)*MX(GU)*
30090 & (SH-MS2(GR))*SCF(GR)*A(SP,GU)*SH*
30091 & (A(SP,GR)*UH+B(SP,GR)*MQ*MN)/(UH-MS2(GU))
30092 IF(ABS(MX(GT)).GT.EPS) ME(1) = ME(1)-LAMC(2)*LAMC(3)*
30093 & TWO*MX(GU)*MX(GT)*(MQS*MNS-UH*TH)*A(SP,GT)*
30094 & A(SP,GU)/(TH-MS2(GT))/(UH-MS2(GU))
30095 ENDIF
30096 IF(ABS(MX(GT)).GT.EPS) THEN
30097 ME(1) = ME(1)+LAMC(3)**2*MX(GT)**2*(MQS-TH)*(MNS-TH)*
30098 & (A(SP,GT)**2+B(SP,GT)**2)/(TH-MS2(GT))**2
30099 & +LAMC(1)*LAMC(3)*TWO*MX(GR)*MX(GT)*
30100 & (SH-MS2(GR))*SCF(GR)*A(SP,GT)*SH*
30101 & (A(SP,GR)*TH+B(SP,GR)*MQ*MN)/(TH-MS2(GT))
30102 ENDIF
30103c--L/R s channel and interference
30104 IF(ABS(MX(GR-1)).GT.EPS) THEN
30105 ME(1) = ME(1)+LAMC(1)**2*MX(GR-1)**2*SCF(GR-1)*SH*
30106 & ((SH-MQS-MNS)*(A(SP,GR-1)**2+B(SP,GR-1)**2)
30107 & -4*MQ*MN*A(SP,GR-1)*B(SP,GR-1))
30108 & +LAMC(1)**2*TWO*MX(GR)*MX(GR-1)*SCF(GR)*
30109 & SCF(GR-1)*SH*
30110 & ((SH-MS2(GR))*(SH-MS2(GR-1))+
30111 & MSWD(GR)*MSWD(GR-1))*
30112 & ((SH-MQS-MNS)*(A(SP,GR)*A(SP,GR-1)+
30113 & B(SP,GR)*B(SP,GR-1))-TWO*MQ*MN*
30114 & (A(SP,GR)*B(SP,GR-1)+A(SP,GR-1)*B(SP,GR)))
30115 IF(ABS(MX(GU)).GT.EPS) ME(1) = ME(1)+LAMC(1)*LAMC(2)*
30116 & TWO*MX(GR-1)*MX(GU)*(SH-MS2(GR-1))*SCF(GR-1)*
30117 & A(SP,GU)*SH*(A(SP,GR-1)*UH+B(SP,GR-1)*MQ*MN)
30118 & /(UH-MS2(GU))
30119 IF(ABS(MX(GT)).GT.EPS) ME(1) = ME(1)+LAMC(1)*LAMC(3)*
30120 & TWO*MX(GR-1)*MX(GT)*(SH-MS2(GR-1))*SCF(GR-1)*
30121 & A(SP,GT)*SH*(A(SP,GR-1)*TH+B(SP,GR-1)*MQ*MN)
30122 & /(TH-MS2(GT))
30123 IF(ABS(MX(GU-1)).GT.EPS) ME(1)=ME(1)+LAMC(1)*LAMC(2)*
30124 & TWO*MX(GR-1)*MX(GU-1)*(SH-MS2(GR-1))*
30125 & SCF(GR-1)*A(SP,GU-1)*SH*(A(SP,GR-1)*UH+
30126 & B(SP,GR-1)*MQ*MN)/(UH-MS2(GU-1))
30127 IF(ABS(MX(GT-1)).GT.EPS) ME(1)=ME(1)+LAMC(1)*LAMC(3)*
30128 & TWO*MX(GR-1)*MX(GT-1)*(SH-MS2(GR-1))*
30129 & SCF(GR-1)*A(SP,GT-1)*SH*(A(SP,GR-1)*TH+
30130 & B(SP,GR-1)*MQ*MN)/(TH-MS2(GT-1))
30131 ENDIF
30132C--u channel and L/R mixing
30133 IF(ABS(MX(GU-1)).GT.EPS) THEN
30134 ME(1) = ME(1)+LAMC(2)**2*MX(GU-1)**2*(MQS-UH)*(MNS-UH)*
30135 & (A(SP,GU-1)**2+B(SP,GU-1)**2)/(UH-MS2(GU-1))**2
30136 & +LAMC(2)**2*TWO*MX(GU)*MX(GU-1)*(MQS-UH)*(MNS-UH)*
30137 & (A(SP,GU)*A(SP,GU-1)+B(SP,GU)*B(SP,GU-1))
30138 & /(UH-MS2(GU))/(UH-MS2(GU-1))
30139 & +TWO*LAMC(1)*LAMC(2)*MX(GR)*MX(GU-1)*
30140 & (SH-MS2(GR))*SCF(GR)*A(SP,GU-1)*SH*
30141 & (A(SP,GR)*UH+B(SP,GR)*MQ*MN)/(UH-MS2(GU-1))
30142 IF(ABS(MX(GT)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*TWO*
30143 & MX(GU-1)*MX(GT)*(MQS*MNS-UH*TH)*A(SP,GT)*A(SP,GU-1)
30144 & /(TH-MS2(GT))/(UH-MS2(GU-1))
30145 IF(ABS(MX(GT-1)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*
30146 & TWO*MX(GU-1)*MX(GT-1)*(MQS*MNS-UH*TH)*A(SP,GT-1)*
30147 & A(SP,GU-1)/(TH-MS2(GT-1))/(UH-MS2(GU-1))
30148 ENDIF
30149C--t channel and t channel L/R mixing
30150 IF(ABS(MX(GT-1)).GT.EPS) THEN
30151 ME(1) = ME(1)+LAMC(3)**2*MX(GT-1)**2*(MQS-TH)*(MNS-TH)*
30152 & (A(SP,GT-1)**2+B(SP,GT-1)**2)/(TH-MS2(GT-1))**2
30153 & +LAMC(3)**2*TWO*MX(GT)*MX(GT-1)*(MQS-TH)*(MNS-TH)*
30154 & (A(SP,GT)*A(SP,GT-1)+B(SP,GT)*B(SP,GT-1))
30155 & /(TH-MS2(GT))/(TH-MS2(GT-1))
30156 & +LAMC(1)*LAMC(3)*TWO*MX(GR)*MX(GT-1)*
30157 & (SH-MS2(GR))*SCF(GR)*A(SP,GT-1)*SH*
30158 & (A(SP,GR)*TH+B(SP,GR)*MQ*MN)/(TH-MS2(GT-1))
30159 IF(ABS(MX(GU)).GT.EPS) ME(1)=ME(1)-LAMC(2)*LAMC(3)*TWO*
30160 & MX(GU)*MX(GT-1)*(MQS*MNS-UH*TH)*A(SP,GT-1)*A(SP,GU)
30161 & /(TH-MS2(GT-1))/(UH-MS2(GU))
30162 ENDIF
30163c--phase space factors
30164 MEC(L,GN,I,J) = G**2*FAC*ME(1)*PCM
30165 210 CON = 4
30166 I2 = SP+2
30167 IF(MOD(K,2).EQ.1) I2 =I2+2
30168 HCS=HCS+MEC(L,GN,I,J)*DISF(I1,1)*DISF(J1,2)
30169 IF(GENEV.AND.HCS.GT.RCS) THEN
30170 CALL HWHRSS(3,I1,J1,K,I2,0,0)
30171 GOTO 900
30172 ENDIF
30173 HCS=HCS+MEC(L,GN,I,J)*DISF(J1,1)*DISF(I1,2)
30174 IF(GENEV.AND.HCS.GT.RCS) THEN
30175 CALL HWHRSS(4,J1,I1,K,I2,0,0)
30176 GOTO 900
30177 ENDIF
30178 HCS=HCS+MEC(L,GN,I,J)*DISF(I1+6,1)*DISF(J1+6,2)
30179 IF(GENEV.AND.HCS.GT.RCS) THEN
30180 CALL HWHRSS(3,I1,J1,K,I2+2,1,0)
30181 GOTO 900
30182 ENDIF
30183 HCS=HCS+MEC(L,GN,I,J)*DISF(J1+6,1)*DISF(I1+6,2)
30184 IF(GENEV.AND.HCS.GT.RCS) THEN
30185 CALL HWHRSS(4,J1,I1,K,I2+2,1,0)
30186 GOTO 900
30187 ENDIF
30188 220 CONTINUE
30189 ENDDO
30190 230 CONTINUE
30191 240 CONTINUE
30192C--Now the radiative decays, if possible
30193 300 IF(.NOT.RAD.OR.(CHAN(5).LT.EPS.AND.CHAN(11).LT.EPS)) GOTO 400
30194 IF(GENEV) GOTO 320
30195 DO 310 I=1,6
30196 310 MER(I)=ZERO
30197C--stop to light stop and Z
30198 IF(SH.GT.(MZ+MS(11))**2) THEN
30199 PCM = SQRT((SH-(MZ+MS(11))**2)*(SH-(MZ-MS(11))**2))*HALF/SQSH
30200 ECM=SQRT(PCM**2+MZ2)
30201 TH = MZ2-SQSH*(ECM-PCM*COSTH)
30202 UH = MZ2-SQSH*(ECM+PCM*COSTH)
30203 MER(3) = SH**2*PCM**2*(SCF(11)*ZSQU(2,1)**2*QMIXSS(6,2,1)**2
30204 & +SCF(12)*ZSQU(2,2)**2*QMIXSS(6,2,2)**2
30205 & +TWO*SCF(11)*SCF(12)*QMIXSS(6,2,1)*QMIXSS(6,2,2)*
30206 & ZSQU(2,1)*ZSQU(2,2)*((SH-MS2(11))*
30207 & (SH-MS2(12))+MSWD(11)*MSWD(12)))
30208 & +QMIXSS(6,2,1)**2/UH**2*ZQRK(1)**2*(
30209 & TWO*MZ2*(UH*TH-MS2(11)*MZ2)+UH**2*SH)
30210 & +QMIXSS(6,2,1)**2/TH**2*ZQRK(1)**2*(
30211 & TWO*MZ2*(UH*TH-MS2(11)*MZ2)+TH**2*SH)
30212 & +ZQRK(1)*SH*QMIXSS(6,2,1)*
30213 & (QMIXSS(6,2,1)*ZSQU(2,1)*(SH-MS2(11))*SCF(11)
30214 & +QMIXSS(6,2,2)*ZSQU(2,2)*(SH-MS2(12))*SCF(12))
30215 & *((MZ2*(TWO*MS2(11)-TH)+TH*(SH-MS2(11)))/TH
30216 & +(MZ2*(TWO*MS2(11)-UH)+UH*(SH-MS2(11)))/UH)
30217 & -TWO*QMIXSS(6,2,1)**2/UH/TH*ZQRK(1)**2*
30218 & (TWO*MZ2*(MS2(11)-UH)*(MS2(11)-TH)-SH*TH*UH)
30219 MER(3) = MER(3)*FOUR*PCM/MZ2
30220 ENDIF
30221C--sbottom to light sbottom and Z
30222 IF(SH.GT.(MZ+MS(5))**2) THEN
30223 PCM = SQRT((SH-(MZ+MS(5))**2)*(SH-(MZ-MS(5))**2))*HALF/SQSH
30224 ECM=SQRT(PCM**2+MZ2)
30225 TH = MZ2-SQSH*(ECM-PCM*COSTH)
30226 UH = MZ2-SQSH*(ECM+PCM*COSTH)
30227 MER(6) = SH**2*PCM**2*(SCF(5)*QMIXSS(5,2,1)**2*ZSQU(1,1)**2
30228 & +SCF(6)*QMIXSS(5,2,2)**2*ZSQU(1,2)**2
30229 & +TWO*SCF(5)*SCF(6)*QMIXSS(5,2,1)*QMIXSS(5,2,2)*
30230 & ZSQU(1,1)*ZSQU(1,2)*((SH-MS2(5))*
30231 & (SH-MS2(6))+MSWD(5)*MSWD(6)))
30232 & +QMIXSS(5,2,1)**2/UH**2*ZQRK(1)**2*
30233 & (TWO*MZ2*(UH*TH-MS2(5)*MZ2)+UH**2*SH)
30234 & +QMIXSS(5,2,1)**2/TH**2*ZQRK(2)**2*
30235 & (TWO*MZ2*(UH*TH-MS2(5)*MZ2)+TH**2*SH)
30236 & +QMIXSS(5,2,1)*SH*
30237 & (QMIXSS(5,2,1)*ZSQU(1,1)*(SH-MS2(5))*SCF(5)
30238 & +QMIXSS(5,2,2)*ZSQU(1,2)*(SH-MS2(6))*SCF(6))*
30239 & (ZQRK(1)/UH*(MZ2*(TWO*MS2(5)-UH)+(SH-MS2(5))*UH)
30240 & +ZQRK(2)/TH*(MZ2*(TWO*MS2(5)-TH)+(SH-MS2(5))*TH))
30241 & -TWO*QMIXSS(5,2,1)**2*ZQRK(1)*ZQRK(2)/UH/TH*
30242 & (TWO*MZ2*(MS2(5)-UH)*(MS2(5)-TH)-SH*TH*UH)
30243 MER(6) = MER(6)*FOUR*PCM/MZ2
30244 ENDIF
30245C--stop to sbottom and W
30246 DO J=1,2
30247 IF(SH.GT.(MW+MS(4+J))**2) THEN
30248 PCM =SQRT((SH-(MW+MS(4+J))**2)*(SH-(MW-MS(4+J))**2))*HALF/SQSH
30249C--diagram square pieces
30250 DO I=1,2
30251 MER(J)=MER(J)+SCF(10+I)*
30252 & (QMIXSS(6,2,I)*QMIXSS(6,1,I)*QMIXSS(5,1,J))**2
30253 ENDDO
30254C--light/heavy interference
30255 MER(J)=TWO*SH**2*PCM**3/MW2*(MER(J)+TWO*SCF(11)*SCF(12)*
30256 & ((SH-MS2(11))*(SH-MS2(12))
30257 & +MSWD(11)*MSWD(12))*QMIXSS(5,1,J)**2*
30258 & QMIXSS(6,2,1)*QMIXSS(6,2,2)*QMIXSS(6,1,1)*QMIXSS(6,1,2))
30259 ENDIF
30260C--sbottom to stop and W
30261 IF(SH.GT.(MW+MS(10+J))**2) THEN
30262 PCM=SQRT((SH-(MW+MS(10+J))**2)*(SH-(MW-MS(10+J))**2))*HALF/SQSH
30263C--diagram square pieces
30264 DO I=1,2
30265 MER(J+3)=MER(J+3)+SCF(4+I)*
30266 & (QMIXSS(5,2,I)*QMIXSS(5,1,I)*QMIXSS(6,1,J))**2
30267 ENDDO
30268C--light/heavy interference
30269 MER(J+3)=TWO*SH**2*PCM**3/MW2*(MER(J+3)+TWO*SCF(5)*SCF(6)*
30270 & ((SH-MS2(5))*(SH-MS2(6))+
30271 & MSWD(5)*MSWD(6))*QMIXSS(6,1,J)**2*
30272 & QMIXSS(5,2,1)*QMIXSS(5,2,2)*QMIXSS(5,1,1)*QMIXSS(5,1,2))
30273 ENDIF
30274 ENDDO
30275C--Now multiply by the parton distributions and phase space factors
30276 320 DO J=1,3
30277 DO K=1,3
30278 CON = 5
30279C--resonant stop's
30280 IF(ABS(LAMDA3(3,J,K)).GT.EPS.AND.J.LT.K) THEN
30281 FAC2 = LAMDA3(3,J,K)**2*FAC*G**2
30282 DO I=1,3
30283 I1=2*J-1
30284 J1=2*K-1
30285 ME2 = MER(I)*FAC2
30286 HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
30287 IF(GENEV.AND.HCS.GT.RCS) THEN
30288 CALL HWHRSS(5,I1,J1,I,I,0,0)
30289 GOTO 900
30290 ENDIF
30291 HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
30292 IF(GENEV.AND.HCS.GT.RCS) THEN
30293 CALL HWHRSS(6,J1,I1,I,I,0,0)
30294 GOTO 900
30295 ENDIF
30296 HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
30297 IF(GENEV.AND.HCS.GT.RCS) THEN
30298 CALL HWHRSS(5,I1,J1,I,I,1,0)
30299 GOTO 900
30300 ENDIF
30301 HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
30302 IF(GENEV.AND.HCS.GT.RCS) THEN
30303 CALL HWHRSS(6,J1,I1,I,I,1,0)
30304 GOTO 900
30305 ENDIF
30306 ENDDO
30307 ENDIF
30308C--resonant sbottom's
30309 IF(ABS(LAMDA3(J,K,3)).GT.EPS) THEN
30310 FAC2 = LAMDA3(J,K,3)**2*FAC*G**2
30311 DO I=4,6
30312 I1=2*J
30313 J1=2*K-1
30314 ME2 = MER(I)*FAC2
30315 HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
30316 IF(GENEV.AND.HCS.GT.RCS) THEN
30317 CALL HWHRSS(5,I1,J1,I,I,0,0)
30318 GOTO 900
30319 ENDIF
30320 HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
30321 IF(GENEV.AND.HCS.GT.RCS) THEN
30322 CALL HWHRSS(6,J1,I1,I,I,0,0)
30323 GOTO 900
30324 ENDIF
30325 HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
30326 IF(GENEV.AND.HCS.GT.RCS) THEN
30327 CALL HWHRSS(5,I1,J1,I,I,1,0)
30328 GOTO 900
30329 ENDIF
30330 HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
30331 IF(GENEV.AND.HCS.GT.RCS) THEN
30332 CALL HWHRSS(6,J1,I1,I,I,1,0)
30333 GOTO 900
30334 ENDIF
30335 ENDDO
30336 ENDIF
30337 ENDDO
30338 ENDDO
30339C--Now the Higgs decays if possible
30340 400 IF(.NOT.HIGGS) GOTO 900
30341 IF(GENEV) GOTO 490
30342 DO I=1,3
30343 DO 405 J=1,42
30344 405 MEH(I,J) = ZERO
30345 ENDDO
30346 DO I=1,3
30347 DO 420 J=1,3
30348C--Neutral Higgs down type squark
30349 IF(SQSH.LT.MH(J)+MS(2*I-1)) GOTO 410
30350 PCM = SQRT((SH-(MH(J)+MS(2*I-1))**2)*
30351 & (SH-(MH(J)-MS(2*I-1))**2))*HALF/SQSH
30352 ECM=SQRT(PCM**2+MH(J)**2)
30353 TH = MH(J)**2-SQSH*(ECM-PCM*COSTH)
30354 UH = MH(J)**2-SQSH*(ECM+PCM*COSTH)
30355 MEH(1,3*I-3+J) = PCM*SH*(
30356 & QMIXSS(2*I-1,2,1)**2*SCF(2*I-1)*GHSQSS(J,2*I-1,1,1)**2
30357 & +QMIXSS(2*I-1,2,2)**2*SCF(2*I)*GHSQSS(J,2*I-1,2,1)**2
30358 & +TWO*QMIXSS(2*I-1,2,1)*QMIXSS(2*I-1,2,2)*SCF(2*I-1)
30359 & *SCF(2*I)*GHSQSS(J,2*I-1,1,1)*GHSQSS(J,2*I-1,2,1)*
30360 & ((SH-MS2(2*I-1))*(SH-MS2(2*I))+MSWD(2*I-1)*MSWD(2*I)))
30361 MEH(2,3*I-3+J) = PCM*GUU(J)*QMIXSS(2*I,2,1)**2/TH**2*
30362 & (TH*UH-MH(J)**2*MS2(2*I-1))
30363 MEH(3,3*I-3+J) = PCM*GDD(J)*QMIXSS(2*I,2,1)**2/UH**2*
30364 & (TH*UH-MH(J)**2*MS2(2*I-1))
30365C--Neutral Higgs up type squarks
30366 410 IF(SQSH.LT.MH(J)+MS(2*I+5)) GOTO 420
30367 PCM = SQRT((SH-(MH(J)+MS(2*I+5))**2)*
30368 & (SH-(MH(J)-MS(2*I+5))**2))*HALF/SQSH
30369 ECM=SQRT(PCM**2+MH(J)**2)
30370 TH = MH(J)**2-SQSH*(ECM-PCM*COSTH)
30371 UH = MH(J)**2-SQSH*(ECM+PCM*COSTH)
30372 MEH(1,3*I+6+J) = PCM*SH*(
30373 & QMIXSS(2*I,2,1)**2*SCF(2*I+5)*GHSQSS(J,2*I,1,1)**2
30374 & +QMIXSS(2*I,2,2)**2*SCF(2*I+6)*GHSQSS(J,2*I,2,1)**2
30375 & +TWO*QMIXSS(2*I,2,1)*QMIXSS(2*I,2,2)*SCF(2*I+5)
30376 & *SCF(2*I+6)*GHSQSS(J,2*I,1,1)*GHSQSS(J,2*I,2,1)*
30377 & ((SH-MS2(2*I+5))*(SH-MS2(2*I+6))+
30378 & MSWD(2*I+5)*MSWD(2*I+6)))
30379 MEH(2,3*I+6+J) = PCM*GDD(J)*QMIXSS(2*I-1,2,1)**2/TH**2*
30380 & (TH*UH-MH(J)**2*MS2(2*I+5))
30381 MEH(3,3*I+6+J) = PCM*GDD(J)*QMIXSS(2*I-1,2,1)**2/UH**2*
30382 & (TH*UH-MH(J)**2*MS2(2*I+5))
30383 420 CONTINUE
30384C--Charged Higgs up type squark
30385 DO 440 J=1,2
30386 IF(SQSH.LT.MH(4)+MS(2*I+4+J)) GOTO 430
30387 PCM = SQRT((SH-(MH(4)+MS(2*I+4+J))**2)*
30388 & (SH-(MH(4)-MS(2*I+4+J))**2))*HALF/SQSH
30389 ECM=SQRT(PCM**2+MH(4)**2)
30390 TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
30391 UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
30392 MEH(1,4*I+14+J) = PCM*SH*(
30393 & QMIXSS(2*I-1,2,1)**2*GHSQSS(4,2*I,J,1)**2*SCF(2*I-1)
30394 & +QMIXSS(2*I-1,2,2)**2*GHSQSS(4,2*I,J,2)**2*SCF(2*I)
30395 & +TWO*QMIXSS(2*I-1,2,1)*QMIXSS(2*I-1,2,2)*SCF(2*I-1)
30396 & *SCF(2*I)*GHSQSS(4,2*I,J,1)*GHSQSS(4,2*I,J,2)*
30397 & ((SH-MS2(2*I-1))*(SH-MS2(2*I))+
30398 & MSWD(2*I-1)*MSWD(2*I)))
30399 MEH(2,4*I+14+J) = PCM*QMIXSS(2*I,2,J)**2*GDD(4)/TH**2*
30400 & (UH*TH-MS2(2*I+4+J)*MH(4)**2)
30401C--Charged Higgs down type squark
30402 430 IF(SQSH.LT.MH(4)+MS(2*I-2+J)) GOTO 440
30403 PCM = SQRT((SH-(MH(4)+MS(2*I-2+J))**2)*
30404 & (SH-(MH(4)-MS(2*I-2+J))**2))*HALF/SQSH
30405 ECM=SQRT(PCM**2+MH(4)**2)
30406 TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
30407 UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
30408 MEH(1,4*I+16+J) = PCM*SH*(
30409 & QMIXSS(2*I,2,1)**2*GHSQSS(4,2*I-1,J,1)**2*SCF(2*I+5)
30410 & +QMIXSS(2*I,2,2)**2*GHSQSS(4,2*I-1,J,2)**2*SCF(2*I+6)
30411 & +TWO*QMIXSS(2*I,2,1)*QMIXSS(2*I,2,2)*SCF(2*I+5)
30412 & *SCF(2*I+6)*GHSQSS(4,2*I-1,J,1)*GHSQSS(4,2*I-1,J,2)*
30413 & ((SH-MS2(2*I+5))*(SH-MS2(2*I+6))+
30414 & MSWD(2*I+5)*MSWD(2*I+6)))
30415 MEH(2,4*I+16+J) = PCM*QMIXSS(2*I-1,2,J)**2*GUU(4)/TH**2*
30416 & (UH*TH-MS2(2*I-2+J)*MH(4)**2)
30417 MEH(3,4*I+16+J) = PCM*QMIXSS(2*I-1,2,J)**2*GUU(4)/UH**2*
30418 & (UH*TH-MS2(2*I-2+J)*MH(4)**2)
30419 440 CONTINUE
30420 ENDDO
30421 490 DO I=1,3
30422 DO J=1,3
30423 DO K=1,3
30424 CON = 5
30425 DO L=1,3
30426 IF(ABS(LAMDA3(J,K,I)).GT.EPS) THEN
30427C--neutral higgs and sdown
30428 FAC2 = FAC*G**2*LAMDA3(J,K,I)**2
30429 I1=2*J
30430 J1=2*K-1
30431 ME2 = FAC2*(MEH(1,3*I-3+L)+RMASS(I1)**2*MEH(2,3*I-3+L)
30432 & +RMASS(J1)**2*MEH(3,3*I-3+L))
30433 HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
30434 IF(GENEV.AND.HCS.GT.RCS) THEN
30435 CALL HWHRSS(7,I1,J1,L,2*I-1,0,0)
30436 GOTO 900
30437 ENDIF
30438 HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
30439 IF(GENEV.AND.HCS.GT.RCS) THEN
30440 CALL HWHRSS(8,J1,I1,L,2*I-1,0,0)
30441 GOTO 900
30442 ENDIF
30443 IF(I2.NE.200) I2=198
30444 HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
30445 IF(GENEV.AND.HCS.GT.RCS) THEN
30446 CALL HWHRSS(7,I1,J1,L,2*I-1,1,0)
30447 GOTO 900
30448 ENDIF
30449 HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
30450 IF(GENEV.AND.HCS.GT.RCS) THEN
30451 CALL HWHRSS(8,J1,I1,L,2*I-1,1,0)
30452 GOTO 900
30453 ENDIF
30454 ENDIF
30455 IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) THEN
30456 FAC2 = FAC*G**2*LAMDA3(I,J,K)**2
30457C--neutral higgs and sup
30458 I1=2*J-1
30459 J1=2*K-1
30460 ME2 = FAC2*(MEH(1,3*I+6+L)+RMASS(I1)**2*MEH(2,3*I+6+L)
30461 & +RMASS(J1)**2*MEH(3,3*I+6+L))
30462 HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
30463 IF(GENEV.AND.HCS.GT.RCS) THEN
30464 CALL HWHRSS(7,I1,J1,L,2*I+5,0,0)
30465 GOTO 900
30466 ENDIF
30467 HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
30468 IF(GENEV.AND.HCS.GT.RCS) THEN
30469 CALL HWHRSS(8,J1,I1,L,2*I+5,0,0)
30470 GOTO 900
30471 ENDIF
30472 HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
30473 IF(GENEV.AND.HCS.GT.RCS) THEN
30474 CALL HWHRSS(7,I1,J1,L,2*I+5,1,0)
30475 GOTO 900
30476 ENDIF
30477 HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
30478 IF(GENEV.AND.HCS.GT.RCS) THEN
30479 CALL HWHRSS(8,J1,I1,L,2*I+5,1,0)
30480 GOTO 900
30481 ENDIF
30482 ENDIF
30483 ENDDO
30484 DO L=1,2
30485 IF(ABS(LAMDA3(J,K,I)).GT.EPS) THEN
30486C--charged higgs and sup
30487 I1=2*J
30488 J1=2*K-1
30489 FAC2 = FAC*G**2
30490 ME2 = FAC2*(LAMDA3(J,K,I)**2*MEH(1,4*I+L+14)
30491 & +LAMDA3(I,J,K)**2*RMASS(I1-1)**2*MEH(2,4*I+L+14))
30492 HCS= HCS+ME2*DISF(I1,1)*DISF(J1,2)
30493 IF(GENEV.AND.HCS.GT.RCS) THEN
30494 CALL HWHRSS(7,I1,J1,4,2*I+4+L,0,0)
30495 GOTO 900
30496 ENDIF
30497 HCS= HCS+ME2*DISF(J1,1)*DISF(I1,2)
30498 IF(GENEV.AND.HCS.GT.RCS) THEN
30499 CALL HWHRSS(8,J1,I1,4,2*I+4+L,0,0)
30500 GOTO 900
30501 ENDIF
30502 HCS= HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
30503 IF(GENEV.AND.HCS.GT.RCS) THEN
30504 CALL HWHRSS(7,I1,J1,5,2*I+4+L,1,0)
30505 GOTO 900
30506 ENDIF
30507 HCS= HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
30508 IF(GENEV.AND.HCS.GT.RCS) THEN
30509 CALL HWHRSS(8,J1,I1,5,2*I+4+L,1,0)
30510 GOTO 900
30511 ENDIF
30512 ENDIF
30513C--charged higgs and sdown
30514 IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) THEN
30515 I1=2*J-1
30516 J1=2*K-1
30517 FAC2 = FAC*G**2
30518 ME2 = FAC2*(MEH(1,4*I+L+16)*LAMDA3(I,J,K)**2
30519 & +RMASS(I1+1)**2*LAMDA3(J,I,K)**2*MEH(2,4*I+L+16)
30520 & +RMASS(J1+1)**2*LAMDA3(K,I,J)**2*MEH(3,4*I+L+16))
30521 HCS=HCS+ME2*DISF(I1,1)*DISF(J1,2)
30522 IF(GENEV.AND.HCS.GT.RCS) THEN
30523 CALL HWHRSS(7,I1,J1,5,2*I-2+L,0,0)
30524 GOTO 900
30525 ENDIF
30526 HCS=HCS+ME2*DISF(J1,1)*DISF(I1,2)
30527 IF(GENEV.AND.HCS.GT.RCS) THEN
30528 CALL HWHRSS(8,J1,I1,5,2*I-2+L,0,0)
30529 GOTO 900
30530 ENDIF
30531 HCS=HCS+ME2*DISF(I1+6,1)*DISF(J1+6,2)
30532 IF(GENEV.AND.HCS.GT.RCS) THEN
30533 CALL HWHRSS(7,I1,J1,4,2*I-2+L,1,0)
30534 GOTO 900
30535 ENDIF
30536 HCS=HCS+ME2*DISF(J1+6,1)*DISF(I1+6,2)
30537 IF(GENEV.AND.HCS.GT.RCS) THEN
30538 CALL HWHRSS(8,J1,I1,4,2*I-2+L,1,0)
30539 GOTO 900
30540 ENDIF
30541 ENDIF
30542 ENDDO
30543 ENDDO
30544 ENDDO
30545 ENDDO
30546C--calculate of the matrix elements
30547 900 IF(GENEV) THEN
30548 CALL HWETWO(.TRUE.,.TRUE.)
30549 IF(IERROR.NE.0) RETURN
30550 HVFCEN = .TRUE.
30551C--first stage of the colour connection corrections
30552 DO THEP=1,5
30553 IF(THEP.NE.3) THEN
30554 JMOHEP(2,THEP+NHEP-5)=NHEP-5+THEP
30555 & +CONECT(HWRINT(1,2),THEP,CON)
30556 JDAHEP(2,THEP+NHEP-5) = JMOHEP(2,THEP+NHEP-5)
30557 ENDIF
30558 ENDDO
30559 IF(IDHEP(NHEP-4).LT.0) THEN
30560 JDAHEP(2,NHEP-4)=NHEP-1
30561 JDAHEP(2,NHEP-3)=NHEP-3
30562 JDAHEP(2,NHEP-1)=NHEP-4
30563 IF(CON.EQ.5) JDAHEP(2,NHEP-4)=NHEP
30564 JDAHEP(2,NHEP)=CONECT(1,6,CON)+NHEP
30565 ELSE
30566 JMOHEP(2,NHEP-4)=NHEP-1
30567 JMOHEP(2,NHEP-3)=NHEP-3
30568 JMOHEP(2,NHEP-1)=NHEP-4
30569 IF(CON.EQ.5) JMOHEP(2,NHEP-4)=NHEP
30570 JMOHEP(2,NHEP)=CONECT(1,6,CON)+NHEP
30571 ENDIF
30572 IF(CON.EQ.5) THEN
30573 SP=JDAHEP(2,NHEP)
30574 JDAHEP(2,NHEP) = JDAHEP(2,NHEP-1)
30575 JDAHEP(2,NHEP-1) = SP
30576 SP=JMOHEP(2,NHEP)
30577 JMOHEP(2,NHEP) = JMOHEP(2,NHEP-1)
30578 JMOHEP(2,NHEP-1) = SP
30579 ENDIF
30580 HRDCOL(1,1) = NHEP
30581 HRDCOL(1,2) = NHEP-2
30582 ELSE
30583 EVWGT = HCS
30584 ENDIF
30585 END
30586CDECK ID>, HWHREE.
30587*CMZ :- -05/04/02 15:40:41 by Peter Richardson
30588*-- Author : Peter Richardson
30589C-----------------------------------------------------------------------
30590 SUBROUTINE HWHREE
30591C-----------------------------------------------------------------------
30592C SUSY E+E- --> SM PARTICLES VIA RPV
30593C MODIFIED TO INCLUDE BEAM POLARIZATION EFFECTS BY PETER RICHARDSON
30594C-----------------------------------------------------------------------
c63d70bc 30595 INCLUDE 'herwig65.inc'
65767955 30596 DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,HWUMBW,HWUAEM,HCS,RCS,FACA,
30597 & S,T,PCM,MQ1,MQ2,SP,TP,TPZ,TPN,TPN2,MSL2(3),MZ,
30598 & MZ2,MSU2(3,2),MWD(3),GL,GR,GLP,GRP,EC,EE,THTMIN,
30599 & MIX(3,2),CFAC,LAM(4,3,3,3,3,3),MET,ME(2,3,3)
30600 DOUBLE COMPLEX FSLL,FSLR,FSRL,FSRR,FTLL,FTLR,FTRL,FTRR,Z,Z0,GZ,
30601 & SCF(3)
30602 INTEGER I,IHEP,RSID(2),IL,GN,J,K,L,GNMN,GNMX,K1,L1,NTRY,GNR,FID(2)
30603 SAVE HCS,MSL2,MWD,LAM,ME,GL,GR,MZ,MZ2,MSU2,MIX,GNMN,GNMX,IL,RSID,
30604 & FID
30605 EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUMBW,HWUAEM
30606 PARAMETER(Z=(0.D0,1.D0),Z0=(0.D0,0.D0))
30607C--Start of the code
30608 IF(GENEV) THEN
30609 RCS = HCS*HWRGEN(0)
30610 ELSE
30611 IF(FSTWGT) THEN
30612C--identify the beam particles
30613 IF(ABS(IDHEP(1)).EQ.11) THEN
30614C--electron beams
30615 RSID(1) = 2
30616 IL = 1
30617 ELSEIF(ABS(IDHEP(1)).EQ.13) THEN
30618C--muon beams
30619 RSID(1) = 1
30620 IL = 2
30621C--unrecognized beam particles issue warning
30622 ELSE
30623 CALL HWWARN('HWHREE',500)
30624 ENDIF
30625 RSID(2) = 3
30626C--masses of the sleptons
30627 DO I=1,3
30628 MSL2(I) = RMASS(424+2*I)
30629 MWD(I) = MSL2(I)*HBAR/RLTIM(424+2*I)
30630 MSL2(I) = MSL2(I)**2
30631 ENDDO
30632C--masses and mixings of the t channel squarks
30633 DO I=1,3
30634 MSU2(I,1) = RMASS(400+2*I)
30635 MSU2(I,2) = RMASS(412+2*I)
30636 DO J=1,2
30637 MIX(I,J) = QMIXSS(2*I,1,J)**2
30638 MSU2(I,J) = MSU2(I,J)**2
30639 ENDDO
30640 ENDDO
30641C--Z mass
30642 MZ = RMASS(200)
30643 MZ2 = MZ**2
30644C--find the couplings
30645 DO GN=1,3
30646 DO I=1,3
30647 DO J=1,3
30648 DO K=1,3
30649 DO L=1,3
30650 LAM(1,GN,I,J,K,L) = LAMDA1(GN,I,J)*LAMDA1(GN,K,L)
30651 LAM(2,GN,I,J,K,L) = LAMDA1(GN,I,J)*LAMDA2(GN,K,L)
30652 LAM(3,GN,I,J,K,L) = LAM(1,GN,I,J,K,L)
30653 LAM(4,GN,I,J,K,L) = LAMDA2(I,GN,J)*LAMDA2(K,GN,L)
30654 ENDDO
30655 ENDDO
30656 ENDDO
30657 ENDDO
30658 ENDDO
30659C--Z couplings
30660 GL = LFCH(11)
30661 GR = RFCH(11)
30662C--select the process from the IPROC code
30663 IF(IPROC.EQ.860) THEN
30664 GNMN = 1
30665 GNMX = 2
30666 FID(1) = 0
30667 FID(2) = 0
30668 ELSEIF(IPROC.GE.870.AND.IPROC.LT.890) THEN
30669 J = MOD(IPROC,10)
30670 IF(MOD(IPROC,10).EQ.0) THEN
30671 FID(1) = 0
30672 FID(2) = 0
30673 ELSE
30674 FID(1) = MOD(J-1,3)+1
30675 FID(2) = INT((J-1)/3)+1
30676 ENDIF
30677 IF(IPROC.LT.880) THEN
30678 GNMN = 1
30679 ELSE
30680 GNMN = 2
30681 ENDIF
30682 GNMX = GNMN
30683 ELSE
30684 CALL HWWARN('HWHREE',501)
30685 ENDIF
30686 ENDIF
30687C--calculate the kinematic varibles
30688 EVWGT = ZERO
30689 S = PHEP(5,3)**2
30690 THTMIN = ONE-FOUR*PTMIN**2/S
30691 IF(THTMIN.LT.ZERO) CALL HWWARN('HWHREE',502)
30692 THTMIN = SQRT(THTMIN)
30693 COSTH = HWRUNI(0,-THTMIN,THTMIN)
30694 EMSCA = PHEP(5,3)
30695 GZ = ONE/(S-MZ**2+Z*MZ*GAMZ)
30696 EE = HWUAEM(S)
30697 FACA = GEV2NB*EE**2*PIFAC*S/FOUR
30698 EE = 0.25D0/EE/PIFAC
30699 SP = ONE/S
30700 T = -HALF*S*(ONE-COSTH)
30701 TP = ONE/T
30702 TPZ = ONE/(T-MZ2)
30703C--Calculate the prefactor due multichannel approach
30704 DO GN=1,3
30705 IF(GN.EQ.RSID(1).OR.GN.EQ.RSID(2)) THEN
30706 SCF(GN)= ONE/(S-MSL2(GN)+Z*MWD(GN))
30707 ELSE
30708 SCF(GN) = Z0
30709 ENDIF
30710 ENDDO
30711 ENDIF
30712C--Now the loop to actually calculate the cross sections
30713 HCS = ZERO
30714 DO GN=GNMN,GNMX
30715 GNR = GN+2
30716 DO K1=1,3
30717 DO 80 L1=1,3
30718 IF(FID(1).NE.0.AND.(FID(1).NE.K1.OR.FID(2).NE.L1).AND.
30719 & (FID(1).NE.L1.OR.FID(2).NE.K1)) GOTO 80
30720 IF(GN.EQ.1) THEN
30721 K = 119+2*K1
30722 L = 125+2*L1
30723 GLP = GL
30724 GRP = GR
30725 EC = ONE
30726 CFAC = ONE
30727 ELSEIF(GN.EQ.2) THEN
30728 K = 2*K1-1
30729 L = 2*L1+5
30730 GLP = LFCH(K)
30731 GRP = RFCH(K)
30732 EC = ONE/THREE
30733 CFAC = THREE
30734 ENDIF
30735 MQ1 = RMASS(K)
30736 MQ2 = RMASS(L)
30737 IF(EMSCA.LT.(MQ1+MQ2)) GOTO 80
30738 MET = ZERO
30739 IF(GENEV) GOTO 60
30740C--calculate the matrix element
30741C--set all coefficents to zero
30742 FSLL = Z0
30743 FSLR = Z0
30744 FSRL = Z0
30745 FSRR = Z0
30746 FTLL = Z0
30747 FTLR = Z0
30748 FTRL = Z0
30749 FTRR = Z0
30750C--Standard Model terms
30751 IF(K1.EQ.L1) THEN
30752C--first if same flavour pair production
30753 FSLL = EC*SP+GL*GRP*GZ
30754 FSLR = EC*SP+GL*GLP*GZ
30755 FSRL = EC*SP+GR*GRP*GZ
30756 FSRR = EC*SP+GR*GLP*GZ
30757C--t channel terms if e+e- --> e+e-
30758 IF(K1.EQ.IL.AND.GN.EQ.1) THEN
30759 FTLL = TP+GL*GR*TPZ
30760 FTLR = TP+GL**2*TPZ
30761 FTRL = TP+GR**2*TPZ
30762 FTRR = TP+GL*GR*TPZ
30763 ENDIF
30764 ENDIF
30765C--Now add the RPV terms
30766 DO I=1,3
30767 IF(GN.EQ.1) THEN
30768 TPN = ONE/(T-MSL2(I))
30769 TPN2 = TPN
30770 ELSE
30771 TPN = MIX(I,1)/(T-MSU2(I,1))+ MIX(I,2)/(T-MSU2(I,2))
30772 TPN2 = ZERO
30773 ENDIF
30774 FSLL = FSLL+HALF*LAM(GNR,I,IL,K1,IL,L1)*EE*TPN
30775 FSRR = FSRR+HALF*LAM(GNR,I,K1,IL,L1,IL)*EE*TPN2
30776 FTLL = FTLL+HALF*LAM(GN,I,IL,IL,K1,L1)*EE*SCF(I)
30777 FTRR = FTRR+HALF*LAM(GN,I,IL,IL,L1,K1)*EE*SCF(I)
30778 ENDDO
30779C--now calculate the matrix element (including beam polarization)
30780 MET =(ONE+COSTH)**2*DREAL(
30781 & DCONJG(FSLR)*FSLR*(ONE-EPOLN(3))*(ONE+PPOLN(3))
30782 & +DCONJG(FSRL)*FSRL*(ONE+EPOLN(3))*(ONE-PPOLN(3))
30783 & +DCONJG(FTLR)*FTLR*(ONE-EPOLN(3))*(ONE+PPOLN(3))
30784 & +DCONJG(FTRL)*FTRL*(ONE+EPOLN(3))*(ONE-PPOLN(3))
30785 & +TWO*FTLR*DCONJG(FSLR)*(ONE-EPOLN(3))*(ONE+PPOLN(3))
30786 & +TWO*FTRL*DCONJG(FSRL)*(ONE+EPOLN(3))*(ONE-PPOLN(3)))
30787 & +(ONE-COSTH)**2*DREAL(
30788 & DCONJG(FSLL)*FSLL*(ONE-EPOLN(3))*(ONE+PPOLN(3))
30789 & +DCONJG(FSRR)*FSRR*(ONE+EPOLN(3))*(ONE-PPOLN(3)))
30790 & +FOUR*DREAL(
30791 & DCONJG(FTLL)*FTLL*(ONE+EPOLN(3))*(ONE+PPOLN(3))
30792 & +DCONJG(FTRR)*FTRR*(ONE-EPOLN(3))*(ONE-PPOLN(3)))
30793C--final phase space factors
30794 ME(GN,K1,L1) = MET*CFAC*FACA*THTMIN
30795 60 HCS = HCS+ME(GN,K1,L1)
30796 IF(HCS.GT.RCS.AND.GENEV) GOTO 900
30797 80 CONTINUE
30798 ENDDO
30799 ENDDO
30800 900 IF(GENEV) THEN
30801C--change sign of COSTH if antiparticle first
30802 IF(IDHEP(1).LT.IDHEP(2)) COSTH = -COSTH
30803C-Set up the particle types
30804 IDHW(NHEP+1) = 15
30805 IDHEP(NHEP+1) = 0
30806 ISTHEP(NHEP+1) = 110
30807 IDHW(NHEP+2) = K
30808 IDHW(NHEP+3) = L
30809 IDHEP(NHEP+2) = IDPDG(K)
30810 IDHEP(NHEP+3) = IDPDG(L)
30811C--Select the masses of the particles and the final-state momenta
30812 910 NTRY = NTRY+1
30813 PHEP(5,NHEP+2) = HWUMBW(K)
30814 PHEP(5,NHEP+3) = HWUMBW(L)
30815 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
30816 PCM = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
30817 IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
30818 GOTO 910
30819 ELSEIF(PCM.LT.ZERO) THEN
30820 CALL HWWARN('HWHREE',100)
30821 GOTO 999
30822 ENDIF
30823C--Set up the colours etc
30824 ISTHEP(NHEP+2) = 113
30825 ISTHEP(NHEP+3) = 114
30826 JMOHEP(1,NHEP+1) = 1
30827 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
30828 JMOHEP(2,NHEP+1) = 2
30829 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
30830 JMOHEP(1,NHEP+2) = NHEP+1
30831 JMOHEP(2,NHEP+2) = NHEP+3
30832 JMOHEP(1,NHEP+3) = NHEP+1
30833 JMOHEP(2,NHEP+3) = NHEP+2
30834 JDAHEP(1,NHEP+1) = NHEP+2
30835 JDAHEP(2,NHEP+1) = NHEP+3
30836 JDAHEP(1,NHEP+2) = 0
30837 JDAHEP(2,NHEP+2) = NHEP+3
30838 JDAHEP(1,NHEP+3) = 0
30839 JDAHEP(2,NHEP+3) = NHEP+2
30840C--Set up the momenta
30841 IHEP = NHEP+2
30842 PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
30843 PHEP(3,IHEP) = PCM*COSTH
30844 PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
30845 PHEP(2,IHEP) = ZERO
30846 CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
30847 CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
30848 CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
30849 NHEP = NHEP+3
30850 ELSE
30851 EVWGT = HCS
30852 ENDIF
30853 999 RETURN
30854 END
30855CDECK ID>, HWHREM.
30856*CMZ :- -01/06/94 17.03.31 by Mike Seymour
30857*-- Author : Mike Seymour
30858C-----------------------------------------------------------------------
30859 SUBROUTINE HWHREM(IBEAM,ITARG)
30860C-----------------------------------------------------------------------
30861C IDENTIFY THE REMNANTS OF THE HARD SCATTERING
30862C AND BREAK THEIR COLOUR CONNECTION IF NECESSARY
30863C-----------------------------------------------------------------------
c63d70bc 30864 INCLUDE 'herwig65.inc'
65767955 30865 DOUBLE PRECISION PCL(5),
30866 $ P1P2,P1SQ,P2SQ,S,M1SQ,M2SQ,TMP1,TMP2,A,B,C,D,PTOT(4),HWULDO
30867 INTEGER IBEAM,ITARG,IHEP,NTEMP,I,ICOL,IANT
30868 LOGICAL LTEMP,T,COL,ANT
30869 PARAMETER (T=.TRUE.)
30870 COL(I)=I.EQ.13 .OR. I.GE.1.AND.I.LE.6 .OR. I.GE.115.AND.I.LE.120
30871 ANT(I)=I.EQ.13 .OR. I.GE.7.AND.I.LE.12.OR. I.GE.109.AND.I.LE.114
30872C---LOOK FOR UNTREATED BEAM AND TARGET REMNANTS
30873 IBEAM=0
30874 ITARG=0
30875 DO 10 IHEP=1,NHEP
30876 IF (ISTHEP(IHEP).EQ.148) THEN
30877 IF (ITARG.NE.0) THEN
30878 CALL HWWARN('HWHREM',100)
30879 GOTO 999
30880 ENDIF
30881 ITARG=IHEP
30882 ELSEIF (ISTHEP(IHEP).EQ.147) THEN
30883 IF (IBEAM.NE.0) THEN
30884 CALL HWWARN('HWHREM',101)
30885 GOTO 999
30886 ENDIF
30887 IBEAM=IHEP
30888 ENDIF
30889 10 CONTINUE
30890 IF (ITARG.EQ.0) THEN
30891 CALL HWWARN('HWHREM',102)
30892 GOTO 999
30893 ENDIF
30894 IF (IBEAM.EQ.0) THEN
30895 CALL HWWARN('HWHREM',103)
30896 GOTO 999
30897 ENDIF
30898C---MHS FIX TO PREVENT MOMENTUM VIOLATION DUE TO OFF-SHELL BEAM REMNANTS
30899C---FIND REMNANT MOMENTA AND MASSES
30900 P1P2=HWULDO(PHEP(1,IBEAM),PHEP(1,ITARG))
30901 P1SQ=HWULDO(PHEP(1,IBEAM),PHEP(1,IBEAM))
30902 P2SQ=HWULDO(PHEP(1,ITARG),PHEP(1,ITARG))
30903 S=P1SQ+2*P1P2+P2SQ
30904 TMP1=P1P2**2-P1SQ*P2SQ
30905 IF (TMP1.LE.0) THEN
30906 CALL HWWARN('HWHREM',104)
30907 GOTO 999
30908 ENDIF
30909 TMP1=SQRT(TMP1)
30910 M1SQ=RMASS(IDHW(IBEAM))**2
30911 M2SQ=RMASS(IDHW(ITARG))**2
30912 TMP2=(S-M1SQ-M2SQ)**2-4*M1SQ*M2SQ
30913 IF (TMP2.LE.0) THEN
30914 CALL HWWARN('HWHREM',105)
30915 GOTO 999
30916 ENDIF
30917 TMP2=SQRT(TMP2)
30918C---EXCHANGE A LITTLE MOMENTUM TO PUT THEM BOTH ON MASS-SHELL
30919 A=(1-(P1P2+P2SQ)/TMP1)/2
30920 B=(1-(P1P2+P1SQ)/TMP1)/2
30921 C=(S-M1SQ+M2SQ-TMP2)/(2*S)
30922 D=(S+M1SQ-M2SQ-TMP2)/(2*S)
30923 CALL HWVSUM(4,PHEP(1,IBEAM),PHEP(1,ITARG),PTOT)
30924 CALL HWVSCA(4,(1-A)*(1-C)+A*D,PHEP(1,IBEAM),PHEP(1,IBEAM))
30925 CALL HWVSCA(4,B*(1-C)+(1-B)*D,PHEP(1,ITARG),PHEP(1,ITARG))
30926 CALL HWVSUM(4,PHEP(1,IBEAM),PHEP(1,ITARG),PHEP(1,IBEAM))
30927 CALL HWVDIF(4,PTOT,PHEP(1,IBEAM),PHEP(1,ITARG))
30928 CALL HWUMAS(PHEP(1,IBEAM))
30929 CALL HWUMAS(PHEP(1,ITARG))
30930C---END MHS FIX
30931C---IF THEY ARE COLOUR CONNECTED, DISCONNECT THEM BY EMITTING A SOFT
30932C GLUON AND SPLITTING THAT GLUON TO LIGHT QUARKS
30933C (WHICH NORMALLY GETS DONE AS THE FIRST STAGE OF CLUSTER FORMATION)
30934C---LOOP OVER COLOUR/ANTICOLOUR LINE
30935 DO 20 I=1,2
30936 IF (I.EQ.1) THEN
30937 ICOL=IBEAM
30938 IANT=ITARG
30939 ELSE
30940 ICOL=ITARG
30941 IANT=IBEAM
30942 ENDIF
30943 IF (COL(IDHW(ICOL)).AND.ANT(IDHW(IANT)).AND.
30944 $ JMOHEP(2,ICOL).EQ.IANT.AND.JDAHEP(2,IANT).EQ.ICOL) THEN
30945 CALL HWVSUM(4,PHEP(1,ICOL),PHEP(1,IANT),PCL)
30946 CALL HWUMAS(PCL)
30947 NTEMP=NHEP
30948 CALL HWCCUT(ICOL,IANT,PCL,T,LTEMP)
30949 IF (IERROR.NE.0) RETURN
30950C---IF NOTHING WAS CREATED THEY MUST BE BELOW THRESHOLD, SO GIVE UP
30951 IF (NHEP.NE.NTEMP+2) RETURN
30952C---RELABEL THEM AS PERTUBATIVE JUST TO NEATEN UP THE EVENT RECORD
30953 ISTHEP(NHEP-1)=149
30954 ISTHEP(NHEP)=149
30955 ENDIF
30956 20 CONTINUE
30957 999 RETURN
30958 END
30959CDECK ID>, HWHREP.
30960*CMZ :- -18/10/00 13:46:47 by Peter Richardson
30961*-- Author : Peter Richardson
30962C-----------------------------------------------------------------------
30963 SUBROUTINE HWHREP
30964C-----------------------------------------------------------------------
30965C SUSY E+E- RPV PRODUCTION
30966C-----------------------------------------------------------------------
c63d70bc 30967 INCLUDE 'herwig65.inc'
65767955 30968 IF(IPROC.GE.800.AND.IPROC.LE.850) THEN
30969 CALL HWHRES
30970 ELSEIF(IPROC.GE.860.AND.IPROC.LT.890) THEN
30971 CALL HWHREE
30972C---UNRECOGNIZED PROCESS
30973 ELSE
30974 CALL HWWARN('HWHREP',500)
30975 ENDIF
30976 END
30977CDECK ID>, HWHRES.
30978*CMZ :- -07/04/02 10:38:51 by Peter Richardson
30979*-- Author : Peter Richardson
30980C-----------------------------------------------------------------------
30981 SUBROUTINE HWHRES
30982C-----------------------------------------------------------------------
30983C SUSY E+E- --> RPV SINGLE SPARTICLE PRODUCTION
30984C POLARZATION EFFECTS ADDED 5/4/02 BY PETER RICHARDSON
30985C-----------------------------------------------------------------------
c63d70bc 30986 INCLUDE 'herwig65.inc'
65767955 30987 DOUBLE PRECISION HWRGEN,HWUAEM,HWRUNI,HWUPCM,HWUMBW,HCS,RCS,FACA,
30988 & FACB,FACC,FACD,FACE,M1(4,4),M2(2,4),M3(8,2),
30989 & MW,MZ,MSCL(2,2),MSCL2(2,2),MZ2,MSL2,MSR2,MSNU2,
30990 & MW2,MCH(2),MCH2(2),MNU(4),MNU2(4),MLT(3),MLT2(3),
30991 & MNUT(2),MNUT2(2),RMNUT(2),S,U,T,QPE,SQPE,SM,DM,
30992 & PF,PCM,SCF(2),UP,TP,MH(4),MH2(4),THCOS(2),THTMIN,
30993 & A(6,4),B(6,4),SW,CW,MC,SIN2B,ZNU,RHO,HSL(2,2),
30994 & HL(4),M4(10,2),HNU(3)
30995 INTEGER I,SSNU,NTID(2),CHID(2),IG1,IG2,IHEP,SSCH,ISL,ISR,NTRY,
30996 & ISN,IDL,J,L,RSID(2),K,L2,IL,IDZ,RADID(2,8),GMIN,GMAX
30997 LOGICAL NEUT,CHAR,RAD,HIGGS,THSGN
30998 SAVE HCS,M1,M2,M3,M4,SW,CW,MW,MZ,MW2,MZ2,MLT,MLT2,MNUT,MNUT2,
30999 & RMNUT,MNU,MNU2,MCH,MCH2,MSNU2,A,B,MSL2,MSR2,MSCL,
31000 & MSCL2,ZNU,THCOS,HSL,HL,HNU,MH,MH2,GMIN,GMAX,
31001 & RADID,NTID,ISL,ISR,ISN,IDL,CHID,RSID,IL,NEUT,CHAR,RAD,HIGGS
31002 EXTERNAL HWRGEN,HWUAEM,HWRUNI,HWUPCM,HWUMBW
31003 PARAMETER (SSNU=449,SSCH = 455)
31004C--Start of the code
31005 IF(GENEV) THEN
31006 RCS = HCS*HWRGEN(0)
31007 ELSE
31008C--Initialise the hard processes
31009 IF(FSTWGT) THEN
31010C--Decide which processes to generate
31011 NEUT = .FALSE.
31012 CHAR = .FALSE.
31013 RAD = .FALSE.
31014 HIGGS = .FALSE.
31015C--all single sparticle production
31016 IF(IPROC.EQ.800) THEN
31017 NEUT = .TRUE.
31018 CHAR = .TRUE.
31019 RAD = .TRUE.
31020 HIGGS = .TRUE.
31021 NTID(1) = 1
31022 NTID(2) = 4
31023 CHID(1) = 1
31024 CHID(2) = 2
31025 GMIN = 1
31026 GMAX = 6
31027C--single neutralino production
31028 ELSEIF(IPROC.GE.810.AND.IPROC.LE.814) THEN
31029 NEUT = .TRUE.
31030 IF(IPROC.EQ.810) THEN
31031 NTID(1) = 1
31032 NTID(2) = 4
31033 ELSE
31034 NTID(1) = IPROC-810
31035 NTID(2) = NTID(1)
31036 ENDIF
31037C--single chargino production
31038 ELSEIF(IPROC.GE.820.AND.IPROC.LE.822) THEN
31039 CHAR = .TRUE.
31040 IF(IPROC.EQ.820) THEN
31041 CHID(1) = 1
31042 CHID(2) = 2
31043 ELSE
31044 CHID(1) = IPROC-820
31045 CHID(2) = CHID(1)
31046 ENDIF
31047C--single slepton production with gauge boson
31048 ELSEIF(IPROC.EQ.830) THEN
31049 RAD = .TRUE.
31050 GMIN = 1
31051 GMAX = 6
31052C--single slepton production with Higgs boson
31053 ELSEIF(IPROC.EQ.840) THEN
31054 HIGGS = .TRUE.
31055C--photon radiation processes
31056 ELSEIF(IPROC.EQ.850) THEN
31057 RAD = .TRUE.
31058 GMIN = 7
31059 GMAX = 8
31060C--unrecognized process issue warning
31061 ELSE
31062 CALL HWWARN('HWHRES',500)
31063 ENDIF
31064C--check the particles in the beam
31065 RSID(2) = 3
31066 IF(ABS(IDHEP(1)).EQ.11) THEN
31067C--electron beams
31068 ISL = 425
31069 ISR = 437
31070 ISN = 426
31071 RSID(1) = 2
31072 IL = 1
31073 ELSEIF(ABS(IDHEP(1)).EQ.13) THEN
31074C--muon beams
31075 ISL = 427
31076 ISR = 439
31077 ISN = 428
31078 RSID(1) = 1
31079 IL = 2
31080C--unrecognised beam particles issue warning
31081 ELSE
31082 CALL HWWARN('HWHRES',501)
31083 ENDIF
31084 IDL=ABS(IDHEP(1))
31085C--masses and electroweak parameters
31086 SW = SQRT(SWEIN)
31087 CW = SQRT(1-SWEIN)
31088 MW = RMASS(198)
31089 MZ = RMASS(200)
31090 MW2 = MW**2
31091 MZ2 = MZ**2
31092 SIN2B = TWO*SINB*COSB
31093C--neutralino and chargino masses
31094 DO I=1,4
31095 MNU(I) = RMASS(SSNU+I)
31096 MNU2(I) = MNU(I)**2
31097 ENDDO
31098 DO I = 1,2
31099 MCH(I) = RMASS(I+SSCH)
31100 MCH2(I) = MCH(I)**2
31101 ENDDO
31102C--incoming lepton mass
31103 MLT(1) = RMASS(IDL+110)
31104C--lepton masses in chargino production
31105 DO I=1,2
31106 MLT(I+1) = RMASS(119+2*RSID(I))
31107 ENDDO
31108 DO I=1,3
31109 MLT2(I) = MLT(I)**2
31110 ENDDO
31111C--t-channel slepton masses
31112 MSL2 = RMASS(ISL)**2
31113 MSR2 = RMASS(ISR)**2
31114 MSNU2 = RMASS(ISN)**2
31115C--resonant sneutrino masses and widths
31116 DO I=1,2
31117 MNUT(I) = RMASS(424+2*RSID(I))
31118 MNUT2(I) = MNUT(I)**2
31119 RMNUT(I) = MNUT2(I)*HBAR**2/RLTIM(424+2*RSID(I))**2
31120 ENDDO
31121C--now calculate the coefficients for the processes
31122C--first neutralino production
31123 DO L=1,4
31124 MC = MLT(1)*ZMIXSS(L,3)/(TWO*MW*COSB*SW)
31125C--first for the left slepton
31126 A(L,1) = SLFCH(IDL,L)
31127 B(L,1) = ZSGNSS(L)*MC
31128C--then the right slepton
31129 A(L,2) = ZSGNSS(L)*SRFCH(IDL,L)
31130 B(L,2) = MC
31131C--the resonant sneutrino
31132 DO I=1,2
31133 A(L,2+I) = SLFCH(10+2*RSID(I),L)
31134 B(L,2+I) = ZERO
31135 ENDDO
31136 ENDDO
31137C--now chargino production
31138 DO L=1,2
31139 J=L+4
31140 MC = WMXUSS(L,2)/(SQRT(TWO)*MW*COSB*SW)
31141C--first for the t channel sneutrino
31142 A(J,1) = WSGNSS(L)*WMXVSS(L,1)/SW
31143 B(J,1) = -MLT(1)*MC
31144C--now for the resonant sneutrinos
31145 DO I=1,2
31146 A(J,I+1) = WSGNSS(L)*WMXVSS(L,1)/SW
31147 B(J,I+1) = -MLT(I+1)*MC
31148 ENDDO
31149 ENDDO
31150C--coupling of the Z to the sneutrino
31151 ZNU = HALF/SW/CW
31152C--now the masses and IDs of the slepton in the radiative processes
31153C--IDs and masses of the charged sleptons
31154 DO I=1,2
31155 RADID(2,2*I-1) = 423+RSID(I)*2
31156 RADID(2,2*I ) = 435+RSID(I)*2
31157 MSCL(I,1) = RMASS(RADID(2,2*I-1))
31158 MSCL(I,2) = RMASS(RADID(2,2*I))
31159 DO J=1,2
31160 MSCL2(I,J) = MSCL(I,J)**2
31161 ENDDO
31162 ENDDO
31163C--ID of the W for charged slepton processes
31164 DO I=1,4
31165 RADID(1,I) = 198
31166 ENDDO
31167C--ID's for the Z and gamma processes
31168 DO I=1,2
31169 RADID(1,I+4) = 200
31170 RADID(1,I+6) = 59
31171 RADID(2,I+4) = 424+RSID(I)*2
31172 RADID(2,I+6) = RADID(2,I+4)
31173 ENDDO
31174C--couplings of the sleptons to the Higgs
31175 DO I=1,2
31176 DO J=1,2
31177 K = 2*RSID(I)-1
31178 L = 119+2*RSID(I)
31179 HSL(I,J) = LMIXSS(K,1,J)*(RMASS(L)**2*TANB-MW2*SIN2B)
31180 & +LMIXSS(K,2,J)*RMASS(L)*MUSS
31181 IF(RSID(I).EQ.3) HSL(I,J) = HSL(I,J)
31182 & +LMIXSS(K,2,J)*RMASS(L)*ALSS*TANB
31183 HSL(I,J) = HSL(I,J)/SQRT(HALF)/MW
31184 ENDDO
31185 ENDDO
31186C--coupling of the sneutrino to the Higgs
31187 HNU(1) = HALF*MZ*SINBPA/CW
31188 HNU(2) = -HALF*MZ*COSBPA/CW
31189 HNU(3) = ZERO
31190C--couplings of the leptons to the Higgs
31191 RHO = HALF*MLT(1)/MW
31192 HL(1) = -RHO*SINA/COSB
31193 HL(2) = RHO*COSA/COSB
31194 HL(3) = RHO*TANB
31195 HL(4) = RHO*TANB/SQRT(HALF)
31196C--Higgs Masses
31197 DO I=1,4
31198 MH(I) = RMASS(202+I)
31199 MH2(I) = MH(I)**2
31200 ENDDO
31201 ENDIF
31202C--Now calculate the weights
31203 COSTH = HWRUNI(1,-ONE,ONE)
31204 S = PHEP(5,3)**2
31205 EMSCA = PHEP(5,3)
31206 FACA = HWUAEM(S)*GEV2NB/S/8.0D0
31207 FACD = HALF*FACA/SWEIN
31208 FACB = HALF*FACD/MW2
31209 FACC = HALF*FACA/MZ2
31210 FACE = ALPHEM*GEV2NB/S/8.0D0
31211 DO I=1,2
31212 SCF(I) = ONE/((S-MNUT2(I))**2+RMNUT(I))
31213 ENDDO
31214C--single neutralino production
31215 IF(.NOT.NEUT) THEN
31216 DO L=1,4
31217 DO J=1,4
31218 M1(L,J) = ZERO
31219 ENDDO
31220 ENDDO
31221 GOTO 100
31222 ENDIF
31223 DO L=NTID(1),NTID(2)
31224 DO J=1,2
31225 SQPE = S - MNU2(L)
31226 K = J+2
31227 IF(SQPE.GE.ZERO) THEN
31228 PF = SQPE/S
31229 T = HALF*(SQPE*COSTH-S+MNU2(L))
31230 U = -T-S+MNU2(L)
31231 UP = ONE/(U-MSL2)
31232 TP = ONE/(T-MSR2)
31233C--neutralino antineutrino production (including beam polarization)
31234 M1(L,J) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*(
31235 & A(L,K)**2*S*(S-MNU2(L))*SCF(J)
31236 & +TWO*S*U*(S-MNUT2(J))*UP*SCF(J)*A(L,K)*A(L,1)
31237 & +TWO*S*T*(S-MNUT2(J))*TP*SCF(J)*A(L,K)*A(L,2)
31238 & +TWO*U*T*UP*TP*A(L,1)*A(L,2))
31239 & +U*(U-MNU2(L))*UP**2*(ONE-PPOLN(3))*
31240 & (A(L,1)**2*(ONE-EPOLN(3))+B(L,1)**2*(ONE+EPOLN(3)))
31241 & +T*(T-MNU2(L))*TP**2*(ONE-EPOLN(3))*
31242 & (A(L,2)**2*(ONE-PPOLN(3))+B(L,2)**2*(ONE+PPOLN(3)))
31243C--neutralino neutrino production (including beam polarization)
31244 M1(L,K) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*(
31245 & A(L,K)**2*S*(S-MNU2(L))*SCF(J)
31246 & +TWO*S*U*(S-MNUT2(J))*UP*SCF(J)*A(L,K)*A(L,1)
31247 & +TWO*S*T*(S-MNUT2(J))*TP*SCF(J)*A(L,K)*A(L,2)
31248 & +TWO*U*T*UP*TP*A(L,1)*A(L,2))
31249 & +U*(U-MNU2(L))*UP**2*(ONE+PPOLN(3))*
31250 & (A(L,1)**2*(ONE+EPOLN(3))+B(L,1)**2*(ONE-EPOLN(3)))
31251 & +T*(T-MNU2(L))*TP**2*(ONE+EPOLN(3))*
31252 & (A(L,2)**2*(ONE+PPOLN(3))+B(L,2)**2*(ONE-PPOLN(3)))
31253C--final coefficients
31254 M1(L,J) = LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M1(L,J)
31255 M1(L,K) = LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M1(L,K)
31256 ELSE
31257 M1(L,J) = ZERO
31258 M1(L,K) = ZERO
31259 ENDIF
31260 ENDDO
31261 ENDDO
31262C--single chargino production
31263 100 IF(.NOT.CHAR) THEN
31264 DO L=1,2
31265 DO J=1,4
31266 M2(L,J) = ZERO
31267 ENDDO
31268 ENDDO
31269 GOTO 200
31270 ENDIF
31271 DO L = CHID(1),CHID(2)
31272 DO J = 1,2
31273 K = J+1
31274 L2 = L+4
31275 SM = MCH(L) + MLT(K)
31276 QPE = S - SM**2
31277 IF (QPE.GE.ZERO) THEN
31278 DM = MCH(L) - MLT(K)
31279 SQPE = SQRT(QPE*(S-DM**2))
31280 PF = SQPE/S
31281 T = HALF*(SQPE*COSTH-S+MCH2(L)+MLT2(K))
31282 U = -T-S+MCH2(L)+MLT2(K)
31283 UP = ONE/(U-MSNU2)
31284C--chargino antilepton (including beam polarization)
31285 M2(L,J) = S*SCF(J)*(-FOUR*MLT(K)*MCH(L)*A(L2,K)*B(L2,K)
31286 & +(S-MLT2(K)-MCH2(L))*(A(L2,K)**2+B(L2,K)**2))*
31287 & (ONE-EPOLN(3))*(ONE-PPOLN(3))
31288 & +(MLT2(K)-U)*(MCH2(L)-U)*UP**2*(ONE-PPOLN(3))*
31289 & (A(L2,1)**2*(ONE-EPOLN(3))+B(L2,1)**2*(ONE+EPOLN(3)))
31290 & -TWO*S*(S-MNUT2(J))*UP*SCF(J)*A(L2,1)*(ONE-EPOLN(3))*
31291 & (ONE-PPOLN(3))*(U*A(L2,K)+MLT(K)*MCH(L)*B(L2,K))
31292C--chargino lepton (including beam polarization)
31293 M2(L,J+2) = S*SCF(J)*(-FOUR*MLT(K)*MCH(L)*A(L2,K)*B(L2,K)
31294 & +(S-MLT2(K)-MCH2(L))*(A(L2,K)**2+B(L2,K)**2))*
31295 & (ONE+EPOLN(3))*(ONE+PPOLN(3))
31296 & +(MLT2(K)-U)*(MCH2(L)-U)*UP**2*(ONE+PPOLN(3))*
31297 & (A(L2,1)**2*(ONE+EPOLN(3))+B(L2,1)**2*(ONE-EPOLN(3)))
31298 & -TWO*S*(S-MNUT2(J))*UP*SCF(J)*A(L2,1)*(ONE+EPOLN(3))*
31299 & (ONE+PPOLN(3))*(U*A(L2,K)+MLT(K)*MCH(L)*B(L2,K))
31300C--final coefficients
31301 M2(L,J) =HALF*LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M2(L,J)
31302 M2(L,J+2)=HALF*LAMDA1(RSID(J),IL,IL)**2*FACA*PF*M2(L,J+2)
31303 ELSE
31304 M2(L,J) = ZERO
31305 M2(L,J+2) = ZERO
31306 ENDIF
31307 ENDDO
31308 ENDDO
31309C--Radiative processes
31310 200 IF(.NOT.RAD) THEN
31311 DO I=1,8
31312 DO J=1,2
31313 M3(I,J) = ZERO
31314 ENDDO
31315 ENDDO
31316 GOTO 300
31317 ENDIF
31318 IF(GMAX.LT.7) THEN
31319C--W charged slepton production
31320 DO I=1,2
31321 DO J=1,2
31322 QPE = S-(MW+MSCL(I,J))**2
31323 IF(QPE.GE.ZERO) THEN
31324 DM = MW-MSCL(I,J)
31325 SQPE = SQRT(QPE*(S-DM**2))
31326 PF = SQPE/S
31327 T = HALF*(SQPE*COSTH-S+MW2+MSCL2(I,J))
31328 U = -T-S+MW2+MSCL2(I,J)
31329 UP = ONE/U
31330C--W slepton
31331 M3(2*I+J-2,1) = SCF(I)*S*SQPE**2
31332 & +UP**2*(TWO*MW2*(U*T-MW2*MSCL2(I,J))+U**2*S)
31333 & -TWO*UP*SCF(I)*(S-MNUT2(I))*S*(MW2*(TWO*MSCL2(I,J)-U)+
31334 & U*(S-MSCL2(I,J)))
31335 M3(2*I+J-2,1) = LAMDA1(RSID(I),IL,IL)**2*FACB*PF
31336 & *LMIXSS(2*RSID(I)-1,1,J)**2*M3(2*I+J-2,1)
31337C--W- antislepton (including beam polarization)
31338 M3(2*I+J-2,2) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*
31339 & M3(2*I+J-2,1)
31340C--W+ antislepton (including beam polarization)
31341 M3(2*I+J-2,1) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*
31342 & M3(2*I+J-2,1)
31343 ELSE
31344 M3(2*I+J-2,1) = ZERO
31345 M3(2*I+J-2,2) = ZERO
31346 ENDIF
31347 ENDDO
31348 ENDDO
31349C--Z sneutrino production
31350 DO I=1,2
31351 QPE = S-(MZ+MNUT(I))**2
31352 IF(QPE.GE.ZERO) THEN
31353 DM = MZ-MNUT(I)
31354 SQPE = SQRT(QPE*(S-DM**2))
31355 PF = SQPE/S
31356 T = HALF*(SQPE*COSTH-S+MZ2+MNUT2(I))
31357 U = -T-S+MZ2+MNUT2(I)
31358 UP = ONE/U
31359 TP = ONE/T
31360 IDZ = 9+RSID(I)*2
31361C--Z sneutrino production
31362 M3(I+4,1) = SCF(I)*S*SQPE**2*ZNU**2
31363 & +TP**2*RFCH(IDZ)**2*(TWO*MZ2*(U*T-MNUT2(I)*MZ2)+S*T**2)
31364 & +UP**2*LFCH(IDZ)**2*(TWO*MZ2*(U*T-MNUT2(I)*MZ2)+S*U**2)
31365 & -TWO*ZNU*RFCH(IDZ)*TP*S*SCF(I)*(S-MNUT2(I))*
31366 & (MZ2*(TWO*MNUT2(I)-T)+T*(S-MNUT2(I)))
31367 & +TWO*ZNU*LFCH(IDZ)*UP*S*SCF(I)*(S-MNUT2(I))*
31368 & (MZ2*(TWO*MNUT2(I)-U)+U*(S-MNUT2(I)))
31369 & +TWO*LFCH(IDZ)*RFCH(IDZ)*UP*TP*
31370 & (TWO*MZ2*(MNUT2(I)-T)*(MNUT2(I)-U)-S*U*T)
31371 M3(I+4,1) = LAMDA1(RSID(I),IL,IL)**2*FACC*PF*M3(I+4,1)
31372C--Z antisneutrino (including beam polarization)
31373 M3(I+4,2) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*M3(I+4,1)
31374C--Z sneutrino (including beam polarization)
31375 M3(I+4,1) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*M3(I+4,1)
31376 ELSE
31377 M3(I+4,1) = ZERO
31378 M3(I+4,2) = ZERO
31379 ENDIF
31380 ENDDO
31381 ELSE
31382C--gamma sneutrino production (includes Jacobian 1-costh**2)
31383C--now includes polarization effects
31384 DO I=1,2
31385 SQPE = S-MNUT2(I)
31386 IF(SQPE.GE.ZERO) THEN
31387 PF = SQPE/S
31388 PCM = HALF*EMSCA*PF
31389 THTMIN = PTMIN/PCM
31390 IF(THTMIN.GT.ONE) CALL HWWARN('HWHRES',502)
31391 THTMIN = ONE-THTMIN**2
31392 THTMIN = HALF*LOG((1+THTMIN)/(1-THTMIN))
31393 RHO = HWRUNI(2,-THTMIN,THTMIN)
31394 THCOS(I) = -TANH(RHO)
31395 T = HALF*(SQPE*THCOS(I)-S+MNUT2(I))
31396 U = -T-S+MNUT2(I)
31397 UP = ONE/U
31398 TP = ONE/T
31399 M3(I+6,1) = U*TP+T*UP+TWO*UP*TP*(MNUT2(I)-U)*(MNUT2(I)-T)
31400 M3(I+6,1) = LAMDA1(RSID(I),IL,IL)**2*FACE*PF*M3(I+6,1)*
31401 & (ONE-THCOS(I)**2)*THTMIN
31402 M3(I+6,2) = M3(I+6,1)*(ONE-EPOLN(3))*(ONE-PPOLN(3))
31403 M3(I+6,1) = M3(I+6,1)*(ONE+EPOLN(3))*(ONE+PPOLN(3))
31404 ELSE
31405 M3(I+6,1) = ZERO
31406 M3(I+6,2) = ZERO
31407 ENDIF
31408 ENDDO
31409 ENDIF
31410C--Higgs processes
31411 300 IF(.NOT.HIGGS) THEN
31412 DO I=1,10
31413 DO J=1,2
31414 M4(I,J) = ZERO
31415 ENDDO
31416 ENDDO
31417 GOTO 500
31418 ENDIF
31419C--Charged Higgs charged slepton production
31420 DO I=1,2
31421 DO J=1,2
31422 QPE = S-(MH(4)+MSCL(I,J))**2
31423 IF(QPE.GE.ZERO) THEN
31424 DM = MH(4)-MSCL(I,J)
31425 SQPE = SQRT(QPE*(S-DM**2))
31426 PF = SQPE/S
31427 T = HALF*(SQPE*COSTH-S+MH2(4)+MSCL2(I,J))
31428 U = -T-S+MH2(4)+MSCL2(I,J)
31429C--charged Higgs antislepton
31430 M4(2*I+J-2,1) = HSL(I,J)**2*S*SCF(I)*
31431 & (ONE-EPOLN(3))*(ONE-PPOLN(3))
31432 & +FOUR*LMIXSS(2*RSID(I)-1,1,J)**2*HL(4)**2
31433 & *(U*T-MSCL2(I,J)*MH2(4))/U**2*
31434 & (ONE+EPOLN(3))*(ONE-PPOLN(3))
31435C--charged Higgs slepton
31436 M4(2*I+J-2,2) = HSL(I,J)**2*S*SCF(I)*
31437 & (ONE+EPOLN(3))*(ONE+PPOLN(3))
31438 & +FOUR*LMIXSS(2*RSID(I)-1,1,J)**2*HL(4)**2
31439 & *(U*T-MSCL2(I,J)*MH2(4))/U**2*
31440 & (ONE-EPOLN(3))*(ONE+PPOLN(3))
31441C--final coefficients
31442 M4(2*I+J-2,1) = FACD*LAMDA1(RSID(I),IL,IL)**2*
31443 & M4(2*I+J-2,1)*PF
31444 M4(2*I+J-2,2) = FACD*LAMDA1(RSID(I),IL,IL)**2*
31445 & M4(2*I+J-2,2)*PF
31446 ELSE
31447 M4(2*I+J-2,1) = ZERO
31448 M4(2*I+J-2,2) = ZERO
31449 ENDIF
31450 ENDDO
31451 ENDDO
31452C--neutral higgs sneutrino production
31453 DO L=1,3
31454 DO I=1,2
31455 QPE = S-(MH(L)+MNUT(I))**2
31456 IF(QPE.GE.ZERO) THEN
31457 DM = MH(L)-MNUT(I)
31458 SQPE = SQRT(QPE*(S-DM**2))
31459 PF = SQPE/S
31460 T = HALF*(SQPE*COSTH-S+MH2(L)+MNUT2(I))
31461 U = -T-S+MH2(L)+MNUT2(I)
31462 IF(L.NE.3) THEN
31463C--h0, H0 antisneutrino (including beam polarization)
31464 M4(2*L+I+2,1) = HNU(L)**2*S*SCF(I)*
31465 & (ONE-EPOLN(3))*(ONE-PPOLN(3))
31466 & +HL(L)**2*( ONE/T**2*(ONE+EPOLN(3))*(ONE-PPOLN(3))
31467 & +ONE/U**2*(ONE-EPOLN(3))*(ONE+PPOLN(3)))
31468 & *(U*T-MH2(L)*MNUT2(I))
31469C--h0, H0 sneutrino (including beam polarization)
31470 M4(2*L+I+2,2) = HNU(L)**2*S*SCF(I)*
31471 & (ONE+EPOLN(3))*(ONE+PPOLN(3))
31472 & +HL(L)**2*( ONE/T**2*(ONE-EPOLN(3))*(ONE+PPOLN(3))
31473 & +ONE/U**2*(ONE+EPOLN(3))*(ONE-PPOLN(3)))
31474 & *(U*T-MH2(L)*MNUT2(I))
31475 ELSE
31476C--A0 antisneutrino (including beam polarization)
31477 M4(2*L+I+2,1) = (ONE-EPOLN(3))*(ONE-PPOLN(3))*(
31478 & HNU(L)**2*S*SCF(I)
31479 & +HL(L)**2*(ONE/T**2+ONE/U**2)*(U*T-MH2(L)*MNUT2(I)))
31480C--A0 sneutrino (including beam polarization)
31481 M4(2*L+I+2,2) = (ONE+EPOLN(3))*(ONE+PPOLN(3))*(
31482 & HNU(L)**2*S*SCF(I)
31483 & +HL(L)**2*(ONE/T**2+ONE/U**2)*(U*T-MH2(L)*MNUT2(I)))
31484 ENDIF
31485C--final coefficients
31486 M4(2*L+I+2,1) = FACD*LAMDA1(RSID(I),IL,IL)**2*
31487 & M4(2*L+I+2,1)*PF
31488 M4(2*L+I+2,2) = FACD*LAMDA1(RSID(I),IL,IL)**2*
31489 & M4(2*L+I+2,2)*PF
31490 ELSE
31491 M4(2*L+I+2,1) = ZERO
31492 M4(2*L+I+2,2) = ZERO
31493 ENDIF
31494 ENDDO
31495 ENDDO
31496 ENDIF
31497C--Add up the weights now
31498 500 HCS = ZERO
31499C--single neutralino production
31500 IF(.NOT.NEUT) GOTO 550
31501 DO L=NTID(1),NTID(2)
31502 IG1= SSNU+L
31503 DO J=1,4
31504 IG2 = 126+2*RSID(MOD(J-1,2)+1)-6*INT((J-1)/2)
31505 HCS = HCS+M1(L,J)
31506 THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.GT.2).OR.
31507 & (IDHEP(1).GT.IDHEP(2).AND.J.LE.2)
31508 IF(GENEV.AND.HCS.GT.RCS) GOTO 900
31509 ENDDO
31510 ENDDO
31511C--single chargino production
31512 550 IF(.NOT.CHAR) GOTO 600
31513 DO L=CHID(1),CHID(2)
31514 DO J=1,4
31515 IG1 = SSCH+L-2*INT((J-1)/2)
31516 IG2 = 125+2*RSID(MOD((J-1),2)+1)-6*INT((J-1)/2)
31517 HCS = HCS + M2(L,J)
31518 THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.GT.2).OR.
31519 & (IDHEP(1).GT.IDHEP(2).AND.J.LE.2)
31520 IF (GENEV.AND.HCS.GT.RCS) GOTO 900
31521 ENDDO
31522 ENDDO
31523C--gauge boson slepton production
31524 600 IF(.NOT.RAD) GOTO 650
31525 DO I=GMIN,GMAX
31526 IG1 = RADID(1,I)
31527 IG2 = RADID(2,I)
31528 IF(I.GE.7) COSTH = THCOS(I-6)
31529 DO J=1,2
31530 HCS = HCS+M3(I,J)
31531 THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR.
31532 & (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2)
31533 IF(GENEV.AND.HCS.GT.RCS) GOTO 900
31534 IF(I.LE.4) IG1 = IG1+1
31535 IG2 = IG2+6
31536 ENDDO
31537 ENDDO
31538C--higgs slepton production
31539 650 IF(.NOT.HIGGS) GOTO 900
31540C--charged Higgs slepton
31541 DO I=1,4
31542 IG1 = 207
31543 IG2 = RADID(2,I)+6
31544 DO J=1,2
31545 HCS=HCS+M4(I,J)
31546 THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR.
31547 & (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2)
31548 IF(GENEV.AND.HCS.GT.RCS) GOTO 900
31549 IG1 = IG1-1
31550 IG2 = IG2-6
31551 ENDDO
31552 ENDDO
31553C--Neutral Higgs sneutrino
31554 DO L=1,3
31555 DO I=1,2
31556 IG1 = 202+L
31557 IG2 = 430+2*RSID(I)
31558 DO J=1,2
31559 HCS = HCS+M4(2+2*L+I,J)
31560 THSGN = (IDHEP(1).LT.IDHEP(2).AND.J.EQ.1).OR.
31561 & (IDHEP(1).GT.IDHEP(2).AND.J.EQ.2)
31562 IF(GENEV.AND.HCS.GT.RCS) GOTO 900
31563 IG2 = IG2-6
31564 ENDDO
31565 ENDDO
31566 ENDDO
31567 900 IF(GENEV) THEN
31568C--change sign of COSTH if antiparticle first
31569 IF(THSGN) COSTH = -COSTH
31570C-Set up the particle types
31571 IDHW(NHEP+1) = 15
31572 IDHEP(NHEP+1) = 0
31573 ISTHEP(NHEP+1) = 110
31574 IDHW(NHEP+2) = IG1
31575 IDHW(NHEP+3) = IG2
31576 IDHEP(NHEP+2) = IDPDG(IG1)
31577 IDHEP(NHEP+3) = IDPDG(IG2)
31578C--generate the particle masses and final-state momenta
31579 NTRY = 0
31580 910 NTRY = NTRY+1
31581 PHEP(5,NHEP+2) = HWUMBW(IG1)
31582 PHEP(5,NHEP+3) = HWUMBW(IG2)
31583C--Set up the Centre-of-mass energy
31584 CALL HWVEQU(5,PHEP(1,3),PHEP(1,NHEP+1))
31585 PCM = HWUPCM(PHEP(5,NHEP+1),PHEP(5,NHEP+2),PHEP(5,NHEP+3))
31586 IF(PCM.LT.ZERO.AND.NTRY.LE.NETRY) THEN
31587 GOTO 910
31588 ELSEIF(PCM.LT.ZERO) THEN
31589 CALL HWWARN('HWHRES',100)
31590 GOTO 999
31591 ENDIF
31592C--Set up the colours etc
31593 ISTHEP(NHEP+2) = 113
31594 ISTHEP(NHEP+3) = 114
31595 JMOHEP(1,NHEP+1) = 1
31596 IF (JDAHEP(1,1).NE.0) JMOHEP(1,NHEP+1)=JDAHEP(1,1)
31597 JMOHEP(2,NHEP+1) = 2
31598 IF (JDAHEP(1,2).NE.0) JMOHEP(2,NHEP+1)=JDAHEP(1,2)
31599 JMOHEP(1,NHEP+2) = NHEP+1
31600 JMOHEP(2,NHEP+2) = NHEP+2
31601 JMOHEP(1,NHEP+3) = NHEP+1
31602 JMOHEP(2,NHEP+3) = NHEP+3
31603 JDAHEP(1,NHEP+1) = NHEP+2
31604 JDAHEP(2,NHEP+1) = NHEP+3
31605 JDAHEP(1,NHEP+2) = 0
31606 JDAHEP(2,NHEP+2) = NHEP+2
31607 JDAHEP(1,NHEP+3) = 0
31608 JDAHEP(2,NHEP+3) = NHEP+3
31609C--set up the rest of the momenta
31610 IHEP = NHEP+2
31611 PHEP(4,IHEP) = SQRT(PCM**2+PHEP(5,IHEP)**2)
31612 PHEP(3,IHEP) = PCM*COSTH
31613 PHEP(1,IHEP) = SQRT((PCM+PHEP(3,IHEP))*(PCM-PHEP(3,IHEP)))
31614 PHEP(2,IHEP) = ZERO
31615 CALL HWRAZM(PHEP(1,IHEP),PHEP(1,IHEP),PHEP(2,IHEP))
31616 CALL HWULOB(PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP))
31617 CALL HWVDIF(4,PHEP(1,NHEP+1),PHEP(1,IHEP),PHEP(1,IHEP+1))
31618 NHEP = NHEP+3
31619 ELSE
31620 EVWGT = HCS
31621 ENDIF
31622 999 RETURN
31623 END
31624CDECK ID>, HWHRLL.
31625*CMZ :- -08/04/02 09:00:27 by Peter Richardson
31626*-- Author : Peter Richardson
31627C-----------------------------------------------------------------------
31628 SUBROUTINE HWHRLL
31629C-----------------------------------------------------------------------
31630C Subroutine for resonant sleptons to standard model particles
31631C slepton mass and mass*width added to save statement to
31632C avoid problems with Linux by Peter Richardson
31633C-----------------------------------------------------------------------
c63d70bc 31634 INCLUDE 'herwig65.inc'
65767955 31635 DOUBLE PRECISION HCS,S,RCS,HWRGEN,FAC,ECM,TH,PCM,CFAC,CHANPB,SH,
31636 & TAU,TAUA,TAUB,LOWTLM,UPPTLM,HWRUNI,MSL(12),
31637 & SQSH,MET(2),SCF(12),MIX(12),ME(4,3,3,3,3,2),
31638 & RAND,CHAN(12),LAM(2,7,3,3,3,3),SLWD(12),RTAB,
31639 & WD,MQ1,MQ2,EPS,XMIN,XMAX,XPOW,XUPP,MSL2(12),
31640 & MSWD(12)
31641 INTEGER I,J,K,L,I1,J1,K1,L1,GEN,GN,GR,GNMX,GNMN,MIG,MXG,CUP,CF
31642 LOGICAL FIRST
31643 EXTERNAL HWRGEN,HWRUNI
31644 PARAMETER(EPS=1D-20)
31645 COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
31646 SAVE HCS,ME,MSL,SLWD,LAM,MIX,CHAN,GNMN,GNMX,SH,SQSH,FAC,SCF,MSL2,
31647 & MSWD
31648 IF(GENEV) THEN
31649 RCS = HCS*HWRGEN(0)
31650 ELSE
31651 IF(FSTWGT) THEN
31652 DO I=1,3
31653 MSL(2*I-1) = RMASS(423+2*I)
31654 MSL(2*I) = RMASS(435+2*I)
31655 MSL(2*I+5) = RMASS(424+2*I)
31656 MSL(2*I+6) = RMASS(436+2*I)
31657 SLWD(2*I-1) = HBAR/RLTIM(423+2*I)
31658 SLWD(2*I) = HBAR/RLTIM(435+2*I)
31659 SLWD(2*I+5) = HBAR/RLTIM(424+2*I)
31660 SLWD(2*I+6) = HBAR/RLTIM(436+2*I)
31661 ENDDO
31662 DO I=1,12
31663 MSL2(I) = MSL(I)**2
31664 MSWD(I) = MSL(I)*SLWD(I)
31665 ENDDO
31666 RAND = ZERO
31667 DO I=1,3
31668 CHANPB=ZERO
31669 DO J=1,3
31670 DO K=1,3
31671 CHANPB=CHANPB+LAMDA2(I,J,K)**4
31672 ENDDO
31673 ENDDO
31674 RAND=RAND+2*CHANPB
31675 DO J=1,2
31676 CHAN(2*I-2+J) = LMIXSS(2*I-1,1,J)**2*CHANPB
31677 CHAN(2*I+4+J) = LMIXSS(2*I ,1,J)**2*CHANPB
31678 MIX(2*I-2+J) = LMIXSS(2*I-1,1,J)**2
31679 MIX(2*I+4+J) = LMIXSS(2*I ,1,J)**2
31680 ENDDO
31681 ENDDO
31682 IF(RAND.GT.ZERO) THEN
31683 DO I=1,12
31684 CHAN(I)=CHAN(I)/RAND
31685 ENDDO
31686 ELSE
31687 CALL HWWARN('HWHRLL',500)
31688 ENDIF
31689C--find the couplings
31690 DO GN=1,3
31691 DO I=1,3
31692 DO J=1,3
31693 DO K=1,3
31694 DO L=1,3
31695 LAM(1,GN,I,J,K,L) =LAMDA2(GN,I,J)*LAMDA1(GN,K,L)
31696 LAM(2,GN,I,J,K,L) =LAMDA2(GN,I,J)*LAMDA2(GN,K,L)
31697 LAM(1,GN+3,I,J,K,L)=LAM(1,GN,I,J,K,L)
31698 LAM(2,GN+3,I,J,K,L)=LAM(2,GN,I,J,K,L)
31699 ENDDO
31700 ENDDO
31701 ENDDO
31702 ENDDO
31703 ENDDO
31704C--select the process from the IPROC code
31705 GNMN = 1
31706 GNMX = 4
31707 IF(MOD(IPROC,10000).EQ.4070) THEN
31708 GNMX = 2
31709 ELSEIF(MOD(IPROC,10000).EQ.4080) THEN
31710 GNMN = 3
31711 ENDIF
31712 ENDIF
31713 EVWGT = ZERO
31714 S = PHEP(5,3)**2
31715 COSTH = HWRUNI(0,-ONE,ONE)
31716C--Generate the smoothing
31717 RAND=HWRUNI(0,ZERO,ONE)
31718 DO I=1,12
31719 IF(CHAN(I).GT.RAND) GOTO 20
31720 RAND=RAND-CHAN(I)
31721 ENDDO
31722 20 GR = I
31723C--Calculate hard scale and obtain parton distributions
31724 TAUA = MSL2(GR)/S
31725 TAUB = SLWD(GR)**2/S
31726 RTAB = SQRT(TAUA*TAUB)
31727 XUPP = XMAX
31728 IF(XMAX**2.GT.S) XUPP = SQRT(S)
31729 LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
31730 UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
31731 TAU = HWRUNI(0,LOWTLM,UPPTLM)
31732 TAU = RTAB*TAN(RTAB*TAU)+TAUA
31733 SH = S*TAU
31734 SQSH = SQRT(SH)
31735 EMSCA = SQSH
31736 XX(1) = EXP(HWRUNI(0,ZERO,LOG(TAU)))
31737 XX(2) = TAU/XX(1)
31738 CALL HWSGEN(.FALSE.)
31739C--Calculate the prefactor due multichannel approach
31740 FAC = ZERO
31741 DO GN=1,12
31742 SCF(GN)=1/((SH-MSL2(GN))**2+MSWD(GN)**2)
31743 FAC=FAC+CHAN(GN)*SCF(GN)
31744 ENDDO
31745 FAC=-(UPPTLM-LOWTLM)*LOG(TAU)*GEV2NB
31746 & /(96*PIFAC*SQSH*SH*TAU*FAC*S**2)
31747 ENDIF
31748C--Now the loop to actually calculate the cross-sections
31749 HCS = ZERO
31750 DO GN=GNMN,GNMX
31751 IF(MOD(GN,2).EQ.1) THEN
31752 MIG = 1
31753 MXG = 6
31754 ELSE
31755 MIG = 7
31756 MXG = 12
31757 ENDIF
31758 IF(GN.LE.2) THEN
31759 CFAC = THREE*FAC
31760 CUP=2
31761 ELSE
31762 CFAC = FAC
31763 CUP=1
31764 ENDIF
31765 DO K1=1,3
31766 DO 80 L1=1,3
31767 IF(GN.EQ.1) THEN
31768 K = 2*K1
31769 L = 2*L1+5
31770 ELSEIF(GN.EQ.2) THEN
31771 K = 2*K1-1
31772 L = 2*L1+5
31773 ELSEIF(GN.EQ.3) THEN
31774 K = 120+2*K1
31775 L = 125+2*L1
31776 ELSEIF(GN.EQ.4) THEN
31777 K = 119+2*K1
31778 L = 125+2*L1
31779 ENDIF
31780 MQ1 = RMASS(K)
31781 MQ2 = RMASS(L)
31782 IF(SQSH.GT.(MQ1+MQ2)) THEN
31783 PCM = SQRT((SH-(MQ1+MQ2)**2)*(SH-(MQ1-MQ2)**2))/(2*SQSH)
31784 WD = (SH-MQ1**2-MQ2**2)*SH*PCM
31785 ELSE
31786 GOTO 80
31787 ENDIF
31788 DO I1=1,3
31789 DO 70 J1=1,3
31790 IF(MOD(GN,2).EQ.1) THEN
31791 I=2*I1
31792 J=2*J1+5
31793 ELSE
31794 I=2*I1-1
31795 J=2*J1+5
31796 ENDIF
31797 DO GR =1,2
31798 MET(GR) = ZERO
31799 ENDDO
31800 IF(GENEV) GOTO 60
31801 DO 50 GEN=MIG,MXG
31802 IF(ABS(LAM(CUP,INT((GEN+1)/2),I1,J1,K1,L1)).LT.EPS.
31803 & OR.ABS(MIX(GEN)).LT.EPS) GOTO 50
31804 DO GR=MIG,MXG
31805 IF(ABS(LAM(CUP,INT((GR+1)/2),I1,J1,K1,L1)).GT.EPS.
31806 & AND.ABS(MIX(GR)).GT.EPS) THEN
31807 MET(1) =MET(1)+SCF(GEN)*SCF(GR)*WD*
31808 & ((SH-MSL2(GEN))*(SH-MSL2(GR))+MSWD(GEN)*MSWD(GR))
31809 & *LAM(CUP,INT((GEN+1)/2),I1,J1,K1,L1)*MIX(GEN)
31810 & *LAM(CUP,INT((GR+1)/2),I1,J1,K1,L1)*MIX(GR)
31811 ENDIF
31812 ENDDO
31813C--Now the t-channel diagrams if the s-channel particles is a sneutrino
31814 IF(GN.EQ.2) THEN
31815 ECM=SQRT(PCM**2+MQ1**2)
31816 TH=MQ1**2-SQSH*(ECM-PCM*COSTH)
31817 DO GR=MIG,MXG
31818 MET(2)=MET(2)+(MQ1**2-TH)*(MQ2**2-TH)*PCM*
31819 & LAM(2,INT((GEN+1)/2),I1,K1,J1,L1)*MIX(GEN)*
31820 & LAM(2,INT((GR+1)/2),I1,K1,J1,L1)*MIX(GR)
31821 & /((TH-MSL2(GEN))*(TH-MSL2(GR)))
31822 ENDDO
31823 ENDIF
31824 50 CONTINUE
31825C--final phase space factors
31826 IF(MET(1).LT.EPS.AND.MET(2).LT.EPS) GOTO 70
31827 DO GR = 1,2
31828 ME(GN,I1,J1,K1,L1,GR) = MET(GR)*CFAC
31829 ENDDO
31830 60 DO GR = 1,2
31831 CF = GR
31832 IF(CUP.EQ.1) CF=0
31833 HCS = HCS+ME(GN,I1,J1,K1,L1,GR)*DISF(I,1)*DISF(J,2)
31834 IF(HCS.GT.RCS.AND.GENEV) THEN
31835 CALL HWHRSS(9,I,J,K,L,0,CF)
31836 GOTO 100
31837 ENDIF
31838 HCS = HCS+ME(GN,I1,J1,K1,L1,GR)*DISF(J,1)*DISF(I,2)
31839 IF(HCS.GT.RCS.AND.GENEV) THEN
31840 CALL HWHRSS(10,J,I,K,L,0,CF)
31841 GOTO 100
31842 ENDIF
31843 HCS = HCS+ME(GN,I1,J1,K1,L1,GR)
31844 & *DISF(I+6,1)*DISF(J-6,2)
31845 IF(HCS.GT.RCS.AND.GENEV) THEN
31846 CALL HWHRSS(9,I,J,K,L,1,CF)
31847 GOTO 100
31848 ENDIF
31849 HCS = HCS+ME(GN,I1,J1,K1,L1,GR)
31850 & *DISF(J-6,1)*DISF(I+6,2)
31851 IF(HCS.GT.RCS.AND.GENEV) THEN
31852 CALL HWHRSS(10,J,I,K,L,1,CF)
31853 GOTO 100
31854 ENDIF
31855 ENDDO
31856 70 CONTINUE
31857 ENDDO
31858 80 CONTINUE
31859 ENDDO
31860 ENDDO
31861 100 IF(GENEV) THEN
31862 CALL HWETWO(.TRUE.,.TRUE.)
31863 ELSE
31864 EVWGT = HCS
31865 ENDIF
31866 END
31867CDECK ID>, HWHRLS.
31868*CMZ :- -23/10/00 13:53:06 by Peter Richardson
31869*-- Author : Peter Richardson
31870C-----------------------------------------------------------------------
31871 SUBROUTINE HWHRLS
31872C-----------------------------------------------------------------------
31873C Subroutine for 2 parton -> sparticle + X via LQD
31874C-----------------------------------------------------------------------
c63d70bc 31875 INCLUDE 'herwig65.inc'
65767955 31876 DOUBLE PRECISION HCS,A(6,12),B(6,12),S,RCS,HWRGEN,CW,FAC2,EC,ME2,
31877 & MW,G,TAU,TAUA,TAUB,LOWTLM,UPPTLM,HWRUNI,SW,SQSH,LC,
31878 & SH,MSL(12),MSU(12),MST(6),C(2,6,12),D(2,6,12),UH,
31879 & TH,MEN(4,6,3,3),SCF(12),SLWD(12),MLT(6),MNT(4),PCM,
31880 & MXS(12),MER(8),MCR(2),RTAB,H(18),MEH(3,18),MXT(12),
31881 & CHAN(12),MXU(12),RAND,FAC,ECM,MC(2),MEC(2,6,3,3),
31882 & MZ,CHPROB,EPS,HWUAEM,XMIN,XMAX,XPOW,SIN2B,GUU(4),
31883 & ML,MN,MLS,MNS,XUPP,MW2,MZ2,ZSLP(2),ZQRK(2),GDD(4),
31884 & MSL2(12),MH(4),MSWD(12)
31885 INTEGER I,J,K,L,J1,K1,GN,GR,SP,GU,GT,I2,I1,NEUTMN
31886 & ,NEUTMX,CHARMN,CHARMX,P
31887 LOGICAL RAD,NEUT,CHAR,HIGGS,FIRST
31888 EXTERNAL HWRGEN,HWRUNI,HWUAEM
31889 COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
31890 SAVE HCS,A,B,C,D,FAC,MER,MEC,MEN,MLT,MSL,MSU,MST,SLWD,MNT,MXT,MXU,
31891 & SW,CW,MXS,H,MEH,CHAN,NEUTMN,NEUTMX,CHARMN,CHARMX,RAD,NEUT,
31892 & CHAR,HIGGS,MW,MZ,MW2,MZ2,MCR,SH,SQSH,EC,G,SCF,ZSLP,ZQRK,GUU,
31893 & GDD,MSL2,MH,MSWD
31894 PARAMETER(EPS=1D-20)
31895 IF(GENEV) THEN
31896 RCS = HCS*HWRGEN(0)
31897 ELSE
31898 IF(FSTWGT) THEN
31899C--Calculate Electroweak parameters needed
31900 SW = SQRT(SWEIN)
31901 CW = SQRT(1-SWEIN)
31902 MW = RMASS(198)
31903 MZ = RMASS(200)
31904 MW2 = MW**2
31905 MZ2 = MZ**2
31906 SIN2B = TWO*SINB*COSB
31907C--Masses and widths
31908 DO I=1,3
31909 MSL(2*I-1) = RMASS(423+2*I)
31910 MSL(2*I) = RMASS(435+2*I)
31911 MSL(2*I+5) = RMASS(424+2*I)
31912 MSL(2*I+6) = RMASS(436+2*I)
31913 SLWD(2*I-1) = HBAR/RLTIM(423+2*I)
31914 SLWD(2*I) = HBAR/RLTIM(435+2*I)
31915 SLWD(2*I+5) = HBAR/RLTIM(424+2*I)
31916 SLWD(2*I+6) = HBAR/RLTIM(436+2*I)
31917 MSU(2*I-1) = RMASS(400+2*I)**2
31918 MSU(2*I) = RMASS(412+2*I)**2
31919 MSU(2*I+5) = RMASS(399+2*I)**2
31920 MSU(2*I+6) = RMASS(411+2*I)**2
31921 MST(2*I-1) = RMASS(399+2*I)**2
31922 MST(2*I) = RMASS(411+2*I)**2
31923 MLT(2*I) = ZERO
31924 MLT(2*I-1) = RMASS(119+2*I)
31925 ENDDO
31926 DO I=1,12
31927 MSL2(I) = MSL(I)**2
31928 MSWD(I) = MSL(I)*SLWD(I)
31929 ENDDO
31930 DO I=1,4
31931 MNT(I) = ABS(RMASS(449+I))
31932 ENDDO
31933 MCR(1) = ABS(RMASS(454))
31934 MCR(2) = ABS(RMASS(455))
31935C--Couplings for the neutralinos
31936 DO L=1,4
31937 MC(1) = ZMIXSS(L,3)/(2*MW*COSB*SW)
31938 MC(2) = ZMIXSS(L,4)/(2*MW*SINB*SW)
31939 DO I=1,3
31940 DO J=1,2
31941C--resonant charged sleptons
31942 A(L,2*I-2+J) = MC(1)*MLT(2*I-1)*LMIXSS(2*I-1,2,J)
31943 & +SLFCH(9+2*I,L)*LMIXSS(2*I-1,1,J)
31944 B(L,2*I-2+J) = ZSGNSS(L)*(MC(1)*MLT(2*I-1)*
31945 & LMIXSS(2*I-1,1,J)+SRFCH(9+2*I,L)*LMIXSS(2*I-1,2,J))
31946C--resonant sneutrinos
31947 A(L,2*I+4+J) = SLFCH(10+2*I,L)*LMIXSS(2*I,1,J)
31948 B(L,2*I+4+J) = ZERO
31949C--u channel up type squarks
31950 C(1,L,2*I-2+J) = MC(2)*QMIXSS(2*I,2,J)*
31951 & RMASS(2*I)+SLFCH(2*I,L)*QMIXSS(2*I,1,J)
31952 D(1,L,2*I-2+J) = ZSGNSS(L)*(MC(2)*QMIXSS(2*I,1,J)*
31953 & RMASS(2*I)+SRFCH(2*I ,L)*QMIXSS(2*I,2,J))
31954C--u channel down type squarks
31955 C(1,L,2*I+4+J) = MC(1)*QMIXSS(2*I-1,2,J)*
31956 & RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
31957 D(1,L,2*I+4+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
31958 & RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
31959C--t channel down type squarks
31960 C(2,L,2*I-2+J) = ZSGNSS(L)*(MC(1)*QMIXSS(2*I-1,1,J)*
31961 & RMASS(2*I-1)+SRFCH(2*I-1,L)*QMIXSS(2*I-1,2,J))
31962 D(2,L,2*I-2+J) = MC(1)*QMIXSS(2*I-1,2,J)*
31963 & RMASS(2*I-1)+SLFCH(2*I-1,L)*QMIXSS(2*I-1,1,J)
31964 ENDDO
31965 ENDDO
31966 DO I=1,6
31967 C(2,L,6+I) = C(2,L,I)
31968 D(2,L,6+I) = D(2,L,I)
31969 ENDDO
31970 ENDDO
31971C--Couplings for charginos
31972 DO L=1,2
31973 MC(1) = 1/(SQRT(2.0D0)*MW*COSB)
31974 MC(2) = 1/(SQRT(2.0D0)*MW*SINB)
31975 SP=L+4
31976 DO I=1,3
31977 DO J=1,2
31978C--resonant charged slepton
31979 A(SP,2*I-2+J) = WMXUSS(L,1)*LMIXSS(2*I-1,1,J)
31980 & -LMIXSS(2*I-1,2,J)*WMXUSS(L,2)*
31981 & MLT(2*I-1)*MC(1)
31982 B(SP,2*I-2+J) = ZERO
31983C--resonant sneutrinos
31984 A(SP,2*I+4+J) = WSGNSS(L)*WMXVSS(L,1)*LMIXSS(2*I,1,J)
31985 B(SP,2*I+4+J) = -MLT(2*I-1)*WMXUSS(L,2)*LMIXSS(2*I,1,J)
31986 & *MC(1)
31987C--u channel sup
31988 C(1,SP,2*I-2+J) = WSGNSS(L)*(WMXVSS(L,1)*QMIXSS(2*I,1,J)
31989 & -WMXVSS(L,2)*MC(2)*RMASS(2*I)*QMIXSS(2*I,2,J))
31990 D(1,SP,2*I-2+J) = -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)
31991 & *QMIXSS(2*I,1,J)
31992C--u channel sdown
31993 C(1,SP,2*I+4+J) = WMXUSS(L,1)*QMIXSS(2*I-1,1,J)
31994 & -WMXUSS(L,2)*MC(1)*RMASS(2*I-1)*QMIXSS(2*I-1,2,J)
31995 D(1,SP,2*I+4+J) = -WSGNSS(L)*WMXVSS(L,2)*MC(2)*
31996 & RMASS(2*I)*QMIXSS(2*I-1,1,J)
31997 ENDDO
31998 ENDDO
31999 ENDDO
32000C--Couplings and massesfor Higgs
32001 DO I=1,4
32002 MH(I) = RMASS(202+I)
32003 ENDDO
32004C--first the neutral Higgs
32005C--fix to the sign of the A and mu term 31/03/00 PR
32006 DO I=1,3
32007 H(I) = MLT(2*I-1)*HALF/MW/COSB*MUSS*COSA
32008 H(I+4) = MLT(2*I-1)*HALF/MW/COSB*MUSS*SINA
32009 H(I+8) = -MLT(2*I-1)*HALF/MW*MUSS
32010 ENDDO
32011 H(3) = (H(3)+MLT(5)*HALF/MW/COSB*ALSS*SINA)*TWO*
32012 & LMIXSS(5,2,1)*LMIXSS(5,1,1)
32013 & -MZ*SINBPA/CW*(LMIXSS(5,1,1)**2*(HALF-SWEIN)
32014 & +SWEIN*LMIXSS(5,2,1)**2)+MLT(5)**2*SINA/MW/COSB
32015 H(4) = -MZ*SINBPA/CW*(LMIXSS(5,1,1)*LMIXSS(5,1,2)*(HALF-SWEIN)
32016 & +SWEIN*LMIXSS(5,2,1)*LMIXSS(5,2,2))
32017 & +MLT(5)*HALF/COSB/MW*(MUSS*COSA+ALSS*SINA)*
32018 & (LMIXSS(5,2,2)*LMIXSS(5,1,1)+LMIXSS(5,1,2)*LMIXSS(5,2,1))
32019 H(7) = (H(7)-MLT(5)*HALF/MW/COSB*ALSS*COSA)*TWO*
32020 & LMIXSS(5,2,1)*LMIXSS(5,1,1)
32021 & +MZ*COSBPA/CW*(LMIXSS(5,1,1)**2*(HALF-SWEIN)
32022 & +LMIXSS(5,2,1)**2*SWEIN)-MLT(5)**2*COSA/MW/COSB
32023 H(8) = MZ*COSBPA/CW*(LMIXSS(5,1,2)*LMIXSS(5,1,1)*(HALF-SWEIN)
32024 & +LMIXSS(5,2,2)*LMIXSS(5,2,1)*SWEIN)
32025 & +MLT(5)*HALF/MW/COSB*(MUSS*SINA-ALSS*COSA)*
32026 & (LMIXSS(5,2,2)*LMIXSS(5,1,1)+LMIXSS(5,1,2)*LMIXSS(5,2,1))
32027 H(12) = H(11)-MLT(5)*HALF/MW*ALSS*TANB
32028 H(11) = ZERO
32029C--Now the charged Higgs
32030 DO J=1,2
32031 DO I=1,3
32032 H(10+2*I+J) = LMIXSS(2*I-1,1,J)*
32033 & (MLT(2*I-1)**2*TANB-MW2*SIN2B)
32034 & +LMIXSS(2*I-1,2,J)*MLT(2*I-1)*MUSS
32035 ENDDO
32036 H(16+J) = H(16+J)+LMIXSS(5,2,J)*MLT(5)*ALSS*TANB
32037 ENDDO
32038C--End of fix
32039C--couplings of the Higgs to quarks
32040 DO I=1,3
32041 GUU(I) = GHUUSS(I)**2/MW2*HALF**2
32042 GDD(I) = GHDDSS(I)**2/MW2*HALF**2
32043 ENDDO
32044 GUU(4) = ONE/TANB**2/MW2/8.0D0
32045 GDD(4) = ONE*TANB**2/MW2/8.0D0
32046C--Couplings of the Z to quarks, left up right down, and charged sleptons
32047 ZQRK(1) = -SW**2/6.0D0/CW
32048 ZQRK(2) = (SW**2/3.0D0-HALF**2)/CW
32049 ZSLP(1) = HALF*(LMIXSS(5,1,1)**2-2.0D0*SW**2)/CW
32050 ZSLP(2) = HALF*LMIXSS(5,1,1)*LMIXSS(5,1,2)/CW
32051C--parameters for multichannel integration
32052 RAND = ZERO
32053 DO I=1,3
32054 CHPROB = ZERO
32055 DO J=1,3
32056 DO K=1,3
32057 CHPROB=CHPROB+LAMDA2(I,J,K)**2
32058 ENDDO
32059 ENDDO
32060 RAND = RAND+2*CHPROB
32061 DO J=1,2
32062 MXS(2*I-2+J) = LMIXSS(2*I-1,1,J)
32063 MXS(2*I+4+J) = LMIXSS(2*I,1,J)
32064 MXU(2*I-2+J) = QMIXSS(2*I,1,J)
32065 MXU(2*I+4+J) = QMIXSS(2*I-1,1,J)
32066 MXT(2*I-2+J) = QMIXSS(2*I-1,2,J)
32067 MXT(2*I+4+J) = QMIXSS(2*I-1,2,J)
32068 CHAN(2*I-2+J) = LMIXSS(2*I-1,1,J)**2*CHPROB
32069 CHAN(2*I+4+J) = LMIXSS(2*I,1,J)**2*CHPROB
32070 ENDDO
32071 ENDDO
32072 IF(RAND.GT.ZERO) THEN
32073 DO I=1,12
32074 CHAN(I)=CHAN(I)/RAND
32075 ENDDO
32076 ELSE
32077 CALL HWWARN('HWHRLS',500)
32078 ENDIF
32079C--decide what processes to generate
32080 RAD = .FALSE.
32081 NEUT = .FALSE.
32082 CHAR = .FALSE.
32083 HIGGS = .FALSE.
32084 NEUTMN= 1
32085 NEUTMX = 4
32086 CHARMN = 1
32087 CHARMX = 2
32088C--Decide which process to generate
32089 IF(MOD(IPROC,10000).EQ.4000) THEN
32090 RAD = .TRUE.
32091 NEUT = .TRUE.
32092 CHAR = .TRUE.
32093 HIGGS = .TRUE.
32094 ELSEIF(MOD(IPROC,10000).LT.4020) THEN
32095 IF(MOD(IPROC,10000).NE.4010) THEN
32096 NEUTMN = MOD(IPROC,10)
32097 NEUTMX = NEUTMN
32098 ENDIF
32099 NEUT=.TRUE.
32100 ELSEIF(MOD(IPROC,10000).LT.4030) THEN
32101 IF(MOD(IPROC,10000).NE.4020) THEN
32102 CHARMN = MOD(IPROC,10)
32103 CHARMX=CHARMN
32104 ENDIF
32105 CHAR = .TRUE.
32106 ELSEIF(MOD(IPROC,10000).EQ.4040) THEN
32107 RAD = .TRUE.
32108 ELSEIF(MOD(IPROC,10000).EQ.4050) THEN
32109 HIGGS = .TRUE.
32110 ENDIF
32111 ENDIF
32112C--basic parameters
32113 EVWGT = ZERO
32114 S = PHEP(5,3)**2
32115 COSTH = HWRUNI(0,-ONE,ONE)
32116 RAND = HWRUNI(0,ZERO,ONE)
32117C--zero arrays
32118 DO I=1,6
32119 DO J=1,3
32120 DO K=1,3
32121 DO L=1,2
32122 MEN(L,I,J,K) = ZERO
32123 MEN(L+2,I,J,K) = ZERO
32124 MEC(L,I,J,K) = ZERO
32125 ENDDO
32126 ENDDO
32127 ENDDO
32128 ENDDO
32129 DO I=1,8
32130 MER(I)=ZERO
32131 ENDDO
32132C--Perform multichannel integration
32133 DO I=1,12
32134 IF(CHAN(I).GT.RAND) THEN
32135 GR=I
32136 GOTO 25
32137 ENDIF
32138 RAND=RAND-CHAN(I)
32139 ENDDO
32140C--Calculate the hard scale and obtain parton distributions
32141 25 TAUA = MSL2(GR)/S
32142 TAUB = SLWD(GR)**2/S
32143 RTAB = SQRT(TAUA*TAUB)
32144 XUPP = XMAX
32145 IF(XMAX**2.GT.S) XUPP = SQRT(S)
32146 LOWTLM = DATAN((XMIN**2/S-TAUA)/RTAB)/RTAB
32147 UPPTLM = DATAN((XUPP**2/S-TAUA)/RTAB)/RTAB
32148 TAU = HWRUNI(0,LOWTLM,UPPTLM)
32149 TAU = RTAB*TAN(RTAB*TAU)+TAUA
32150 SH = S*TAU
32151 SQSH = SQRT(SH)
32152 EMSCA = SQSH
32153 XX(1) = EXP(HWRUNI(0,LOG(TAU),ZERO))
32154 XX(2) = TAU/XX(1)
32155 CALL HWSGEN(.FALSE.)
32156C--EM and Weak couplings
32157 EC = SQRT(4*PIFAC*HWUAEM(SH))
32158 G = EC/SW
32159C--Calculate the prefactor due multichannel approach
32160 FAC = ZERO
32161 DO GN=1,12
32162 SCF(GN)=1/((SH-MSL2(GN))**2+MSWD(GN)**2)
32163 FAC=FAC+CHAN(GN)*SCF(GN)
32164 ENDDO
32165 FAC=-(UPPTLM-LOWTLM)*GEV2NB*LOG(TAU)/
32166 & (48*TAU*FAC*PIFAC*S**2*SH*SQSH)
32167 ENDIF
32168 HCS = ZERO
32169C--First we do the neutralino production
32170 IF(.NOT.NEUT) GOTO 200
32171 DO 140 GN=1,6
32172 I=GN
32173 GR = 2*GN-1
32174 I1 = 2*GN-1
32175 IF(GN.GT.3) THEN
32176 I=I-3
32177 I1=I1-5
32178 ENDIF
32179 IF(CHAN(GR).LT.EPS) GOTO 140
32180 DO 130 L=NEUTMN,NEUTMX
32181 MN = MNT(L)
32182 MNS = MN**2
32183 ML = MLT(I1)
32184 MLS = ML**2
32185 IF((ML+MN).GT.SQSH) GOTO 130
32186C--that and uhat
32187 PCM = SQRT((SH-(ML+MN)**2)*(SH-(ML-MN)**2))*HALF/SQSH
32188 ECM = SQRT(PCM**2+MLS)
32189 TH = MLS-SQSH*(ECM-PCM*COSTH)
32190 UH = MLS-SQSH*(ECM+PCM*COSTH)
32191 DO J=1,3
32192 DO 120 K=1,3
32193 IF(ABS(LAMDA2(I,J,K)).LT.EPS) GOTO 120
32194 J1 = 2*J
32195 K1 = 2*K+5
32196 IF(GN.GT.3) J1=J1-1
32197 IF(GENEV) GOTO 110
32198C--squarks in u and t channels
32199 GU = 6*INT((GN-1)/3)+2*J-1
32200 GT = 2*K
32201C--calulate the matrix element
32202 ME2=MXS(GR)**2*SCF(GR)*SH*((SH-MLS-MNS)*
32203 & (A(L,GR)**2+B(L,GR)**2)-4*ML*MN*A(L,GR)*B(L,GR))
32204 & +MXU(GU)**2*(MLS-UH)*(MNS-UH)*
32205 & (C(1,L,GU)**2+D(1,L,GU)**2)/(UH-MSU(GU))**2
32206 & +MXT(GT)**2*(MLS-TH)*(MNS-TH)*
32207 & (C(2,L,GT)**2+D(2,L,GT)**2)/(TH-MST(GT))**2
32208 & -TWO*MXT(GT)*MXU(GU)*C(1,L,GU)*C(2,L,GT)*(MLS*MNS-UH*TH)
32209 & /(UH-MSU(GU))/(TH-MST(GT))
32210 & +TWO*MXS(GR)*MXU(GU)*(SH-MSL2(GR))*SCF(GR)*C(1,L,GU)*
32211 & SH*(UH*A(L,GR)+ML*MN*B(L,GR))/(UH-MSU(GU))
32212 & +TWO*MXS(GR)*MXT(GT)*(SH-MSL2(GR))*SCF(GR)*C(2,L,GT)*
32213 & SH*(TH*A(L,GR)+ML*MN*B(L,GR))/(TH-MST(GT))
32214C--s channel mixing L/R mixing
32215 IF(ABS(MXS(GR+1)).GT.EPS) THEN
32216 ME2=ME2+MXS(GR+1)**2*SCF(GR+1)*SH*((SH-MLS-MNS)*
32217 & (A(L,GR+1)**2+B(L,GR+1)**2)
32218 & -4*ML*MN*A(L,GR+1)*B(L,GR+1))
32219 & +TWO*MXS(GR)*MXS(GR+1)*SCF(GR)*SCF(GR+1)*
32220 & ((SH-MSL2(GR))*(SH-MSL2(GR+1))+
32221 & MSWD(GR)*MSWD(GR+1))*SH*
32222 & ((SH-MLS-MNS)*(A(L,GR)*A(L,GR+1)+B(L,GR)*B(L,GR+1))
32223 & -2*ML*MN*(A(L,GR)*B(L,GR+1)+A(L,GR+1)*B(L,GR)))
32224 & +TWO*MXS(GR+1)*MXU(GU)*(SH-MSL2(GR+1))*SCF(GR+1)*
32225 & SH*C(1,L,GU)*(UH*A(L,GR+1)+ML*MN*B(L,GR+1))
32226 & /(UH-MSU(GU))
32227 & +TWO*MXS(GR+1)*MXT(GT)*(SH-MSL2(GR+1))*SCF(GR+1)*
32228 & SH*C(2,L,GT)*(TH*A(L,GR+1)+ML*MN*B(L,GR+1))
32229 & /(TH-MST(GT))
32230 IF(ABS(MXU(GU+1)).GT.EPS) ME2=ME2+TWO*MXS(GR+1)*MXU(GU+1)*
32231 & (SH-MSL2(GR+1))*SCF(GR+1)*SH*C(1,L,GU+1)*
32232 & (UH*A(L,GR+1)+ML*MN*B(L,GR+1))/(UH-MSU(GU+1))
32233 IF(ABS(MXT(GT-1)).GT.EPS) ME2=ME2+TWO*MXS(GR+1)*MXT(GT-1)*
32234 & (SH-MSL2(GR+1))*SCF(GR+1)*SH*C(2,L,GT-1)*
32235 & (TH*A(L,GR+1)+ML*MN*B(L,GR+1))/(TH-MST(GT-1))
32236 ENDIF
32237C--u channel L/R mixing
32238 IF(ABS(MXU(GU+1)).GT.EPS) THEN
32239 ME2=ME2+MXU(GU+1)**2*(MLS-UH)*(MNS-UH)*(C(1,L,GU+1)**2+
32240 & D(1,L,GU+1)**2)/(UH-MSU(GU+1))**2
32241 & +TWO*MXU(GU)*MXU(GU+1)*(MLS-UH)*(MNS-UH)*
32242 & (C(1,L,GU)*C(1,L,GU+1)+D(1,L,GU)*D(1,L,GU+1))
32243 & /(UH-MSU(GU))/(UH-MSU(GU+1))
32244 & -TWO*MXT(GT)*MXU(GU+1)*C(1,L,GU+1)*C(2,L,GT)*
32245 & (MLS*MNS-UH*TH)/(UH-MSU(GU+1))/(TH-MST(GT))
32246 & +TWO*MXS(GR)*MXU(GU+1)*(SH-MSL2(GR))*SCF(GR)*
32247 & SH*C(1,L,GU+1)*(UH*A(L,GR)+ML*MN*B(L,GR))
32248 & /(UH-MSU(GU+1))
32249 IF(ABS(MXT(GT-1)).GT.EPS) ME2=ME2-TWO*MXT(GT-1)*MXU(GU+1)*
32250 & C(1,L,GU+1)*C(2,L,GT-1)*(MLS*MNS-UH*TH)
32251 & /(UH-MSU(GU+1))/(TH-MST(GT-1))
32252 ENDIF
32253C--t channel L/R mixing
32254 IF(ABS(MXT(GT-1)).GT.EPS) THEN
32255 ME2=ME2+MXT(GT-1)**2*(MLS-TH)*(MNS-TH)*(C(2,L,GT-1)**2
32256 & +D(2,L,GT-1)**2)/(TH-MST(GT-1))**2
32257 & +TWO*MXT(GT)*MXT(GT-1)*(MLS-TH)*(MNS-TH)*
32258 & (C(2,L,GT)*C(2,L,GT-1)+D(2,L,GT)*D(2,L,GT-1))
32259 & /(TH-MST(GT))/(TH-MST(GT-1))
32260 & -TWO*MXT(GT-1)*MXU(GU)*C(1,L,GU)*C(2,L,GT-1)*
32261 & (MLS*MNS-UH*TH)/(UH-MSU(GU))/(TH-MST(GT-1))
32262 & +TWO*MXS(GR)*MXT(GT-1)*(SH-MSL2(GR))*SCF(GR)*
32263 & SH*C(2,L,GT-1)*(TH*A(L,GR)+ML*MN*B(L,GR))
32264 & /(TH-MST(GT-1))
32265 ENDIF
32266C--multiply by lamda and factors
32267 MEN(L,GN,J,K) = FAC*ME2*EC**2*LAMDA2(I,J,K)**2*PCM
32268 110 I2=I1+6
32269 HCS = HCS+MEN(L,GN,J,K)*DISF(J1,1)*DISF(K1,2)
32270 IF(GENEV.AND.HCS.GT.RCS) THEN
32271 CALL HWHRSS(11,J1,K1,I2,L,0,0)
32272 GOTO 500
32273 ENDIF
32274 HCS = HCS+MEN(L,GN,J,K)*DISF(K1,1)*DISF(J1,2)
32275 IF(GENEV.AND.HCS.GT.RCS) THEN
32276 CALL HWHRSS(12,K1,J1,I2,L,0,0)
32277 GOTO 500
32278 ENDIF
32279 HCS = HCS+MEN(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2)
32280 IF(GENEV.AND.HCS.GT.RCS) THEN
32281 CALL HWHRSS(11,J1,K1,I2,L,1,0)
32282 GOTO 500
32283 ENDIF
32284 HCS = HCS+MEN(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2)
32285 IF(GENEV.AND.HCS.GT.RCS) THEN
32286 CALL HWHRSS(12,K1,J1,I2,L,1,0)
32287 GOTO 500
32288 ENDIF
32289 120 CONTINUE
32290 ENDDO
32291 130 CONTINUE
32292 140 CONTINUE
32293 200 IF(.NOT.CHAR) GOTO 300
32294C--Chargino production
32295 DO 240 GN=1,6
32296 GR=2*GN-1
32297 I=GN
32298 I1 = 2*GN
32299 IF(GN.GT.3) THEN
32300 I1=I1-7
32301 I=GN-3
32302 ENDIF
32303 IF(CHAN(GR).LT.EPS) GOTO 240
32304 DO 230 L=CHARMN,CHARMX
32305 MN = MCR(L)
32306 MNS = MN**2
32307 ML = MLT(I1)
32308 MLS = ML**2
32309 SP = L+4
32310 IF((ML+MN).GT.EMSCA) GOTO 230
32311 PCM = SQRT((SH-(ML+MN)**2)*(SH-(ML-MN)**2))*HALF/SQSH
32312 ECM = SQRT(PCM**2+MLS)
32313 TH = MLS-SQSH*(ECM-PCM*COSTH)
32314 UH = MLS-SQSH*(ECM+PCM*COSTH)
32315 DO J=1,3
32316 DO 220 K=1,3
32317 IF(ABS(LAMDA2(I,J,K)).LT.EPS) GOTO 220
32318 J1=2*J
32319 K1=2*K+5
32320 IF(GN.GT.3) J1=J1-1
32321 IF(GENEV) GOTO 210
32322 GU = 2*J-1
32323 IF(GN.LE.3) GU=GU+6
32324C--Calculate the matrix element, s and u terms
32325 ME2 =MXS(GR)**2*SCF(GR)*SH*(
32326 & (SH-MLS-MNS)*(A(SP,GR)**2+B(SP,GR)**2)
32327 & -4*ML*MN*A(SP,GR)*B(SP,GR))
32328 & +MXU(GU)**2*(MLS-UH)*(MNS-UH)*
32329 & (C(1,SP,GU)**2+D(1,SP,GU)**2)/(UH-MSU(GU))**2
32330 & -2*MXS(GR)*MXU(GU)*(SH-MSL2(GR))*SCF(GR)*C(1,SP,GU)*
32331 & SH*(UH*A(SP,GR)+B(SP,GR)*ML*MN)/(UH-MSU(GU))
32332C--s channel L/R mixing
32333 IF(ABS(MXS(GR+1)).GT.EPS) THEN
32334 ME2=ME2+MXS(GR+1)**2*SCF(GR+1)*SH*((SH-MLS-MNS)*
32335 & (A(SP,GR+1)**2+B(SP,GR+1)**2)
32336 & -4*ML*MN*A(SP,GR+1)*B(SP,GR+1))
32337 & +2*MXS(GR)*MXS(GR+1)*SCF(GR)*SCF(GR+1)*
32338 & ((SH-MSL2(GR))*(SH-MSL2(GR+1))+
32339 & MSWD(GR)*MSWD(GR+1))*SH*
32340 & ((SH-MLS-MNS)*(A(SP,GR)*A(SP,GR+1)
32341 & +B(SP,GR)*B(SP,GR+1))-4*ML*MN*
32342 & (A(SP,GR)*B(SP,GR+1)+B(SP,GR)*A(SP,GR+1)))
32343 & -2*MXS(GR+1)*MXU(GU)*(SH-MSL2(GR+1))*SCF(GR+1)*SH*
32344 & C(1,SP,GU)*(UH*A(SP,GR+1)+B(SP,GR+1)*ML*MN)
32345 & /(UH-MSU(GU))
32346 IF(ABS(MXU(GU+1)).GT.EPS) ME2=ME2-2*MXS(GR+1)*MXU(GU+1)*
32347 & (SH-MSL2(GR+1))*SCF(GR+1)*C(1,SP,GU+1)*SH*
32348 & (UH*A(SP,GR+1)+B(SP,GR+1)*ML*MN)/(UH-MSU(GU+1))
32349 ENDIF
32350C--u channel L/R mixing
32351 IF(ABS(MXU(GU+1)).GT.EPS) ME2 = ME2+MXU(GU+1)**2*(MLS-UH)*
32352 & (MNS-UH)*(C(1,SP,GU+1)**2+D(1,SP,GU+1)**2)
32353 & /(UH-MSU(GU+1))**2
32354 & +2*MXU(GU)*MXU(GU+1)*(MLS-UH)*(MNS-UH)*
32355 & (C(1,SP,GU)*C(1,SP,GU+1)+D(1,SP,GU)*D(1,SP,GU+1))
32356 & /(UH-MSU(GU))/(UH-MSU(GU+1))
32357 & -2*MXS(GR)*MXU(GU+1)*(SH-MSL2(GR))*SCF(GR)*SH*
32358 & C(1,SP,GU+1)*(UH*A(SP,GR)+B(SP,GR)*ML*MN)
32359 & /(UH-MSU(GU+1))
32360 MEC(L,GN,J,K) = FAC*ME2*G**2*LAMDA2(I,J,K)**2*PCM*HALF
32361 210 I2 = I1+6
32362 P = L+4
32363 HCS = HCS+MEC(L,GN,J,K)*DISF(J1,1)*DISF(K1,2)
32364 IF(GN.GT.3) P = P+2
32365 IF(GENEV.AND.HCS.GT.RCS) THEN
32366 CALL HWHRSS(11,J1,K1,I2,P,0,0)
32367 GOTO 500
32368 ENDIF
32369 HCS = HCS+MEC(L,GN,J,K)*DISF(K1,1)*DISF(J1,2)
32370 IF(GENEV.AND.HCS.GT.RCS) THEN
32371 CALL HWHRSS(12,K1,J1,I2,P,0,0)
32372 GOTO 500
32373 ENDIF
32374 HCS = HCS+MEC(L,GN,J,K)*DISF(J1+6,1)*DISF(K1-6,2)
32375 IF(GENEV.AND.HCS.GT.RCS) THEN
32376 CALL HWHRSS(11,J1,K1,I2,P,1,0)
32377 GOTO 500
32378 ENDIF
32379 HCS = HCS+MEC(L,GN,J,K)*DISF(K1-6,1)*DISF(J1+6,2)
32380 IF(GENEV.AND.HCS.GT.RCS) THEN
32381 CALL HWHRSS(12,K1,J1,I2,P,1,0)
32382 GOTO 500
32383 ENDIF
32384 220 CONTINUE
32385 ENDDO
32386 230 CONTINUE
32387 240 CONTINUE
32388 300 IF(.NOT.RAD) GOTO 400
32389C--Radiative decays
32390 IF(GENEV) GOTO 320
32391 DO 310 GN=1,3
32392 I1= 2*GN+5
32393 I = 2*GN-1
32394C--charged slepton to sneutrino W
32395 IF(SQSH.GT.(MW+MSL(I1))) THEN
32396 PCM = SQRT((SH-(MW+MSL(I1))**2)*(SH-(MW-MSL(I1))**2))*HALF/SQSH
32397 ECM = SQRT(PCM**2+MW2)
32398 TH = MW2-SQSH*(ECM-PCM*COSTH)
32399 UH = MW2-SQSH*(ECM+PCM*COSTH)
32400 ME2 = MXS(I)**4*SCF(I)*SH**2*PCM**2
32401 & +HALF**2/TH**2*(TWO*MW2*(UH*TH-MSL2(I1)*MW2)+TH**2*SH)
32402 & -HALF*MXS(I)**2*SH*(SH-MSL2(I))*SCF(I)/TH*
32403 & (MW2*(TWO*MSL2(I1)-TH)+(SH-MSL2(I1))*TH)
32404 IF(GN.EQ.3) ME2 = ME2+MXS(I+1)**4*SCF(I+1)*SH**2*PCM**2
32405 & +2.0D0*MXS(I)**2*MXS(I+1)**2*SCF(I)*SCF(I+1)*SH**2*PCM**2
32406 & *((SH-MSL2(I))*(SH-MSL2(I+1))+MSWD(I)*MSWD(I+1))
32407 & -HALF*MXS(I+1)**2*SH*(SH-MSL2(I+1))*SCF(I+1)/TH*
32408 & (MW2*(TWO*MSL2(I1)-TH)+(SH-MSL2(I1))*TH)
32409 MER(GN) = ME2*PCM/MW2
32410 ENDIF
32411C--sneutrino to charged slepton W
32412 IF(SQSH.GT.(MW+MSL(I))) THEN
32413 PCM = SQRT((SH-(MW+MSL(I))**2)*(SH-(MW-MSL(I))**2))*HALF/SQSH
32414 ECM = SQRT(PCM**2+MW2)
32415 TH = MW2-SQSH*(ECM-PCM*COSTH)
32416 UH = MW2-SQSH*(ECM+PCM*COSTH)
32417 ME2 = MXS(I)**2*SCF(I1)*SH**2*PCM**2
32418 & +HALF**2*MXS(I)**2/TH**2*
32419 & (TWO*MW2*(UH*TH-MW2*MSL2(I))+TH**2*SH)
32420 & -HALF*MXS(I)**2*SH*(SH-MSL2(I1))*SCF(I1)/TH*
32421 & (MW2*(TWO*MSL2(I)-TH)+(SH-MSL2(I))*TH)
32422 MER(GN+4) = ME2*PCM/MW2
32423 ENDIF
32424 310 CONTINUE
32425C--now the decay stau_2 to stau_1 Z
32426 IF(SQSH.GT.(MZ+MSL(5))) THEN
32427 PCM = SQRT((SH-(MZ+MSL(5))**2)*(SH-(MZ-MSL(5))**2))*HALF/SQSH
32428 ECM = SQRT(PCM**2+MZ2)
32429 TH = MZ2-SQSH*(ECM-PCM*COSTH)
32430 UH = MZ2-SQSH*(ECM+PCM*COSTH)
32431 ME2 = SH**2*PCM**2*(SCF(5)*MXS(5)**2*ZSLP(1)**2
32432 & +SCF(6)*MXS(6)**2*ZSLP(2)**2+TWO*SCF(5)*SCF(6)*
32433 & MXS(5)*MXS(6)*ZSLP(1)*ZSLP(2)*((SH-MSL2(5))*
32434 & (SH-MSL2(6))+MSWD(5)*MSWD(6)))
32435 & +MXS(5)**2*ZQRK(2)**2/TH**2*
32436 & (TWO*MZ2*(UH*TH-MZ2*MSL2(5))+TH**2*SH)
32437 & +MXS(5)**2*ZQRK(1)**2/UH**2*
32438 & (TWO*MZ2*(UH*TH-MZ2*MSL2(5))+UH**2*SH)
32439 & +MXS(5)*SH*(MXS(5)*SCF(5)*ZSLP(1)*(SH-MSL2(5))
32440 & +MXS(6)*SCF(6)*ZSLP(2)*(SH-MSL2(6)))*
32441 & (-ZQRK(2)/TH*(MZ2*(TWO*MSL2(5)-TH)+TH*(SH-MSL2(5)))
32442 & +ZQRK(1)/UH*(MZ2*(TWO*MSL2(5)-UH)+UH*(SH-MSL2(5))))
32443 & +TWO*MXS(5)**2*ZQRK(1)*ZQRK(2)/UH/TH*
32444 & (TWO*MZ2*(MSL2(5)-UH)*(MSL2(5)-TH)-SH*UH*TH)
32445 MER(4) = TWO*ME2*PCM/MZ2
32446 ENDIF
32447C--now the decay tau sneutrino to tau_2 W
32448 IF(SQSH.GT.(MW+MSL(6))) THEN
32449 PCM = SQRT((SH-(MW+MSL(6))**2)*(SH-(MW-MSL(6))**2))*HALF/SQSH
32450 ECM = SQRT(PCM**2+MW2)
32451 TH = MW2-SQSH*(ECM-PCM*COSTH)
32452 UH = MW2-SQSH*(ECM+PCM*COSTH)
32453 ME2 = MXS(6)**2*SCF(11)*SH**2*PCM**2
32454 & +HALF**2*MXS(6)**2/TH**2*
32455 & (TWO*MW2*(UH*TH-MW2*MSL2(6))+TH**2*SH)
32456 & -HALF*MXS(6)**2*SH*(SH-MSL2(11))*SCF(11)/TH*
32457 & (MW2*(2*MSL2(6)-TH)+(SH-MSL2(6))*TH)
32458 MER(8) = ME2*PCM/MW2
32459 ENDIF
32460C--Multiply by the parton distributions
32461 320 DO I=1,4
32462 DO J=1,3
32463 DO 330 K=1,3
32464 IF(I.LE.3) THEN
32465 LC = LAMDA2(I,J,K)**2
32466 ELSE
32467 LC = LAMDA2(3,J,K)**2
32468 ENDIF
32469 IF(LC.LT.EPS) GOTO 330
32470 FAC2 = G**2*LC*FAC
32471C--radiative cross-sections
32472 J1=2*J
32473 K1=2*K+5
32474 ME2 = FAC2*MER(I)
32475 HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
32476 IF(GENEV.AND.HCS.GT.RCS) THEN
32477 CALL HWHRSS(13,J1,K1,I,I,0,0)
32478 GOTO 500
32479 ENDIF
32480 HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
32481 IF(GENEV.AND.HCS.GT.RCS) THEN
32482 CALL HWHRSS(14,K1,J1,I,I,0,0)
32483 GOTO 500
32484 ENDIF
32485 HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
32486 IF(GENEV.AND.HCS.GT.RCS) THEN
32487 CALL HWHRSS(13,J1,K1,I,I,1,0)
32488 GOTO 500
32489 ENDIF
32490 HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
32491 IF(GENEV.AND.HCS.GT.RCS) THEN
32492 CALL HWHRSS(14,K1,J1,I,I,1,0)
32493 GOTO 500
32494 ENDIF
32495 J1=2*J-1
32496 K1=2*K+5
32497 ME2 = FAC2*MER(I+4)
32498 HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
32499 IF(GENEV.AND.HCS.GT.RCS) THEN
32500 CALL HWHRSS(13,J1,K1,I+4,I+4,0,0)
32501 GOTO 500
32502 ENDIF
32503 HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
32504 IF(GENEV.AND.HCS.GT.RCS) THEN
32505 CALL HWHRSS(14,K1,J1,I+4,I+4,0,0)
32506 GOTO 500
32507 ENDIF
32508 HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
32509 IF(GENEV.AND.HCS.GT.RCS) THEN
32510 CALL HWHRSS(13,J1,K1,I+4,I+4,1,0)
32511 GOTO 500
32512 ENDIF
32513 HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
32514 IF(GENEV.AND.HCS.GT.RCS) THEN
32515 CALL HWHRSS(14,K1,J1,I+4,I+4,1,0)
32516 GOTO 500
32517 ENDIF
32518 330 CONTINUE
32519 ENDDO
32520 ENDDO
32521 400 IF(.NOT.HIGGS) GOTO 500
32522 IF(GENEV) GOTO 480
32523 DO I=1,3
32524 DO 405 J=1,18
32525 405 MEH(I,J) = ZERO
32526 ENDDO
32527C--Neutral higgs charged slepton
32528 DO 420 L=1,3
32529 DO 410 I=1,2
32530C--first two generations
32531 IF(SQSH.LT.MH(L)+MSL(2*I)) GOTO 410
32532 PCM = SQRT((SH-(MSL(2*I)+MH(L))**2)*
32533 & (SH-(MSL(2*I)-MH(L))**2))*HALF/SQSH
32534 MEH(1,3*L-3+I) = PCM*SH*SCF(2*I-1)*H(4*L+I-4)**2
32535 410 CONTINUE
32536C--third generation
32537 IF(SQSH.LT.MH(L)+MSL(5)) GOTO 420
32538 PCM = SQRT((SH-(MSL(5)+MH(L))**2)*
32539 & (SH-(MSL(5)-MH(L))**2))*HALF/SQSH
32540 ECM = SQRT(PCM**2+MH(L)**2)
32541 TH = MH(L)**2-SQSH*(ECM-PCM*COSTH)
32542 UH = MH(L)**2-SQSH*(ECM+PCM*COSTH)
32543 MEH(1,3*L) = PCM*SH*(MXS(5)**2*SCF(5)*H(4*L-1)**2
32544 & +MXS(6)**2*SCF(6)*H(4*L)**2
32545 & +TWO*MXS(5)*MXS(6)*SCF(5)*SCF(6)*H(4*L-1)*
32546 & H(4*L)*((SH-MSL2(5))*(SH-MSL2(6))+
32547 & MSWD(5)*MSWD(6)) )
32548 ME2 = MXS(5)**2*PCM*(UH*TH-MSL2(5)*MH(L)**2)
32549 MEH(2,3*L) =ME2*GUU(L)/TH**2
32550 MEH(3,3*L) =ME2*GDD(L)/UH**2
32551 420 CONTINUE
32552C--Charged higgs
32553 DO 440 I=1,3
32554C--charged slepton charged Higgs
32555 DO 430 J=1,2
32556 IF(SQSH.LT.(MH(4)+MSL(2*I-2+J))) GOTO 430
32557 PCM = SQRT((SH-(MH(4)+MSL(2*I-2+J))**2)*
32558 & (SH-(MH(4)-MSL(2*I-2+J))**2))*HALF/SQSH
32559 ECM = SQRT(PCM**2+MH(4)**2)
32560 TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
32561 UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
32562 MEH(1,2*I+J+7) = PCM*SH*HALF/MW2*H(2*I+J+10)**2*SCF(5+2*I)
32563 MEH(2,2*I+J+7) = PCM*GDD(4)*MXS(2*I-2+J)**2*
32564 & (UH*TH-MH(4)**2*MSL2(2*I-2+J))/TH**2
32565 430 CONTINUE
32566C--Sneutrino Charged Higgs
32567 IF(SQSH.LT.(MH(4)+MSL(2*I+5))) GOTO 440
32568 PCM = SQRT((SH-(MH(4)+MSL(2*I+5))**2)*
32569 & (SH-(MH(4)-MSL(2*I+5))**2))*HALF/SQSH
32570 ECM = SQRT(PCM**2+MH(4)**2)
32571 TH = MH(4)**2-SQSH*(ECM-PCM*COSTH)
32572 UH = MH(4)**2-SQSH*(ECM+PCM*COSTH)
32573 MEH(1,15+I) = PCM*SH*HALF/MW2*(
32574 & MXS(2*I-1)**2*SCF(2*I-1)*H(11+2*I)**2
32575 & +MXS(2*I)**2*SCF(2*I)*H(12+2*I)**2
32576 & +TWO*MXS(2*I-1)*MXS(2*I)*SCF(2*I-1)*
32577 & SCF(2*I)*H(11+2*I)*H(12+2*I)*
32578 & ((SH-MSL2(2*I-1))*(SH-MSL2(2*I))+
32579 & MSWD(2*I-1)*MSWD(2*I)))
32580 MEH(2,15+I) = PCM*GUU(4)*
32581 & (UH*TH-MH(4)**2*MSL2(2*I+5))/TH**2
32582 440 CONTINUE
32583C--Multiply by the parton distributions
32584 480 DO I=1,3
32585 DO J=1,3
32586 DO 490 K=1,3
32587 IF(LAMDA2(I,J,K).LT.EPS) GOTO 490
32588C--Higgs cross-sections
32589 J1=2*J
32590 K1=2*K+5
32591 FAC2 = G**2*LAMDA2(I,J,K)**2*FAC*HALF
32592 DO L=1,3
32593 ME2 = FAC2*(MEH(1,3*L-3+I)+RMASS(J1)**2*MEH(2,3*L-3+I)
32594 & +RMASS(K1)**2*MEH(3,3*L-3+I))
32595 HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
32596 IF(GENEV.AND.HCS.GT.RCS) THEN
32597 CALL HWHRSS(15,J1,K1,I,L,0,0)
32598 GOTO 500
32599 ENDIF
32600 HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
32601 IF(GENEV.AND.HCS.GT.RCS) THEN
32602 CALL HWHRSS(16,K1,J1,I,L,0,0)
32603 GOTO 500
32604 ENDIF
32605 HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
32606 IF(GENEV.AND.HCS.GT.RCS) THEN
32607 CALL HWHRSS(15,J1,K1,I,L,1,0)
32608 GOTO 500
32609 ENDIF
32610 HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
32611 IF(GENEV.AND.HCS.GT.RCS) THEN
32612 CALL HWHRSS(16,K1,J1,I,L,1,0)
32613 GOTO 500
32614 ENDIF
32615 ENDDO
32616 ME2 = FAC2*(MEH(1,15+I)+RMASS(J1)**2*MEH(2,15+I))
32617 HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
32618 IF(GENEV.AND.HCS.GT.RCS) THEN
32619 CALL HWHRSS(15,J1,K1,9+I,4,0,0)
32620 GOTO 500
32621 ENDIF
32622 HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
32623 IF(GENEV.AND.HCS.GT.RCS) THEN
32624 CALL HWHRSS(16,K1,J1,9+I,4,0,0)
32625 GOTO 500
32626 ENDIF
32627 HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
32628 IF(GENEV.AND.HCS.GT.RCS) THEN
32629 CALL HWHRSS(15,J1,K1,9+I,5,1,0)
32630 GOTO 500
32631 ENDIF
32632 HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
32633 IF(GENEV.AND.HCS.GT.RCS) THEN
32634 CALL HWHRSS(16,K1,J1,9+I,5,1,0)
32635 GOTO 500
32636 ENDIF
32637 J1=2*J-1
32638 K1=2*K+5
32639 DO L=2,3
32640 ME2 = FAC2*(MEH(1,2*I+L+6)+RMASS(J1)**2*MEH(2,2*I+L+6))
32641 HCS = HCS+ME2*DISF(J1,1)*DISF(K1,2)
32642 IF(GENEV.AND.HCS.GT.RCS) THEN
32643 CALL HWHRSS(15,J1,K1,2*I+L,5,0,0)
32644 GOTO 500
32645 ENDIF
32646 HCS = HCS+ME2*DISF(K1,1)*DISF(J1,2)
32647 IF(GENEV.AND.HCS.GT.RCS) THEN
32648 CALL HWHRSS(16,K1,J1,2*I+L,5,0,0)
32649 GOTO 500
32650 ENDIF
32651 HCS = HCS+ME2*DISF(J1+6,1)*DISF(K1-6,2)
32652 IF(GENEV.AND.HCS.GT.RCS) THEN
32653 CALL HWHRSS(15,J1,K1,2*I+L,4,1,0)
32654 GOTO 500
32655 ENDIF
32656 HCS = HCS+ME2*DISF(K1-6,1)*DISF(J1+6,2)
32657 IF(GENEV.AND.HCS.GT.RCS) THEN
32658 CALL HWHRSS(16,K1,J1,2*I+L,4,1,0)
32659 GOTO 500
32660 ENDIF
32661 ENDDO
32662 490 CONTINUE
32663 ENDDO
32664 ENDDO
32665C--Setup to generate the event
32666 500 IF(GENEV) THEN
32667 CALL HWETWO(.TRUE.,.TRUE.)
32668 ELSE
32669 EVWGT = HCS
32670 ENDIF
32671 END
32672CDECK ID>, HWHRSP.
32673*CMZ :- -20/07/99 10:56:12 by Peter Richardson
32674*-- Author : Peter Richardson
32675C-----------------------------------------------------------------------
32676 SUBROUTINE HWHRSP
32677C-----------------------------------------------------------------------
32678C Subroutine for all hadron-hadron Rparity violating processes
32679C-----------------------------------------------------------------------
c63d70bc 32680 INCLUDE 'herwig65.inc'
65767955 32681 IF(MOD(IPROC,10000).GE.4000.AND.MOD(IPROC,10000).LT.4060) THEN
32682C--SINGLE SPARTICLE VIA LQD
32683 CALL HWHRLS
32684 ELSEIF(MOD(IPROC,10000).GE.4060.AND.MOD(IPROC,10000).LT.4100) THEN
32685C--RESONANT SLEPTONS TO STANDARD MODEL VIA LQD
32686 CALL HWHRLL
32687 ELSEIF(MOD(IPROC,10000).GE.4100.AND.MOD(IPROC,10000).LT.4160) THEN
32688C--SINGLE SPARTICLE VIA UDD
32689 CALL HWHRBS
32690C--RESONANT SQUARKS TO STANDARD MODEL VIA UDD
32691 ELSEIF(MOD(IPROC,10000).EQ.4160) THEN
32692 CALL HWHRBB
32693 ELSE
32694C--UNKNOWN PROCESS
32695 CALL HWWARN('HWHRSP',500)
32696 ENDIF
32697 END
32698CDECK ID>, HWHRSS.
32699*CMZ :- -20/07/99 10:56:12 by Peter Richardson
32700*-- Author : Peter Richardson
32701C-----------------------------------------------------------------------
32702 SUBROUTINE HWHRSS(TYPE,ID1,ID2,ID3,ID4,R4,IPERM)
32703C-----------------------------------------------------------------------
32704C IDENTIDY HARD R-PARITY VIOLATING PROCESS
32705C-----------------------------------------------------------------------
c63d70bc 32706 INCLUDE 'herwig65.inc'
65767955 32707 INTEGER ID3, ID4, R4, IPERM,TYPE,ID1,ID2,NEUTD1(8),SLEPID(8),
32708 & NEUTD2(13),SQUID(6),SGN,HWUANT,SQUID2(12),SLPID2(12),
32709 & GAGID1(6),GAGID2(8)
32710 EXTERNAL HWUANT
32711 SAVE NEUTD1,NEUTD2,SLEPID,SQUID ,SQUID2,SLPID2,GAGID1,GAGID2
32712 DATA NEUTD1 /450,451,452,453,454,455,456,457/
32713 DATA NEUTD2 /449,449,449,450,451,452,453,454,455,456,457,454,455/
32714 DATA SLEPID /432,434,436,435,431,433,435,447/
32715 DATA SQUID /411,423,412,412,424,411/
32716 DATA SQUID2 /407,419,409,421,411,423,408,420,410,422,412,424/
32717 DATA SLPID2 /443,445,435,431,443,433,445,435,447,432,434,436/
32718 DATA GAGID1 /199,199,200,198,198,200/
32719 DATA GAGID2 /198,198,198,200,199,199,199,199/
32720 IDCMF = 15
32721 IF(IPERM.EQ.0) THEN
32722 ICO(1) = 2
32723 ICO(2) = 1
32724 ICO(3) = 3
32725 ICO(4) = 4
32726 ELSEIF(IPERM.EQ.1) THEN
32727 ICO(1) = 2
32728 ICO(2) = 1
32729 ICO(3) = 4
32730 ICO(4) = 3
32731 ELSEIF(IPERM.EQ.2) THEN
32732 ICO(1) = 3
32733 ICO(2) = 4
32734 ICO(3) = 1
32735 ICO(4) = 2
32736 ELSE
32737 CALL HWWARN('HWHRSS',100)
32738 GOTO 999
32739 ENDIF
32740 IF(TYPE.LE.8) THEN
32741 IDN(1) = ID1+R4*6
32742 IDN(2) = ID2+R4*6
32743 ELSE
32744 SGN = 1
32745 IF(MOD(TYPE,2).EQ.0) SGN = -1
32746 IDN(1) = ID1+R4*6*SGN
32747 IDN(2) = ID2-R4*6*SGN
32748 ENDIF
32749 IF(TYPE.LE.2) THEN
32750 IDN(3) = ID3+6*R4
32751 IDN(4) = ID4+6*R4
32752 ELSEIF(TYPE.GE.3.AND.TYPE.LE.4) THEN
32753 IDN(3) = ID3-R4*6
32754 IDN(4) = NEUTD2(ID4)
32755 ELSEIF(TYPE.GE.5.AND.TYPE.LE.6) THEN
32756 IDN(3) = GAGID1(ID3)
32757 IDN(4) = SQUID(ID4)-R4*6
32758 IF(R4.EQ.1) IDN(3) = HWUANT(IDN(3))
32759 ELSEIF(TYPE.GE.7.AND.TYPE.LE.8) THEN
32760 IDN(3) =202+ID3
32761 IDN(4) = SQUID2(ID4)-R4*6
32762 ELSEIF(TYPE.GE.9.AND.TYPE.LE.10) THEN
32763 IDN(3) = ID3+6*R4
32764 IDN(4) = ID4-6*R4
32765 IF(IPERM.EQ.2.AND.TYPE.EQ.10) THEN
32766 SGN=IDN(3)
32767 IDN(3) = IDN(4)
32768 IDN(4) = SGN
32769 ENDIF
32770 ELSEIF(TYPE.GE.11.AND.TYPE.LE.12) THEN
32771 IDN(3) = 120+ID3-R4*6
32772 IDN(4) = NEUTD1(ID4)
32773 IF(R4.EQ.1) IDN(4) = HWUANT(IDN(4))
32774 ELSEIF(TYPE.GE.13.AND.TYPE.LE.14) THEN
32775 IDN(3) = SLEPID(ID3)-R4*6
32776 IDN(4) = GAGID2(ID4)
32777 IF(R4.NE.0) IDN(4) = HWUANT(IDN(4))
32778 ELSEIF(TYPE.GE.15.AND.TYPE.LE.16) THEN
32779 IDN(3) = SLPID2(ID3)-R4*6
32780 IDN(4) = 202+ID4
32781 ENDIF
32782 IF(MOD(TYPE,2).EQ.0.AND.TYPE.NE.8) COSTH=-COSTH
32783 999 RETURN
32784 END
32785CDECK ID>, HWHSCT.
32786*CMZ :- -18/03/04 18.42.43 by Mike Seymour
32787*-- Author : Mike Seymour
32788C-----------------------------------------------------------------------
32789 SUBROUTINE HWHSCT(REPORT,FIRSTC,JMUEO,PTJIM)
32790C-----------------------------------------------------------------------
32791C RELABEL THE EVENT RECORD FOR EXTRA HARD SCATTERING,
32792C DO THE SCATTERING, PARTON SHOWER IT, AND CLEAN UP THE EVENT RECORD
32793C REPORT RETURNS THE OUTCOME:
32794C 0 = SUCCESSFUL
32795C 1 = FAILED DUE TO ERROR IN HARD SCATTERING GENERATION
32796C 2 = FAILED DUE TO ENERGY CONSERVATION IN HARD SCATTERING
32797C 3 = FAILED DUE TO ERROR IN PARTON EVOLUTION
32798C 4 = FAILED DUE TO ENERGY CONSERVATION IN PARTON EVOLUTION
32799C 5 = COMPLETELY FAILED (IERROR IS ALSO NON-ZERO TO CANCEL EVENT)
32800C FIRSTC IS AN INPUT FLAG THAT SAYS THAT THIS IS THE FIRST CALL
32801C OF THE EVENT
32802C JMUEO IS THE UNDERLYING EVENT OPTION: 1=>VETO EVENTS WITH M
32803C SCATTERS ABOVE PTMIN WITH PROBABILITY 1/(M+1)
32804C PTJIM IS THE MINIMUM TRANSVERSE MOMENTUM FOR ADDITIONAL SCATTERS
32805C-----------------------------------------------------------------------
c63d70bc 32806 INCLUDE 'herwig65.inc'
65767955 32807 DOUBLE PRECISION HWRGEN,HWRGET,HWRSET,WGT,PBOOST(5),RBOOST(3,3),
32808 $ WJMAX,PT,PTJIM,DUMMY,HWUPCM
32809 INTEGER IHEP,IBM,ITG,IBMN,ITGN,IBMT,ITGT,I,REPORT,NHARD,
32810 $ MYRN(2),TMPRN(2),JMUEO
32811 LOGICAL COL,FIRSTC,TMPFLG
32812 INTEGER IPRTMP
32813 EXTERNAL HWRGEN,HWRGET,HWRSET,HWUPCM
32814 SAVE WJMAX,MYRN,NHARD
32815 DATA WJMAX,MYRN,NHARD/0,004122,7679781,0/
32816 COL(I)=I.EQ.13 .OR. I.GE.1.AND.I.LE.6 .OR. I.GE.115.AND.I.LE.120
32817 REPORT=5
32818 IF (IERROR.NE.0) RETURN
32819C---RESET THE COUNTER FOR HARD SCATTERS ON THE FIRST CALL
32820 IF (FIRSTC) NHARD=0
32821C---FIND BEAM AND TARGET REMNANTS
32822 CALL HWHREM(IBM,ITG)
32823 IF (IERROR.NE.0) RETURN
32824C---RECALCULATE THEIR MASS CORRECTLY
32825 CALL HWUMAS(PHEP(1,IBM))
32826 CALL HWUMAS(PHEP(1,ITG))
32827C---SET UP NEW ENTRIES IN THE EVENT RECORD
32828 NHEP=NHEP+1
32829 CALL HWVEQU(5,PHEP(1,IBM),PHEP(1,NHEP))
32830 ISTHEP(NHEP)=3
32831 IBMN=NHEP
32832 IBMT=JDAHEP(1,1)
32833 IF (IBMT.EQ.0) THEN
32834 JMOHEP(1,NHEP)=1
32835 IDHW(NHEP)=72
32836 ELSE
32837 JMOHEP(1,NHEP)=IBMT
32838 IDHW(NHEP)=71
32839 ENDIF
32840 JMOHEP(2,NHEP)=0
32841 JDAHEP(1,NHEP)=0
32842 JDAHEP(2,NHEP)=0
32843 IDHEP(NHEP)=IDPDG(IDHW(NHEP))
32844 NHEP=NHEP+1
32845 CALL HWVEQU(5,PHEP(1,ITG),PHEP(1,NHEP))
32846 ISTHEP(NHEP)=3
32847 ITGN=NHEP
32848 ITGT=JDAHEP(1,2)
32849 IF (ITGT.EQ.0) THEN
32850 JMOHEP(1,NHEP)=2
32851 IDHW(NHEP)=72
32852 ELSE
32853 JMOHEP(1,NHEP)=ITGT
32854 IDHW(NHEP)=71
32855 ENDIF
32856 JMOHEP(2,NHEP)=0
32857 JDAHEP(1,NHEP)=0
32858 JDAHEP(2,NHEP)=0
32859 IDHEP(NHEP)=IDPDG(IDHW(NHEP))
32860C---BOOST TO THEIR CENTRE-OF-MASS FRAME
32861 CALL HWVSUM(4,PHEP(1,IBMN),PHEP(1,ITGN),PBOOST)
32862 CALL HWUMAS(PBOOST)
32863 DO 100 IHEP=IBMN,NHEP
32864 CALL HWULOF(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
32865 100 CONTINUE
32866 CALL HWUROT(PHEP(1,IBMN),ONE,ZERO,RBOOST)
32867 DO 110 IHEP=IBMN,NHEP
32868 CALL HWUROF(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
32869 110 CONTINUE
32870C---PERFORM A SEARCH FOR THE MAXIMUM WEIGHT, IF IT IS NOT YET FOUND
32871 IF (WJMAX.EQ.0) THEN
32872C---USING LOCAL RANDOM NUMBER SEEDS
32873 DUMMY=HWRGET(TMPRN)
32874 DUMMY=HWRSET(MYRN)
32875 GENEV=.FALSE.
32876 DO I=1,IBSH
32877 CALL HWHSCU(WGT,PTJIM)
32878 WJMAX=MAX(WJMAX,WGT)
32879 ENDDO
32880 WRITE (6,'(A,G12.4)') ' Jimmy search for maximum weight=',WJMAX
32881 DUMMY=HWRGET(MYRN)
32882 DUMMY=HWRSET(TMPRN)
32883C---BECAUSE OF THE ENERGY DEPENDENCE, LEAVE LOTS OF SAFETY MARGIN
32884 WJMAX=WJMAX*2
32885 ENDIF
32886C---GENERATE A NEW HARD SCATTERING
32887 5 GENEV=.FALSE.
32888 10 CALL HWHSCU(WGT,PTJIM)
32889 IF (WGT.GT.WJMAX) THEN
32890 WRITE (6,'(A,G12.4/A,G12.4,A,G12.4)')
32891 $ ' Jimmy maximum weight exceeded! SQRT(S)=',PHEP(5,3),
32892 $ ' Increasing from ',WJMAX,' to ',WGT*2
32893 WJMAX=WGT*2
32894 ENDIF
32895 IF (WGT.LE.WJMAX*HWRGEN(0)) GOTO 10
32896 GENEV=.TRUE.
32897 CALL HWHSCU(WGT,PTJIM)
32898C---IF ADDING LOW PT SCATTERS TO HIGH PT EVENTS ADD AN EXTRA VETO ON
32899C SCATTERS THAT HAPPEN TO BE HIGH PT
32900 TMPFLG=.FALSE.
32901 IF (JMUEO.EQ.1) THEN
32902C---FIRST RECONSTRUCT THE PT THAT WAS GENERATED IN THE SCATTERING
32903 PT=SQRT(PHEP(1,NHEP)**2+PHEP(2,NHEP)**2)*
32904 $ SQRT(XX(1)*XX(2))*PHEP(5,3)
32905 $ /(2*HWUPCM(PHEP(5,NHEP-2),PHEP(5,NHEP-1),PHEP(5,NHEP)))
32906C---IF IT IS ABOVE THE TRIGGER THRESHOLD APPLY THE VETO
32907 IF (PT.GT.PTMIN) THEN
32908 IF ((NHARD+2)*HWRGEN(1).LT.1) THEN
32909 NHEP=IBMN-1
32910 GOTO 5
32911 ENDIF
32912 TMPFLG=.TRUE.
32913 ENDIF
32914 ENDIF
32915C---IF MOMENTUM CANNOT BE CONSERVED, STOP GENERATING HARD SCATTERS
32916 IF ( PHEP(4,IBMN+2) .GT. PHEP(4,IBMN).OR.
32917 $ PHEP(4,ITGN+2) .GT. PHEP(4,ITGN).OR.
32918 $ PHEP(3,IBMN+2) .GT. PHEP(3,IBMN).OR.
32919 $ -PHEP(3,ITGN+2) .GT.-PHEP(3,ITGN).OR.IERROR.NE.0) THEN
32920 IF (IERROR.GT.0) THEN
32921 WRITE (6,'(A/A)')
32922 $ ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS',
32923 $ ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL'
32924 REPORT=1
32925 ELSE
32926 REPORT=2
32927 ENDIF
32928 NHEP=IBMN-1
32929 IERROR=0
32930 RETURN
32931 ENDIF
32932C---RELABEL OUTGOING REMNANTS AS INCOMING HADRONS
32933 JDAHEP(1,1)=IBMN
32934 JDAHEP(1,2)=ITGN
32935C---EVOLVE THEM
32936 ISLENT=-1
32937C---SAVE THE CURRENT PROCESS TYPE, AND SWITCH TO
32938C QCD SCATTERING TO AVOID PROBLEMS WITH THE
32939C PARTON SHOWER.
32940 IPRTMP=IPRO
32941 IPRO=15
32942 CALL HWBGEN
32943 IPRO=IPRTMP
32944 ISLENT=1
32945C---PUT THE LABELS BACK
32946 JDAHEP(1,1)=IBMT
32947 JDAHEP(1,2)=ITGT
32948C---IF THERE WERE ANY PROBLEMS, STOP GENERATING HARD SCATTERS
32949 IF (IERROR.NE.0) THEN
32950 IF (IERROR.GT.0) THEN
32951 WRITE (6,'(A/A)')
32952 $ ' THIS ERROR OCCURED DURING A SECONDARY SCATTER AND WAS',
32953 $ ' CAUGHT BY HWHSCT, SO EVENT IS NOT KILLED AFTER ALL'
32954 REPORT=3
32955 ELSE
32956 REPORT=4
32957 ENDIF
32958 NHEP=IBMN-1
32959 IERROR=0
32960 RETURN
32961 ENDIF
32962C---UNDO THE LORENTZ BOOST
32963 DO 200 IHEP=IBMN,NHEP
32964 CALL HWUROB(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
32965 CALL HWULOB(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
32966 200 CONTINUE
32967C---FIND THE NEW BEAM AND TARGET REMNANTS
32968 ISTHEP(IBM)=3
32969 ISTHEP(ITG)=3
32970 CALL HWHREM(IBMN,ITGN)
32971 IF (IERROR.NE.0) RETURN
32972C---CONNECT UP THE COLOUR/FLAVOUR LINES OF THE TWO SCATTERS
32973 IDHW(IBMN)=IDHW(IBM)
32974 IDHEP(IBMN)=IDHEP(IBM)
32975 IF (COL(IDHW(IBM))) THEN
32976 JMOHEP(2,JDAHEP(2,IBMN))=JMOHEP(2,IBM)
32977 JDAHEP(2,JMOHEP(2,IBM))=JDAHEP(2,IBMN)
32978 JDAHEP(2,IBMN)=JDAHEP(2,IBM)
32979 JMOHEP(2,JDAHEP(2,IBM))=IBMN
32980 ELSE
32981 JDAHEP(2,JMOHEP(2,IBMN))=JDAHEP(2,IBM)
32982 JMOHEP(2,JDAHEP(2,IBM))=JMOHEP(2,IBMN)
32983 JMOHEP(2,IBMN)=JMOHEP(2,IBM)
32984 JDAHEP(2,JMOHEP(2,IBM))=IBMN
32985 ENDIF
32986 JMOHEP(2,IBM)=0
32987 JDAHEP(1,IBM)=IBMN
32988 JDAHEP(2,IBM)=0
32989 IDHW(ITGN)=IDHW(ITG)
32990 IDHEP(ITGN)=IDHEP(ITG)
32991 IF (COL(IDHW(ITG))) THEN
32992 JMOHEP(2,JDAHEP(2,ITGN))=JMOHEP(2,ITG)
32993 JDAHEP(2,JMOHEP(2,ITG))=JDAHEP(2,ITGN)
32994 JDAHEP(2,ITGN)=JDAHEP(2,ITG)
32995 JMOHEP(2,JDAHEP(2,ITG))=ITGN
32996 ELSE
32997 JDAHEP(2,JMOHEP(2,ITGN))=JDAHEP(2,ITG)
32998 JMOHEP(2,JDAHEP(2,ITG))=JMOHEP(2,ITGN)
32999 JMOHEP(2,ITGN)=JMOHEP(2,ITG)
33000 JDAHEP(2,JMOHEP(2,ITG))=ITGN
33001 ENDIF
33002 JMOHEP(2,ITG)=0
33003 JDAHEP(1,ITG)=ITGN
33004 JDAHEP(2,ITG)=0
33005C---LOOK FOR COLOUR SINGLET GLUONS (A RARE BUT ANNOYING SPECIAL CASE)
33006 DO 20 IHEP=1,NHEP
33007 IF (IDHW(IHEP).EQ.13.AND.JMOHEP(2,IHEP).EQ.IHEP) THEN
33008 CALL HWWARN('HWHSCT',120)
33009 GOTO 999
33010 ENDIF
33011 20 CONTINUE
33012 REPORT=0
33013 IF (TMPFLG) NHARD=NHARD+1
33014 999 RETURN
33015 END
33016CDECK ID>, HWHSCU
33017*CMZ :- -17/03/04 14.37.43 by Mike Seymour
33018*-- Author : Mike Seymour
33019C-----------------------------------------------------------------------
33020 SUBROUTINE HWHSCU(WGT,PTJIM)
33021C-----------------------------------------------------------------------
33022C SWAP THE HARD PROCESS GENERATION PARAMETERS,
33023C CALL HWHQCD, AND SWAP BACK
33024C WGT IS THE OUTPUT EVENT WEIGHT
33025C-----------------------------------------------------------------------
c63d70bc 33026 INCLUDE 'herwig65.inc'
65767955 33027 DOUBLE PRECISION WGT,PTJIM,XMIN,XMAX,XPOW,
33028 $ TMPXMN,TMPXMX,TMPXPW,TMPWGT
33029 LOGICAL FIRST
33030 COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
33031C---STORE THE CURRENT VALUES
33032 TMPWGT=EVWGT
33033 TMPXMN=XMIN
33034 TMPXMX=XMAX
33035 TMPXPW=XPOW
33036C---REPLACE BY NEW ONES
33037 XMIN=2*PTJIM
33038 XMAX=2*SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
33039 XPOW=-4D0
33040C---AND ENSURE THAT HWRPOW GETS REINITIALIZED
33041 FIRST=.TRUE.
33042C---GENERATE A PHASE SPACE POINT
33043 CALL HWHQCD
33044 IF (IERROR.NE.0.OR.EVWGT.LT.0) THEN
33045 IERROR=0
33046 EVWGT=0
33047 ENDIF
33048 WGT=EVWGT
33049C---PUT THE OLD VALUES BACK
33050 EVWGT=TMPWGT
33051 XMIN=TMPXMN
33052 XMAX=TMPXMX
33053 XPOW=TMPXPW
33054C---AND AGAIN ENSURE THAT HWRPOW GETS REINITIALIZED
33055 FIRST=.TRUE.
33056C---INCLUDE GAMWT HERE
33057 WGT=WGT*GAMWT
33058 END
33059CDECK ID>, HWHSNG.
33060*CMZ :- -20/09/95 14.59.15 by Mike Seymour
33061*-- Author : Mike Seymour
33062C-----------------------------------------------------------------------
33063 SUBROUTINE HWHSNG
33064C PARTON-PARTON SCATTERING VIA COLOUR SINGLET
33065C MEAN EVWGT = SIGMA IN NB
33066C TREATS ALL PARTONS ON EQUAL FOOTING WITH HWHSNM(ID1,ID2,S,T)
33067C PROVIDING THE MATRIX ELEMENT SQUARED FOR PARTON TYPES ID1 AND ID2
33068C-----------------------------------------------------------------------
c63d70bc 33069 INCLUDE 'herwig65.inc'
65767955 33070 INTEGER ID1,ID2
33071 DOUBLE PRECISION HWRGEN,HWRUNI,HWHSNM,EPS,RCS,ET,EJ,KK,KK2,
33072 & YJ1INF,YJ1SUP,Z1,YJ2INF,YJ2SUP,Z2,FACT,S,T,U,HCS
33073 SAVE HCS,FACT,S,T
33074 PARAMETER (EPS=1.D-9)
33075 IF (GENEV) THEN
33076 RCS=HCS*HWRGEN(0)
33077 ELSE
33078 EVWGT=0.
33079 CALL HWRPOW(ET,EJ)
33080 KK=ET/PHEP(5,3)
33081 KK2=KK**2
33082 IF (KK.GE.ONE) RETURN
33083 YJ1INF=MAX( YJMIN , LOG((1.-SQRT(1.-KK2))/KK) )
33084 YJ1SUP=MIN( YJMAX , LOG((1.+SQRT(1.-KK2))/KK) )
33085 IF (YJ1INF.GE.YJ1SUP) RETURN
33086 Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
33087 YJ2INF=MAX( YJMIN , -LOG(2./KK-1./Z1) )
33088 YJ2SUP=MIN( YJMAX , LOG(2./KK-Z1) )
33089 IF (YJ2INF.GE.YJ2SUP) RETURN
33090 Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
33091 XX(1)=0.5*(Z1+Z2)*KK
33092 IF (XX(1).GE.ONE) RETURN
33093 XX(2)=XX(1)/(Z1*Z2)
33094 IF (XX(2).GE.ONE) RETURN
33095 COSTH=(Z1-Z2)/(Z1+Z2)
33096 S=XX(1)*XX(2)*PHEP(5,3)**2
33097 T=-0.5*S*(1.-COSTH)
33098 U=-S-T
33099C---SET EMSCA TO HARD PROCESS SCALE (APPROX ET-JET)
33100 EMSCA=SQRT(2.*S*T*U/(S*S+T*T+U*U))
33101 FACT=GEV2NB*0.5*ET*EJ*(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
33102 $ /(16*PIFAC*S**2)
33103 CALL HWSGEN(.FALSE.)
33104 ENDIF
33105C
33106 HCS=0.
33107 DO 20 ID1=1,13
33108 IF (DISF(ID1,1).LT.EPS) GOTO 20
33109 DO 10 ID2=1,13
33110 IF (DISF(ID2,1).LT.EPS) GOTO 10
33111 HCS=HCS+FACT*DISF(ID1,1)*DISF(ID2,2)*HWHSNM(ID1,ID2,S,T)
33112 IF (GENEV.AND.HCS.GT.RCS) THEN
33113 CALL HWHQCP(ID1,ID2,3412,90)
33114 GOTO 30
33115 ENDIF
33116 10 CONTINUE
33117 20 CONTINUE
33118 EVWGT=HCS
33119 RETURN
33120C---GENERATE EVENT
33121 30 IDN(1)=ID1
33122 IDN(2)=ID2
33123 IDCMF=15
33124 CALL HWETWO(.TRUE.,.TRUE.)
33125 END
33126CDECK ID>, HWHSNM.
33127*CMZ :- -20/09/95 15.28.53 by Mike Seymour
33128*-- Author : Mike Seymour
33129C-----------------------------------------------------------------------
33130 FUNCTION HWHSNM(ID1,ID2,S,T)
33131C MATRIX ELEMENT SQUARED FOR COLOUR-SINGLET PARTON-PARTON SCATTERING
33132C INCLUDES SPIN AND COLOUR AVERAGES AND SUMS.
33133C FOR PHOTON EXCHANGE, INTERFERENCE WITH U-CHANNEL CONTRIBUTION IS
33134C INCLUDED FOR IDENTICAL QUARKS AND LIKEWISE S-CHANNEL CONTRIBUTION
33135C FOR IDENTICAL QUARK-ANTIQUARK PAIRS.
33136C-----------------------------------------------------------------------
c63d70bc 33137 INCLUDE 'herwig65.inc'
65767955 33138 DOUBLE PRECISION HWHSNM,HWUAEM,HWUALF,S,T,ASQ,AINU,AINS,Y,SOLD,
33139 $ TOLD,QQ(13,13),ZETA3
33140 INTEGER ID1,ID2
33141 LOGICAL PHOTON
33142C---ZETA3=RIEMANN ZETA FUNCTION(3)
33143 PARAMETER (ZETA3=1.202056903159594D0)
33144 SAVE ASQ,AINU,AINS,SOLD,TOLD,QQ
33145 DATA ASQ,AINU,AINS,SOLD,TOLD,QQ/5*0,169*-1/
33146C---PHOTON=.TRUE. FOR PHOTON EXCHANGE, .FALSE. FOR MUELLER-TANG
33147 PHOTON=MOD(IPROC,100).GE.50
33148C---QQ CACHES THE KINEMATIC-INDEPENDENT FACTORS, TO MAKE IT RUN FASTER
33149C (BEARING IN MIND THAT THIS ROUTINE IS CALLED 169 TIMES PER EVENT)
33150 IF (QQ(ID1,ID2).LT.ZERO) THEN
33151 IF (PHOTON) THEN
33152 IF (ID1.EQ.13.OR.ID2.EQ.13) THEN
33153 QQ(ID1,ID2)=0
33154 ELSE
33155 QQ(ID1,ID2)=(QFCH(MOD(ID1-1,6)+1)*QFCH(MOD(ID2-1,6)+1))**2
33156 $ *(4*PIFAC)**2
33157 ENDIF
33158 ELSE
33159 IF (ID1.EQ.13.AND.ID2.EQ.13) THEN
33160 QQ(ID1,ID2)=CAFAC**4
33161 ELSEIF (ID1.EQ.13.OR.ID2.EQ.13) THEN
33162 QQ(ID1,ID2)=(CAFAC*CFFAC)**2
33163 ELSE
33164 QQ(ID1,ID2)=CFFAC**4
33165 ENDIF
33166 QQ(ID1,ID2)=QQ(ID1,ID2)*
33167 $ PIFAC**3/(4*(3.5*ASFIXD*CAFAC*ZETA3)**3)
33168 $ *(16*PIFAC)
33169 ENDIF
33170 ENDIF
33171C---THE KINEMATIC-DEPENDENT PART IS ALSO CACHED
33172 IF (S.NE.SOLD.OR.T.NE.TOLD) THEN
33173 IF (PHOTON) THEN
33174 AINS=HWUAEM(T)**2
33175 ASQ=2*(S**2+(S+T)**2)/T**2*AINS
33176 AINU=-4*S/T*AINS/NCOLO
33177 AINS=4*AINS/NCOLO-AINU
33178 ELSE
33179 Y=LOG(S/(-T))+ONE
33180 ASQ=HWUALF(1,EMSCA)**4*(S/T)**2*EXP(2*OMEGA0*Y)/Y**3
33181 AINU=0
33182 AINS=0
33183 ENDIF
33184 ENDIF
33185C---THE FINAL ANSWER IS JUST THEIR PRODUCT
33186 IF (ID1.EQ.ID2) THEN
33187 HWHSNM=QQ(ID1,ID2)*(ASQ+AINU)
33188 ELSEIF (ABS(ID1-ID2).EQ.6) THEN
33189 HWHSNM=QQ(ID1,ID2)*(ASQ+AINS)
33190 ELSE
33191 HWHSNM=QQ(ID1,ID2)*ASQ
33192 ENDIF
33193 END
33194CDECK ID>, HWHSPN.
33195*CMZ :- -01/10/01 19.41.18 by Peter Richardson
33196*-- Author : Peter Richardson
33197C-----------------------------------------------------------------------
33198 SUBROUTINE HWHSPN
33199C-----------------------------------------------------------------------
33200C Calculates the spin correlations for the hard process
33201C-----------------------------------------------------------------------
c63d70bc 33202 INCLUDE 'herwig65.inc'
65767955 33203 INTEGER NDIAHD
33204 PARAMETER(NDIAHD=10)
33205 DOUBLE COMPLEX ZI,S,D,ME(2,2,2,2,NCFMAX),MED(2,2,2,2),F3(2,2,8),
33206 & F4(2,2,8),F3M(2,2,8),F4M(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8),
33207 & FUP(2,2,8,8),FUM(2,2,8,8),FST(2,2,8)
33208 DOUBLE PRECISION P(5,4),A(2,NDIAHD),B(2,NDIAHD),XMASS,PLAB,
33209 & PRW,PCM,MS(NDIAHD),MWD(NDIAHD),MR(NDIAHD),HWULDO,EE,
33210 & PREF(5),EPS,N(3),HWVDOT,PP,PRE,SH,TH,UH,PM(5,4),DIJ(2,2),
33211 & MA(4),MA2(4),PTMP(5),WGT,WGTB(NCFMAX),WGTC,HWRGEN
33212 INTEGER ICM,IHEP,IST,JHEP,KHEP,ID,LHEP,MHEP,IK,IL,IM,IJ,L1,L2,I,J,
33213 & IDP(4+NDIAHD),DRTYPE(NDIAHD),NDIA,P1,P2,P3,P4,IFLOW(NDIAHD),
33214 & ID1,ID2,III,JJJ,KKK,O(2),LLL,MMM
33215 DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
33216 & AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
33217 & HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
33218 & HZZ(2),ZAB(12,2,2),HHB(2,3),HWUAEM
33219 COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
33220 & OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
33221 LOGICAL SPIN,FIRST
33222 EXTERNAL HWUAEM
33223 PARAMETER(ZI=(0.0D0,1.0D0))
33224 COMMON/HWHEWS/S(8,8,2),D(8,8)
33225 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
33226 & MA2,SH,TH,UH,IDP,DRTYPE
33227 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
33228 PARAMETER(EPS=1D-20)
33229 EXTERNAL HWULDO,HWVDOT,HWRGEN
33230 SAVE PREF,DIJ,O,FIRST
33231 DATA PREF/1.0D0,0.0D0,0.0D0,1.0D0,0.0D0/
33232 DATA DIJ/1.0D0,0.0D0,0.0D0,1.0D0/
33233 DATA O/2,1/
33234 DATA FIRST/.TRUE./
33235 IF(IERROR.NE.0) RETURN
33236 IF(FIRST) THEN
33237 CALL HWISPC
33238 FIRST = .FALSE.
33239 ENDIF
33240C--search the event record for the hard process
33241 DO 1 IHEP=1,NHEP
33242 IST = ISTHEP(IHEP)
33243 IF(IST.EQ.110.OR.IST.EQ.120) THEN
33244 ICM = IHEP
33245 GOTO 2
33246 ENDIF
33247 1 CONTINUE
33248C--now decide whether or not to perform spin correlation
33249 2 KHEP = JDAHEP(1,ICM)
33250 IK = IDHW(KHEP)
33251 JHEP = JDAHEP(2,ICM)
33252 IJ = IDHW(JHEP)
33253 IF(JHEP-KHEP+1.NE.2) CALL HWWARN('HWHSPN',500)
33254 SPIN = .FALSE.
33255 DO 3 IHEP=KHEP,JHEP
33256 ID = IDHW(IHEP)
33257 IF(RSPIN(ID).EQ.0.5D0) SPIN=.TRUE.
33258 3 CONTINUE
33259 IF(.NOT.SPIN) RETURN
33260 IF((RSPIN(IDHW(KHEP)).EQ.ONE.AND.RSPIN(IDHW(JHEP)).EQ.ZERO).OR.
33261 & (RSPIN(IDHW(KHEP)).EQ.ZERO.AND.RSPIN(IDHW(JHEP)).EQ.ONE)) RETURN
33262 LHEP = JMOHEP(1,ICM)
33263 MHEP = JMOHEP(2,ICM)
33264C--now identify the hard process
33265C--SM processes first
33266C--fermion-antifermion production in lepton-lepton collisions
33267C--or via Z/gamma in hadron-hadron collisions
33268 IF(IPRO.EQ.1.OR.IPRO.EQ.13) THEN
33269C--only need spin correlations for top and tau production
33270 IF((IK.EQ. 6.AND.IJ.EQ. 12).OR.(IK.EQ. 12.AND.IJ.EQ.6 ).OR.
33271 & (IK.EQ.125.AND.IJ.EQ.131).OR.(IK.EQ.131.AND.IJ.EQ.125)) THEN
33272C--check fermion first and change order if not
33273 IF(IDHEP(LHEP).LT.0) THEN
33274 ID = LHEP
33275 LHEP = MHEP
33276 MHEP = ID
33277 ENDIF
33278C--Id's of the incoming and outgoing fermions
33279 IL = IDHW(LHEP)
33280 ID1 = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120)
33281 ID2 = IK-6*INT((IK-1)/6)+10*INT((IK-1)/120)
33282C--couplings for the diagrams
33283C--first the photon exchange
33284 A(1,1) = -QFCH(ID1)
33285 A(2,1) = -QFCH(ID1)
33286 B(1,1) = -QFCH(ID2)
33287 B(2,1) = -QFCH(ID2)
33288 IDP(5) = 59
33289 DRTYPE(1) = 4
33290C--then the Z exchange
33291 A(1,2) = -RFCH(ID1)
33292 A(2,2) = -LFCH(ID1)
33293 B(1,2) = -RFCH(ID2)
33294 B(2,2) = -LFCH(ID2)
33295 IDP(6) = 200
33296 DRTYPE(2) = 4
33297C--setup the colour flow
33298 NDIA = 2
33299 NCFL(1) = 1
33300 SPNCFC(1,1,1) = ONE
33301 IFLOW(1) = 1
33302 IFLOW(2) = 1
33303 ELSE
33304 RETURN
33305 ENDIF
33306C--fermion-antifermion via s-channel W in hadron-hadron
33307 ELSEIF(IPRO.EQ.14) THEN
33308 IF(IK.EQ. 6.OR.IK.EQ. 12.OR.IJ.EQ. 6.OR.IJ.EQ. 12.OR.
33309 & IK.EQ.125.OR.IJ.EQ.131.OR.IK.EQ.131.OR.IJ.EQ.125) THEN
33310C--check fermion first and reorder if not
33311 IF(IDHEP(LHEP).LT.0) THEN
33312 ID = LHEP
33313 LHEP = MHEP
33314 MHEP = ID
33315 ENDIF
33316C--couplings for the diagram
33317 A(1,1) = ZERO
33318 A(2,1) =-ORT/SW
33319 B(1,1) = ZERO
33320 B(2,1) =-ORT/SW
33321 IDP(5) = 198
33322 DRTYPE(1) = 4
33323 NDIA = 1
33324 NCFL(1) = 1
33325 SPNCFC(1,1,1) = ONE
33326 IFLOW(1) = 1
33327 ELSE
33328 RETURN
33329 ENDIF
33330C--top quark production via QCD
33331 ELSEIF(IPRO.EQ.15.OR.IPRO.EQ.17) THEN
33332 IF((IK.EQ.6.AND.IJ.EQ.12).OR.(IK.EQ.12.AND.IJ.EQ.6)) THEN
33333C--check if the outgoing fermion is first and change order if not
33334 IF(IDHEP(KHEP).LT.0) THEN
33335 ID = KHEP
33336 KHEP = JHEP
33337 JHEP = ID
33338 ENDIF
33339C--quark-quark to t tbar
33340 IF(IDHW(LHEP).LE.12.AND.IDHW(MHEP).LE.12) THEN
33341C--first check the incoming fermion is first and change order if not
33342 IF(IDHEP(LHEP).LT.0) THEN
33343 ID = LHEP
33344 LHEP = MHEP
33345 MHEP = ID
33346 ENDIF
33347 IL = IDHW(LHEP)
33348C--couplings for the diagram
33349 A(1,1) =-ONE
33350 A(2,1) =-ONE
33351 B(1,1) =-ONE
33352 B(2,1) =-ONE
33353 IDP(5) = 13
33354 DRTYPE(1) = 4
33355 NDIA = 1
33356C--setup the colour flow
33357 NCFL(1) = 1
33358 SPNCFC(1,1,1) = TWO/9.0D0
33359 IFLOW(1) = 1
33360C--gluon-gluon to t tbar
33361 ELSEIF(IDHW(LHEP).EQ.13.AND.IDHW(MHEP).EQ.13) THEN
33362C--setup the diagrams
33363 IDP(5) = 12
33364 IDP(6) = 12
33365 IDP(7) = 13
33366 IDP(8) = 13
33367 DRTYPE(1) = 5
33368 DRTYPE(2) = 6
33369 DRTYPE(3) = 7
33370 DRTYPE(4) = 7
33371 NDIA = 4
33372C--setup the colour flow
33373 NCFL(1) = 2
33374 IFLOW(1) = 1
33375 IFLOW(2) = 2
33376 IFLOW(3) = 1
33377 IFLOW(4) = 2
33378 SPNCFC(1,1,1) = 0.25D0/THREE
33379 SPNCFC(2,2,1) = SPNCFC(1,1,1)
33380 SPNCFC(1,2,1) = ONE/THREE/32.0D0
33381 SPNCFC(2,1,1) = ONE/THREE/32.0D0
33382C--incorrect initial state
33383 ELSE
33384 CALL HWWARN('HWHSPN',501)
33385 ENDIF
33386C--don't need spin correlations haven't produced top
33387 ELSE
33388 RETURN
33389 ENDIF
33390C--single top quark production in hadron collisions
33391 ELSEIF(IPRO.EQ.20) THEN
33392C--change order if b quark not first and identify incoming particles
33393 IF(ABS(IDHEP(LHEP)).NE.5) THEN
33394 ID = LHEP
33395 LHEP = MHEP
33396 MHEP = ID
33397 ENDIF
33398 IL = IDHEP(LHEP)
33399 IM = IDHEP(MHEP)
33400C--change order if t quark not first
33401 IF(ABS(IDHEP(KHEP)).NE.6) THEN
33402 ID = KHEP
33403 KHEP = JHEP
33404 JHEP = ID
33405 ENDIF
33406C--identify diagram type
33407C--fermion fermion
33408 IF(IL.GT.0.AND.IM.GT.0) THEN
33409 DRTYPE(1) = 17
33410C--fermion antifermion
33411 ELSEIF(IL.GT.0.AND.IM.LT.0) THEN
33412 DRTYPE(1) = 18
33413C--antifermion fermion
33414 ELSEIF(IL.LT.0.AND.IM.GT.0) THEN
33415 DRTYPE(1) = 19
33416C--antifermion antifermion
33417 ELSEIF(IL.LT.0.AND.IM.LT.0) THEN
33418 DRTYPE(1) = 20
33419C--incorrect initial state
33420 ELSE
33421 CALL HWWARN('HWHSPN',502)
33422 ENDIF
33423C--couplings
33424 A(1,1) = ZERO
33425 A(2,1) = -ORT/SW
33426 B(1,1) = ZERO
33427 B(2,1) = -ORT/SW
33428C--virtual particle etc
33429 IDP(5) = 198
33430 NDIA = 1
33431 NCFL(1) = 1
33432 SPNCFC(1,1,1) = ONE
33433 IFLOW(1) = 1
33434C--SUSY particle production
33435 ELSEIF(IPRO.EQ.7.OR.IPRO.EQ.30) THEN
33436 IF(MOD(IPROC,10000).GT.3030) RETURN
33437C--fermion-antifermion to neutralino neutralino
33438 IF(IK.GE.450.AND.IK.LE.453.AND.IJ.GE.450.AND.IJ.LE.453) THEN
33439C--first check the fermion is first and change order if not
33440 IF(IDHEP(LHEP).LT.0) THEN
33441 ID = LHEP
33442 LHEP = MHEP
33443 MHEP = ID
33444 ENDIF
33445 IL = IDHW(LHEP)
33446 IM = IDHW(MHEP)
33447C--couplings of the various diagrams
33448 L1 = IK-449
33449 L2 = IJ-449
33450 ID = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120)
33451C--couplings for the Z exchange diagram
33452 A(1,1) = -RFCH(ID)
33453 A(2,1) = -LFCH(ID)
33454 B(2,1) = HALF*(-ZMIXSS(L1,3)*ZMIXSS(L2,3)
33455 & +ZMIXSS(L1,4)*ZMIXSS(L2,4))/SW/CW
33456 B(1,1) = -B(2,1)
33457 B(2,1) = B(2,1)*ZSGNSS(L1)*ZSGNSS(L2)
33458 DRTYPE(1) = 1
33459 IDP(5) = 200
33460C--couplings for the t-channel diagrams
33461 A(1,2) = ZERO
33462 A(2,2) =-RT*SLFCH(ID,L1)
33463 B(1,2) =-RT*SLFCH(ID,L2)
33464 B(2,2) = ZERO
33465 IDP(6) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+400
33466 A(1,3) =-RT*SRFCH(ID,L1)*ZSGNSS(L1)
33467 A(2,3) = ZERO
33468 B(1,3) = ZERO
33469 B(2,3) =-RT*SRFCH(ID,L2)*ZSGNSS(L2)
33470 IDP(7) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+412
33471 DRTYPE(2) = 2
33472 DRTYPE(3) = 2
33473C--couplings for the u-channel diagrams
33474 A(1,4) = ZERO
33475 A(2,4) =-RT*SLFCH(ID,L2)*ZSGNSS(L2)
33476 B(1,4) =-RT*SLFCH(ID,L1)*ZSGNSS(L1)
33477 B(2,4) = ZERO
33478 IDP(8) = IDP(6)
33479 A(1,5) =-RT*SRFCH(ID,L2)
33480 A(2,5) = ZERO
33481 B(1,5) = ZERO
33482 B(2,5) =-RT*SRFCH(ID,L1)
33483 IDP(9) = IDP(7)
33484 DRTYPE(4) = 3
33485 DRTYPE(5) = 3
33486 NDIA=5
33487C--setup the colour flow
33488 NCFL(1) = 1
33489 SPNCFC(1,1,1) = ONE
33490 IFLOW(1) = 1
33491 IFLOW(2) = 1
33492 IFLOW(3) = 1
33493 IFLOW(4) = 1
33494 IFLOW(5) = 1
33495C--chargino pair production
33496 ELSEIF(IK.GE.454.AND.IK.LE.457.AND.IJ.GE.454.AND.IJ.LE.457) THEN
33497C--first check the fermion is first and change order if not
33498 IF(IDHEP(LHEP).LT.0) THEN
33499 ID = LHEP
33500 LHEP = MHEP
33501 MHEP = ID
33502 ENDIF
33503 IL = IDHW(LHEP)
33504 IM = IDHW(MHEP)
33505C--couplings of the various diagrams
33506 L1 = IK-453-2*INT((IK-454)/2)
33507 L2 = IJ-453-2*INT((IJ-454)/2)
33508 ID = IL-6*INT((IL-1)/6)+10*INT((IL-1)/120)
33509C--couplings for the s-channel photon exchange
33510 A(1,1) = -QFCH(ID)
33511 A(2,1) = -QFCH(ID)
33512 B(1,1) = -DIJ(L1,L2)
33513 B(2,1) = -DIJ(L1,L2)
33514 IDP(5) = 59
33515 DRTYPE(1) = 1
33516C--couplings for the s-channel Z exchange
33517 A(1,2) = -RFCH(ID)
33518 A(2,2) = -LFCH(ID)
33519 B(1,2) =(-WMXUSS(L1,1)*WMXUSS(L2,1)
33520 & -HALF*WMXUSS(L1,2)*WMXUSS(L2,2)+DIJ(L1,L2)*SWEIN)/CW/SW
33521 B(2,2) =WSGNSS(L1)*WSGNSS(L2)*(-WMXVSS(L1,1)*WMXVSS(L2,1)
33522 & -HALF*WMXVSS(L1,2)*WMXVSS(L2,2)+DIJ(L1,L2)*SWEIN)/CW/SW
33523 IDP(6) = 200
33524 DRTYPE(2) = 1
33525C--couplings for the t-channel diagram
33526 IF(IDHEP(KHEP).GT.0.AND.MOD(IL,2).EQ.0) THEN
33527 A(1,3) = ZERO
33528 A(2,3) =-WMXUSS(L1,1)/SW
33529 B(1,3) =-WMXUSS(L2,1)/SW
33530 B(2,3) = ZERO
33531 DRTYPE(3) = 2
33532 ELSEIF(IDHEP(KHEP).LT.0.AND.MOD(IL,2).NE.0) THEN
33533 A(1,3) =-WMXVSS(L1,1)*WSGNSS(L1)/SW
33534 A(2,3) = ZERO
33535 B(1,3) = ZERO
33536 B(2,3) =-WMXVSS(L2,1)*WSGNSS(L2)/SW
33537 DRTYPE(3) = 2
33538 ELSEIF(IDHEP(KHEP).GT.0.AND.MOD(IL,2).NE.0) THEN
33539 A(1,3) = ZERO
33540 A(2,3) =-WMXVSS(L2,1)*WSGNSS(L2)/SW
33541 B(1,3) =-WMXVSS(L1,1)*WSGNSS(L1)/SW
33542 B(2,3) = ZERO
33543 DRTYPE(3) = 3
33544 ELSE
33545 A(1,3) =-WMXUSS(L2,1)/SW
33546 A(2,3) = ZERO
33547 B(1,3) = ZERO
33548 B(2,3) =-WMXUSS(L1,1)/SW
33549 DRTYPE(3) = 3
33550 ENDIF
33551 IDP(7) = IL-6*INT((IL-1)/6)+24*INT((IL-1)/120)+400
33552 & +2*MOD(IL,2)-1
33553 NDIA = 3
33554C--setup the colour flow
33555 NCFL(1) = 1
33556 SPNCFC(1,1,1) = ONE
33557 IFLOW(1) = 1
33558 IFLOW(2) = 1
33559 IFLOW(3) = 1
33560C--chargino neutralino production
33561 ELSEIF((IK.GE.454.AND.IK.LE.457.AND.IJ.GE.450.AND.IJ.LE.453).OR.
33562 & (IJ.GE.454.AND.IJ.LE.457.AND.IK.GE.450.AND.IK.LE.453)) THEN
33563C--first check the fermion is first and change order if not
33564 IF(IDHEP(LHEP).LT.0) THEN
33565 ID = LHEP
33566 LHEP = MHEP
33567 MHEP = ID
33568 ENDIF
33569C--chargino first
33570 IF(IK.GT.453) THEN
33571C--change order of outgoing particles if negative chargino
33572 IF(IDHEP(KHEP).LT.0) THEN
33573 ID =KHEP
33574 KHEP=JHEP
33575 JHEP=ID
33576 ENDIF
33577 L1 = IK-453-2*INT((IK-454)/2)
33578 L2 = IJ-449
33579C--chargino second
33580 ELSE
33581 IF(IDHEP(JHEP).GT.0) THEN
33582 ID =KHEP
33583 KHEP=JHEP
33584 JHEP=ID
33585 ENDIF
33586 L1 = IJ-453-2*INT((IJ-454)/2)
33587 L2 = IK-449
33588 ENDIF
33589C--first the W exchange diagram
33590 A(1,1) = ZERO
33591 A(2,1) =-ORT/SW
33592 B(1,1) =( ORT*ZMXNSS(L2,3)*WMXUSS(L1,2)
33593 & +ZMXNSS(L2,2)*WMXUSS(L1,1))/SW
33594 B(2,1) =WSGNSS(L1)*ZSGNSS(L2)*(-ORT*ZMXNSS(L2,4)*WMXVSS(L1,2)
33595 & +ZMXNSS(L2,2)*WMXVSS(L1,1))/SW
33596 IDP(5) = 198
33597 DRTYPE(1) = 1
33598C--intermediate particles for the t and u channel diagrams
33599 IL = IDHW(LHEP)
33600 IM = IDHW(MHEP)
33601 IDP(6) = IM+394
33602 IDP(7) = IL+406
33603 IF(MOD(IL,2).EQ.0) THEN
33604 A(1,2) = ZERO
33605 A(2,2) =-WMXUSS(L1,1)/SW
33606 B(1,2) =-RT*SLFCH(IM-6,L2)
33607 B(2,2) = ZERO
33608 DRTYPE(2) = 2
33609 A(1,3) = ZERO
33610 A(2,3) =-RT*ZSGNSS(L2)*SLFCH(IL,L2)
33611 B(1,3) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
33612 B(2,3) = ZERO
33613 DRTYPE(3) = 3
33614 ELSE
33615 A(1,2) = ZERO
33616 A(2,2) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
33617 B(1,2) =-RT*ZSGNSS(L2)*SLFCH(IM-6,L2)
33618 B(2,2) = ZERO
33619 DRTYPE(2) = 3
33620 A(1,3) = ZERO
33621 A(2,3) =-RT*SLFCH(IL,L2)
33622 B(1,3) =-WMXUSS(L1,1)/SW
33623 B(2,3) = ZERO
33624 DRTYPE(3) = 2
33625 ENDIF
33626C--setup the colour flow
33627 NDIA = 3
33628 NCFL(1) = 1
33629 SPNCFC(1,1,1) = ONE
33630 IFLOW(1) = 1
33631 IFLOW(2) = 1
33632 IFLOW(3) = 1
33633C--neutralino gluino production
33634 ELSEIF((IK.EQ.449.AND.IJ.GE.450.AND.IJ.LE.453).OR.
33635 & (IJ.EQ.449.AND.IK.GE.450.AND.IK.LE.453)) THEN
33636C--first check the fermion is first and change order if not
33637 IF(IDHEP(LHEP).LT.0) THEN
33638 ID = LHEP
33639 LHEP = MHEP
33640 MHEP = ID
33641 ENDIF
33642C--check neutralino first and change order if not
33643 IF(IK.EQ.449) THEN
33644 L1 = IJ-449
33645 ID = KHEP
33646 KHEP = JHEP
33647 JHEP = ID
33648 ELSE
33649 L1 = IK-449
33650 ENDIF
33651 IL = IDHW(LHEP)
33652C--coupling for the diagrams
33653C--first t-channel squark exchange
33654 IDP(5) = 400+IL
33655 A(1,1) = ZERO
33656 A(2,1) =-RT*SLFCH(IL,L1)
33657 B(1,1) =-RT
33658 B(2,1) = ZERO
33659 DRTYPE(1) = 2
33660 IDP(6) = 412+IL
33661 A(1,2) =-RT*ZSGNSS(L1)*SRFCH(IL,L1)
33662 A(2,2) = ZERO
33663 B(1,2) = ZERO
33664 B(2,2) = RT
33665 DRTYPE(2) = 2
33666C--then u-channel s squark exchange
33667 IDP(7) = 400+IL
33668 A(1,3) = ZERO
33669 A(2,3) =-RT
33670 B(1,3) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)
33671 B(2,3) = ZERO
33672 DRTYPE(3) = 3
33673 IDP(8) = 412+IL
33674 A(1,4) = RT
33675 A(2,4) = ZERO
33676 B(1,4) = ZERO
33677 B(2,4) =-RT*SRFCH(IL,L1)
33678 DRTYPE(4) = 3
33679C--colour flow information
33680 NDIA = 4
33681 NCFL(1) = 1
33682 IFLOW(1) = 1
33683 IFLOW(2) = 1
33684 IFLOW(3) = 1
33685 IFLOW(4) = 1
33686 SPNCFC(1,1,1) = ONE
33687C--chargino gluino production
33688 ELSEIF((IK.GE.454.AND.IK.LE.457.AND.IJ.EQ.449).OR.
33689 & (IJ.GE.454.AND.IJ.LE.457.AND.IK.EQ.449)) THEN
33690C--first check the fermion is first and change order if not
33691 IF(IDHEP(LHEP).LT.0) THEN
33692 ID = LHEP
33693 LHEP = MHEP
33694 MHEP = ID
33695 ENDIF
33696C--check chargino first and change order if not
33697 IF(IK.EQ.449) THEN
33698 L1 = IJ-453-2*INT((IJ-454)/2)
33699 ID = KHEP
33700 KHEP = JHEP
33701 JHEP = ID
33702 ELSE
33703 L1 = IK-453-2*INT((IK-454)/2)
33704 ENDIF
33705 IL = IDHW(LHEP)
33706 IM = IDHW(MHEP)
33707 IDP(5) = IM+394
33708 IDP(6) = IL+406
33709 IF(MOD(IL,2).EQ.0) THEN
33710 A(1,1) = ZERO
33711 A(2,1) =-WMXUSS(L1,1)/SW
33712 B(1,1) =-RT
33713 B(2,1) = ZERO
33714 DRTYPE(1) = 2
33715 A(1,2) = ZERO
33716 A(2,2) =-RT
33717 B(1,2) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
33718 B(2,2) = ZERO
33719 DRTYPE(2) = 3
33720 ELSE
33721 A(1,1) = ZERO
33722 A(2,1) =-WSGNSS(L1)*WMXVSS(L1,1)/SW
33723 B(1,1) =-RT
33724 B(2,1) = ZERO
33725 DRTYPE(1) = 2
33726 A(1,2) = ZERO
33727 A(2,2) =-RT
33728 B(1,2) =-WMXUSS(L1,1)/SW
33729 B(2,2) = ZERO
33730 DRTYPE(2) = 3
33731 ENDIF
33732C--setup the colour flow
33733 NDIA = 2
33734 NCFL(1) = 1
33735 SPNCFC(1,1,1) = ONE
33736 IFLOW(1) = 1
33737 IFLOW(2) = 1
33738C--quark quark to gluino gluino
33739 ELSEIF(IJ.EQ.449.AND.IK.EQ.449.AND.
33740 & IDHW(LHEP).LE.12.AND.IDHW(MHEP).LE.12) THEN
33741C--change order if antiquark first
33742 IF(IDHEP(LHEP).LT.0) THEN
33743 ID = LHEP
33744 LHEP = MHEP
33745 MHEP = ID
33746 ENDIF
33747 IL = IDHW(LHEP)
33748C--couplings of the various diagrams
33749 A(1,1) = ZERO
33750 A(2,1) =-RT
33751 B(1,1) =-RT
33752 B(2,1) = ZERO
33753 A(1,2) = RT
33754 A(2,2) = ZERO
33755 B(1,2) = ZERO
33756 B(2,2) = RT
33757 DO 4 I=1,2
33758 A(I,3) = A(I,1)
33759 B(I,3) = B(I,1)
33760 A(I,4) = A(I,2)
33761 4 B(I,4) = B(I,2)
33762 A(1,5) = ONE
33763 A(2,5) = ONE
33764 B(1,5) = ONE
33765 B(2,5) = ONE
33766 A(1,6) =-ONE
33767 A(2,6) =-ONE
33768 B(1,6) = ONE
33769 B(2,6) = ONE
33770C--intermediate particles
33771 IDP(5) = 400+IL
33772 IDP(6) = 412+IL
33773 IDP(7) = 400+IL
33774 IDP(8) = 412+IL
33775 IDP(9) = 13
33776 IDP(10) = 13
33777C--types of diagram
33778 DRTYPE(1) = 2
33779 DRTYPE(2) = 2
33780 DRTYPE(3) = 3
33781 DRTYPE(4) = 3
33782 DRTYPE(5) = 1
33783 DRTYPE(6) = 1
33784 NDIA = 6
33785C--setup the colour flow
33786 NCFL(1) = 2
33787 SPNCFC(1,1,1) = 8.0D0/27.0D0
33788 SPNCFC(2,2,1) = 8.0D0/27.0D0
33789 SPNCFC(1,2,1) =-ONE/27.0D0
33790 SPNCFC(2,1,1) =-ONE/27.0D0
33791 IFLOW(1) = 1
33792 IFLOW(2) = 1
33793 IFLOW(3) = 2
33794 IFLOW(4) = 2
33795 IFLOW(5) = 1
33796 IFLOW(6) = 2
33797C--gluon gluon to gluino gluino
33798 ELSEIF(IDHW(LHEP).EQ.13.AND.IDHW(MHEP).EQ.13.AND.IJ.EQ.449
33799 & .AND.IK.EQ.449) THEN
33800C--setup the diagrams
33801 IDP(5) = 449
33802 IDP(6) = 449
33803 IDP(7) = 13
33804 IDP(8) = 13
33805 DRTYPE(1) = 14
33806 DRTYPE(2) = 15
33807 DRTYPE(3) = 16
33808 DRTYPE(4) = 16
33809 NDIA = 4
33810C--setup the colour flow
33811 NCFL(1) = 2
33812 IFLOW(1) = 1
33813 IFLOW(2) = 2
33814 IFLOW(3) = 1
33815 IFLOW(4) = 2
33816 SPNCFC(1,1,1) = 9.0D0/16.0D0
33817 SPNCFC(2,2,1) = SPNCFC(1,1,1)
33818 SPNCFC(1,2,1) =-9.0D0/32.0D0
33819 SPNCFC(2,1,1) =-9.0D0/32.0D0
33820C--neutralino squark production
33821 ELSEIF( (IK.GE.450.AND.IK.LE.453.AND.
33822 & ((IJ.GE.401.AND.IJ.LE.406).OR.(IJ.GE.413.AND.IJ.LE.418)))
33823 & .OR.(IJ.GE.450.AND.IJ.LE.453.AND.
33824 & ((IK.GE.401.AND.IK.LE.406).OR.(IK.GE.413.AND.IK.LE.418))))
33825 & THEN
33826C--change order if gluon first
33827 IF(IDHW(LHEP).EQ.13) THEN
33828 ID = LHEP
33829 LHEP = MHEP
33830 MHEP = ID
33831 ENDIF
33832C--change order in squark first
33833 IF(IJ.GE.450) THEN
33834 ID = KHEP
33835 KHEP = JHEP
33836 JHEP = ID
33837 IK = IDHW(KHEP)
33838 IJ = IDHW(JHEP)
33839 ENDIF
33840 IL = IDHW(LHEP)
33841 L1 = IK-449
33842C--left handed (lighter) squark
33843 IF(IJ.LT.412) THEN
33844 A(1,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,1)
33845 A(2,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,1)
33846C--right handed (heavier) squark
33847 ELSEIF(IJ.GT.412) THEN
33848 A(1,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,2)
33849 A(2,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,2)
33850 ENDIF
33851 DO 5 I=1,2
33852 5 A(I,2) = A(I,1)
33853 IDP(5) = IJ
33854 IDP(6) = IL
33855C--colour flow info
33856 DRTYPE(1) = 8
33857 DRTYPE(2) = 10
33858 NDIA = 2
33859 NCFL(1) = 1
33860 SPNCFC(1,1,1) = HALF/THREE
33861 IFLOW(1) = 1
33862 IFLOW(2) = 1
33863C--neutralino antisquark production
33864 ELSEIF( (IK.GE.450.AND.IK.LE.453.AND.
33865 & ((IJ.GE.407.AND.IJ.LE.412).OR.(IJ.GE.419.AND.IJ.LE.424)))
33866 & .OR.(IJ.GE.450.AND.IJ.LE.453.AND.
33867 & ((IK.GE.407.AND.IK.LE.412).OR.(IK.GE.419.AND.IK.LE.424))))
33868 & THEN
33869C--change order if gluon first
33870 IF(IDHW(LHEP).EQ.13) THEN
33871 ID = LHEP
33872 LHEP = MHEP
33873 MHEP = ID
33874 ENDIF
33875C--change order in squark first
33876 IF(IJ.GE.450) THEN
33877 ID = KHEP
33878 KHEP = JHEP
33879 JHEP = ID
33880 IK = IDHW(KHEP)
33881 IJ = IDHW(JHEP)
33882 ENDIF
33883 IL = IDHW(LHEP)-6
33884 L1 = IK-449
33885C--left handed (lighter) squark
33886 IF(IJ.LE.412) THEN
33887 A(1,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,1)
33888 A(2,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,1)
33889C--right handed (heavier) squark
33890 ELSEIF(IJ.GT.412) THEN
33891 A(1,1) =-RT*ZSGNSS(L1)*SLFCH(IL,L1)*QMIXSS(IL,1,2)
33892 A(2,1) =-RT*SRFCH(IL,L1)*QMIXSS(IL,2,2)
33893 ENDIF
33894 DO 6 I=1,2
33895 6 A(I,2) = A(I,1)
33896 IDP(5) = IJ
33897 IDP(6) = IL
33898C--colour flow info
33899 DRTYPE(1) = 9
33900 DRTYPE(2) = 11
33901 NDIA = 2
33902 NCFL(1) = 1
33903 SPNCFC(1,1,1) = HALF/THREE
33904 IFLOW(1) = 1
33905 IFLOW(2) = 1
33906C--chargino squark
33907 ELSEIF((IK.GE.454.AND.IK.LE.457.AND.
33908 & ((IJ.GE.401.AND.IJ.LE.406).OR.(IJ.GE.413.AND.IJ.LE.418)))
33909 & .OR.(IJ.GE.454.AND.IJ.LE.457.AND.
33910 & ((IK.GE.401.AND.IK.LE.406).OR.(IK.GE.413.AND.IK.LE.418))))
33911 & THEN
33912C--change order if gluon first
33913 IF(IDHW(LHEP).EQ.13) THEN
33914 ID = LHEP
33915 LHEP = MHEP
33916 MHEP = ID
33917 ENDIF
33918C--change order if squark first
33919 IF(IJ.GE.454) THEN
33920 ID = KHEP
33921 KHEP = JHEP
33922 JHEP = ID
33923 IK = IDHW(KHEP)
33924 IJ = IDHW(JHEP)
33925 ENDIF
33926 IL = IDHW(LHEP)
33927 L1 = IK-453-2*INT((IK-454)/2)
33928C--left handed (lighter) squark
33929 A(1,1) = ZERO
33930 IF(IJ.LE.412) THEN
33931 IF(MOD(IL,2).EQ.0) THEN
33932 A(2,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,1)/SW
33933 ELSE
33934 A(2,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,1)/SW
33935 ENDIF
33936C--right handed (heavier) squark
33937 ELSEIF(IJ.GT.412) THEN
33938 IF(MOD(IL,2).EQ.0) THEN
33939 A(2,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,2)/SW
33940 ELSE
33941 A(2,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,2)/SW
33942 ENDIF
33943 ENDIF
33944 DO 7 I=1,2
33945 7 A(I,2) = A(I,1)
33946 IDP(5) = IJ
33947 IDP(6) = IL
33948C--colour flow info
33949 DRTYPE(1) = 8
33950 DRTYPE(2) = 10
33951 NDIA = 2
33952 NCFL(1) = 1
33953 SPNCFC(1,1,1) = HALF/THREE
33954 IFLOW(1) = 1
33955 IFLOW(2) = 1
33956C--chargino antisquark
33957 ELSEIF((IK.GE.454.AND.IK.LE.457.AND.
33958 & ((IJ.GE.407.AND.IJ.LE.412).OR.(IJ.GE.419.AND.IJ.LE.424)))
33959 & .OR.(IJ.GE.454.AND.IJ.LE.457.AND.
33960 & ((IK.GE.407.AND.IK.LE.412).OR.(IK.GE.419.AND.IK.LE.424))))
33961 & THEN
33962C--change order if gluon first
33963 IF(IDHW(LHEP).EQ.13) THEN
33964 ID = LHEP
33965 LHEP = MHEP
33966 MHEP = ID
33967 ENDIF
33968C--change order in squark first
33969 IF(IJ.GE.454) THEN
33970 ID = KHEP
33971 KHEP = JHEP
33972 JHEP = ID
33973 IK = IDHW(KHEP)
33974 IJ = IDHW(JHEP)
33975 ENDIF
33976 IL = IDHW(LHEP)-6
33977 L1 = IK-453-2*INT((IK-454)/2)
33978C--left handed (lighter) squark
33979 A(2,1) = ZERO
33980 IF(IJ.LE.412) THEN
33981 IF(MOD(IL,2).EQ.0) THEN
33982 A(1,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,1)/SW
33983 ELSE
33984 A(1,1) = -WSGNSS(L1)*WMXVSS(L1,1)*QMIXSS(IL+1,1,1)/SW
33985 ENDIF
33986C--right handed (heavier) squark
33987 ELSEIF(IJ.GT.412) THEN
33988 IF(MOD(IL,2).EQ.0) THEN
33989 A(1,1) = -WMXUSS(L1,1)*QMIXSS(IL-1,1,2)/SW
33990 ELSE
33991 A(1,1) = -WMXVSS(L1,1)*QMIXSS(IL+1,1,2)/SW
33992 ENDIF
33993 ENDIF
33994 DO 8 I=1,2
33995 8 A(I,2) = A(I,1)
33996 IDP(5) = IJ
33997 IDP(6) = IL
33998C--colour flow info
33999 DRTYPE(1) = 9
34000 DRTYPE(2) = 11
34001 NDIA = 2
34002 NCFL(1) = 1
34003 SPNCFC(1,1,1) = ONE
34004 IFLOW(1) = 1
34005 IFLOW(2) = 1
34006C--squark gluino production
34007 ELSEIF((IK.EQ.449.AND.((IJ.GE.401.AND.IJ.LE.406)
34008 & .OR.(IJ.GE.413.AND.IJ.LE.418)))
34009 & .OR.(IJ.GE.449.AND.((IK.GE.401.AND.IK.LE.406)
34010 & .OR.(IK.GE.413.AND.IK.LE.418)))) THEN
34011C--change order if gluon first
34012 IF(IDHW(LHEP).EQ.13) THEN
34013 ID = LHEP
34014 LHEP = MHEP
34015 MHEP = ID
34016 ENDIF
34017 IL = IDHW(LHEP)
34018C--change order in squark first
34019 IF(IJ.EQ.449) THEN
34020 ID = KHEP
34021 KHEP = JHEP
34022 JHEP = ID
34023 IJ = IDHW(JHEP)
34024 ENDIF
34025 ID = INT((IJ-401)/12)+1
34026 IF(ID.EQ.1) THEN
34027 A(1,1) = ZERO
34028 A(2,1) =-RT
34029 ELSE
34030 A(1,1) = RT
34031 A(2,1) = ZERO
34032 ENDIF
34033 DO 9 I=1,2
34034 A(I,2) =-A(I,1)
34035 A(I,3) = A(I,1)
34036 9 A(I,4) = A(I,1)
34037 DRTYPE(1) = 12
34038 DRTYPE(2) = 12
34039 DRTYPE(3) = 8
34040 DRTYPE(4) = 10
34041 IDP(5) = 449
34042 IDP(6) = 449
34043 IDP(7) = IJ
34044 IDP(8) = IL
34045C--colour flows
34046 NDIA = 4
34047 NCFL(1) = 2
34048 IFLOW(1) = 1
34049 IFLOW(2) = 2
34050 IFLOW(3) = 1
34051 IFLOW(4) = 2
34052 SPNCFC(1,1,1) = 2.0D0/9.0D0
34053 SPNCFC(2,2,1) = 2.0D0/9.0D0
34054 SPNCFC(1,2,1) = -0.25D0/9.0D0
34055 SPNCFC(2,1,1) = -0.25D0/9.0D0
34056C--antisquark gluino production
34057 ELSEIF((IK.GE.449..AND.((IJ.GE.407.AND.IJ.LE.412)
34058 & .OR.(IJ.GE.419.AND.IJ.LE.424)))
34059 & .OR.(IJ.GE.449.AND.((IK.GE.407.AND.IK.LE.412)
34060 & .OR.(IK.GE.419.AND.IK.LE.424)))) THEN
34061C--change order if gluon first
34062 IF(IDHW(LHEP).EQ.13) THEN
34063 ID = LHEP
34064 LHEP = MHEP
34065 MHEP = ID
34066 ENDIF
34067 IL = IDHW(LHEP)
34068C--change order in squark first
34069 IF(IJ.EQ.449) THEN
34070 ID = KHEP
34071 KHEP = JHEP
34072 JHEP = ID
34073 IJ = IDHW(JHEP)
34074 ENDIF
34075 ID = INT((IJ-401)/12)+1
34076 IF(ID.EQ.1) THEN
34077 A(1,1) =-RT
34078 A(2,1) = ZERO
34079 ELSE
34080 A(1,1) = ZERO
34081 A(2,1) = RT
34082 ENDIF
34083 DO 10 I=1,2
34084 A(I,2) =-A(I,1)
34085 A(I,3) = A(I,1)
34086 10 A(I,4) = A(I,1)
34087 DRTYPE(1) = 13
34088 DRTYPE(2) = 13
34089 DRTYPE(3) = 9
34090 DRTYPE(4) = 11
34091 IDP(5) = 449
34092 IDP(6) = 449
34093 IDP(7) = IJ
34094 IDP(8) = IL
34095C--colour flows
34096 NDIA = 4
34097 NCFL(1) = 2
34098 IFLOW(1) = 1
34099 IFLOW(2) = 2
34100 IFLOW(3) = 1
34101 IFLOW(4) = 2
34102 SPNCFC(1,1,1) = 2.0D0/9.0D0
34103 SPNCFC(2,2,1) = 2.0D0/9.0D0
34104 SPNCFC(1,2,1) = -0.25D0/9.0D0
34105 SPNCFC(2,1,1) = -0.25D0/9.0D0
34106C--unrecognised SUSY process
34107 ELSE
34108 CALL HWWARN('HWHSPN',503)
34109 ENDIF
34110C--LLE processes
34111 ELSEIF(IPRO.EQ.8) THEN
34112C--neutralino antineutrino production
34113 IF(IK.GE.450.AND.IK.LE.453.AND.
34114 & IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.0) THEN
34115C--ensure lepton first
34116 IF(IDHEP(LHEP).LT.0) THEN
34117 ID = LHEP
34118 LHEP = MHEP
34119 MHEP = ID
34120 ENDIF
34121C--RPV indices
34122 III = (IJ-126)/2
34123 JJJ = (IDHW(LHEP)-119)/2
34124 KKK = (IDHW(MHEP)-125)/2
34125 L1 = IK-449
34126 IDP(5) = 424+2*III
34127 DO 11 I=1,2
34128 IDP(5+I) = 423+2*JJJ+(I-1)*12
34129 11 IDP(7+I) = 423+2*KKK+(I-1)*12
34130C--types of diagram
34131 DRTYPE(1) = 21
34132 DRTYPE(2) = 22
34133 DRTYPE(3) = 22
34134 DRTYPE(4) = 23
34135 DRTYPE(5) = 23
34136C--RPV couplings
34137 A(1,1) = ZERO
34138 A(2,1) = -LAMDA1(III,JJJ,KKK)
34139 DO 12 I=1,2
34140 B(1,I+1) = ZERO
34141 B(2,I+1) = -LMIXSS(2*JJJ-1,1,I)*LAMDA1(III,JJJ,KKK)
34142 A(1,I+3) = ZERO
34143 12 A(2,I+3) = -LMIXSS(2*KKK-1,2,I)*LAMDA1(III,JJJ,KKK)
34144C--MSSM couplings
34145 DO 13 J=1,2
34146 B(J,1) = AFN(O(J),2*III+6,1,L1)
34147 DO 13 I=1,2
34148 A(J,I+1) = AFN(O(J),2*JJJ+5,I,L1)
34149 13 B(J,I+3) = AFN( J ,2*KKK+5,I,L1)
34150C--colour flows
34151 NDIA = 5
34152 NCFL(1) = 1
34153 DO 14 I=1,5
34154 14 IFLOW(I) = 1
34155 SPNCFC(1,1,1) = ONE
34156C--neutralino neutrino production
34157 ELSEIF(IK.GE.450.AND.IK.LE.453.AND.
34158 & IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.0) THEN
34159C--ensure lepton first
34160 IF(IDHEP(LHEP).LT.0) THEN
34161 ID = LHEP
34162 LHEP = MHEP
34163 MHEP = ID
34164 ENDIF
34165C--RPV indices
34166 III = (IJ-120)/2
34167 JJJ = (IDHW(MHEP)-125)/2
34168 KKK = (IDHW(LHEP)-119)/2
34169 L1 = IK-449
34170 IDP(5) = 424+2*III
34171 DO 15 I=1,2
34172 IDP(5+I) = 423+2*JJJ+(I-1)*12
34173 15 IDP(7+I) = 423+2*KKK+(I-1)*12
34174C--types of diagram
34175 DRTYPE(1) = 24
34176 DRTYPE(2) = 25
34177 DRTYPE(3) = 25
34178 DRTYPE(4) = 26
34179 DRTYPE(5) = 26
34180C--RPV couplings
34181 A(1,1) = -LAMDA1(III,JJJ,KKK)
34182 A(2,1) = ZERO
34183 DO 16 I=1,2
34184 B(1,I+1) = -LMIXSS(2*JJJ-1,1,I)*LAMDA1(III,JJJ,KKK)
34185 B(2,I+1) = ZERO
34186 A(1,I+3) = -LMIXSS(2*KKK-1,2,I)*LAMDA1(III,JJJ,KKK)
34187 16 A(2,I+3) = ZERO
34188C--MSSM couplings
34189 DO 17 J=1,2
34190 B(J,1) = AFN( J ,2*III+6,1,L1)
34191 DO 17 I=1,2
34192 A(J,I+1) = AFN( J ,2*JJJ+5,I,L1)
34193 17 B(J,I+3) = AFN(O(J),2*KKK+5,I,L1)
34194C--colour flows
34195 NDIA = 5
34196 NCFL(1) = 1
34197 DO 18 I=1,5
34198 18 IFLOW(I) = 1
34199 SPNCFC(1,1,1) = ONE
34200C--chargino antilepton
34201 ELSEIF(IK.GE.456.AND.IK.LE.457.AND.
34202 & IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN
34203C--ensure lepton first
34204 IF(IDHEP(LHEP).LT.0) THEN
34205 ID = LHEP
34206 LHEP = MHEP
34207 MHEP = ID
34208 ENDIF
34209C--RPV indices
34210 III = (IJ-125)/2
34211 JJJ = (IDHW(LHEP)-119)/2
34212 KKK = (IDHW(MHEP)-125)/2
34213 L1 = IK-455
34214 IDP(5) = 2*III+424
34215 IDP(6) = 2*JJJ+424
34216C--RPV couplings
34217 A(1,1) = ZERO
34218 A(2,1) = LAMDA1(III,JJJ,KKK)
34219 B(1,2) = ZERO
34220 B(2,2) =-LAMDA1(III,JJJ,KKK)
34221C--MSSM couplings
34222 DO 19 J=1,2
34223 B(J,1) = AFC(O(J),2*III+6,1,L1)
34224 19 A(J,2) = AFC(O(J),2*JJJ+6,1,L1)
34225C--colour flows
34226 DRTYPE(1) = 21
34227 DRTYPE(2) = 22
34228 NDIA = 2
34229 NCFL(1) = 1
34230 DO 20 I=1,2
34231 20 IFLOW(I) = 1
34232 SPNCFC(1,1,1) = ONE
34233C--chargino lepton
34234 ELSEIF(IK.GE.454.AND.IK.LE.455.AND.
34235 & IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1) THEN
34236C--ensure lepton first
34237 IF(IDHEP(LHEP).LT.0) THEN
34238 ID = LHEP
34239 LHEP = MHEP
34240 MHEP = ID
34241 ENDIF
34242C--RPV indices
34243 III = (IJ-119)/2
34244 JJJ = (IDHW(MHEP)-125)/2
34245 KKK = (IDHW(LHEP)-119)/2
34246 L1 = IK-453
34247 IDP(5) = 2*III+424
34248 IDP(6) = 2*JJJ+424
34249C--RPV couplings
34250 A(1,1) = LAMDA1(III,JJJ,KKK)
34251 A(2,1) = ZERO
34252 B(1,2) =-LAMDA1(III,JJJ,KKK)
34253 B(2,2) = ZERO
34254C--MSSM couplings
34255 DO 21 J=1,2
34256 B(J,1) = AFC(J,2*III+6,1,L1)
34257 21 A(J,2) = AFC(J,2*JJJ+6,1,L1)
34258C--colour flows
34259 DRTYPE(1) = 24
34260 DRTYPE(2) = 25
34261 NDIA = 2
34262 NCFL(1) = 1
34263 DO 22 I=1,2
34264 22 IFLOW(I) = 1
34265 SPNCFC(1,1,1) = ONE
34266C--e+e- production
34267 ELSEIF(IK.GE.121.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND.
34268 & IJ.GE.121.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN
34269C--ensure incoming lepton first
34270 IF(IDHEP(LHEP).LT.0) THEN
34271 ID = MHEP
34272 MHEP = LHEP
34273 LHEP = ID
34274 ENDIF
34275C--ensure outgoing lepton first
34276 IF(IDHEP(KHEP).LT.0) THEN
34277 ID = IK
34278 IK = IJ
34279 IJ = ID
34280 ID = KHEP
34281 KHEP = JHEP
34282 JHEP = ID
34283 ENDIF
34284C--only need the correlations for tau production
34285 IF(IK.NE.125.AND.IJ.NE.131) RETURN
34286C--find the RPV indices
34287 III = (IDHW(LHEP)-119)/2
34288 KKK = (IK-119)/2
34289 LLL = (IJ-125)/2
34290 NDIA = 0
34291 EE = SQRT(HWUAEM(SH)*FOUR*PIFAC)
34292C--s-channel photon and Z exchange if needed
34293 IF(KKK.EQ.LLL) THEN
34294 NDIA = 2
34295 ID1 = 9+2*III
34296 ID2 = 9+2*KKK
34297C--photon first
34298 A(1,1) = -EE*QFCH(ID1)
34299 A(2,1) = -EE*QFCH(ID1)
34300 B(1,1) = -EE*QFCH(ID2)
34301 B(2,1) = -EE*QFCH(ID2)
34302 IDP(5) = 59
34303 DRTYPE(1) = 4
34304C--then the Z exchange
34305 A(1,2) = -EE*RFCH(ID1)
34306 A(2,2) = -EE*LFCH(ID1)
34307 B(1,2) = -EE*RFCH(ID2)
34308 B(2,2) = -EE*LFCH(ID2)
34309 IDP(6) = 200
34310 DRTYPE(2) = 4
34311 ENDIF
34312 DO 23 JJJ=1,3
34313C--s-channel sneutrino exchange
34314 IF(ABS(LAMDA1(III,JJJ,III)*LAMDA1(LLL,JJJ,KKK)).GT.EPS) THEN
34315 NDIA = NDIA+1
34316 DRTYPE(NDIA) = 21
34317 IDP(NDIA+4) = 424+2*JJJ
34318 A(1,NDIA) = LAMDA1(III,JJJ,III)
34319 A(2,NDIA) = ZERO
34320 B(1,NDIA) = ZERO
34321 B(2,NDIA) = LAMDA1(LLL,JJJ,KKK)
34322 ENDIF
34323C--s-channel antisneutrino exchange
34324 IF(ABS(LAMDA1(III,JJJ,III)*LAMDA1(KKK,JJJ,LLL)).GT.EPS) THEN
34325 NDIA = NDIA+1
34326 DRTYPE(NDIA) = 21
34327 IDP(NDIA+4) = 424+2*JJJ
34328 A(1,NDIA) = ZERO
34329 A(2,NDIA) = LAMDA1(III,JJJ,III)
34330 B(1,NDIA) = LAMDA1(KKK,JJJ,LLL)
34331 B(2,NDIA) = ZERO
34332 ENDIF
34333C--t-channel sneutrino exchange
34334 IF(ABS(LAMDA1(KKK,JJJ,III)*LAMDA1(LLL,JJJ,III)).GT.EPS) THEN
34335 NDIA = NDIA+1
34336 DRTYPE(NDIA) = 22
34337 IDP(NDIA+4) = 424+2*JJJ
34338 A(1,NDIA) = LAMDA1(KKK,JJJ,III)
34339 A(2,NDIA) = ZERO
34340 B(1,NDIA) = ZERO
34341 B(2,NDIA) = LAMDA1(LLL,JJJ,III)
34342 ENDIF
34343C--t-channel antisneutrino exchange
34344 IF(ABS(LAMDA1(III,JJJ,KKK)*LAMDA1(III,JJJ,LLL)).GT.EPS) THEN
34345 NDIA = NDIA+1
34346 DRTYPE(NDIA) = 22
34347 IDP(NDIA+4) = 424+2*JJJ
34348 A(1,NDIA) = ZERO
34349 A(2,NDIA) = LAMDA1(III,JJJ,KKK)
34350 B(1,NDIA) = LAMDA1(III,JJJ,LLL)
34351 B(2,NDIA) = ZERO
34352 ENDIF
34353 23 CONTINUE
34354C--setup the colour flow
34355 NCFL(1) = 1
34356 SPNCFC(1,1,1) = ONE
34357 DO 24 I=1,NDIA
34358 24 IFLOW(I) = 1
34359C--d dbar production
34360 ELSEIF(IK.LE.12.AND.IK.LE.12.AND.
34361 & MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN
34362C--can't produce quark which decays before hadronization
34363 RETURN
34364C--unrecognised process
34365 ELSE
34366 CALL HWWARN('HWHSPN',504)
34367 ENDIF
34368C--LQD processes
34369 ELSEIF(IPRO.EQ.40) THEN
34370C--change outgoing order
34371 ID = IJ
34372 IJ = IK
34373 IK = ID
34374 ID = JHEP
34375 JHEP = KHEP
34376 KHEP = ID
34377C--neutrino neutralino production
34378 IF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
34379 & IDPDG(IJ).GT.0) THEN
34380C--change order if antiparticle first
34381 IF(IDHEP(LHEP).LT.0) THEN
34382 ID = LHEP
34383 LHEP = MHEP
34384 MHEP = ID
34385 ENDIF
34386C--indices for RPV coupling
34387 III = (IJ-120)/2
34388 JJJ = (IDHW(MHEP)-5)/2
34389 KKK = (IDHW(LHEP)+1)/2
34390 L1 = IK - 449
34391 IDP(5) = 424+2*III
34392 DO 25 I=1,2
34393 IDP(5+I) = 399+2*JJJ+(I-1)*12
34394 25 IDP(7+I) = 399+2*KKK+(I-1)*12
34395C--types of diagram
34396 DRTYPE(1) = 24
34397 DRTYPE(2) = 25
34398 DRTYPE(3) = 25
34399 DRTYPE(4) = 26
34400 DRTYPE(5) = 26
34401C--RPV couplings
34402 A(1,1) = -LAMDA2(III,JJJ,KKK)
34403 A(2,1) = ZERO
34404 DO 26 I=1,2
34405 B(1,I+1) = -QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
34406 B(2,I+1) = ZERO
34407 A(1,I+3) = -QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
34408 26 A(2,I+3) = ZERO
34409C--MSSM couplings
34410 DO 27 J=1,2
34411 B(J,1) = AFN( J ,2*III+6,1,L1)
34412 DO 27 I=1,2
34413 A(J,I+1) = AFN( J ,2*JJJ-1,I,L1)
34414 27 B(J,I+3) = AFN(O(J),2*KKK-1,I,L1)
34415C--colour flows
34416 NDIA = 5
34417 NCFL(1) = 1
34418 DO 28 I=1,5
34419 28 IFLOW(I) = 1
34420 SPNCFC(1,1,1) = ONE/THREE
34421C--antineutrino neutralino production
34422 ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
34423 & IDPDG(IJ).LT.0) THEN
34424C--change order if antiparticle first
34425 IF(IDHEP(LHEP).LT.0) THEN
34426 ID = LHEP
34427 LHEP = MHEP
34428 MHEP = ID
34429 ENDIF
34430C--indices for RPV coupling
34431 III = (IJ-126)/2
34432 JJJ = (IDHW(LHEP)+1)/2
34433 KKK = (IDHW(MHEP)-5)/2
34434 L1 = IK - 449
34435 IDP(5) = 424+2*III
34436 DO 29 I=1,2
34437 IDP(5+I) = 399+2*JJJ+(I-1)*12
34438 29 IDP(7+I) = 399+2*KKK+(I-1)*12
34439C--types of diagram
34440 DRTYPE(1) = 21
34441 DRTYPE(2) = 22
34442 DRTYPE(3) = 22
34443 DRTYPE(4) = 23
34444 DRTYPE(5) = 23
34445C--RPV couplings
34446 A(1,1) = ZERO
34447 A(2,1) = -LAMDA2(III,JJJ,KKK)
34448 DO 30 I=1,2
34449 B(1,I+1) = ZERO
34450 B(2,I+1) = -QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
34451 A(1,I+3) = ZERO
34452 30 A(2,I+3) = -QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
34453C--MSSM couplings
34454 DO 31 J=1,2
34455 B(J,1) = AFN(O(J),2*III+6,1,L1)
34456 DO 31 I=1,2
34457 A(J,I+1) = AFN(O(J),2*JJJ-1,I,L1)
34458 31 B(J,I+3) = AFN( J ,2*KKK-1,I,L1)
34459C--colour flows
34460 NDIA = 5
34461 NCFL(1) = 1
34462 DO 32 I=1,5
34463 32 IFLOW(I) = 1
34464 SPNCFC(1,1,1) = ONE/THREE
34465C--lepton neutralino production
34466 ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
34467 & IDPDG(IJ).GT.0) THEN
34468C--change order if antiparticle first
34469 IF(IDHEP(LHEP).LT.0) THEN
34470 ID = LHEP
34471 LHEP = MHEP
34472 MHEP = ID
34473 ENDIF
34474C--indices for RPV coupling
34475 III = (IJ-119)/2
34476 JJJ = (IDHW(MHEP)-6)/2
34477 KKK = (IDHW(LHEP)+1)/2
34478 L1 = IK - 449
34479 DO 33 I=1,2
34480 IDP(4+I) = 423+2*III+(I-1)*12
34481 IDP(6+I) = 400+2*JJJ+(I-1)*12
34482 33 IDP(8+I) = 399+2*KKK+(I-1)*12
34483C--types of diagram
34484 DRTYPE(1) = 24
34485 DRTYPE(2) = 24
34486 DRTYPE(3) = 25
34487 DRTYPE(4) = 25
34488 DRTYPE(5) = 26
34489 DRTYPE(6) = 26
34490C--RPV couplings
34491 DO 34 I=1,2
34492 A(1,I ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
34493 A(2,I ) = 0.0D0
34494 B(1,I+2) = QMIXSS(2*JJJ ,1,I)*LAMDA2(III,JJJ,KKK)
34495 B(2,I+2) = 0.0D0
34496 A(1,I+4) = QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
34497 A(2,I+4) = 0.0D0
34498C--MSSM couplings
34499 DO 34 J=1,2
34500 B(J,I ) = AFN( J ,2*III+5,I,L1)
34501 A(J,I+2) = AFN( J ,2*JJJ ,I,L1)
34502 34 B(J,I+4) = AFN(O(J),2*KKK-1,I,L1)
34503C--colour flows
34504 NDIA = 6
34505 NCFL(1) = 1
34506 DO 35 I=1,6
34507 35 IFLOW(I) = 1
34508 SPNCFC(1,1,1) = ONE/THREE
34509C--antilepton neutralino production
34510 ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
34511 & IDPDG(IJ).LT.0) THEN
34512C--change order if antiparticle first
34513 IF(IDHEP(LHEP).LT.0) THEN
34514 ID = LHEP
34515 LHEP = MHEP
34516 MHEP = ID
34517 ENDIF
34518C--indices for RPV coupling
34519 III = (IJ-125)/2
34520 JJJ = IDHW(LHEP)/2
34521 KKK = (IDHW(MHEP)-5)/2
34522 L1 = IK - 449
34523 DO 36 I=1,2
34524 IDP(4+I) = 423+2*III+(I-1)*12
34525 IDP(6+I) = 400+2*JJJ+(I-1)*12
34526 36 IDP(8+I) = 399+2*KKK+(I-1)*12
34527C--types of diagram
34528 DRTYPE(1) = 21
34529 DRTYPE(2) = 21
34530 DRTYPE(3) = 22
34531 DRTYPE(4) = 22
34532 DRTYPE(5) = 23
34533 DRTYPE(6) = 23
34534C--RPV couplings
34535 DO 37 I=1,2
34536 A(1,I ) = 0.0D0
34537 A(2,I ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
34538 B(1,I+2) = 0.0D0
34539 B(2,I+2) = QMIXSS(2*JJJ ,1,I)*LAMDA2(III,JJJ,KKK)
34540 A(1,I+4) = 0.0D0
34541 A(2,I+4) = QMIXSS(2*KKK-1,2,I)*LAMDA2(III,JJJ,KKK)
34542C--MSSM couplings
34543 DO 37 J=1,2
34544 B(J,I ) = AFN(O(J),2*III+5,I,L1)
34545 A(J,I+2) = AFN(O(J),2*JJJ ,I,L1)
34546 37 B(J,I+4) = AFN( J ,2*KKK-1,I,L1)
34547C--colour flows
34548 NDIA = 6
34549 NCFL(1) = 1
34550 DO 39 I=1,6
34551 39 IFLOW(I) = 1
34552 SPNCFC(1,1,1) = ONE/THREE
34553C-- +ve chargino antineutrino
34554 ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.0) THEN
34555C--change order if antiparticle first
34556 IF(IDHEP(LHEP).LT.0) THEN
34557 ID = LHEP
34558 LHEP = MHEP
34559 MHEP = ID
34560 ENDIF
34561C--indices for RPV
34562 III = (IJ-126)/2
34563 JJJ = IDHW(LHEP)/2
34564 KKK = (IDHW(MHEP)-5)/2
34565 L1 = IK-453
34566 DO 40 I=1,2
34567 IDP(4+I) = 423+2*III+(I-1)*12
34568 40 IDP(6+I) = 399+2*JJJ+(I-1)*12
34569C--types of diagram
34570 DRTYPE(1) = 21
34571 DRTYPE(2) = 21
34572 DRTYPE(3) = 22
34573 DRTYPE(4) = 22
34574 DO 41 I=1,2
34575C--RPV couplings
34576 A(1,I ) = ZERO
34577 A(2,I ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
34578 B(1,I+2) = ZERO
34579 B(2,I+2) =-QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
34580C--MSSM couplings
34581 DO 41 J=1,2
34582 B(J,I ) = AFC(O(J),2*III+5,I,L1)
34583 41 A(J,I+2) = AFC(O(J),2*JJJ-1,I,L1)
34584C--colour flows
34585 NDIA = 4
34586 NCFL(1) = 1
34587 DO 42 I=1,4
34588 42 IFLOW(I) = 1
34589 SPNCFC(1,1,1) = ONE/THREE
34590C-- -ve chargino neutrino
34591 ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.0) THEN
34592C--change order if antiparticle first
34593 IF(IDHEP(LHEP).LT.0) THEN
34594 ID = LHEP
34595 LHEP = MHEP
34596 MHEP = ID
34597 ENDIF
34598C--indices for RPV
34599 III = (IJ-120)/2
34600 JJJ = (IDHW(MHEP)-6)/2
34601 KKK = (IDHW(LHEP)+1)/2
34602 L1 = IK-455
34603 DO 43 I=1,2
34604 IDP(4+I) = 423+2*III+(I-1)*12
34605 43 IDP(6+I) = 399+2*JJJ+(I-1)*12
34606C--types of diagram
34607 DRTYPE(1) = 24
34608 DRTYPE(2) = 24
34609 DRTYPE(3) = 25
34610 DRTYPE(4) = 25
34611 DO 44 I=1,2
34612C--RPV couplings
34613 A(1,I ) = LMIXSS(2*III-1,1,I)*LAMDA2(III,JJJ,KKK)
34614 A(2,I ) = ZERO
34615 B(1,I+2) =-QMIXSS(2*JJJ-1,1,I)*LAMDA2(III,JJJ,KKK)
34616 B(2,I+2) = ZERO
34617C--MSSM couplings
34618 DO 44 J=1,2
34619 B(J,I ) = AFC(J,2*III+5,I,L1)
34620 44 A(J,I+2) = AFC(J,2*JJJ-1,I,L1)
34621C--colour flows
34622 NDIA = 4
34623 NCFL(1) = 1
34624 DO 45 I=1,4
34625 45 IFLOW(I) = 1
34626 SPNCFC(1,1,1) = ONE/THREE
34627C-- -ve chargino antilepton
34628 ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.1) THEN
34629C--change order if antiparticle first
34630 IF(IDHEP(LHEP).LT.0) THEN
34631 ID = LHEP
34632 LHEP = MHEP
34633 MHEP = ID
34634 ENDIF
34635C--indices for RPV
34636 III = (IJ-125)/2
34637 JJJ = (IDHW(LHEP)+1)/2
34638 KKK = (IDHW(MHEP)-5)/2
34639 L1 = IK-455
34640 IDP(5) = 424+2*III
34641 DO 46 I=1,2
34642 46 IDP(5+I) = 400+2*JJJ+(I-1)*12
34643C--types of diagram
34644 DRTYPE(1) = 21
34645 DRTYPE(2) = 22
34646 DRTYPE(3) = 22
34647C--RPV couplings
34648 A(1,1) = 0.0D0
34649 A(2,1) =-LAMDA2(III,JJJ,KKK)
34650 DO 47 I=1,2
34651 B(1,I+1) = 0.0D0
34652 47 B(2,I+1) = QMIXSS(2*JJJ,1,I)*LAMDA2(III,JJJ,KKK)
34653C--MSSM couplings
34654 DO 48 J=1,2
34655 B(J,1) = AFC(O(J),2*III+6,1,L1)
34656 DO 48 I=1,2
34657 48 A(J,I+1) = AFC(O(J),2*JJJ,I,L1)
34658C--colour flows
34659 NDIA = 3
34660 NCFL(1) = 1
34661 DO 49 I=1,3
34662 49 IFLOW(I) = 1
34663 SPNCFC(1,1,1) = ONE/THREE
34664C-- +ve chargino lepton
34665 ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.1) THEN
34666C--change order if antiparticle first
34667 IF(IDHEP(LHEP).LT.0) THEN
34668 ID = LHEP
34669 LHEP = MHEP
34670 MHEP = ID
34671 ENDIF
34672C--indices for RPV
34673 III = (IJ-119)/2
34674 JJJ = (IDHW(MHEP)-5)/2
34675 KKK = (IDHW(LHEP)+1)/2
34676 L1 = IK-453
34677 IDP(5) = 424+2*III
34678 DO 50 I=1,2
34679 50 IDP(5+I) = 400+2*JJJ+(I-1)*12
34680C--types of diagram
34681 DRTYPE(1) = 24
34682 DRTYPE(2) = 25
34683 DRTYPE(3) = 25
34684C--RPV couplings
34685 A(1,1) =-LAMDA2(III,JJJ,KKK)
34686 A(2,1) = 0.0D0
34687 DO 51 I=1,2
34688 B(1,I+1) = QMIXSS(2*JJJ,1,I)*LAMDA2(III,JJJ,KKK)
34689 51 B(2,I+1) = 0.0D0
34690C--MSSM couplings
34691 DO 52 J=1,2
34692 B(J,1) = AFC(J,2*III+6,1,L1)
34693 DO 52 I=1,2
34694 52 A(J,I+1) = AFC(J,2*JJJ,I,L1)
34695C--colour flows
34696 NDIA = 3
34697 NCFL(1) = 1
34698 DO 53 I=1,3
34699 53 IFLOW(I) = 1
34700 SPNCFC(1,1,1) = ONE/THREE
34701C--d dbar d dbar
34702 ELSEIF(IK.LE.12.AND.IJ.LE.12.AND.
34703 & MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN
34704C--can't produce unstable quark (on hadronization timescale)
34705 RETURN
34706C--u dbar --> u dbar
34707 ELSEIF((IJ.LE. 6.AND.MOD(IJ,2).EQ.0.AND.
34708 & IK.LE.12.AND.MOD(IK,2).EQ.1).OR.
34709 & (IK.LE.6 .AND.MOD(IK,2).EQ.0.AND.
34710 & IJ.LE.12.AND.MOD(IJ,2).EQ.1)) THEN
34711C--ensure u first (incoming)
34712 IF(MOD(IDHW(LHEP),2).EQ.1) THEN
34713 ID = MHEP
34714 MHEP = LHEP
34715 LHEP = ID
34716 ENDIF
34717C--ensure u first (outgoing)
34718 IF(MOD(IK,2).EQ.1) THEN
34719 ID = IJ
34720 IJ = IK
34721 IK = ID
34722 ID = JHEP
34723 JHEP = KHEP
34724 KHEP = ID
34725 ENDIF
34726C--can't produce unstable quark (on hadronization timescale)
34727 IF(IK.NE.6) RETURN
34728C--RPV indices
34729 JJJ = IDHW(LHEP)/2
34730 KKK = (IDHW(MHEP)-5)/2
34731 LLL = IK/2
34732 MMM = (IJ-5)/2
34733 NDIA = 0
34734 DO 54 III=1,3
34735 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA2(III,LLL,MMM)).LT.EPS)
34736 & GOTO 54
34737 DO 55 J=1,2
34738 IFLOW(NDIA+J) = 1
34739 IDP(4+NDIA+J) = 423+2*III+12*(J-1)
34740 A(1,NDIA+J) = ZERO
34741 A(2,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
34742 B(1,NDIA+J) = LAMDA2(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
34743 B(2,NDIA+J) = ZERO
34744 55 DRTYPE(NDIA+J) = 21
34745 NDIA = NDIA+2
34746 54 CONTINUE
34747 NCFL(1) = 1
34748 SPNCFC(1,1,1) = ONE
34749C--ubar d --> ubar d
34750 ELSEIF((IJ.LE.12.AND.MOD(IJ,2).EQ.0.AND.
34751 & IK.LE. 6.AND.MOD(IK,2).EQ.1).OR.
34752 & (IK.LE.12.AND.MOD(IK,2).EQ.0.AND.
34753 & IJ.LE. 6.AND.MOD(IJ,2).EQ.1)) THEN
34754C--ensure d first (incoming)
34755 IF(MOD(IDHW(LHEP),2).EQ.0) THEN
34756 ID = MHEP
34757 MHEP = LHEP
34758 LHEP = ID
34759 ENDIF
34760C--ensure d first (outgoing)
34761 IF(MOD(IK,2).EQ.0) THEN
34762 ID = IJ
34763 IJ = IK
34764 IK = ID
34765 ID = JHEP
34766 JHEP = KHEP
34767 KHEP = ID
34768 ENDIF
34769C--can't produce unstable quark (on hadronization timescale)
34770 IF(IJ.NE.12) RETURN
34771C--RPV indices
34772 JJJ = (IDHW(MHEP)-6)/2
34773 KKK = (IDHW(LHEP)+1)/2
34774 LLL = (IJ-6)/2
34775 MMM = (IK+1)/2
34776 NDIA = 0
34777 DO 56 III=1,3
34778 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA2(III,LLL,MMM)).LT.EPS)
34779 & GOTO 56
34780 DO 57 J=1,2
34781 IFLOW(NDIA+J) = 1
34782 IDP(4+NDIA+J) = 423+2*III+12*(J-1)
34783 A(1,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
34784 A(2,NDIA+J) = ZERO
34785 B(1,NDIA+J) = ZERO
34786 B(2,NDIA+J) = LAMDA2(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
34787 57 DRTYPE(NDIA+J) = 21
34788 NDIA = NDIA+2
34789 56 CONTINUE
34790 NCFL(1) = 1
34791 SPNCFC(1,1,1) = ONE
34792C--d dbar --> ell- ell+
34793 ELSEIF(IDHW(LHEP).LE.12.AND.MOD(IDHW(LHEP),2).EQ.1.AND.
34794 & IDHW(MHEP).LE.12.AND.MOD(IDHW(MHEP),2).EQ.1.AND.
34795 & IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND.
34796 & IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1) THEN
34797C--change outgoing order
34798 ID = IK
34799 IK = IJ
34800 IJ = ID
34801 ID = JHEP
34802 JHEP = KHEP
34803 KHEP = ID
34804C--change order if dbar first
34805 IF(IDHEP(LHEP).LT.0) THEN
34806 ID = LHEP
34807 LHEP = MHEP
34808 MHEP = ID
34809 ENDIF
34810C--don't do correlations if no taus
34811 IF(IK.NE.125.AND.IJ.NE.131) RETURN
34812C--RPV couplings
34813 JJJ = (IDHW(LHEP)+1)/2
34814 KKK = (IDHW(MHEP)-5)/2
34815 LLL = (IK-119)/2
34816 MMM = (IJ-125)/2
34817 NDIA = 0
34818 DO 58 III=1,3
34819 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
34820 & GOTO 58
34821 NDIA = NDIA+1
34822 IFLOW(NDIA) = 1
34823 IDP(4+NDIA) = 424+2*III
34824 A(1,NDIA) = ZERO
34825 A(2,NDIA) = LAMDA2(III,JJJ,KKK)
34826 B(1,NDIA) = LAMDA1(III,LLL,MMM)
34827 B(2,NDIA) = ZERO
34828 DRTYPE(NDIA) = 21
34829 58 CONTINUE
34830 NCFL(1) = 1
34831 SPNCFC(1,1,1) = ONE/THREE
34832C--dbar d --> ell+ ell-
34833 ELSEIF(IDHW(LHEP).LE.12.AND.MOD(IDHW(LHEP),2).EQ.1.AND.
34834 & IDHW(MHEP).LE.12.AND.MOD(IDHW(MHEP),2).EQ.1.AND.
34835 & IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.1.AND.
34836 & IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1) THEN
34837C--change order if dbar first
34838 IF(IDHEP(LHEP).LT.0) THEN
34839 ID = LHEP
34840 LHEP = MHEP
34841 MHEP = ID
34842 ENDIF
34843C--don't do correlations if no taus
34844 IF(IK.NE.125.AND.IJ.NE.131) RETURN
34845C--RPV couplings
34846 JJJ = (IDHW(MHEP)-5)/2
34847 KKK = (IDHW(LHEP)+1)/2
34848 LLL = (IJ-125)/2
34849 MMM = (IK-119)/2
34850 NDIA = 0
34851 DO 59 III=1,3
34852 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
34853 & GOTO 59
34854 NDIA = NDIA+1
34855 IFLOW(NDIA) = 1
34856 IDP(4+NDIA) = 424+2*III
34857 A(1,NDIA) = LAMDA2(III,JJJ,KKK)
34858 A(2,NDIA) = ZERO
34859 B(1,NDIA) = ZERO
34860 B(2,NDIA) = LAMDA1(III,LLL,MMM)
34861 DRTYPE(NDIA) = 21
34862 59 CONTINUE
34863 NCFL(1) = 1
34864 SPNCFC(1,1,1) = ONE/THREE
34865C--u dbar --> nu ell+
34866 ELSEIF((IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.0.AND.
34867 & IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.1).OR.
34868 & (IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.1.AND.
34869 & IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.0)) THEN
34870C--ensure u first
34871 IF(MOD(IDHW(LHEP),2).NE.0) THEN
34872 ID = LHEP
34873 LHEP = MHEP
34874 MHEP = ID
34875 ENDIF
34876C--ensure nu first
34877 IF(MOD(IK,2).NE.0) THEN
34878 ID = IK
34879 IK = IJ
34880 IJ = ID
34881 ID = JHEP
34882 JHEP = KHEP
34883 KHEP = ID
34884 ENDIF
34885C--only need correlations if tau
34886 IF(IJ.NE.131) RETURN
34887C--RPV couplings
34888 JJJ = IDHW(LHEP)/2
34889 KKK = (IDHW(MHEP)-5)/2
34890 LLL = (IK-120)/2
34891 MMM = (IJ-125)/2
34892 NDIA = 0
34893 DO 60 III=1,3
34894 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
34895 & GOTO 60
34896 DO 61 J=1,2
34897 IFLOW(NDIA+J) = 1
34898 IDP(4+NDIA+J) = 423+2*III+12*(J-1)
34899 A(1,NDIA+J) = ZERO
34900 A(2,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
34901 B(1,NDIA+J) = LAMDA1(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
34902 B(2,NDIA+J) = ZERO
34903 61 DRTYPE(NDIA+J) = 21
34904 NDIA = NDIA+2
34905 60 CONTINUE
34906 NCFL(1) = 1
34907 SPNCFC(1,1,1) = ONE/THREE
34908C--ubar d --> ell nubar
34909 ELSEIF((IK.GE.127.AND.IK.LE.132.AND.MOD(IK,2).EQ.0.AND.
34910 & IJ.GE.121.AND.IJ.LE.126.AND.MOD(IJ,2).EQ.1).OR.
34911 & (IK.GE.121.AND.IK.LE.126.AND.MOD(IK,2).EQ.1.AND.
34912 & IJ.GE.127.AND.IJ.LE.132.AND.MOD(IJ,2).EQ.0)) THEN
34913C--ensure u second
34914 IF(MOD(IDHW(MHEP),2).NE.0) THEN
34915 ID = LHEP
34916 LHEP = MHEP
34917 MHEP = ID
34918 ENDIF
34919C-- ensure nu second
34920 IF(MOD(IJ,2).NE.0) THEN
34921 ID = IK
34922 IK = IJ
34923 IJ = ID
34924 ID = JHEP
34925 JHEP = KHEP
34926 KHEP = ID
34927 ENDIF
34928C--only need correlations if tau
34929 IF(IK.NE.125) RETURN
34930C--RPV couplings
34931 JJJ = (IDHW(MHEP)-6)/2
34932 KKK = (IDHW(LHEP)+1)/2
34933 LLL = (IJ-126)/2
34934 MMM = (IK-119)/2
34935 NDIA = 0
34936 DO 62 III=1,3
34937 IF(ABS(LAMDA2(III,JJJ,KKK)*LAMDA1(III,LLL,MMM)).LT.EPS)
34938 & GOTO 62
34939 DO 63 J=1,2
34940 IFLOW(NDIA+J) = 1
34941 IDP(4+NDIA+J) = 423+2*III+12*(J-1)
34942 A(1,NDIA+J) = LAMDA2(III,JJJ,KKK)*LMIXSS(2*III-1,1,J)
34943 A(2,NDIA+J) = ZERO
34944 B(1,NDIA+J) = ZERO
34945 B(2,NDIA+J) = LAMDA1(III,LLL,MMM)*LMIXSS(2*III-1,1,J)
34946 63 DRTYPE(NDIA+J) = 21
34947 NDIA = NDIA+2
34948 62 CONTINUE
34949 NCFL(1) = 1
34950 SPNCFC(1,1,1) = ONE/THREE
34951C--unrecognized process
34952 ELSE
34953 CALL HWWARN('HWHSPN',505)
34954 ENDIF
34955C--UDD processes
34956 ELSEIF(IPRO.EQ.41) THEN
34957C--change outgoing order
34958 ID = IJ
34959 IJ = IK
34960 IK = ID
34961 ID = JHEP
34962 JHEP = KHEP
34963 KHEP = ID
34964C--ubar neutralino
34965 IF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
34966 & IDPDG(IJ).LT.0) THEN
34967C--indices for RPV
34968 III = (IJ-6)/2
34969 JJJ = (IDHW(LHEP)+1)/2
34970 KKK = (IDHW(MHEP)+1)/2
34971 L1 = IK - 449
34972C--types of diagram
34973 DRTYPE(1) = 27
34974 DRTYPE(2) = 27
34975 DRTYPE(3) = 28
34976 DRTYPE(4) = 28
34977 DRTYPE(5) = 29
34978 DRTYPE(6) = 29
34979C--RPV couplings
34980 DO 64 J=1,2
34981 A(1,J ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
34982 A(2,J ) = ZERO
34983 B(1,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
34984 B(2,J+2) = ZERO
34985 A(1,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
34986 A(2,J+4) = ZERO
34987C--particles
34988 IDP(4+J) = 400+2*III+12*(J-1)
34989 IDP(6+J) = 399+2*JJJ+12*(J-1)
34990 IDP(8+J) = 399+2*KKK+12*(J-1)
34991C--MSSM couplings
34992 DO 64 I=1,2
34993 B(I,J) = AFN(O(I),2*III,J,L1)
34994 A(I,J+2) = AFN(O(I),2*JJJ-1,J,L1)
34995 64 B(I,J+4) = AFN(O(I),2*KKK-1,J,L1)
34996C--colour flows
34997 NDIA = 6
34998 NCFL(1) = 1
34999 DO 65 I=1,6
35000 65 IFLOW(I) = 1
35001 SPNCFC(1,1,1) = TWO/THREE
35002C--u neutralino
35003 ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.0.AND.
35004 & IDPDG(IJ).GT.0) THEN
35005C--indices for RPV
35006 III = IJ/2
35007 JJJ = (IDHW(LHEP)-5)/2
35008 KKK = (IDHW(MHEP)-5)/2
35009 L1 = IK - 449
35010C--types of diagram
35011 DRTYPE(1) = 30
35012 DRTYPE(2) = 30
35013 DRTYPE(3) = 31
35014 DRTYPE(4) = 31
35015 DRTYPE(5) = 32
35016 DRTYPE(6) = 32
35017C--RPV couplings
35018 DO 66 J=1,2
35019 A(1,J ) = ZERO
35020 A(2,J ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
35021 B(1,J+2) = ZERO
35022 B(2,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
35023 A(1,J+4) = ZERO
35024 A(2,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
35025C--particles
35026 IDP(4+J) = 400+2*III+12*(J-1)
35027 IDP(6+J) = 399+2*JJJ+12*(J-1)
35028 IDP(8+J) = 399+2*KKK+12*(J-1)
35029C--MSSM couplings
35030 DO 66 I=1,2
35031 B(I,J) = AFN(I,2*III,J,L1)
35032 A(I,J+2) = AFN(I,2*JJJ-1,J,L1)
35033 66 B(I,J+4) = AFN(I,2*KKK-1,J,L1)
35034C--colour flows
35035 NDIA = 6
35036 NCFL(1) = 1
35037 DO 67 I=1,6
35038 67 IFLOW(I) = 1
35039 SPNCFC(1,1,1) = TWO/THREE
35040C--dbar neutralino
35041 ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
35042 & IDPDG(IJ).LT.0) THEN
35043C--ensure u type first
35044 IF(MOD(IDHW(LHEP),2).NE.0) THEN
35045 ID = LHEP
35046 LHEP = MHEP
35047 MHEP = ID
35048 ENDIF
35049C--RPV indices
35050 III = IDHW(LHEP)/2
35051 JJJ = (IDHW(MHEP)+1)/2
35052 KKK = (IJ-5)/2
35053 L1 = IK - 449
35054C--types of diagram
35055 DRTYPE(1) = 27
35056 DRTYPE(2) = 27
35057 DRTYPE(3) = 28
35058 DRTYPE(4) = 28
35059 DRTYPE(5) = 29
35060 DRTYPE(6) = 29
35061C--RPV couplings
35062 DO 68 I=1,2
35063 A(1,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
35064 A(2,I ) = ZERO
35065 B(1,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
35066 B(2,I+2) = ZERO
35067 A(1,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
35068 A(2,I+4) = ZERO
35069C--particles
35070 IDP(4+I) = 399+2*KKK+12*(I-1)
35071 IDP(6+I) = 400+2*III+12*(I-1)
35072 IDP(8+I) = 399+2*JJJ+12*(I-1)
35073C--MSSM couplings
35074 DO 68 J=1,2
35075 B(J,I ) = AFN(O(J),2*KKK-1,I,L1)
35076 A(J,I+2) = AFN(O(J),2*III ,I,L1)
35077 68 B(J,I+4) = AFN(O(J),2*JJJ-1,I,L1)
35078C--colour flows
35079 NDIA = 6
35080 NCFL(1) = 1
35081 DO 69 I=1,6
35082 69 IFLOW(I) = 1
35083 SPNCFC(1,1,1) = TWO/THREE
35084C--d neutralino
35085 ELSEIF(IK.GE.450.AND.IK.LE.453.AND.MOD(IJ,2).EQ.1.AND.
35086 & IDPDG(IJ).GT.0) THEN
35087C--ensure u type first
35088 IF(MOD(IDHW(LHEP),2).NE.0) THEN
35089 ID = LHEP
35090 LHEP = MHEP
35091 MHEP = ID
35092 ENDIF
35093C--RPV indices
35094 III = (IDHW(LHEP)-6)/2
35095 JJJ = (IDHW(MHEP)-5)/2
35096 KKK = (IJ+1)/2
35097 L1 = IK - 449
35098C--types of diagram
35099 DRTYPE(1) = 30
35100 DRTYPE(2) = 30
35101 DRTYPE(3) = 31
35102 DRTYPE(4) = 31
35103 DRTYPE(5) = 32
35104 DRTYPE(6) = 32
35105C--RPV couplings
35106 DO 70 I=1,2
35107 A(1,I ) = ZERO
35108 A(2,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
35109 B(1,I+2) = ZERO
35110 B(2,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
35111 A(1,I+4) = ZERO
35112 A(2,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
35113C--particles
35114 IDP(4+I) = 399+2*KKK+12*(I-1)
35115 IDP(6+I) = 400+2*III+12*(I-1)
35116 IDP(8+I) = 399+2*JJJ+12*(I-1)
35117C--MSSM couplings
35118 DO 70 J=1,2
35119 B(J,I ) = AFN(J,2*KKK-1,I,L1)
35120 A(J,I+2) = AFN(J,2*III ,I,L1)
35121 70 B(J,I+4) = AFN(J,2*JJJ-1,I,L1)
35122C--colour flows
35123 NDIA = 6
35124 NCFL(1) = 1
35125 DO 71 I=1,6
35126 71 IFLOW(I) = 1
35127 SPNCFC(1,1,1) = TWO/THREE
35128C--ubar gluino
35129 ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.0.AND.IDPDG(IJ).LT.0) THEN
35130C--indices for RPV
35131 III = (IJ-6)/2
35132 JJJ = (IDHW(LHEP)+1)/2
35133 KKK = (IDHW(MHEP)+1)/2
35134C--types of diagram
35135 DRTYPE(1) = 27
35136 DRTYPE(2) = 27
35137 DRTYPE(3) = 28
35138 DRTYPE(4) = 28
35139 DRTYPE(5) = 29
35140 DRTYPE(6) = 29
35141C--RPV couplings
35142 DO 72 J=1,2
35143 A(1,J ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
35144 A(2,J ) = ZERO
35145 B(1,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
35146 B(2,J+2) = ZERO
35147 A(1,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
35148 A(2,J+4) = ZERO
35149C--particles
35150 IDP(4+J) = 400+2*III+12*(J-1)
35151 IDP(6+J) = 399+2*JJJ+12*(J-1)
35152 IDP(8+J) = 399+2*KKK+12*(J-1)
35153C--MSSM couplings
35154 DO 72 I=1,2
35155 B(I,J) = AFG(O(I),2*III,J)
35156 A(I,J+2) = AFG(O(I),2*JJJ-1,J)
35157 72 B(I,J+4) = AFG(O(I),2*KKK-1,J)
35158C--colour flows
35159 NDIA = 6
35160 NCFL(1) = 3
35161 DO 73 I=1,2
35162 IFLOW(I ) = 1
35163 IFLOW(I+2) = 2
35164 73 IFLOW(I+4) = 3
35165 DO 74 I=1,3
35166 DO 74 J=1,3
35167 IF(I.EQ.J) THEN
35168 SPNCFC(I,J,1) = 8.0D0/9.0D0
35169 ELSE
35170 SPNCFC(I,J,1) =-4.0D0/9.0D0
35171 ENDIF
35172 74 CONTINUE
35173C--u gluino
35174 ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.0.AND.IDPDG(IJ).GT.0) THEN
35175C--indices for RPV
35176 III = IJ/2
35177 JJJ = (IDHW(LHEP)-5)/2
35178 KKK = (IDHW(MHEP)-5)/2
35179C--types of diagram
35180 DRTYPE(1) = 30
35181 DRTYPE(2) = 30
35182 DRTYPE(3) = 31
35183 DRTYPE(4) = 31
35184 DRTYPE(5) = 32
35185 DRTYPE(6) = 32
35186C--RPV couplings
35187 DO 75 J=1,2
35188 A(1,J ) = ZERO
35189 A(2,J ) = QMIXSS(2*III,2,J)*LAMDA3(III,JJJ,KKK)
35190 B(1,J+2) = ZERO
35191 B(2,J+2) = QMIXSS(2*JJJ-1,2,J)*LAMDA3(III,JJJ,KKK)
35192 A(1,J+4) = ZERO
35193 A(2,J+4) = QMIXSS(2*KKK-1,2,J)*LAMDA3(III,JJJ,KKK)
35194C--particles
35195 IDP(4+J) = 400+2*III+12*(J-1)
35196 IDP(6+J) = 399+2*JJJ+12*(J-1)
35197 IDP(8+J) = 399+2*KKK+12*(J-1)
35198C--MSSM couplings
35199 DO 75 I=1,2
35200 B(I,J) = AFG(I,2*III,J)
35201 A(I,J+2) = AFG(I,2*JJJ-1,J)
35202 75 B(I,J+4) = AFG(I,2*KKK-1,J)
35203C--colour flows
35204 NDIA = 6
35205 NCFL(1) = 3
35206 DO 76 I=1,2
35207 IFLOW(I ) = 1
35208 IFLOW(I+2) = 2
35209 76 IFLOW(I+4) = 3
35210 DO 77 I=1,3
35211 DO 77 J=1,3
35212 IF(I.EQ.J) THEN
35213 SPNCFC(I,J,1) = 8.0D0/9.0D0
35214 ELSE
35215 SPNCFC(I,J,1) =-4.0D0/9.0D0
35216 ENDIF
35217 77 CONTINUE
35218C--dbar gluino
35219 ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.1.AND.IDPDG(IJ).LT.0) THEN
35220C--ensure u type first
35221 IF(MOD(IDHW(LHEP),2).NE.0) THEN
35222 ID = LHEP
35223 LHEP = MHEP
35224 MHEP = ID
35225 ENDIF
35226C--RPV indices
35227 III = IDHW(LHEP)/2
35228 JJJ = (IDHW(MHEP)+1)/2
35229 KKK = (IJ-5)/2
35230C--types of diagram
35231 DRTYPE(1) = 27
35232 DRTYPE(2) = 27
35233 DRTYPE(3) = 28
35234 DRTYPE(4) = 28
35235 DRTYPE(5) = 29
35236 DRTYPE(6) = 29
35237C--RPV couplings
35238 DO 78 I=1,2
35239 A(1,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
35240 A(2,I ) = ZERO
35241 B(1,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
35242 B(2,I+2) = ZERO
35243 A(1,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
35244 A(2,I+4) = ZERO
35245C--particles
35246 IDP(4+I) = 399+2*KKK+12*(I-1)
35247 IDP(6+I) = 400+2*III+12*(I-1)
35248 IDP(8+I) = 399+2*JJJ+12*(I-1)
35249C--MSSM couplings
35250 DO 78 J=1,2
35251 B(J,I ) = AFG(O(J),2*KKK-1,I)
35252 A(J,I+2) = AFG(O(J),2*III ,I)
35253 78 B(J,I+4) = AFG(O(J),2*JJJ-1,I)
35254C--colour flows
35255 NDIA = 6
35256 NCFL(1) = 3
35257 DO 79 I=1,2
35258 IFLOW(I ) = 1
35259 IFLOW(I+2) = 2
35260 79 IFLOW(I+4) = 3
35261 DO 80 I=1,3
35262 DO 80 J=1,3
35263 IF(I.EQ.J) THEN
35264 SPNCFC(I,J,1) = 8.0D0/9.0D0
35265 ELSE
35266 SPNCFC(I,J,1) =-4.0D0/9.0D0
35267 ENDIF
35268 80 CONTINUE
35269C--d gluino
35270 ELSEIF(IK.EQ.449.AND.MOD(IJ,2).EQ.1.AND.IDPDG(IJ).GT.0) THEN
35271C--ensure u type first
35272 IF(MOD(IDHW(LHEP),2).NE.0) THEN
35273 ID = LHEP
35274 LHEP = MHEP
35275 MHEP = ID
35276 ENDIF
35277C--RPV indices
35278 III = (IDHW(LHEP)-6)/2
35279 JJJ = (IDHW(MHEP)-5)/2
35280 KKK = (IJ+1)/2
35281C--types of diagram
35282 DRTYPE(1) = 30
35283 DRTYPE(2) = 30
35284 DRTYPE(3) = 31
35285 DRTYPE(4) = 31
35286 DRTYPE(5) = 32
35287 DRTYPE(6) = 32
35288C--RPV couplings
35289 DO 81 I=1,2
35290 A(1,I ) = ZERO
35291 A(2,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
35292 B(1,I+2) = ZERO
35293 B(2,I+2) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
35294 A(1,I+4) = ZERO
35295 A(2,I+4) = QMIXSS(2*JJJ-1,2,I)*LAMDA3(III,JJJ,KKK)
35296C--particles
35297 IDP(4+I) = 399+2*KKK+12*(I-1)
35298 IDP(6+I) = 400+2*III+12*(I-1)
35299 IDP(8+I) = 399+2*JJJ+12*(I-1)
35300C--MSSM couplings
35301 DO 81 J=1,2
35302 B(J,I ) = AFG(J,2*KKK-1,I)
35303 A(J,I+2) = AFG(J,2*III ,I)
35304 81 B(J,I+4) = AFG(J,2*JJJ-1,I)
35305C--colour flows
35306 NDIA = 6
35307 NCFL(1) = 3
35308 DO 82 I=1,2
35309 IFLOW(I ) = 1
35310 IFLOW(I+2) = 2
35311 82 IFLOW(I+4) = 3
35312 DO 83 I=1,3
35313 DO 83 J=1,3
35314 IF(I.EQ.J) THEN
35315 SPNCFC(I,J,1) = 8.0D0/9.0D0
35316 ELSE
35317 SPNCFC(I,J,1) =-4.0D0/9.0D0
35318 ENDIF
35319 83 CONTINUE
35320C--dbar -ve chargino
35321 ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.1) THEN
35322C--change order so highest generation first
35323 IF(IDHW(MHEP).GT.IDHW(LHEP)) THEN
35324 ID = MHEP
35325 MHEP = LHEP
35326 LHEP = ID
35327 ENDIF
35328C--RPV indices
35329 III = (IJ-5)/2
35330 JJJ = (IDHW(LHEP)+1)/2
35331 KKK = (IDHW(MHEP)+1)/2
35332 L1 = IK-455
35333C--types of diagram
35334 DRTYPE(1) = 27
35335 DRTYPE(2) = 27
35336 DRTYPE(3) = 28
35337 DRTYPE(4) = 28
35338 DRTYPE(5) = 29
35339 DRTYPE(6) = 29
35340C--RPV couplings
35341 DO 84 I=1,2
35342 A(1,I ) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
35343 A(2,I ) = ZERO
35344 B(1,I+2) = QMIXSS(2*JJJ,2,I)*LAMDA3(JJJ,KKK,III)
35345 B(2,I+2) = ZERO
35346 A(1,I+4) = QMIXSS(2*KKK,2,I)*LAMDA3(KKK,III,JJJ)
35347 A(2,I+4) = ZERO
35348C--particles
35349 IDP(4+I) = 400+2*III+12*(I-1)
35350 IDP(6+I) = 400+2*JJJ+12*(I-1)
35351 IDP(8+I) = 400+2*KKK+12*(I-1)
35352C--MSSM couplings
35353 DO 84 J=1,2
35354 B(J,I ) = AFC(O(J),2*III,I,L1)
35355 A(J,I+2) = AFC(O(J),2*JJJ,I,L1)
35356 84 B(J,I+4) = AFC(O(J),2*KKK,I,L1)
35357C--colour flows
35358 NDIA = 6
35359 NCFL(1) = 1
35360 DO 85 I=1,6
35361 85 IFLOW(I) = 1
35362 SPNCFC(1,1,1) = TWO/THREE
35363C--d +ve chargino
35364 ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.1) THEN
35365C--change order so highest generation first
35366 IF(IDHW(MHEP).GT.IDHW(LHEP)) THEN
35367 ID = MHEP
35368 MHEP = LHEP
35369 LHEP = ID
35370 ENDIF
35371C--RPV indices
35372 III = (IJ+1)/2
35373 JJJ = (IDHW(LHEP)-5)/2
35374 KKK = (IDHW(MHEP)-5)/2
35375 L1 = IK-453
35376C--types of diagram
35377 DRTYPE(1) = 30
35378 DRTYPE(2) = 30
35379 DRTYPE(3) = 31
35380 DRTYPE(4) = 31
35381 DRTYPE(5) = 32
35382 DRTYPE(6) = 32
35383C--RPV couplings
35384 DO 86 I=1,2
35385 A(1,I ) = ZERO
35386 A(2,I ) = QMIXSS(2*III,2,I)*LAMDA3(III,JJJ,KKK)
35387 B(1,I+2) = ZERO
35388 B(2,I+2) = QMIXSS(2*JJJ,2,I)*LAMDA3(JJJ,KKK,III)
35389 A(1,I+4) = ZERO
35390 A(2,I+4) = QMIXSS(2*KKK,2,I)*LAMDA3(KKK,III,JJJ)
35391C--particles
35392 IDP(4+I) = 400+2*III+12*(I-1)
35393 IDP(6+I) = 400+2*JJJ+12*(I-1)
35394 IDP(8+I) = 400+2*KKK+12*(I-1)
35395C--MSSM couplings
35396 DO 86 J=1,2
35397 B(J,I ) = AFC(J,2*III,I,L1)
35398 A(J,I+2) = AFC(J,2*JJJ,I,L1)
35399 86 B(J,I+4) = AFC(J,2*KKK,I,L1)
35400C--colour flows
35401 NDIA = 6
35402 NCFL(1) = 1
35403 DO 87 I=1,6
35404 87 IFLOW(I) = 1
35405 SPNCFC(1,1,1) = TWO/THREE
35406C--ubar +ve chargino
35407 ELSEIF(IK.GE.454.AND.IK.LE.455.AND.MOD(IJ,2).EQ.0) THEN
35408C--ensure u type first
35409 IF(MOD(IDHW(LHEP),2).NE.0) THEN
35410 ID = LHEP
35411 LHEP = MHEP
35412 MHEP = ID
35413 ENDIF
35414C--RPV indices
35415 III = IDHW(LHEP)/2
35416 JJJ = (IDHW(MHEP)+1)/2
35417 KKK = (IJ-6)/2
35418 L1 = IK-453
35419C--types of diagram
35420 DRTYPE(1) = 27
35421 DRTYPE(2) = 27
35422 DRTYPE(3) = 28
35423 DRTYPE(4) = 28
35424C--RPV couplings
35425 DO 88 I=1,2
35426 A(1,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
35427 A(2,I ) = ZERO
35428 B(1,I+2) = QMIXSS(2*III-1,2,I)*LAMDA3(KKK,III,JJJ)
35429 B(2,I+2) = ZERO
35430C--particles
35431 IDP(4+I) = 399+2*KKK+12*(I-1)
35432 IDP(6+I) = 399+2*III+12*(I-1)
35433C--MSSM couplings
35434 DO 88 J=1,2
35435 B(J,I ) = AFC(O(J),2*KKK-1,I,L1)
35436 88 A(J,I+2) = AFC(O(J),2*III-1,I,L1)
35437C--colour flows
35438 NDIA = 4
35439 NCFL(1) = 1
35440 DO 89 I=1,4
35441 89 IFLOW(I) = 1
35442 SPNCFC(1,1,1) = TWO/THREE
35443C--u -ve chargino
35444 ELSEIF(IK.GE.456.AND.IK.LE.457.AND.MOD(IJ,2).EQ.0) THEN
35445C--ensure u type first
35446 IF(MOD(IDHW(LHEP),2).NE.0) THEN
35447 ID = LHEP
35448 LHEP = MHEP
35449 MHEP = ID
35450 ENDIF
35451C--RPV indices
35452 III = (IDHW(LHEP)-6)/2
35453 JJJ = (IDHW(MHEP)-5)/2
35454 KKK = IJ/2
35455 L1 = IK-455
35456C--types of diagram
35457 DRTYPE(1) = 30
35458 DRTYPE(2) = 30
35459 DRTYPE(3) = 31
35460 DRTYPE(4) = 31
35461C--RPV couplings
35462 DO 90 I=1,2
35463 A(1,I ) = ZERO
35464 A(2,I ) = QMIXSS(2*KKK-1,2,I)*LAMDA3(III,JJJ,KKK)
35465 B(1,I+2) = ZERO
35466 B(2,I+2) = QMIXSS(2*III-1,2,I)*LAMDA3(KKK,III,JJJ)
35467C--particles
35468 IDP(4+I) = 399+2*KKK+12*(I-1)
35469 IDP(6+I) = 399+2*III+12*(I-1)
35470C--MSSM couplings
35471 DO 90 J=1,2
35472 B(J,I ) = AFC(J,2*KKK-1,I,L1)
35473 90 A(J,I+2) = AFC(J,2*III-1,I,L1)
35474C--colour flows
35475 NDIA = 4
35476 NCFL(1) = 1
35477 DO 91 I=1,4
35478 91 IFLOW(I) = 1
35479 SPNCFC(1,1,1) = TWO/THREE
35480C--d d --> d d
35481 ELSEIF(IDPDG(IK).GT.0.AND.IDPDG(IK).GT.0.AND.
35482 & MOD(IK,2).EQ.1.AND.MOD(IJ,2).EQ.1) THEN
35483C--can't produce unstable quark on hadronisation timescale
35484 RETURN
35485C--dbar dbar --> dbar dbar
35486 ELSEIF(IDPDG(IK).LT.0.AND.IDPDG(IJ).LT.0.AND.
35487 & MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.1) THEN
35488C--can't produce unstable quark on hadronisation timescale
35489 RETURN
35490C--u d --> u d
35491 ELSEIF(IDPDG(IK).GT.0.AND.IDPDG(IJ).GT.0.AND.
35492 & ((MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.0).OR.
35493 & (MOD(IJ,2).EQ.0.AND.MOD(IK,2).EQ.1))) THEN
35494C--ensure u first (incoming)
35495 IF(MOD(IDHW(LHEP),2).EQ.1) THEN
35496 ID = MHEP
35497 MHEP = LHEP
35498 LHEP = ID
35499 ENDIF
35500C--ensure u first (outgoing)
35501 IF(MOD(IK,2).EQ.1) THEN
35502 ID = IJ
35503 IJ = IK
35504 IK = ID
35505 ID = JHEP
35506 JHEP = KHEP
35507 KHEP = ID
35508 ENDIF
35509C--can't produce unstable quark on hadronisation timescale
35510 IF(IK.NE.6) RETURN
35511C--RPV indices
35512 III = IDHW(LHEP)/2
35513 KKK = (IDHW(MHEP)+1)/2
35514 LLL = IK/2
35515 MMM = (IJ+1)/2
35516 NDIA = 0
35517 DO 92 JJJ=1,3
35518 IF(ABS(LAMDA3(III,JJJ,KKK)*LAMDA3(LLL,JJJ,MMM)).LT.EPS)
35519 & GOTO 92
35520 DO 93 J=1,2
35521 IFLOW(NDIA+J) = 1
35522 IDP(4+NDIA+J) = 399+2*JJJ+12*(J-1)
35523 A(1,NDIA+J) = LAMDA3(III,JJJ,KKK)*QMIXSS(2*JJJ-1,2,J)
35524 A(2,NDIA+J) = ZERO
35525 B(1,NDIA+J) = ZERO
35526 B(2,NDIA+J) = LAMDA3(LLL,JJJ,MMM)*QMIXSS(2*JJJ-1,2,J)
35527 93 DRTYPE(NDIA+J) = 33
35528 NDIA = NDIA+2
35529 92 CONTINUE
35530 NCFL(1) = 1
35531 SPNCFC(1,1,1) = ONE/THREE
35532C--ubar dbar --> ubar dbar
35533 ELSEIF(IDPDG(IK).LT.0.AND.IDPDG(IJ).LT.0.AND.
35534 & ((MOD(IJ,2).EQ.1.AND.MOD(IK,2).EQ.0).OR.
35535 & (MOD(IJ,2).EQ.0.AND.MOD(IK,2).EQ.1))) THEN
35536C--ensure u first (incoming)
35537 IF(MOD(IDHW(LHEP),2).EQ.1) THEN
35538 ID = MHEP
35539 MHEP = LHEP
35540 LHEP = ID
35541 ENDIF
35542C--ensure u first (outgoing)
35543 IF(MOD(IK,2).EQ.1) THEN
35544 ID = IJ
35545 IJ = IK
35546 IK = ID
35547 ID = JHEP
35548 JHEP = KHEP
35549 KHEP = ID
35550 ENDIF
35551C--can't produce unstable quark on hadronisation timescale
35552 IF(IK.NE.6) RETURN
35553C--RPV indices
35554 III = (IDHW(LHEP)-6)/2
35555 KKK = (IDHW(MHEP)-5)/2
35556 LLL = (IK-6)/2
35557 MMM = (IJ-5)/2
35558 NDIA = 0
35559 DO 94 JJJ=1,3
35560 IF(ABS(LAMDA3(III,JJJ,KKK)*LAMDA3(LLL,JJJ,MMM)).LT.EPS)
35561 & GOTO 94
35562 DO 95 J=1,2
35563 IFLOW(NDIA+J) = 1
35564 IDP(4+NDIA+J) = 399+2*JJJ+12*(J-1)
35565 A(1,NDIA+J) = ZERO
35566 A(2,NDIA+J) = LAMDA3(III,JJJ,KKK)*QMIXSS(2*JJJ-1,2,J)
35567 B(1,NDIA+J) = LAMDA3(LLL,JJJ,MMM)*QMIXSS(2*JJJ-1,2,J)
35568 B(2,NDIA+J) = ZERO
35569 95 DRTYPE(NDIA+J) = 34
35570 NDIA = NDIA+2
35571 94 CONTINUE
35572 NCFL(1) = 1
35573 SPNCFC(1,1,1) = ONE/THREE
35574C--unrecognized process
35575 ELSE
35576 CALL HWWARN('HWHSPN',506)
35577 ENDIF
35578C--unrecognized process
35579 ELSE
35580 CALL HWWARN('HWHSPN',507)
35581 ENDIF
35582C--copy the momenta into the internal array
35583 CALL HWVEQU(5,PHEP(1,LHEP),P(1,1))
35584 CALL HWVEQU(5,PHEP(1,MHEP),P(1,2))
35585 CALL HWVEQU(5,PHEP(1,KHEP),P(1,3))
35586 CALL HWVEQU(5,PHEP(1,JHEP),P(1,4))
35587C--now compute the masses etc for the diagrams
35588 IDP(1) = IDHW(LHEP)
35589 IDP(2) = IDHW(MHEP)
35590 IDP(3) = IDHW(KHEP)
35591 IDP(4) = IDHW(JHEP)
35592 DO 104 I=1,4
35593 MA (I) = P(5,I)
35594 104 MA2(I) = SIGN(MA(I)**2,MA(I))
35595 DO 105 I=1,NDIA
35596 MR(I) = RMASS(IDP(4+I))
35597 MS(I) = MR(I)**2
35598 IF(IDP(I+4).EQ.200) THEN
35599 MWD(I) = RMASS(200)*GAMZ
35600 ELSEIF(IDP(I+4).EQ.198.OR.IDP(I+4).EQ.199) THEN
35601 MWD(I) = RMASS(198)*GAMW
35602 ELSEIF(IDP(I+4).EQ.59.OR.IDP(I+4).EQ.13.OR.
35603 & IDP(I+4).LE.5.OR.(IDP(I+4).GE.7.AND.IDP(I+4).LE.11)) THEN
35604 MR(I) = ZERO
35605 MS(I) = ZERO
35606 MWD(I) = ZERO
35607 ELSE
35608 MWD(I) = MR(I)*HBAR/RLTIM(IDP(I+4))
35609 ENDIF
35610 105 CONTINUE
35611C--set up the mandelstam variables
35612 SH = TWO*HWULDO(P(1,1),P(1,2))
35613 CALL HWVSCA(4,-ONE,P(1,3),PLAB(1,2))
35614 CALL HWVSUM(5,P(1,1),PLAB(1,2),PLAB(1,1))
35615 TH = P(5,3)**2-TWO*HWULDO(P(1,1),P(1,3))
35616 UH = P(5,4)**2-TWO*HWULDO(P(1,1),P(1,4))
35617C--copy the momenta into the common block for spinor computation
35618 DO 106 I=1,4
35619 IF(IDP(I).LT.400.AND.(IDP(I).NE.6.AND.IDP(I).NE.12
35620 & .AND.IDP(I).NE.125.AND.IDP(I).NE.131)) THEN
35621 CALL HWVEQU(5,PREF,PLAB(1,I+4))
35622C--all other particles
35623 ELSE
35624 PP = SQRT(HWVDOT(3,P(1,I),P(1,I)))
35625 CALL HWVSCA(3,ONE/PP,P(1,I),N)
35626 PLAB(4,I+4) = HALF*(P(4,I)-PP)
35627 PP = HALF*(PP-P(5,I)-PP**2/(P(5,I)+P(4,I)))
35628 CALL HWVSCA(3,PP,N,PLAB(1,I+4))
35629 CALL HWUMAS(PLAB(1,I+4))
35630 PP = HWVDOT(3,PLAB(1,I+4),PLAB(1,I+4))
35631C--fix to avoid problems if approx massless due to energy
35632 IF(PP.LT.EPS) CALL HWVEQU(5,PREF,PLAB(1,I+4))
35633 ENDIF
35634C--now the massless vectors
35635 PP = HALF*MA2(I)/HWULDO(PLAB(1,I+4),P(1,I))
35636 DO 107 J=1,4
35637 107 PLAB(J,I) = P(J,I)-PP*PLAB(J,I+4)
35638 106 CALL HWUMAS(PLAB(1,I))
35639C--change order of momenta for call to HE code
35640 DO 108 I=1,4
35641 PM(1,I) = P(3,I)
35642 PM(2,I) = P(1,I)
35643 PM(3,I) = P(2,I)
35644 PM(4,I) = P(4,I)
35645 108 PM(5,I) = P(5,I)
35646 DO 109 I=1,8
35647 PCM(1,I)=PLAB(3,I)
35648 PCM(2,I)=PLAB(1,I)
35649 PCM(3,I)=PLAB(2,I)
35650 PCM(4,I)=PLAB(4,I)
35651 109 PCM(5,I)=PLAB(5,I)
35652C--compute the S functions
35653 CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
35654 DO 110 I=1,8
35655 DO 110 J=1,8
35656 S(I,J,2) = -S(I,J,2)
35657 110 D(I,J) = TWO*D(I,J)
35658C--compute the F functions
35659 CALL HWH2F1(8,F3 ,7,PM(1,3), MA(3))
35660 CALL HWH2F2(8,F4 ,8,PM(1,4),-MA(4))
35661 CALL HWH2F1(8,F4M,8,PM(1,4), MA(4))
35662 CALL HWH2F2(8,F3M,7,PM(1,3),-MA(3))
35663C--t and u channel functions
35664C--first the t channel ones
35665 CALL HWVSCA(4,-ONE,PM(1,4),PTMP)
35666 CALL HWVSUM(4,PM(1,2),PTMP,PTMP)
35667 CALL HWUMAS(PTMP)
35668 CALL HWH2F3(8,FTP,PTMP, MR(1))
35669 CALL HWH2F3(8,FTM,PTMP,-MR(1))
35670C--then the u-channel ones
35671 CALL HWVSCA(4,-ONE,PM(1,4),PTMP)
35672 CALL HWVSUM(4,PM(1,1),PTMP,PTMP)
35673 CALL HWUMAS(PTMP)
35674 CALL HWH2F3(8,FUP,PTMP, MR(1))
35675 CALL HWH2F3(8,FUM,PTMP,-MR(1))
35676C--function for t-channel scalar exchange
35677 CALL HWVSUM(4,PM(1,4),PM(1,4),PTMP)
35678 CALL HWUMAS(PTMP)
35679 CALL HWH2F1(8,FST,2,PTMP,ZERO)
35680C--compute the prefactor for all diagrams
35681 PRE = HWULDO(PCM(1,7),PM(1,3))*HWULDO(PCM(1,8),PM(1,4))
35682 PRE = ONE/SQRT(PRE)
35683C--zero the matrix element
35684 DO 200 P1=1,2
35685 DO 200 P2=1,2
35686 DO 200 P3=1,2
35687 DO 200 P4=1,2
35688 DO 200 I=1,NCFL(1)
35689 200 ME(P1,P2,P3,P4,I) = (0.0D0,0.0D0)
35690C--now call the subroutines to compute the individual diagrams
35691 DO 210 I=1,NDIA
35692C--s-channel vector boson exchange diagram (f fbar to fermion fermion)
35693 IF(DRTYPE(I).EQ.1) THEN
35694 CALL HWHS01(I,MED)
35695C--t-channel sfermion exchange diagram (f fbar to fermion fermion)
35696 ELSEIF(DRTYPE(I).EQ.2) THEN
35697 CALL HWHS02(I,MED)
35698C--u-channel sfermion exchange diagram(f fbar to fermion fermion)
35699 ELSEIF(DRTYPE(I).EQ.3) THEN
35700 CALL HWHS03(I,MED)
35701C--s-channel vector boson (f fbar to fermion antifermion)
35702 ELSEIF(DRTYPE(I).EQ.4) THEN
35703 CALL HWHS04(I,MED)
35704C--t-channel fermion exchange (g g to fermion antifermion)
35705 ELSEIF(DRTYPE(I).EQ.5) THEN
35706 CALL HWHS05(I,MED)
35707C--u-channel fermion exchange (g g to fermion antifermion)
35708 ELSEIF(DRTYPE(I).EQ.6) THEN
35709 CALL HWHS06(I,MED)
35710C--s-channel gluon exchange (g g to fermion antifermion)
35711 ELSEIF(DRTYPE(I).EQ.7) THEN
35712 CALL HWHS07(I,MED)
35713C--t-channel sfermion exchange (g q to fermion sfermion)
35714 ELSEIF(DRTYPE(I).EQ.8) THEN
35715 CALL HWHS08(I,MED)
35716C--t-channel sfermion exchange (g qbar to fermion antisfermion)
35717 ELSEIF(DRTYPE(I).EQ.9) THEN
35718 CALL HWHS09(I,MED)
35719C--s-channel quark exchange (g q to fermion antisfermion)
35720 ELSEIF(DRTYPE(I).EQ.10) THEN
35721 CALL HWHS10(I,MED)
35722C--s-channel antiquark exchange (g qbar to fermion antisfermion)
35723 ELSEIF(DRTYPE(I).EQ.11) THEN
35724 CALL HWHS11(I,MED)
35725C--u-channel gluino exchange (g q to fermion antisfermion)
35726 ELSEIF(DRTYPE(I).EQ.12) THEN
35727 CALL HWHS12(I,MED)
35728C--u-channel gluino exchange (g qbar to fermion antisfermion)
35729 ELSEIF(DRTYPE(I).EQ.13) THEN
35730 CALL HWHS13(I,MED)
35731C--t-channel fermion exchange (g g to fermion fermion)
35732 ELSEIF(DRTYPE(I).EQ.14) THEN
35733 CALL HWHS14(I,MED)
35734C--u-channel fermion exchange (g g to fermion fermion)
35735 ELSEIF(DRTYPE(I).EQ.15) THEN
35736 CALL HWHS15(I,MED)
35737C--s-channel gluon exchange (g g to fermion fermion)
35738 ELSEIF(DRTYPE(I).EQ.16) THEN
35739 CALL HWHS16(I,MED)
35740C--t-channel gauge boson exchange (fermion fermion)
35741 ELSEIF(DRTYPE(I).EQ.17) THEN
35742 CALL HWHS17(I,MED)
35743C--t-channel gauge boson exchange (fermion antifermion)
35744 ELSEIF(DRTYPE(I).EQ.18) THEN
35745 CALL HWHS18(I,MED)
35746C--t-channel gauge boson exchange (antifermion fermion)
35747 ELSEIF(DRTYPE(I).EQ.19) THEN
35748 CALL HWHS19(I,MED)
35749C--t-channel gauge boson exchange (antifermion antifermion)
35750 ELSEIF(DRTYPE(I).EQ.20) THEN
35751 CALL HWHS20(I,MED)
35752C--s-channel scalar exchange (f fbar --> f fbar)
35753 ELSEIF(DRTYPE(I).EQ.21) THEN
35754 CALL HWHS21(I,MED)
35755C--t-channel scalar exchange (f fbar --> f fbar)
35756 ELSEIF(DRTYPE(I).EQ.22) THEN
35757 CALL HWHS22(I,MED)
35758C--u-channel scalar exchange (f fbar --> f fbar)
35759 ELSEIF(DRTYPE(I).EQ.23) THEN
35760 CALL HWHS23(I,MED)
35761C--s-channel scalar exchange (fbar f --> f f)
35762 ELSEIF(DRTYPE(I).EQ.24) THEN
35763 CALL HWHS24(I,MED)
35764C--t-channel scalar exchange (fbar f --> f f)
35765 ELSEIF(DRTYPE(I).EQ.25) THEN
35766 CALL HWHS25(I,MED)
35767C--u-channel scalar exchange (fbar f --> f f)
35768 ELSEIF(DRTYPE(I).EQ.26) THEN
35769 CALL HWHS26(I,MED)
35770C--s-channel scalar exchange (f f --> f fbar)
35771 ELSEIF(DRTYPE(I).EQ.27) THEN
35772 CALL HWHS27(I,MED)
35773C--t-channel scalar exchange (f f --> f fbar)
35774 ELSEIF(DRTYPE(I).EQ.28) THEN
35775 CALL HWHS28(I,MED)
35776C--u-channel scalar exchange (f f --> f fbar)
35777 ELSEIF(DRTYPE(I).EQ.29) THEN
35778 CALL HWHS29(I,MED)
35779C--s-channel scalar exchange (fbar fbar --> f f)
35780 ELSEIF(DRTYPE(I).EQ.30) THEN
35781 CALL HWHS30(I,MED)
35782C--t-channel scalar exchange (fbar fbar --> f f)
35783 ELSEIF(DRTYPE(I).EQ.31) THEN
35784 CALL HWHS31(I,MED)
35785C--u-channel scalar exchange (fbar fbar --> f f)
35786 ELSEIF(DRTYPE(I).EQ.32) THEN
35787 CALL HWHS32(I,MED)
35788C--s-channel scalar exchange (f f --> f f)
35789 ELSEIF(DRTYPE(I).EQ.33) THEN
35790 CALL HWHS33(I,MED)
35791C--s-channel scalar exchange (fbar fbar --> fbar fbar)
35792 ELSEIF(DRTYPE(I).EQ.34) THEN
35793 CALL HWHS34(I,MED)
35794C--error not known
35795 ELSE
35796 CALL HWWARN('HWHSPN',508)
35797 ENDIF
35798C--add up the matrix elements
35799 DO 210 P1=1,2
35800 DO 210 P2=1,2
35801 DO 210 P3=1,2
35802 DO 210 P4=1,2
35803 210 ME(P1,P2,P3,P4,IFLOW(I)) = ME(P1,P2,P3,P4,IFLOW(I))
35804 & +MED(P1,P2,P3,P4)
35805C--preform the final normalisation
35806 DO 215 P1=1,2
35807 DO 215 P2=1,2
35808 DO 215 P3=1,2
35809 DO 215 P4=1,2
35810 DO 215 I=1,NCFL(1)
35811 215 ME(P1,P2,P3,P4,I) = PRE*ME(P1,P2,P3,P4,I)
35812C--now enter the matrix element in the spin common block
35813 NSPN = 1
35814 IDSPN(1) = ICM
35815 ISNHEP(ICM) = 1
35816 JMOSPN(1) = 0
35817 JDASPN(1,1) = 2
35818 JDASPN(2,1) = 3
35819 DECSPN(1) = .FALSE.
35820 DO 225 P1=1,2
35821 DO 225 P2=1,2
35822 DO 225 P3=1,2
35823 DO 225 P4=1,2
35824 DO 225 I=1,NCFL(1)
35825 225 MESPN(P1,P2,P3,P4,I,1) = ME(P1,P2,P3,P4,I)
35826C--now enter the daughter particles
35827 NSPN = NSPN+2
35828 IDSPN(2) = KHEP
35829 ISNHEP(KHEP) = 2
35830 IDSPN(3) = JHEP
35831 ISNHEP(JHEP) = 3
35832 JMOSPN(2) = 1
35833 JMOSPN(3) = 1
35834C--spin density matrices for daughter particles
35835 DO 230 P1=1,2
35836 DO 230 P2=1,2
35837 DO 230 I=1,3
35838 RHOSPN(1,1,I) = HALF
35839 RHOSPN(1,2,I) = ZERO
35840 RHOSPN(2,1,I) = ZERO
35841 230 RHOSPN(2,2,I) = HALF
35842 DECSPN(2) = .FALSE.
35843 DECSPN(3) = .FALSE.
35844C--select the colour flow if needed
35845 IF(SPCOPT.EQ.2.AND.NCFL(1).NE.1) THEN
35846 WGT = ZERO
35847C--assume no incoming polarization, no processes with more than one
35848C--colour flow in e+e-
35849 DO 335 I =1,NCFL(1)
35850 WGTB(I) = ZERO
35851 DO 335 P1=1,2
35852 DO 335 P2=1,2
35853 DO 335 P3=1,2
35854 DO 335 P4=1,2
35855 WGTB(I) = WGTB(I)+SPNCFC(I,I,1)*DREAL(
35856 & MESPN(P1,P2,P3,P4,I,1)*DCONJG(MESPN(P1,P2,P3,P4,I,1)))
35857 DO 335 J =1,NCFL(1)
35858 335 WGT = WGT+SPNCFC(I,J,1)*DREAL(
35859 & MESPN(P1,P2,P3,P4,I,1)*DCONJG(MESPN(P1,P2,P3,P4,J,1)))
35860 WGTC = ZERO
35861 DO 340 I=1,NCFL(1)
35862 340 WGTC = WGTC+WGTB(I)
35863 WGTC = WGT/WGTC
35864 DO 345 I=1,NCFL(1)
35865 345 WGTB(I) = WGTB(I)*WGTC
35866 WGTC = WGT*HWRGEN(0)
35867 DO 350 I=1,NCFL(1)
35868 IF(WGTB(I).GE.WGTC) THEN
35869 NCFL(1) = I
35870 RETURN
35871 ENDIF
35872 350 WGTC =WGTC-WGTB(I)
35873 ENDIF
35874 END
35875CDECK ID>, HWHS01.
35876*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35877*-- Author : Peter Richardson
35878C-----------------------------------------------------------------------
35879 SUBROUTINE HWHS01(ID,ME)
35880C-----------------------------------------------------------------------
35881C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35882C section f fbar --> gauge boson --> fermion fermion
35883C This diagram 1 from DAMTP-2001-83 with opposite sign of P4
35884C-----------------------------------------------------------------------
c63d70bc 35885 INCLUDE 'herwig65.inc'
65767955 35886 INTEGER NDIAHD
35887 PARAMETER(NDIAHD=10)
35888 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35889 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35890 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35891 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35892 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35893 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35894 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35895 & MA2,SH,TH,UH,IDP,DRTYPE
35896 PARAMETER(ZI=(0.0D0,1.0D0))
35897 COMMON/HWHEWS/S(8,8,2),D(8,8)
35898 SAVE O
35899 DATA O/2,1/
35900C--compute the propagator factor
35901 PRE = -ONE/(SH-MS(ID)+ZI*MWD(ID))
35902 DO 10 P1=1,2
35903 DO 10 P2=1,2
35904 DO 10 P3=1,2
35905 DO 10 P4=1,2
35906 IF(P1.EQ.P2) THEN
35907 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*(
35908 & B(O(P1),ID)*F3(O(P3), P1 ,1)*F4( P1 ,P4,2)
35909 & +B( P1 ,ID)*F3(O(P3),O(P1),2)*F4(O(P1),P4,1))
35910 ELSE
35911 ME(P1,P2,P3,P4) = ZERO
35912 ENDIF
35913 10 CONTINUE
35914 END
35915CDECK ID>, HWHS02.
35916*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35917*-- Author : Peter Richardson
35918C-----------------------------------------------------------------------
35919 SUBROUTINE HWHS02(ID,ME)
35920C-----------------------------------------------------------------------
35921C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35922C section f fbar ---> fermion fermion via t-channel scalar exchange
35923C This diagram 2 from DAMTP-2001-83 with opposite sign of P4
35924C-----------------------------------------------------------------------
c63d70bc 35925 INCLUDE 'herwig65.inc'
65767955 35926 INTEGER NDIAHD
35927 PARAMETER(NDIAHD=10)
35928 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
35929 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35930 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35931 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35932 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35933 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35934 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35935 & MA2,SH,TH,UH,IDP,DRTYPE
35936 COMMON/HWHEWS/S(8,8,2),D(8,8)
35937 SAVE O
35938 DATA O/2,1/
35939C--compute the propagator factor
35940 PRE = -HALF/(TH-MS(ID))
35941 DO 10 P1=1,2
35942 DO 10 P2=1,2
35943 DO 10 P3=1,2
35944 DO 10 P4=1,2
35945 10 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(O(P2),ID)*
35946 & F3(O(P3),P1,1)*F4(P2,P4,2)
35947 END
35948CDECK ID>, HWHS03.
35949*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35950*-- Author : Peter Richardson
35951C-----------------------------------------------------------------------
35952 SUBROUTINE HWHS03(ID,ME)
35953C-----------------------------------------------------------------------
35954C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35955C section f fbar ---> fermion fermion via u-channel scalar exchange
35956C This diagram 3 from DAMTP-2001-83 with opposite sign of P4
35957C-----------------------------------------------------------------------
c63d70bc 35958 INCLUDE 'herwig65.inc'
65767955 35959 INTEGER NDIAHD
35960 PARAMETER(NDIAHD=10)
35961 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,
35962 & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35963 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35964 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35965 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35966 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
35967 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
35968 & MA2,SH,TH,UH,IDP,DRTYPE
35969 COMMON/HWHEWS/S(8,8,2),D(8,8)
35970 SAVE O
35971 DATA O/2,1/
35972C--compute the propagator factor
35973 PRE = HALF/(UH-MS(ID))
35974 DO 10 P1=1,2
35975 DO 10 P2=1,2
35976 DO 10 P3=1,2
35977 DO 10 P4=1,2
35978 10 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(O(P2),ID)*
35979 & F4M(O(P4),P1,1)*F3M(P2,P3,2)
35980 END
35981CDECK ID>, HWHS04.
35982*CMZ :- -02/10/01 10:17:10 by Peter Richardson
35983*-- Author : Peter Richardson
35984C-----------------------------------------------------------------------
35985 SUBROUTINE HWHS04(ID,ME)
35986C-----------------------------------------------------------------------
35987C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
35988C section f fbar --> gauge boson --> fermion antifermion
35989C This diagram 1 from DAMTP-2001-83
35990C-----------------------------------------------------------------------
c63d70bc 35991 INCLUDE 'herwig65.inc'
65767955 35992 INTEGER NDIAHD
35993 PARAMETER(NDIAHD=10)
35994 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
35995 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
35996 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
35997 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
35998 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
35999 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36000 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36001 & MA2,SH,TH,UH,IDP,DRTYPE
36002 PARAMETER(ZI=(0.0D0,1.0D0))
36003 COMMON/HWHEWS/S(8,8,2),D(8,8)
36004 SAVE O
36005 DATA O/2,1/
36006C--compute the propagator factor
36007 PRE = -ONE/(SH-MS(ID)+ZI*MWD(ID))
36008 DO 10 P1=1,2
36009 DO 10 P2=1,2
36010 DO 10 P3=1,2
36011 DO 10 P4=1,2
36012 IF(P1.EQ.P2) THEN
36013 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*(
36014 & B(O(P1),ID)*F3(O(P3), P1 ,1)*F4( P1 ,O(P4),2)
36015 & +B( P1 ,ID)*F3(O(P3),O(P1),2)*F4(O(P1),O(P4),1))
36016 ELSE
36017 ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
36018 ENDIF
36019 10 CONTINUE
36020 END
36021CDECK ID>, HWHS05.
36022*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36023*-- Author : Peter Richardson
36024C-----------------------------------------------------------------------
36025 SUBROUTINE HWHS05(ID,ME)
36026C-----------------------------------------------------------------------
36027C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36028C section gluon gluon --> fermion antifermion (1st colour flow)
36029C N.B. a gauge choice has been made to simplify the triple gluon vertex
36030C This diagram 4 from DAMTP-2001-83 with the gauge choice L1=2 L2=1
36031C-----------------------------------------------------------------------
c63d70bc 36032 INCLUDE 'herwig65.inc'
65767955 36033 INTEGER NDIAHD
36034 PARAMETER(NDIAHD=10)
36035 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36036 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36037 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36038 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36039 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36040 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36041 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36042 & MA2,SH,TH,UH,IDP,DRTYPE
36043 PARAMETER(ZI=(0.0D0,1.0D0))
36044 COMMON/HWHEWS/S(8,8,2),D(8,8)
36045 SAVE O
36046 DATA O/2,1/
36047C--compute the propagator factor
36048 PRE =+ONE/SH/(TH-MS(ID))
36049 DO 10 P1=1,2
36050 DO 10 P2=1,2
36051 DO 10 P3=1,2
36052 DO 10 P4=1,2
36053 10 ME(P1,P2,P3,P4) = PRE*(
36054 & F3(O(P3), P1 ,2)*( FTP( P1 , P2 ,1,1)*F4( P2 ,O(P4),2)
36055 & +FTP( P1 ,O(P2),1,2)*F4(O(P2),O(P4),1))
36056 & +F3(O(P3),O(P1),1)*( FTP(O(P1), P2 ,2,1)*F4( P2 ,O(P4),2)
36057 & +FTP(O(P1),O(P2),2,2)*F4(O(P2),O(P4),1)))
36058 END
36059CDECK ID>, HWHS06.
36060*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36061*-- Author : Peter Richardson
36062C-----------------------------------------------------------------------
36063 SUBROUTINE HWHS06(ID,ME)
36064C-----------------------------------------------------------------------
36065C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36066C section gluon gluon --> fermion antifermion (2st colour flow)
36067C N.B. a gauge choice has been made to simplify the triple gluon vertex
36068C This diagram 5 from DAMTP-2001-83 with the gauge choice L1=2 L2=1
36069C-----------------------------------------------------------------------
c63d70bc 36070 INCLUDE 'herwig65.inc'
65767955 36071 INTEGER NDIAHD
36072 PARAMETER(NDIAHD=10)
36073 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36074 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36075 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36076 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36077 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36078 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36079 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36080 & MA2,SH,TH,UH,IDP,DRTYPE
36081 PARAMETER(ZI=(0.0D0,1.0D0))
36082 COMMON/HWHEWS/S(8,8,2),D(8,8)
36083 SAVE O
36084 DATA O/2,1/
36085C--compute the propagator factor
36086 PRE =-ONE/SH/(UH-MS(ID))
36087 DO 10 P1=1,2
36088 DO 10 P2=1,2
36089 DO 10 P3=1,2
36090 DO 10 P4=1,2
36091 10 ME(P1,P2,P3,P4) = PRE*(
36092 & F3(O(P3), P2 ,1)*( FUP( P2 , P1 ,2,2)*F4( P1 ,O(P4),1)
36093 & +FUP( P2 ,O(P1),2,1)*F4(O(P1),O(P4),2))
36094 & +F3(O(P3),O(P2),2)*( FUP(O(P2), P1 ,1,2)*F4( P1 ,O(P4),1)
36095 & +FUP(O(P2),O(P1),1,1)*F4(O(P1),O(P4),2)))
36096 END
36097CDECK ID>, HWHS07.
36098*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36099*-- Author : Peter Richardson
36100C-----------------------------------------------------------------------
36101 SUBROUTINE HWHS07(ID,ME)
36102C-----------------------------------------------------------------------
36103C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36104C section gluon gluon --> fermion antifermion (triple gluon piece)
36105C N.B. a gauge choice has been made to simplify the triple gluon vertex
36106C This diagram 6 from DAMTP-2001-83 with the gauge choice L1=2 L2=1
36107C-----------------------------------------------------------------------
c63d70bc 36108 INCLUDE 'herwig65.inc'
65767955 36109 INTEGER NDIAHD
36110 PARAMETER(NDIAHD=10)
36111 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36112 & ,F3M(2,2,8),F4M(2,2,8),MET,FST(2,2,8),
36113 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36114 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36115 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36116 INTEGER I,P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36117 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36118 & MA2,SH,TH,UH,IDP,DRTYPE
36119 PARAMETER(ZI=(0.0D0,1.0D0))
36120 COMMON/HWHEWS/S(8,8,2),D(8,8)
36121 SAVE O
36122 DATA O/2,1/
36123C--compute the propagator factor
36124 PRE = HALF/SH**2
36125 DO 10 P3=1,2
36126 DO 10 P4=1,2
36127 MET = (0.0D0,0.0D0)
36128 DO 5 I=1,2
36129 5 MET=MET+F3(O(P3),I,1)*F4(I,O(P4),1)-F3(O(P3),I,2)*F4(I,O(P4),2)
36130 DO 10 P1=1,2
36131 DO 10 P2=1,2
36132 IF(P1.EQ.P2) THEN
36133 ME(P1,P2,P3,P4) = PRE*S(1,2,P1)*S(1,2,O(P1))*MET
36134 ELSE
36135 ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
36136 ENDIF
36137 10 CONTINUE
36138 END
36139CDECK ID>, HWHS08.
36140*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36141*-- Author : Peter Richardson
36142C-----------------------------------------------------------------------
36143 SUBROUTINE HWHS08(ID,ME)
36144C-----------------------------------------------------------------------
36145C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36146C section quark gluon --> fermion sfermion
36147C This diagram 7 from DAMTP-2001-83 with the gauge choice L2=1
36148C-----------------------------------------------------------------------
c63d70bc 36149 INCLUDE 'herwig65.inc'
65767955 36150 INTEGER NDIAHD
36151 PARAMETER(NDIAHD=10)
36152 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36153 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36154 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36155 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36156 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36157 INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36158 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36159 & MA2,SH,TH,UH,IDP,DRTYPE
36160 PARAMETER(ZI=(0.0D0,1.0D0))
36161 COMMON/HWHEWS/S(8,8,2),D(8,8)
36162 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36163 EXTERNAL HWULDO
36164 SAVE O
36165 DATA O/2,1/
36166C--compute the propagator factor
36167 PRE = HALF*SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
36168 & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/
36169 & (TH-MS(ID))
36170 DO 10 P1=1,2
36171 DO 10 P2=1,2
36172 DO 10 P3=1,2
36173 ME(P1,P2,P3,2) = ZERO
36174 10 ME(P1,P2,P3,1) = A(P1,ID)*PRE*FST(P2,P2,1)*F3(O(P3), P1,1)
36175 END
36176CDECK ID>, HWHS09.
36177*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36178*-- Author : Peter Richardson
36179C-----------------------------------------------------------------------
36180 SUBROUTINE HWHS09(ID,ME)
36181C-----------------------------------------------------------------------
36182C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36183C section antiquark gluon --> fermion antisfermion
36184C This diagram 10 from DAMTP-2001-83 with the gauge choice L2=1
36185C-----------------------------------------------------------------------
c63d70bc 36186 INCLUDE 'herwig65.inc'
65767955 36187 INTEGER NDIAHD
36188 PARAMETER(NDIAHD=10)
36189 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36190 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36191 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36192 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36193 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36194 INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36195 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36196 & MA2,SH,TH,UH,IDP,DRTYPE
36197 PARAMETER(ZI=(0.0D0,1.0D0))
36198 COMMON/HWHEWS/S(8,8,2),D(8,8)
36199 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36200 EXTERNAL HWULDO
36201 SAVE O
36202 DATA O/2,1/
36203C--compute the propagator factor
36204 PRE = HALF*SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
36205 & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/
36206 & (TH-MS(ID))
36207 DO 10 P1=1,2
36208 DO 10 P2=1,2
36209 DO 10 P3=1,2
36210 ME(P1,P2,P3,2) = ZERO
36211 10 ME(P1,P2,P3,1) = A(O(P1),ID)*PRE*FST(P2,P2,1)*F3M(P1,P3,1)
36212 END
36213CDECK ID>, HWHS10.
36214*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36215*-- Author : Peter Richardson
36216C-----------------------------------------------------------------------
36217 SUBROUTINE HWHS10(ID,ME)
36218C-----------------------------------------------------------------------
36219C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36220C section quark gluon --> fermion antisfermion (s-channel quark)
36221C This is diagram 8 from DAMTP-2001-83 with the gauge choice L2=1
36222C-----------------------------------------------------------------------
c63d70bc 36223 INCLUDE 'herwig65.inc'
65767955 36224 INTEGER NDIAHD
36225 PARAMETER(NDIAHD=10)
36226 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36227 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36228 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36229 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36230 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36231 INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36232 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36233 & MA2,SH,TH,UH,IDP,DRTYPE
36234 PARAMETER(ZI=(0.0D0,1.0D0))
36235 COMMON/HWHEWS/S(8,8,2),D(8,8)
36236 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36237 EXTERNAL HWULDO
36238 SAVE O
36239 DATA O/2,1/
36240C--compute the propagator factor
36241 PRE = SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
36242 & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/SH
36243 DO 10 P1=1,2
36244 DO 10 P2=1,2
36245 DO 10 P3=1,2
36246 IF(P1.EQ.P2) THEN
36247 ME(p1,p2,p3,1) = PRE*A( P2 ,ID)*F3(O(P3), P2 ,1)*S(1,2,P2)*
36248 & S(1,1,O(P2))
36249 ELSE
36250 ME(P1,P2,P3,1) = PRE*
36251 & A(O(P2),ID)*( F3(O(P3),O(P2),1)*S(1,1,O(P2))
36252 & +F3(O(P3),O(P2),2)*S(2,1,O(P2)))*S(2,1,P2)
36253 ENDIF
36254 10 ME(P1,P2,P3,2) = ZERO
36255 END
36256CDECK ID>, HWHS11.
36257*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36258*-- Author : Peter Richardson
36259C-----------------------------------------------------------------------
36260 SUBROUTINE HWHS11(ID,ME)
36261C-----------------------------------------------------------------------
36262C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36263C section quark gluon --> fermion antisfermion (s-channel quark)
36264C This is diagram 11 from DAMTP-2001-83 with the gauge choice L2=1
36265C-----------------------------------------------------------------------
c63d70bc 36266 INCLUDE 'herwig65.inc'
65767955 36267 INTEGER NDIAHD
36268 PARAMETER(NDIAHD=10)
36269 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36270 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36271 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36272 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36273 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36274 INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36275 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36276 & MA2,SH,TH,UH,IDP,DRTYPE
36277 PARAMETER(ZI=(0.0D0,1.0D0))
36278 COMMON/HWHEWS/S(8,8,2),D(8,8)
36279 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36280 EXTERNAL HWULDO
36281 SAVE O
36282 DATA O/2,1/
36283C--compute the propagator factor
36284 PRE = SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
36285 & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/SH
36286 DO 10 P1=1,2
36287 DO 10 P2=1,2
36288 DO 10 P3=1,2
36289 IF(P1.EQ.P2) THEN
36290 ME(P1,P2,P3,1) = PRE*A(O(P2),ID)*S(1,2,P1)*
36291 & (S(1,1,O(P2))*F3M(P2,P3,1)+S(1,2,O(P2))*F3M(P2,P3,2))
36292 ELSE
36293 ME(P1,P2,P3,1)=PRE*A(P2,ID)*S(1,1,P1)*S(2,1,P2)*F3M(O(P2),P3,1)
36294 ENDIF
36295 10 ME(P1,P2,P3,2) = ZERO
36296 END
36297CDECK ID>, HWHS12.
36298*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36299*-- Author : Peter Richardson
36300C-----------------------------------------------------------------------
36301 SUBROUTINE HWHS12(ID,ME)
36302C-----------------------------------------------------------------------
36303C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36304C section quark gluon --> fermion antisfermion (s-channel quark)
36305C This is diagram 9 from DAMTP-2001-83 with the gauge choice L2=1
36306C-----------------------------------------------------------------------
c63d70bc 36307 INCLUDE 'herwig65.inc'
65767955 36308 INTEGER NDIAHD
36309 PARAMETER(NDIAHD=10)
36310 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36311 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36312 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36313 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36314 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36315 INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36316 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36317 & MA2,SH,TH,UH,IDP,DRTYPE
36318 PARAMETER(ZI=(0.0D0,1.0D0))
36319 COMMON/HWHEWS/S(8,8,2),D(8,8)
36320 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36321 EXTERNAL HWULDO
36322 SAVE O
36323 DATA O/2,1/
36324C--compute the propagator factor
36325 PRE =-SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
36326 & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/(UH-MS(ID))
36327 DO 10 P1=1,2
36328 DO 10 P2=1,2
36329 DO 10 P3=1,2
36330 ME(P1,P2,P3,1) = PRE*A(P1,ID)*(
36331 & F3(O(P3), P2 ,1)*FUP( P2 ,P1, 2,1)
36332 & +F3(O(P3),O(P2), 2)*FUP(O(P2),P1,1,1))
36333 10 ME(P1,P2,P3,2) = ZERO
36334 END
36335CDECK ID>, HWHS13.
36336*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36337*-- Author : Peter Richardson
36338C-----------------------------------------------------------------------
36339 SUBROUTINE HWHS13(ID,ME)
36340C-----------------------------------------------------------------------
36341C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36342C section quark gluon --> fermion antisfermion (s-channel quark)
36343C This is diagram 12 from DAMTP-2001-83 with the gauge choice L2=1
36344C-----------------------------------------------------------------------
c63d70bc 36345 INCLUDE 'herwig65.inc'
65767955 36346 INTEGER NDIAHD
36347 PARAMETER(NDIAHD=10)
36348 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36349 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36350 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36351 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36352 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36353 INTEGER P1,P2,P3,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36354 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36355 & MA2,SH,TH,UH,IDP,DRTYPE
36356 PARAMETER(ZI=(0.0D0,1.0D0))
36357 COMMON/HWHEWS/S(8,8,2),D(8,8)
36358 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36359 EXTERNAL HWULDO
36360 SAVE O
36361 DATA O/2,1/
36362C--compute the propagator factor
36363 PRE =-SQRT(HWULDO(PCM(1,8),PCM(1,4)))/SQRT(TWO)/
36364 & SQRT(HWULDO(PCM(1,1),PCM(1,2)))/(UH-MS(ID))
36365 DO 10 P1=1,2
36366 DO 10 P2=1,2
36367 DO 10 P3=1,2
36368 ME(P1,P2,P3,1) = PRE*A(O(P1),ID)*(
36369 & FUM(P1, P2 ,1,1)*F3M( P2 ,P3, 2)
36370 & +FUM(P1,O(P2),1, 2)*F3M(O(P2),P3,1))
36371 10 ME(P1,P2,P3,2) = ZERO
36372 END
36373CDECK ID>, HWHS14.
36374*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36375*-- Author : Peter Richardson
36376C-----------------------------------------------------------------------
36377 SUBROUTINE HWHS14(ID,ME)
36378C-----------------------------------------------------------------------
36379C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36380C section gluon gluon --> fermion antifermion (1st colour flow)
36381C N.B. a gauge choice has been made to simplify the triple gluon vertex
36382C This diagram 4 from DAMTP-2001-83 with opposite helicity for 4
36383C and gauge choice L1=2 L2=1
36384C-----------------------------------------------------------------------
c63d70bc 36385 INCLUDE 'herwig65.inc'
65767955 36386 INTEGER NDIAHD
36387 PARAMETER(NDIAHD=10)
36388 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
36389 & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8),
36390 & FUP(2,2,8,8),FUM(2,2,8,8)
36391 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36392 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36393 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36394 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36395 & MA2,SH,TH,UH,IDP,DRTYPE
36396 PARAMETER(ZI=(0.0D0,1.0D0))
36397 COMMON/HWHEWS/S(8,8,2),D(8,8)
36398 SAVE O
36399 DATA O/2,1/
36400C--compute the propagator factor
36401 PRE =+ONE/(TH-MS(ID))/SH
36402C--matrix element
36403 DO 10 P1=1,2
36404 DO 10 P2=1,2
36405 DO 10 P3=1,2
36406 DO 10 P4=1,2
36407 10 ME(P1,P2,P3,P4) = PRE*(
36408 & F3(O(P3), P1 ,2)*( FTP( P1 , P2 , 1,1)*F4( P2 ,P4,2)
36409 & +FTP( P1 ,O(P2), 1,2)*F4(O(P2),P4,1))
36410 & +F3(O(P3),O(P1),1)*( FTP(O(P1), P2 ,2,1)*F4( P2 ,P4,2)
36411 & +FTP(O(P1),O(P2),2,2)*F4(O(P2),P4,1)))
36412 END
36413CDECK ID>, HWHS15.
36414*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36415*-- Author : Peter Richardson
36416C-----------------------------------------------------------------------
36417 SUBROUTINE HWHS15(ID,ME)
36418C-----------------------------------------------------------------------
36419C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36420C section gluon gluon --> fermion antifermion (2st colour flow)
36421C N.B. a gauge choice has been made to simplify the triple gluon vertex
36422C This diagram 5 from DAMTP-2001-83 with opposite helicity for 4
36423C and gauge choice L1=2 L2=1
36424C-----------------------------------------------------------------------
c63d70bc 36425 INCLUDE 'herwig65.inc'
65767955 36426 INTEGER NDIAHD
36427 PARAMETER(NDIAHD=10)
36428 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
36429 & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),FTP(2,2,8,8),FTM(2,2,8,8),
36430 & FUP(2,2,8,8),FUM(2,2,8,8)
36431 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36432 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36433 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36434 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST, A,B,MS,MWD,MR,MA,
36435 & MA2,SH,TH,UH,IDP,DRTYPE
36436 PARAMETER(ZI=(0.0D0,1.0D0))
36437 COMMON/HWHEWS/S(8,8,2),D(8,8)
36438 SAVE O
36439 DATA O/2,1/
36440C--compute the propagator factor
36441 PRE =-ONE/(UH-MS(ID))/SH
36442C--matrix element
36443 DO 10 P1=1,2
36444 DO 10 P2=1,2
36445 DO 10 P3=1,2
36446 DO 10 P4=1,2
36447 10 ME(P1,P2,P3,P4) = PRE*(
36448 & F3(O(P3), P2 ,1)*( FUP( P2 , P1 ,2,2)*F4( P1 ,P4,1)
36449 & +FUP( P2 ,O(P1),2,1)*F4(O(P1),P4,2))
36450 &+F3(O(P3),O(P2),2)*( FUP(O(P2), P1 ,1,2)*F4( P1 ,P4,1)
36451 & +FUP(O(P2),O(P1),1,1)*F4(O(P1),P4,2)))
36452 END
36453CDECK ID>, HWHS16.
36454*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36455*-- Author : Peter Richardson
36456C-----------------------------------------------------------------------
36457 SUBROUTINE HWHS16(ID,ME)
36458C-----------------------------------------------------------------------
36459C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36460C section gluon gluon --> fermion antifermion (triple gluon piece)
36461C N.B. a gauge choice has been made to simplify the triple gluon vertex
36462C This diagram 6 from DAMTP-2001-83 with opposite helicity for 4
36463C and gauge choice L1=2 L2=1
36464C-----------------------------------------------------------------------
c63d70bc 36465 INCLUDE 'herwig65.inc'
65767955 36466 INTEGER NDIAHD
36467 PARAMETER(NDIAHD=10)
36468 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI
36469 & ,F3M(2,2,8),F4M(2,2,8),MET,FST(2,2,8),
36470 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36471 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36472 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36473 INTEGER I,P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36474 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36475 & MA2,SH,TH,UH,IDP,DRTYPE
36476 PARAMETER(ZI=(0.0D0,1.0D0))
36477 COMMON/HWHEWS/S(8,8,2),D(8,8)
36478 SAVE O
36479 DATA O/2,1/
36480C--compute the propagator factor
36481 PRE = HALF/SH**2
36482C--matrix element
36483 DO 10 P3=1,2
36484 DO 10 P4=1,2
36485 MET = (0.0D0,0.0D0)
36486 DO 5 I=1,2
36487 5 MET=MET+F3(O(P3),I,1)*F4(I,P4,1)-F3(O(P3),I,2)*F4(I,P4,2)
36488 DO 10 P1=1,2
36489 DO 10 P2=1,2
36490 IF(P1.EQ.P2) THEN
36491 ME(P1,P2,P3,P4) = PRE*MET*S(1,2,P1)*S(1,2,O(P1))
36492 ELSE
36493 ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
36494 ENDIF
36495 10 CONTINUE
36496 END
36497CDECK ID>, HWHS17.
36498*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36499*-- Author : Peter Richardson
36500C-----------------------------------------------------------------------
36501 SUBROUTINE HWHS17(ID,ME)
36502C-----------------------------------------------------------------------
36503C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36504C section fermion fermion --> fermion fermion (t-channel boson)
36505C This diagram 13 from DAMTP-2001-83
36506C-----------------------------------------------------------------------
c63d70bc 36507 INCLUDE 'herwig65.inc'
65767955 36508 INTEGER NDIAHD
36509 PARAMETER(NDIAHD=10)
36510 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
36511 & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36512 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
36513 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36514 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36515 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36516 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36517 & MA2,SH,TH,UH,IDP,DRTYPE
36518 PARAMETER(ZI=(0.0D0,1.0D0))
36519 COMMON/HWHEWS/S(8,8,2),D(8,8)
36520 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36521 EXTERNAL HWULDO
36522 SAVE O,DL
36523 DATA O/2,1/
36524 DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
36525C--compute the propagator factor
36526 PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
36527 DO 10 P1=1,2
36528 DO 10 P2=1,2
36529 DO 10 P3=1,2
36530 DO 10 P4=1,2
36531 IF(P2.EQ.P4) THEN
36532 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
36533 & ( DL(P1,O(P2))*F3(O(P3), P2 ,2)*S(4,1, P2 )
36534 & +DL(P1, P2 )*F3(O(P3),O(P2),4)*S(2,1,O(P2)))
36535 ELSE
36536 ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
36537 ENDIF
36538 10 CONTINUE
36539 END
36540CDECK ID>, HWHS18.
36541*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36542*-- Author : Peter Richardson
36543C-----------------------------------------------------------------------
36544 SUBROUTINE HWHS18(ID,ME)
36545C-----------------------------------------------------------------------
36546C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36547C section fermion antifermion --> fermion antifermion (t-channel boson)
36548C This diagram 14 from DAMTP-2001-83
36549C-----------------------------------------------------------------------
c63d70bc 36550 INCLUDE 'herwig65.inc'
65767955 36551 INTEGER NDIAHD
36552 PARAMETER(NDIAHD=10)
36553 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
36554 & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36555 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
36556 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36557 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36558 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36559 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36560 & MA2,SH,TH,UH,IDP,DRTYPE
36561 PARAMETER(ZI=(0.0D0,1.0D0))
36562 COMMON/HWHEWS/S(8,8,2),D(8,8)
36563 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36564 EXTERNAL HWULDO
36565 SAVE O,DL
36566 DATA O/2,1/
36567 DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
36568C--compute the propagator factor
36569 PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
36570 DO 10 P1=1,2
36571 DO 10 P2=1,2
36572 DO 10 P3=1,2
36573 DO 10 P4=1,2
36574 IF(P2.EQ.P4) THEN
36575 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
36576 & ( DL(P1,O(P2))*F3(O(P3), P2 ,4)*S(2,1, P2 )
36577 & +DL(P1, P2 )*F3(O(P3),O(P2),2)*S(4,1,O(P2)))
36578 ELSE
36579 ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
36580 ENDIF
36581 10 CONTINUE
36582 END
36583CDECK ID>, HWHS19.
36584*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36585*-- Author : Peter Richardson
36586C-----------------------------------------------------------------------
36587 SUBROUTINE HWHS19(ID,ME)
36588C-----------------------------------------------------------------------
36589C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36590C section antifermion fermion --> antifermion fermion (t-channel boson)
36591C This diagram 15 from DAMTP-2001-83
36592C-----------------------------------------------------------------------
c63d70bc 36593 INCLUDE 'herwig65.inc'
65767955 36594 INTEGER NDIAHD
36595 PARAMETER(NDIAHD=10)
36596 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
36597 & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36598 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
36599 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36600 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36601 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36602 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36603 & MA2,SH,TH,UH,IDP,DRTYPE
36604 PARAMETER(ZI=(0.0D0,1.0D0))
36605 COMMON/HWHEWS/S(8,8,2),D(8,8)
36606 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36607 EXTERNAL HWULDO
36608 SAVE O,DL
36609 DATA O/2,1/
36610 DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
36611C--compute the propagator factor
36612 PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
36613 DO 10 P1=1,2
36614 DO 10 P2=1,2
36615 DO 10 P3=1,2
36616 DO 10 P4=1,2
36617 IF(P2.EQ.P4) THEN
36618 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
36619 & ( DL(P1,O(P2))*S(1,2, P1 )*F3M( P2 ,O(P3),4)
36620 & +DL(P1, P2 )*S(1,4, P1 )*F3M(O(P2),O(P3),2))
36621 ELSE
36622 ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
36623 ENDIF
36624 10 CONTINUE
36625 END
36626CDECK ID>, HWHS20.
36627*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36628*-- Author : Peter Richardson
36629C-----------------------------------------------------------------------
36630 SUBROUTINE HWHS20(ID,ME)
36631C-----------------------------------------------------------------------
36632C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36633C section antifermion fermion --> antifermion fermion (t-channel boson)
36634C This diagram 16 from DAMTP-2001-83
36635C-----------------------------------------------------------------------
c63d70bc 36636 INCLUDE 'herwig65.inc'
65767955 36637 INTEGER NDIAHD
36638 PARAMETER(NDIAHD=10)
36639 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE,ZI,
36640 & F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36641 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8),DL(2,2)
36642 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36643 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH,HWULDO,XMASS,PLAB,PRW,PCM
36644 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36645 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36646 & MA2,SH,TH,UH,IDP,DRTYPE
36647 PARAMETER(ZI=(0.0D0,1.0D0))
36648 COMMON/HWHEWS/S(8,8,2),D(8,8)
36649 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
36650 EXTERNAL HWULDO
36651 SAVE O,DL
36652 DATA O/2,1/
36653 DATA DL/(1.0,0.0D0),(0.0D0,0.0D0),(0.0D0,0.0D0),(1.0D0,0.0D0)/
36654C--compute the propagator factor
36655 PRE = SQRT(TWO*HWULDO(PCM(1,8),PCM(1,4)))/(TH-MS(ID))
36656 DO 10 P1=1,2
36657 DO 10 P2=1,2
36658 DO 10 P3=1,2
36659 DO 10 P4=1,2
36660 IF(P2.EQ.P4) THEN
36661 ME(P1,P2,P3,P4) = PRE*A(P1,ID)*B(P2,ID)*
36662 & ( DL(P1,O(P2))*S(1,4, P1 )*F3M( P2 ,O(P3),2)
36663 & +DL(P1, P2 )*S(1,2, P1 )*F3M(O(P2),O(P3),4))
36664 ELSE
36665 ME(P1,P2,P3,P4) = (0.0D0,0.0D0)
36666 ENDIF
36667 10 CONTINUE
36668 END
36669CDECK ID>, HWHS21.
36670*CMZ :- -02/10/01 10:17:10 by Peter Richardson
36671*-- Author : Peter Richardson
36672C-----------------------------------------------------------------------
36673 SUBROUTINE HWHS21(ID,ME)
36674C-----------------------------------------------------------------------
36675C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36676C section f fbar ---> f fbar via s-channel scalar exchange
36677C This is diagram 1 from RPV notes
36678C-----------------------------------------------------------------------
c63d70bc 36679 INCLUDE 'herwig65.inc'
65767955 36680 INTEGER NDIAHD
36681 PARAMETER(NDIAHD=10)
36682 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36683 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
36684 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36685 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36686 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36687 INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36688 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36689 & MA2,SH,TH,UH,IDP,DRTYPE
36690 COMMON/HWHEWS/S(8,8,2),D(8,8)
36691 PARAMETER(ZI=(0.0D0,1.0D0))
36692 SAVE O
36693 DATA O/2,1/
36694C--compute the propagator factor
36695 PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
36696 DO 10 P1=1,2
36697 DO 10 P3=1,2
36698 DO 10 P4=1,2
36699 ME(P1, P1 ,P3,P4) = (0.0D0,0.0D0)
36700 10 ME(P1,O(P1),P3,P4) = PRE*A(P1,ID)*S(2,1,O(P1))*
36701 & ( B( P4 ,ID)*F3(O(P3), P4 ,4)*S(4,8,P4)
36702 & -B(O(P4),ID)*F3(O(P3),O(P4),8)*MA(4))
36703 END
36704CDECK ID>, HWHS22.
36705*CMZ :- -08/04/02 11:54:39 by Peter Richardson
36706*-- Author : Peter Richardson
36707C-----------------------------------------------------------------------
36708 SUBROUTINE HWHS22(ID,ME)
36709C-----------------------------------------------------------------------
36710C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36711C section f fbar ---> f fbar via t-channel scalar exchange
36712C This is diagram 2 from RPV notes
36713C-----------------------------------------------------------------------
c63d70bc 36714 INCLUDE 'herwig65.inc'
65767955 36715 INTEGER NDIAHD
36716 PARAMETER(NDIAHD=10)
36717 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36718 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36719 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36720 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36721 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36722 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36723 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36724 & MA2,SH,TH,UH,IDP,DRTYPE
36725 COMMON/HWHEWS/S(8,8,2),D(8,8)
36726 SAVE O
36727 DATA O/2,1/
36728C--compute the propagator factor
36729 PRE = -HALF/(TH-MS(ID))
36730 DO 10 P1=1,2
36731 DO 10 P2=1,2
36732 DO 10 P3=1,2
36733 DO 10 P4=1,2
36734 10 ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A( P1 ,ID)*
36735 & F4(P2,O(P4),2)*F3(O(P3),P1,1)
36736 END
36737CDECK ID>, HWHS23.
36738*CMZ :- -08/04/02 11:54:39 by Peter Richardson
36739*-- Author : Peter Richardson
36740C-----------------------------------------------------------------------
36741 SUBROUTINE HWHS23(ID,ME)
36742C-----------------------------------------------------------------------
36743C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36744C section f fbar ---> fermion fermion via t-channel scalar exchange
36745C This is diagram 3 from RPV notes
36746C-----------------------------------------------------------------------
c63d70bc 36747 INCLUDE 'herwig65.inc'
65767955 36748 INTEGER NDIAHD
36749 PARAMETER(NDIAHD=10)
36750 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36751 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36752 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36753 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36754 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36755 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36756 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36757 & MA2,SH,TH,UH,IDP,DRTYPE
36758 COMMON/HWHEWS/S(8,8,2),D(8,8)
36759 SAVE O
36760 DATA O/2,1/
36761C--compute the propagator factor
36762 PRE = HALF/(UH-MS(ID))
36763 DO 10 P1=1,2
36764 DO 10 P2=1,2
36765 DO 10 P3=1,2
36766 DO 10 P4=1,2
36767 10 ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A( P1 ,ID)*
36768 & F4M(P4,P1,1)*F3M(P2,P3,2)
36769 END
36770CDECK ID>, HWHS24.
36771*CMZ :- -08/04/02 11:54:39 by Peter Richardson
36772*-- Author : Peter Richardson
36773C-----------------------------------------------------------------------
36774 SUBROUTINE HWHS24(ID,ME)
36775C-----------------------------------------------------------------------
36776C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36777C section f fbar ---> f f via s-channel scalar exchange
36778C This is diagram 4 from RPV notes
36779C-----------------------------------------------------------------------
c63d70bc 36780 INCLUDE 'herwig65.inc'
65767955 36781 INTEGER NDIAHD
36782 PARAMETER(NDIAHD=10)
36783 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36784 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
36785 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36786 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36787 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36788 INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36789 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36790 & MA2,SH,TH,UH,IDP,DRTYPE
36791 COMMON/HWHEWS/S(8,8,2),D(8,8)
36792 PARAMETER(ZI=(0.0D0,1.0D0))
36793 SAVE O
36794 DATA O/2,1/
36795C--compute the propagator factor
36796 PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
36797 DO 10 P1=1,2
36798 DO 10 P3=1,2
36799 DO 10 P4=1,2
36800 ME(P1, P1 ,P3,P4) = (0.0D0,0.0D0)
36801 10 ME(P1,O(P1),P3,P4) = PRE*A(P1,ID)*S(2,1,O(P1))*
36802 & ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3))
36803 & -B( P3 ,ID)*F4M(O(P4), P3 ,7)*MA(3))
36804 END
36805CDECK ID>, HWHS25.
36806*CMZ :- -08/04/02 11:54:39 by Peter Richardson
36807*-- Author : Peter Richardson
36808C-----------------------------------------------------------------------
36809 SUBROUTINE HWHS25(ID,ME)
36810C-----------------------------------------------------------------------
36811C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36812C section f fbar ---> f f via u-channel scalar exchange
36813C This is diagram 5 from RPV notes
36814C-----------------------------------------------------------------------
c63d70bc 36815 INCLUDE 'herwig65.inc'
65767955 36816 INTEGER NDIAHD
36817 PARAMETER(NDIAHD=10)
36818 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36819 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36820 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36821 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36822 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36823 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36824 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36825 & MA2,SH,TH,UH,IDP,DRTYPE
36826 COMMON/HWHEWS/S(8,8,2),D(8,8)
36827 SAVE O
36828 DATA O/2,1/
36829C--compute the propagator factor
36830 PRE = -HALF/(UH-MS(ID))
36831 DO 10 P1=1,2
36832 DO 10 P2=1,2
36833 DO 10 P3=1,2
36834 DO 10 P4=1,2
36835 10 ME(P1,P2,P3,P4) = PRE*B(P1,ID)*A(O(P2),ID)*
36836 & F4M(O(P4),P1,1)*F3M(P2,P3,2)
36837 END
36838CDECK ID>, HWHS26.
36839*CMZ :- -08/04/02 11:54:39 by Peter Richardson
36840*-- Author : Peter Richardson
36841C-----------------------------------------------------------------------
36842 SUBROUTINE HWHS26(ID,ME)
36843C-----------------------------------------------------------------------
36844C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36845C section f fbar ---> f f via t-channel scalar exchange
36846C This is diagram 6 from RPV notes
36847C-----------------------------------------------------------------------
c63d70bc 36848 INCLUDE 'herwig65.inc'
65767955 36849 INTEGER NDIAHD
36850 PARAMETER(NDIAHD=10)
36851 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36852 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),
36853 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36854 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36855 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36856 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36857 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36858 & MA2,SH,TH,UH,IDP,DRTYPE
36859 COMMON/HWHEWS/S(8,8,2),D(8,8)
36860 SAVE O
36861 DATA O/2,1/
36862C--compute the propagator factor
36863 PRE = HALF/(TH-MS(ID))
36864 DO 10 P1=1,2
36865 DO 10 P2=1,2
36866 DO 10 P3=1,2
36867 DO 10 P4=1,2
36868 10 ME(P1,P2,P3,P4) = PRE*B(P1,ID)*A(O(P2),ID)*
36869 & F4(P2,P4,2)*F3(O(P3),P1,1)
36870 END
36871CDECK ID>, HWHS27.
36872*CMZ :- -08/04/02 11:54:39 by Peter Richardson
36873*-- Author : Peter Richardson
36874C-----------------------------------------------------------------------
36875 SUBROUTINE HWHS27(ID,ME)
36876C-----------------------------------------------------------------------
36877C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36878C section f f ---> f fbar via s-channel scalar exchange
36879C This is diagram 7 from RPV notes
36880C-----------------------------------------------------------------------
c63d70bc 36881 INCLUDE 'herwig65.inc'
65767955 36882 INTEGER NDIAHD
36883 PARAMETER(NDIAHD=10)
36884 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36885 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
36886 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36887 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36888 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36889 INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36890 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36891 & MA2,SH,TH,UH,IDP,DRTYPE
36892 COMMON/HWHEWS/S(8,8,2),D(8,8)
36893 PARAMETER(ZI=(0.0D0,1.0D0))
36894 SAVE O
36895 DATA O/2,1/
36896C--compute the propagator factor
36897 PRE =-HALF/(SH-MS(ID)+ZI*MWD(ID))
36898 DO 10 P1=1,2
36899 DO 10 P3=1,2
36900 DO 10 P4=1,2
36901 ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
36902 10 ME(P1, P1 ,P3,P4) = PRE*A(P1,ID)*S(1,2,O(P1))*
36903 & ( B( P4 ,ID)*F3(O(P3), P4 ,4)*S(4,8,P4)
36904 & -B(O(P4),ID)*F3(O(P3),O(P4),8)*MA(4))
36905 END
36906CDECK ID>, HWHS28.
36907*CMZ :- -08/04/02 11:54:39 by Peter Richardson
36908*-- Author : Peter Richardson
36909C-----------------------------------------------------------------------
36910 SUBROUTINE HWHS28(ID,ME)
36911C-----------------------------------------------------------------------
36912C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36913C section f f ---> f fbar via t-channel scalar exchange
36914C This is diagram 8 from RPV notes
36915C-----------------------------------------------------------------------
c63d70bc 36916 INCLUDE 'herwig65.inc'
65767955 36917 INTEGER NDIAHD
36918 PARAMETER(NDIAHD=10)
36919 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36920 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
36921 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36922 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36923 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36924 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36925 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36926 & MA2,SH,TH,UH,IDP,DRTYPE
36927 COMMON/HWHEWS/S(8,8,2),D(8,8)
36928 PARAMETER(ZI=(0.0D0,1.0D0))
36929 SAVE O
36930 DATA O/2,1/
36931C--compute the propagator factor
36932 PRE = -HALF/(TH-MS(ID))
36933 DO 10 P1=1,2
36934 DO 10 P2=1,2
36935 DO 10 P3=1,2
36936 DO 10 P4=1,2
36937 10 ME(P1,P2,P3,P4) = PRE*B(P2,ID)*A( P1 ,ID)*
36938 & F4(O(P2),O(P4),2)*F3(O(P3),P1,1)
36939 END
36940CDECK ID>, HWHS29.
36941*CMZ :- -08/04/02 11:54:39 by Peter Richardson
36942*-- Author : Peter Richardson
36943C-----------------------------------------------------------------------
36944 SUBROUTINE HWHS29(ID,ME)
36945C-----------------------------------------------------------------------
36946C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36947C section f f ---> f fbar via u-channel scalar exchange
36948C This is diagram 9 from RPV notes
36949C-----------------------------------------------------------------------
c63d70bc 36950 INCLUDE 'herwig65.inc'
65767955 36951 INTEGER NDIAHD
36952 PARAMETER(NDIAHD=10)
36953 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36954 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
36955 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36956 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36957 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36958 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36959 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36960 & MA2,SH,TH,UH,IDP,DRTYPE
36961 COMMON/HWHEWS/S(8,8,2),D(8,8)
36962 PARAMETER(ZI=(0.0D0,1.0D0))
36963 SAVE O
36964 DATA O/2,1/
36965C--compute the propagator factor
36966 PRE = HALF/(UH-MS(ID))
36967 DO 10 P1=1,2
36968 DO 10 P2=1,2
36969 DO 10 P3=1,2
36970 DO 10 P4=1,2
36971 10 ME(P1,P2,P3,P4) = PRE*B(P2,ID)*A(P1,ID)*
36972 & F3(O(P3),P2,2)*F4(O(P1),O(P4),1)
36973 END
36974CDECK ID>, HWHS30.
36975*CMZ :- -08/04/02 11:54:39 by Peter Richardson
36976*-- Author : Peter Richardson
36977C-----------------------------------------------------------------------
36978 SUBROUTINE HWHS30(ID,ME)
36979C-----------------------------------------------------------------------
36980C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
36981C section fbar fbar ---> f f via s-channel scalar exchange
36982C This is diagram 10 from RPV notes
36983C-----------------------------------------------------------------------
c63d70bc 36984 INCLUDE 'herwig65.inc'
65767955 36985 INTEGER NDIAHD
36986 PARAMETER(NDIAHD=10)
36987 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
36988 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
36989 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
36990 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
36991 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
36992 INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
36993 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
36994 & MA2,SH,TH,UH,IDP,DRTYPE
36995 COMMON/HWHEWS/S(8,8,2),D(8,8)
36996 PARAMETER(ZI=(0.0D0,1.0D0))
36997 SAVE O
36998 DATA O/2,1/
36999C--compute the propagator factor
37000 PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
37001 DO 10 P1=1,2
37002 DO 10 P3=1,2
37003 DO 10 P4=1,2
37004 ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
37005 10 ME(P1, P1 ,P3,P4) = PRE*A(O(P1),ID)*S(2,1,P1)*
37006 & ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3))
37007 & -B( P3 ,ID)*F4M(O(P4), P3 ,7)*MA(3))
37008 END
37009CDECK ID>, HWHS31.
37010*CMZ :- -08/04/02 11:54:39 by Peter Richardson
37011*-- Author : Peter Richardson
37012C-----------------------------------------------------------------------
37013 SUBROUTINE HWHS31(ID,ME)
37014C-----------------------------------------------------------------------
37015C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
37016C section fbar fbar ---> f f via t-channel scalar exchange
37017C This is diagram 11 from RPV notes
37018C-----------------------------------------------------------------------
c63d70bc 37019 INCLUDE 'herwig65.inc'
65767955 37020 INTEGER NDIAHD
37021 PARAMETER(NDIAHD=10)
37022 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
37023 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
37024 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
37025 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
37026 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
37027 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
37028 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
37029 & MA2,SH,TH,UH,IDP,DRTYPE
37030 COMMON/HWHEWS/S(8,8,2),D(8,8)
37031 PARAMETER(ZI=(0.0D0,1.0D0))
37032 SAVE O
37033 DATA O/2,1/
37034C--compute the propagator factor
37035 PRE = HALF/(TH-MS(ID))
37036 DO 10 P1=1,2
37037 DO 10 P2=1,2
37038 DO 10 P3=1,2
37039 DO 10 P4=1,2
37040 10 ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(O(P1),ID)*
37041 & F4M(O(P4),O(P2),2)*F3M(P1,P3,1)
37042 END
37043CDECK ID>, HWHS32.
37044*CMZ :- -08/04/02 11:54:39 by Peter Richardson
37045*-- Author : Peter Richardson
37046C-----------------------------------------------------------------------
37047 SUBROUTINE HWHS32(ID,ME)
37048C-----------------------------------------------------------------------
37049C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
37050C section fbar fbar ---> f f via u-channel scalar exchange
37051C This is diagram 12 from RPV notes
37052C-----------------------------------------------------------------------
c63d70bc 37053 INCLUDE 'herwig65.inc'
65767955 37054 INTEGER NDIAHD
37055 PARAMETER(NDIAHD=10)
37056 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
37057 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
37058 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
37059 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
37060 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
37061 INTEGER P1,P2,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
37062 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
37063 & MA2,SH,TH,UH,IDP,DRTYPE
37064 COMMON/HWHEWS/S(8,8,2),D(8,8)
37065 PARAMETER(ZI=(0.0D0,1.0D0))
37066 SAVE O
37067 DATA O/2,1/
37068C--compute the propagator factor
37069 PRE =-HALF/(UH-MS(ID))
37070 DO 10 P1=1,2
37071 DO 10 P2=1,2
37072 DO 10 P3=1,2
37073 DO 10 P4=1,2
37074 10 ME(P1,P2,P3,P4) = PRE*B(O(P2),ID)*A(O(P1),ID)*
37075 & F4M(O(P4),O(P1),1)*F3M(P2,P3,2)
37076 END
37077CDECK ID>, HWHS33.
37078*CMZ :- -08/04/02 11:54:39 by Peter Richardson
37079*-- Author : Peter Richardson
37080C-----------------------------------------------------------------------
37081 SUBROUTINE HWHS33(ID,ME)
37082C-----------------------------------------------------------------------
37083C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
37084C section f f ---> f f via s-channel scalar exchange
37085C This is diagram 13 from RPV
37086C-----------------------------------------------------------------------
c63d70bc 37087 INCLUDE 'herwig65.inc'
65767955 37088 INTEGER NDIAHD
37089 PARAMETER(NDIAHD=10)
37090 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
37091 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
37092 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
37093 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
37094 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
37095 INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
37096 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
37097 & MA2,SH,TH,UH,IDP,DRTYPE
37098 COMMON/HWHEWS/S(8,8,2),D(8,8)
37099 PARAMETER(ZI=(0.0D0,1.0D0))
37100 SAVE O
37101 DATA O/2,1/
37102C--compute the propagator factor
37103 PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
37104 DO 10 P1=1,2
37105 DO 10 P3=1,2
37106 DO 10 P4=1,2
37107 ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
37108 10 ME(P1, P1 ,P3,P4) = PRE*A(P1,ID)*S(1,2,O(P1))*
37109 & ( B(O(P3),ID)*F4M(O(P4),O(P3),3)*S(3,7,O(P3))
37110 & -B( P3 ,ID)*F4M(O(P4), P3 ,7)*MA(3))
37111 END
37112CDECK ID>, HWHS34.
37113*CMZ :- -08/04/02 11:54:39 by Peter Richardson
37114*-- Author : Peter Richardson
37115C-----------------------------------------------------------------------
37116 SUBROUTINE HWHS34(ID,ME)
37117C-----------------------------------------------------------------------
37118C Subroutine to calculate the helicity amplitudes for the 2-to-2 cross
37119C section fbar fbar ---> fbar fbar via t-channel scalar exchange
37120C This is diagram 14 from RPV notes
37121C-----------------------------------------------------------------------
c63d70bc 37122 INCLUDE 'herwig65.inc'
65767955 37123 INTEGER NDIAHD
37124 PARAMETER(NDIAHD=10)
37125 DOUBLE COMPLEX ME(2,2,2,2),S,D,F3(2,2,8),F4(2,2,8),PRE
37126 & ,F3M(2,2,8),F4M(2,2,8),FST(2,2,8),ZI,
37127 & FTP(2,2,8,8),FTM(2,2,8,8),FUP(2,2,8,8),FUM(2,2,8,8)
37128 DOUBLE PRECISION A(2,NDIAHD),B(2,NDIAHD),MS(NDIAHD),MWD(NDIAHD),
37129 & MA(4),MA2(4),MR(NDIAHD),SH,TH,UH
37130 INTEGER P1,P3,P4,ID,O(2),IDP(4+NDIAHD),DRTYPE(NDIAHD)
37131 COMMON/HWSPHC/F3,F4,F3M,F4M,FTP,FTM,FUP,FUM,FST,A,B,MS,MWD,MR,MA,
37132 & MA2,SH,TH,UH,IDP,DRTYPE
37133 COMMON/HWHEWS/S(8,8,2),D(8,8)
37134 PARAMETER(ZI=(0.0D0,1.0D0))
37135 SAVE O
37136 DATA O/2,1/
37137C--compute the propagator factor
37138 PRE = HALF/(SH-MS(ID)+ZI*MWD(ID))
37139 DO 10 P1=1,2
37140 DO 10 P3=1,2
37141 DO 10 P4=1,2
37142 ME(P1,O(P1),P3,P4) = (0.0D0,0.0D0)
37143 10 ME(P1, P1 ,P3,P4) = PRE*A(O(P1),ID)*S(2,1,P1)*
37144 & ( B( P4 ,ID)*F3(P3, P4 ,4)*S(4,8,P4)
37145 & -B(O(P4),ID)*F3(P3,O(P4),8)*MA(4))
37146 END
37147CDECK ID>, HWHSS1.
37148*CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri
37149*-- Author : Kosuke Odagiri
37150C-----------------------------------------------------------------------
37151 FUNCTION HWHSS1(S, T, U, M3, M4, SGN, CLL, CLR, CRL, CRR)
37152C-----------------------------------------------------------------------
37153C QQ(BAR) -> GAUGINOS
37154C-----------------------------------------------------------------------
37155 IMPLICIT NONE
37156 DOUBLE PRECISION HWHSS1, S, T, U, M3, M4, SGN
37157 DOUBLE COMPLEX CLL, CLR, CRL, CRR
37158 HWHSS1 = DREAL(
37159 & (DCONJG(CLL)*CLL+DCONJG(CRR)*CRR)*(U-M3*M3)*(U-M4*M4)+
37160 & (DCONJG(CLR)*CLR+DCONJG(CRL)*CRL)*(T-M3*M3)*(T-M4*M4)+
37161 & (DCONJG(CLL)*CLR+DCONJG(CRL)*CRR)*2.*SGN*M3*M4*S )
37162 END
37163CDECK ID>, HWHSS2.
37164*CMZ :- -10/10/01 10:38:15 by Peter Richardson
37165*-- Author : Kosuke Odagiri
37166C-----------------------------------------------------------------------
37167 FUNCTION HWHSS2(S, T, U, M3, M4, SGN, CLL, CLR, CRL, CRR)
37168C-----------------------------------------------------------------------
37169C LL(BAR) -> GAUGINOS (including beam polarization)
37170C-----------------------------------------------------------------------
c63d70bc 37171 INCLUDE 'herwig65.inc'
65767955 37172 DOUBLE PRECISION HWHSS2, S, T, U, M3, M4, SGN
37173 DOUBLE COMPLEX CLL, CLR, CRL, CRR
37174 HWHSS2 =
37175C--first the incoming left electron
37176 & (ONE-EPOLN(3))*(ONE+PPOLN(3))*DREAL(
37177 & DCONJG(CLL)*CLL*(U-M3*M3)*(U-M4*M4)+
37178 & DCONJG(CLR)*CLR*(T-M3*M3)*(T-M4*M4)+
37179 & DCONJG(CLL)*CLR*2.*SGN*M3*M4*S )
37180C--then the incoming right electron
37181 &+(ONE+EPOLN(3))*(ONE-PPOLN(3))*DREAL(
37182 & DCONJG(CRR)*CRR*(U-M3*M3)*(U-M4*M4)+
37183 & DCONJG(CRL)*CRL*(T-M3*M3)*(T-M4*M4)+
37184 & DCONJG(CRL)*CRR*2.*SGN*M3*M4*S )
37185 END
37186CDECK ID>, HWHSSG.
37187*CMZ :- -31/03/00 17:54:05 by Peter Richardson
37188*-- Author : Kosuke Odagiri
37189C-----------------------------------------------------------------------
37190 SUBROUTINE HWHSSG
37191C-----------------------------------------------------------------------
37192C SUSY 2 PARTON -> 2 GAUGINOS PROCESSES (1 - 3)
37193C -> GAUGINO + SPARTON PROCESSES (4 - 7)
37194C-----------------------------------------------------------------------
c63d70bc 37195 INCLUDE 'herwig65.inc'
65767955 37196 DOUBLE PRECISION HWRGEN, HWUALF, HWUAEM, EPS, HCS, RCS, DIST,
37197 & ML(6), ML2(6), MR(6), MR2(6), MCH(2), MCH2(2), MNU(4), MNU2(4),
37198 & MSQK, MG, MG2, SM, DM, DAB, QPE, SGN, PF, SQPE, EMSC2,
37199 & FAC0, FACA, FACB, FACC, S, T, T3, U, U4, SN2TH
37200 DOUBLE PRECISION M1(2,2,6), M2(4,4,6), M3(2,4,6,6),
37201 & M4(4,6), M5(2,6,6), M6L(4,6), M6R(4,6), M7(2,2,6,6),
37202 & XA(4), XB(4), XC(4), XD(4), MZ, MW, XW, SQXW, S2W, S22W
37203 INTEGER I, IQ, IQ1, IQ2, IQ3, IQ4, IG1, IG2, IG3, IG4,
37204 & ID1, ID2, IGL, SSL, SSR, GLU, SSNU, SSCH, INU, ICH, IWD(6), IPB
37205 DOUBLE PRECISION DQD(6), DQU(6), HWHSS1
37206 EXTERNAL HWRGEN, HWUALF, HWUAEM, HWHSS1
37207 SAVE HCS, M1, M2, M3, M4, M5, M6L, M6R, M7
37208 PARAMETER (EPS = 1.D-9, IGL = 49, SSL = 400, SSR = 412, GLU = 449)
37209 PARAMETER (SSNU = 449, SSCH = 453, INU = 49, ICH = 53)
37210 DOUBLE COMPLEX Z, Z0, C1, C2, C3, GZ, GW, CLL, CLR, CRL, CRR
37211 PARAMETER (Z = (0.D0,1.D0), Z0 = (0.D0,0.D0))
37212 EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198)), (MG, RMASS(GLU))
37213 EQUIVALENCE (XA(1), ZMIXSS(1,1)), (XA(2), ZMIXSS(2,1))
37214 EQUIVALENCE (XA(3), ZMIXSS(3,1)), (XA(4), ZMIXSS(4,1))
37215 EQUIVALENCE (XB(1), ZMIXSS(1,2)), (XB(2), ZMIXSS(2,2))
37216 EQUIVALENCE (XB(3), ZMIXSS(3,2)), (XB(4), ZMIXSS(4,2))
37217 EQUIVALENCE (XC(1), ZMIXSS(1,3)), (XC(2), ZMIXSS(2,3))
37218 EQUIVALENCE (XC(3), ZMIXSS(3,3)), (XC(4), ZMIXSS(4,3))
37219 EQUIVALENCE (XD(1), ZMIXSS(1,4)), (XD(2), ZMIXSS(2,4))
37220 EQUIVALENCE (XD(3), ZMIXSS(3,4)), (XD(4), ZMIXSS(4,4))
37221 SAVE IWD,DQD,DQU
37222 DATA IWD/2,1,4,3,6,5/
37223 DATA DQD/ONE,ZERO,ONE,ZERO,ONE,ZERO/
37224 DATA DQU/ZERO,ONE,ZERO,ONE,ZERO,ONE/
37225C
37226 CALL HWSGEN(.FALSE.)
37227 IF (GENEV) THEN
37228 RCS = HCS*HWRGEN(0)
37229 ELSE
37230 SN2TH = 0.25D0 - 0.25D0*COSTH**2
37231 S=XX(1)*XX(2)*PHEP(5,3)**2
37232 EMSC2 = EMSCA**2
37233 FAC0 = FACTSS*HWUAEM(EMSC2)
37234c prefactor for pair production, includes 1/Nc colour factor
37235 FACA = FAC0*HWUAEM(EMSC2) / CAFAC
37236c prefactor for qq -> gaugino + gluino, includes CF/Nc colour factor
37237 FACB = FAC0*HWUALF(1,EMSCA) * CFFAC / CAFAC
37238c prefactor for qg -> gaugino + squark, includes 1/2Nc colour factor
37239 FACC = FACB / CFFAC / TWO
37240 MG2 = MG**2
37241 GZ = S-MZ**2+Z*S/MZ*GAMZ
37242 GW = S-MW**2+Z*S/MW*GAMW
37243 DO IQ = 1,6
37244 IQ1 = SSL + IQ
37245 IQ2 = SSR + IQ
37246 ML(IQ) = RMASS(IQ1)
37247 ML2(IQ) = ML(IQ)**2
37248 MR(IQ) = RMASS(IQ2)
37249 MR2(IQ) = MR(IQ)**2
37250 END DO
37251 XW = TWO * SWEIN
37252 SQXW = SQRT(XW)
37253 S22W = XW * (TWO - XW)
37254 S2W = SQRT(S22W)
37255 DO IG1 = 1,4
37256 MNU(IG1) = RMASS(IG1+SSNU)
37257 MNU2(IG1) = MNU(IG1)**2
37258 END DO
37259 DO IG1 = 1,2
37260 MCH(IG1) = RMASS(IG1+SSCH)
37261 MCH2(IG1) = MCH(IG1)**2
37262 END DO
37263c _ ~+ ~-
37264c (1) q q -> X X
37265c a b
37266 DO IG1 = 1,2
37267 DO IG2 = 1,2
37268 SM = MCH(IG1) + MCH(IG2)
37269 QPE = S - SM**2
37270 IF (QPE.GE.ZERO) THEN
37271 DM = MCH(IG1) - MCH(IG2)
37272 SQPE = SQRT(QPE*(S-DM**2))
37273 PF = SQPE/S
37274 T = (SQPE*COSTH - S + MCH2(IG1) + MCH2(IG2)) / TWO
37275 U = - T - S + MCH2(IG1) + MCH2(IG2)
37276 DAB = ABS(FLOAT(IG1+IG2-3))
37277 C1 = (-WMXVSS(IG1,2)*WMXVSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
37278 C2 = (-WMXUSS(IG1,2)*WMXUSS(IG2,2)+DAB*S22W/XW)/S2W/GZ
37279 SGN = WSGNSS(IG1)*WSGNSS(IG2)
37280C--PR bug fix 31/03/00
37281 DO IQ = 1,6
37282 C3 = -DAB*QFCH(IQ)/S
37283 CLL = C3 - LFCH(IQ)*C1 +
37284 & DQD(IQ)*WMXVSS(IG1,1)*WMXVSS(IG2,1)/((U-ML2(IWD(IQ)))*XW)
37285 CLR = C3 - LFCH(IQ)*C2 -
37286 & DQU(IQ)*WMXUSS(IG1,1)*WMXUSS(IG2,1)/((T-ML2(IWD(IQ)))*XW)
37287 CRL = C3 - RFCH(IQ)*C1
37288 CRR = C3 - RFCH(IQ)*C2
37289 M1(IG1,IG2,IQ)=FACA*PF*
37290 & HWHSS1(S,T,U,MCH(IG1),MCH(IG2),SGN,CLL,CLR,CRL,CRR)
37291 END DO
37292C--End of Fix
37293 ELSE
37294 DO IQ = 1,6
37295 M1(IG1,IG2,IQ) = ZERO
37296 END DO
37297 END IF
37298 END DO
37299 END DO
37300c _ ~o ~o
37301c (2) q q -> X X
37302c i j
37303 DO IG1 = 1,4
37304 DO IG2 = 1,4
37305 SM = MNU(IG1) + MNU(IG2)
37306 QPE = S - SM**2
37307 IF (QPE.GE.ZERO) THEN
37308 DM = MNU(IG1) - MNU(IG2)
37309 SQPE = SQRT(QPE*(S-DM**2))
37310 PF = SQPE/S
37311 T = (SQPE*COSTH - S + MNU2(IG1) + MNU2(IG2)) / TWO
37312 U = - T - S + MNU2(IG1) + MNU2(IG2)
37313 C1 = (XD(IG1)*XD(IG2)-XC(IG1)*XC(IG2))/S2W/GZ
37314 C2 = - C1
37315 SGN = ZSGNSS(IG1)*ZSGNSS(IG2)
37316 DO IQ = 1,6
37317 CLL =LFCH(IQ)*C1+SLFCH(IQ,IG1)*SLFCH(IQ,IG2)/(U-ML2(IQ))
37318 CLR =LFCH(IQ)*C2-SLFCH(IQ,IG1)*SLFCH(IQ,IG2)/(T-ML2(IQ))
37319 CRL =RFCH(IQ)*C1-SRFCH(IQ,IG1)*SRFCH(IQ,IG2)/(T-MR2(IQ))
37320 CRR =RFCH(IQ)*C2+SRFCH(IQ,IG1)*SRFCH(IQ,IG2)/(U-MR2(IQ))
37321 M2(IG1,IG2,IQ) = FACA*PF*HALF*
37322 & HWHSS1(S,T,U,MNU(IG1),MNU(IG2),SGN,CLL,CLR,CRL,CRR)
37323 END DO
37324 ELSE
37325 DO IQ = 1,6
37326 M2(IG1,IG2,IQ) = ZERO
37327 END DO
37328 END IF
37329 END DO
37330 END DO
37331c _ ~+ ~o
37332c (3) U D -> X X
37333c a i
37334 DO IG1 = 1,2
37335 DO IG2 = 1,4
37336 SM = MCH(IG1) + MNU(IG2)
37337 QPE = S - SM**2
37338 IF (QPE.GE.ZERO) THEN
37339 DM = MCH(IG1) - MNU(IG2)
37340 SQPE = SQRT(QPE*(S-DM**2))
37341 PF = SQPE/S
37342 T = (SQPE*COSTH - S + MCH2(IG1) + MNU2(IG2)) / TWO
37343 U = - T - S + MCH2(IG1) + MNU2(IG2)
37344 C1 = XA(IG2)+S2W/XW*XB(IG2)
37345c note the new s-channel signs below. (PR BUG FIX 3/9/01)
37346 C2 = (-XD(IG2)*WMXVSS(IG1,2)/SQXW+C1*WMXVSS(IG1,1))/GW
37347 C3 = ( XC(IG2)*WMXUSS(IG1,2)/SQXW+C1*WMXUSS(IG1,1))/GW
37348 SGN = WSGNSS(IG1)*ZSGNSS(IG2)
37349 DO IQ1 = 1,3
37350 IQ3 = IQ1*2
37351 DO IQ2 = 1,3
37352 IQ4 = IQ2*2-1
37353 CLL = C2+WMXVSS(IG1,1)*SLFCH(IQ3,IG2)/(U-ML2(IQ3))
37354 CLR = C3-WMXUSS(IG1,1)*SLFCH(IQ4,IG2)/(T-ML2(IQ4))
37355 M3(IG1,IG2,IQ1,IQ2) = FACA*PF*VCKM(IQ1,IQ2)/XW*
37356 & HWHSS1(S,T,U,MCH(IG1),MNU(IG2),SGN,CLL,CLR,Z0,Z0)
37357 END DO
37358 END DO
37359 ELSE
37360 DO IQ1 = 1,3
37361 DO IQ2 = 1,3
37362 M3(IG1,IG2,IQ1,IQ2) = ZERO
37363 END DO
37364 END DO
37365 END IF
37366 END DO
37367 END DO
37368c _ ~o ~
37369c (4) q q -> X g
37370c i
37371 DO IG1 = 1,4
37372 SM = MNU(IG1) + MG
37373 QPE = S - SM**2
37374 IF (QPE.GE.ZERO) THEN
37375 DM = MNU(IG1) - MG
37376 SQPE = SQRT(QPE*(S-DM**2))
37377 PF = SQPE/S
37378 T = (SQPE*COSTH - S + MG2 + MNU2(IG1)) / TWO
37379 U = - T - S + MG2 + MNU2(IG1)
37380 DO IQ = 1,6
37381 CLL = SLFCH(IQ,IG1)/(U-ML2(IQ))
37382 CLR = - SLFCH(IQ,IG1)/(T-ML2(IQ))
37383 CRL = - SRFCH(IQ,IG1)/(T-MR2(IQ))
37384 CRR = SRFCH(IQ,IG1)/(U-MR2(IQ))
37385 M4(IG1,IQ) = FACB*PF*
37386 & HWHSS1(S,T,U,MNU(IG1),MG,ZSGNSS(IG1),CLL,CLR,CRL,CRR)
37387 END DO
37388 ELSE
37389 DO IQ = 1,6
37390 M4(IG1,IQ) = ZERO
37391 END DO
37392 END IF
37393 END DO
37394c _ ~+ ~
37395c (5) U D -> X g
37396c a
37397 DO IG1 = 1,2
37398 SM = MCH(IG1) + MG
37399 QPE = S - SM**2
37400 IF (QPE.GE.ZERO) THEN
37401 DM = MCH(IG1) - MG
37402 SQPE = SQRT(QPE*(S-DM**2))
37403 PF = SQPE/S
37404 T = (SQPE*COSTH - S + MCH2(IG1) + MG2) / TWO
37405 U = - T - S + MCH2(IG1) + MG2
37406 DO IQ1 = 1,3
37407 IQ3 = IQ1*2
37408 DO IQ2 = 1,3
37409 IQ4 = IQ2*2-1
37410 CLL = WMXVSS(IG1,1)/(U-ML2(IQ3))
37411 CLR = - WMXUSS(IG1,1)/(T-ML2(IQ4))
37412 M5(IG1,IQ1,IQ2) = FACB*PF*VCKM(IQ1,IQ2)/XW*
37413 & HWHSS1(S,T,U,MCH(IG1),MG,WSGNSS(IG1),CLL,CLR,Z0,Z0)
37414 END DO
37415 END DO
37416 ELSE
37417 DO IQ1 = 1,3
37418 DO IQ2 = 1,3
37419 M5(IG1,IQ1,IQ2) = ZERO
37420 END DO
37421 END DO
37422 END IF
37423 END DO
37424c ~o ~
37425c (6) g q -> X q
37426c i LR
37427 DO IG1 = 1,4
37428 DO IQ = 1,6
37429c left squarks
37430 SM = MNU(IG1)+ML(IQ)
37431 QPE = S - SM**2
37432 IF (QPE.GE.ZERO) THEN
37433 DM = MNU(IG1)-ML(IQ)
37434 SQPE = SQRT(QPE*(S-DM**2))
37435 PF = SQPE/S
37436 T3 = (SQPE*COSTH - S - SM*DM) / TWO
37437 U4 = - T3 - S
37438C--KO bug fix 06/10/00
37439 M6L(IG1,IQ) = FACC*PF*((QMIXSS(IQ,1,1)*SLFCH(IQ,IG1))**2
37440 & +(QMIXSS(IQ,2,1)*SRFCH(IQ,IG1))**2)*
37441 & T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)
37442 ELSE
37443 M6L(IG1,IQ) = ZERO
37444 END IF
37445c right squarks
37446 SM = MNU(IG1)+MR(IQ)
37447 QPE = S - SM**2
37448 IF (QPE.GE.ZERO) THEN
37449 DM = MNU(IG1)-MR(IQ)
37450 SQPE = SQRT(QPE*(S-DM**2))
37451 PF = SQPE/S
37452 T3 = (SQPE*COSTH - S - SM*DM) / TWO
37453 U4 = - T3 - S
37454C--PR bug fix 28/08/01
37455 M6R(IG1,IQ) = FACC*PF * ((QMIXSS(IQ,1,2)*SLFCH(IQ,IG1))**2
37456 & +(QMIXSS(IQ,2,2)*SRFCH(IQ,IG1))**2)*
37457 & T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)
37458 ELSE
37459 M6R(IG1,IQ) = ZERO
37460 END IF
37461 END DO
37462 END DO
37463c ~+-~
37464c (7) g q -> X q'
37465c a L
37466 DO IG1 = 1,2
37467 DO IQ1 = 1,3
37468 IQ3 = IQ1*2
37469 DO IQ2 = 1,3
37470 IQ4 = IQ2*2-1
37471 DO I = 1,2
37472c U initiated processes
37473 IF (I.EQ.1) THEN
37474 MSQK = ML(IQ4)
37475 ELSE
37476 MSQK = MR(IQ4)
37477 END IF
37478 SM = MCH(IG1) + MSQK
37479 QPE = S - SM**2
37480 IF (((I.EQ.1).OR.(IQ2.EQ.3)).AND.(QPE.GE.ZERO)) THEN
37481 DM = MCH(IG1) - MSQK
37482 SQPE = SQRT(QPE*(S-DM**2))
37483 PF = SQPE/S
37484 T3 = (SQPE*COSTH - S - SM*DM) / TWO
37485 U4 = - T3 - S
37486 M7(I,IG1,IQ3,IQ4)=FACC*PF*WMXUSS(IG1,1)**2*VCKM(IQ1,IQ2)
37487 & /XW*T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)*
37488 & QMIXSS(IQ4,1,I)**2
37489 ELSE
37490 M7(I,IG1,IQ3,IQ4) = ZERO
37491 END IF
37492c D initiated processes
37493 IF (I.EQ.1) THEN
37494 MSQK = ML(IQ3)
37495 ELSE
37496 MSQK = MR(IQ3)
37497 END IF
37498 SM = MCH(IG1) + MSQK
37499 QPE = S - SM**2
37500 IF (((I.EQ.1).OR.(IQ1.EQ.3)).AND.(QPE.GE.ZERO)) THEN
37501 DM = MCH(IG1) - MSQK
37502 SQPE = SQRT(QPE*(S-DM**2))
37503 PF = SQPE/S
37504 T3 = (SQPE*COSTH - S - SM*DM) / TWO
37505 U4 = - T3 - S
37506 M7(I,IG1,IQ4,IQ3)=FACC*PF*WMXVSS(IG1,1)**2*VCKM(IQ1,IQ2)
37507 & /XW*T3/S/U4*(-U4+TWO*SM*DM/T3/U4*SQPE*SQPE*SN2TH)*
37508 & QMIXSS(IQ3,1,I)**2
37509 ELSE
37510 M7(I,IG1,IQ4,IQ3) = ZERO
37511 END IF
37512 END DO
37513 END DO
37514 END DO
37515 END DO
37516 END IF
37517 HCS = 0.
37518c _ _ ~+ ~- ~o ~o ~o ~
37519c q q , q q -> X X , X X , X g
37520c a b i j i
37521 DO 1 ID1 = 1,12
37522 IF (DISF(ID1,1).LT.EPS) GOTO 1
37523 IF (ID1.GT.6) THEN
37524 ID2 = ID1 - 6
37525 IQ = ID2
37526 IPB = 4132
37527 ELSE
37528 ID2 = ID1 + 6
37529 IQ = ID1
37530 IPB = 2431
37531 END IF
37532 IF (DISF(ID2,2).LT.EPS) GOTO 1
37533 DIST = DISF(ID1,1)*DISF(ID2,2)
37534 DO IG1 = 1,2
37535 IG3 = ICH+IG1
37536 DO IG2 = 1,2
37537 IG4 = ICH+IG2+2
37538 HCS = HCS + DIST*M1(IG1,IG2,IQ)
37539C--PR bug fix 10/10/01
37540 IF (GENEV.AND.HCS.GT.RCS) THEN
37541 IF(ID2.LT.ID1) COSTH=-COSTH
37542 CALL HWHSSS(IG3,0,IG4,0,2134,21)
37543 GOTO 9
37544 ENDIF
37545 END DO
37546 END DO
37547 DO IG1 = 1,4
37548 IG3 = INU+IG1
37549 DO IG2 = 1,4
37550 IG4 = INU+IG2
37551 IF (IG2.GE.IG1) HCS = HCS + DIST*M2(IG1,IG2,IQ)
37552C--PR bug fix 10/10/01
37553 IF (GENEV.AND.HCS.GT.RCS) THEN
37554 IF(ID2.LT.ID1) COSTH=-COSTH
37555 CALL HWHSSS(IG3,0,IG4,0,2134,22)
37556 GOTO 9
37557 ENDIF
37558 END DO
37559 HCS = HCS + DIST*M4(IG1,IQ)
37560C--PR bug fix 10/10/01
37561 IF (GENEV.AND.HCS.GT.RCS) THEN
37562 IF(ID2.LT.ID1) COSTH=-COSTH
37563 CALL HWHSSS(IG3,0,IGL,0, IPB,24)
37564 GOTO 9
37565 ENDIF
37566 END DO
37567 1 CONTINUE
37568c _ _ ~+-~o ~+-~
37569c q q', q q' -> X X , X g
37570c a i a
37571c
37572c _ _ _ _
37573c ud(+), ud(-), du(-), du(+)
37574 DO 2 IQ1 = 1, 3
37575 DO IQ2 = 1, 3
37576 IF(VCKM(IQ1,IQ2).GT.EPS) THEN
37577c _
37578c ud (+)
37579 ID1 = IQ1 * 2
37580 ID2 = IQ2 * 2 + 5
37581 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37582 DIST = DISF(ID1,1)*DISF(ID2,2)
37583 DO IG1 = 1,2
37584 IG3 = ICH+IG1
37585 DO IG2 = 1,4
37586 IG4 = INU+IG2
37587 HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
37588 IF (GENEV.AND.HCS.GT.RCS) THEN
37589 CALL HWHSSS(IG3,0,IG4,0,2134,23)
37590 GOTO 9
37591 ENDIF
37592 END DO
37593 HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
37594 IF (GENEV.AND.HCS.GT.RCS) THEN
37595 CALL HWHSSS(IG3,0,IGL,0,2431,25)
37596 GOTO 9
37597 ENDIF
37598 END DO
37599 END IF
37600c _
37601c du (+)
37602 ID1 = IQ2 * 2 + 5
37603 ID2 = IQ1 * 2
37604 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37605 DIST = DISF(ID1,1)*DISF(ID2,2)
37606 DO IG1 = 1,2
37607 IG3 = ICH+IG1
37608 DO IG2 = 1,4
37609 IG4 = INU+IG2
37610 HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
37611 IF (GENEV.AND.HCS.GT.RCS) THEN
37612 CALL HWHSSS(IG4,0,IG3,0,2134,23)
37613 GOTO 9
37614 ENDIF
37615 END DO
37616 HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
37617 IF (GENEV.AND.HCS.GT.RCS) THEN
37618 CALL HWHSSS(IGL,0,IG3,0,3124,25)
37619 GOTO 9
37620 ENDIF
37621 END DO
37622 END IF
37623c _
37624c du (-)
37625 ID1 = IQ2 * 2 - 1
37626 ID2 = IQ1 * 2 + 6
37627 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37628 DIST = DISF(ID1,1)*DISF(ID2,2)
37629 DO IG1 = 1,2
37630 IG3 = ICH+IG1+2
37631 DO IG2 = 1,4
37632 IG4 = INU+IG2
37633 HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
37634 IF (GENEV.AND.HCS.GT.RCS) THEN
37635 CALL HWHSSS(IG4,0,IG3,0,2134,23)
37636 GOTO 9
37637 ENDIF
37638 END DO
37639 HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
37640 IF (GENEV.AND.HCS.GT.RCS) THEN
37641 CALL HWHSSS(IGL,0,IG3,0,2314,25)
37642 GOTO 9
37643 ENDIF
37644 END DO
37645 END IF
37646c _
37647c ud (-)
37648 ID1 = IQ1 * 2 + 6
37649 ID2 = IQ2 * 2 - 1
37650 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37651 DIST = DISF(ID1,1)*DISF(ID2,2)
37652 DO IG1 = 1,2
37653 IG3 = ICH+IG1+2
37654 DO IG2 = 1,4
37655 IG4 = INU+IG2
37656 HCS = HCS + DIST*M3(IG1,IG2,IQ1,IQ2)
37657 IF (GENEV.AND.HCS.GT.RCS) THEN
37658 CALL HWHSSS(IG3,0,IG4,0,2134,23)
37659 GOTO 9
37660 ENDIF
37661 END DO
37662 HCS = HCS + DIST*M5(IG1,IQ1,IQ2)
37663 IF (GENEV.AND.HCS.GT.RCS) THEN
37664 CALL HWHSSS(IG3,0,IGL,0,4132,25)
37665 GOTO 9
37666 ENDIF
37667 END DO
37668 END IF
37669 END IF
37670 END DO
37671 2 CONTINUE
37672c _ _ ~o ~ ~+-~
37673c g q , g q , q g , q g -> X q , X q'
37674c i LR a L
37675c neutralino
37676 DO IQ1 = 1,6
37677c
37678c gq
37679 ID1 = 13
37680 ID2 = IQ1
37681 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37682 DIST = DISF(ID1,1)*DISF(ID2,2)
37683 DO IG1 = 1,4
37684 IG3 = INU+IG1
37685 HCS = HCS + DIST*M6L(IG1,IQ1)
37686 IF (GENEV.AND.HCS.GT.RCS) THEN
37687 CALL HWHSSS(IG3,0,ID2,0,2431,26)
37688 GOTO 9
37689 ENDIF
37690 HCS = HCS + DIST*M6R(IG1,IQ1)
37691 IF (GENEV.AND.HCS.GT.RCS) THEN
37692 CALL HWHSSS(IG3,0,ID2,2,2431,26)
37693 GOTO 9
37694 ENDIF
37695 END DO
37696 END IF
37697c _
37698c gq
37699 ID1 = 13
37700 ID2 = IQ1 + 6
37701 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37702 DIST = DISF(ID1,1)*DISF(ID2,2)
37703 DO IG1 = 1,4
37704 IG3 = INU+IG1
37705 HCS = HCS + DIST*M6L(IG1,IQ1)
37706 IF (GENEV.AND.HCS.GT.RCS) THEN
37707 CALL HWHSSS(IG3,0,ID2,0,4132,26)
37708 GOTO 9
37709 ENDIF
37710 HCS = HCS + DIST*M6R(IG1,IQ1)
37711 IF (GENEV.AND.HCS.GT.RCS) THEN
37712 CALL HWHSSS(IG3,0,ID2,2,4132,26)
37713 GOTO 9
37714 ENDIF
37715 END DO
37716 END IF
37717c
37718c qg
37719 ID1 = IQ1
37720 ID2 = 13
37721 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37722 DIST = DISF(ID1,1)*DISF(ID2,2)
37723 DO IG1 = 1,4
37724 IG3 = INU+IG1
37725 HCS = HCS + DIST*M6L(IG1,IQ1)
37726 IF (GENEV.AND.HCS.GT.RCS) THEN
37727 CALL HWHSSS(ID1,0,IG3,0,3124,26)
37728 GOTO 9
37729 ENDIF
37730 HCS = HCS + DIST*M6R(IG1,IQ1)
37731 IF (GENEV.AND.HCS.GT.RCS) THEN
37732 CALL HWHSSS(ID1,2,IG3,0,3124,26)
37733 GOTO 9
37734 ENDIF
37735 END DO
37736 END IF
37737c _
37738c qg
37739 ID1 = IQ1 + 6
37740 ID2 = 13
37741 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
37742 DIST = DISF(ID1,1)*DISF(ID2,2)
37743 DO IG1 = 1,4
37744 IG3 = INU+IG1
37745 HCS = HCS + DIST*M6L(IG1,IQ1)
37746 IF (GENEV.AND.HCS.GT.RCS) THEN
37747 CALL HWHSSS(ID1,0,IG3,0,2314,26)
37748 GOTO 9
37749 ENDIF
37750 HCS = HCS + DIST*M6R(IG1,IQ1)
37751 IF (GENEV.AND.HCS.GT.RCS) THEN
37752 CALL HWHSSS(ID1,2,IG3,0,2314,26)
37753 GOTO 9
37754 ENDIF
37755 END DO
37756 END IF
37757 END DO
37758c chargino
37759 DO IQ1 = 1,3
37760 IQ3 = IQ1*2
37761 DO 3 IQ2 = 1,3
37762 IF (VCKM(IQ1,IQ2).LT.EPS) GOTO 3
37763 IQ4 = IQ2*2-1
37764 DO IG1 = 1,2
37765 IG3 = ICH+IG1
37766 IG4 = ICH+IG1+2
37767c
37768c gq & qg
37769 ID1 = 13
37770 ID2 = IQ3
37771 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
37772 IF (GENEV.AND.HCS.GT.RCS) THEN
37773 CALL HWHSSS(IG3,0,IQ4,0,2431,27)
37774 GOTO 9
37775 ENDIF
37776 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
37777 IF (GENEV.AND.HCS.GT.RCS) THEN
37778 CALL HWHSSS(IG3,0,IQ4,2,2431,27)
37779 GOTO 9
37780 ENDIF
37781 ID2 = IQ4
37782 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
37783 IF (GENEV.AND.HCS.GT.RCS) THEN
37784 CALL HWHSSS(IG4,0,IQ3,0,2431,27)
37785 GOTO 9
37786 ENDIF
37787 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
37788 IF (GENEV.AND.HCS.GT.RCS) THEN
37789 CALL HWHSSS(IG4,0,IQ3,2,2431,27)
37790 GOTO 9
37791 ENDIF
37792 ID1 = IQ3
37793 ID2 = 13
37794 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
37795 IF (GENEV.AND.HCS.GT.RCS) THEN
37796 CALL HWHSSS(IQ4,0,IG3,0,3124,27)
37797 GOTO 9
37798 ENDIF
37799 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
37800 IF (GENEV.AND.HCS.GT.RCS) THEN
37801 CALL HWHSSS(IQ4,2,IG3,0,3124,27)
37802 GOTO 9
37803 ENDIF
37804 ID1 = IQ4
37805 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
37806 IF (GENEV.AND.HCS.GT.RCS) THEN
37807 CALL HWHSSS(IQ3,0,IG4,0,3124,27)
37808 GOTO 9
37809 ENDIF
37810 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
37811 IF (GENEV.AND.HCS.GT.RCS) THEN
37812 CALL HWHSSS(IQ3,2,IG4,0,3124,27)
37813 GOTO 9
37814 ENDIF
37815c _ _
37816c gq & qg
37817 ID1 = 13
37818 ID2 = IQ3 + 6
37819 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
37820 IF (GENEV.AND.HCS.GT.RCS) THEN
37821 CALL HWHSSS(IG4,0,IQ4,1,4132,27)
37822 GOTO 9
37823 ENDIF
37824 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
37825 IF (GENEV.AND.HCS.GT.RCS) THEN
37826 CALL HWHSSS(IG4,0,IQ4,3,4132,27)
37827 GOTO 9
37828 ENDIF
37829 ID2 = IQ4 + 6
37830 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
37831 IF (GENEV.AND.HCS.GT.RCS) THEN
37832 CALL HWHSSS(IG3,0,IQ3,1,4132,27)
37833 GOTO 9
37834 ENDIF
37835 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
37836 IF (GENEV.AND.HCS.GT.RCS) THEN
37837 CALL HWHSSS(IG3,0,IQ3,3,4132,27)
37838 GOTO 9
37839 ENDIF
37840 ID1 = IQ3 + 6
37841 ID2 = 13
37842 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ3,IQ4)
37843 IF (GENEV.AND.HCS.GT.RCS) THEN
37844 CALL HWHSSS(IQ4,1,IG4,0,2314,27)
37845 GOTO 9
37846 ENDIF
37847 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ3,IQ4)
37848 IF (GENEV.AND.HCS.GT.RCS) THEN
37849 CALL HWHSSS(IQ4,3,IG4,0,2314,27)
37850 GOTO 9
37851 ENDIF
37852 ID1 = IQ4 + 6
37853 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(1,IG1,IQ4,IQ3)
37854 IF (GENEV.AND.HCS.GT.RCS) THEN
37855 CALL HWHSSS(IQ3,1,IG3,0,2314,27)
37856 GOTO 9
37857 ENDIF
37858 HCS = HCS + DISF(ID1,1)*DISF(ID2,2)*M7(2,IG1,IQ4,IQ3)
37859 IF (GENEV.AND.HCS.GT.RCS) THEN
37860 CALL HWHSSS(IQ3,3,IG3,0,2314,27)
37861 GOTO 9
37862 ENDIF
37863 END DO
37864 3 CONTINUE
37865 END DO
37866 EVWGT = HCS
37867 RETURN
37868C---GENERATE EVENT
37869 9 IDN(1)=ID1
37870 IDN(2)=ID2
37871 IDCMF=15
37872 CALL HWETWO(.TRUE.,.TRUE.)
37873 IF (AZSPIN) THEN
37874C Calculate coefficients for constructing spin density matrices
37875C Set to zero for now
37876 CALL HWVZRO(7,GCOEF)
37877 END IF
37878 END
37879CDECK ID>, HWHSSL.
37880*CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri
37881*-- Author : Kosuke Odagiri
37882C-----------------------------------------------------------------------
37883 SUBROUTINE HWHSSL
37884C-----------------------------------------------------------------------
37885C SUSY 2 PARTON -> 2 SLEPTON PROCESSES
37886C-----------------------------------------------------------------------
c63d70bc 37887 INCLUDE 'herwig65.inc'
65767955 37888 DOUBLE PRECISION HWRGEN, HWUAEM, EPS, HCS, RCS, DIST, S, PF, QPE,
37889 & FACTR, SN2TH, MZ, MW, ME2(2,2,6,2), ME2W(2,3), EMSC2, GW2
37890 INTEGER IQ, IQ1, IQ2, ID1, ID2, IL, IL1, IL2, I, J
37891 EXTERNAL HWRGEN, HWUAEM
37892 SAVE HCS, ME2, ME2W
37893 PARAMETER (EPS = 1.D-9)
37894 DOUBLE COMPLEX Z, GZ, A, BL, BR, CL, CR, D, E
37895 PARAMETER (Z = (0.D0,1.D0))
37896 EQUIVALENCE (MZ, RMASS(200)), (MW, RMASS(198))
37897C
37898 S = XX(1)*XX(2)*PHEP(5,3)**2
37899 EMSC2 = S
37900 EMSCA = SQRT(EMSC2)
37901 CALL HWSGEN(.FALSE.)
37902 IF (GENEV) THEN
37903 RCS = HCS*HWRGEN(0)
37904 ELSE
37905 SN2TH = 0.25D0 - 0.25D0*COSTH**2
37906 FACTR = FACTSS*HWUAEM(EMSC2)**2/CAFAC*SN2TH
37907 GZ = (S-MZ**2+Z*S*GAMZ/MZ)/S
37908 GW2 = ((ONE-MW**2/S)**2+(GAMW/MW)**2)*(TWO*SWEIN)**2
37909c _ ~ ~*
37910c q q -> l l
37911c
37912 DO IL = 1,6
37913 DO I = 1,2
37914 DO J = 1,2
37915 IF (((I.NE.J).AND.(IL.NE.5)).OR.
37916 & ((I.EQ.2).AND.(((IL/2)*2).EQ.IL))) THEN
37917 QPE = -1.
37918 ELSE
37919 ID1 = 412 + I*12 + IL
37920 ID2 = 412 + J*12 + IL
37921 IL1 = IL + 10
37922 QPE = S-(RMASS(ID1)+RMASS(ID2))**2
37923 END IF
37924 IF (QPE.GT.ZERO) THEN
37925 PF = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))/S
37926 DO IQ = 1,2
37927 A = QFCH(IL1)*QFCH(IQ)
37928 BL = LFCH(IL1)/GZ
37929 BR = RFCH(IL1)/GZ
37930 CL = LMIXSS(IL,1,I)*LMIXSS(IL,1,J)
37931 CR = LMIXSS(IL,2,I)*LMIXSS(IL,2,J)
37932 D = (A+BL*LFCH(IQ))*CL+(A+BR*LFCH(IQ))*CR
37933 E = (A+BL*RFCH(IQ))*CL+(A+BR*RFCH(IQ))*CR
37934 ME2(I,J,IL,IQ)=FACTR*PF**3
37935 $ *DREAL(DCONJG(D)*D+DCONJG(E)*E)
37936 END DO
37937 ELSE
37938 ME2(I,J,IL,1)=ZERO
37939 ME2(I,J,IL,2)=ZERO
37940 END IF
37941 END DO
37942 END DO
37943 END DO
37944c _ ~ ~*
37945c q q' -> l v
37946c
37947 DO IL = 1,3
37948 DO I = 1,2
37949 IF ((IL.NE.3).AND.(I.EQ.2)) THEN
37950 QPE = -1.
37951 ELSE
37952 ID1 = 411 + IL*2 + I*12
37953 ID2 = 424 + IL*2
37954 QPE = S-(RMASS(ID1)+RMASS(ID2))**2
37955 END IF
37956 IF (QPE.GT.ZERO) THEN
37957 PF = SQRT(QPE*(S-(RMASS(ID1)-RMASS(ID2))**2))/S
37958 ME2W(I,IL)=FACTR*PF**3/GW2
37959 IF (IL.EQ.3) ME2W(I,3)=ME2W(I,3)*LMIXSS(5,1,I)**2
37960 ELSE
37961 ME2W(I,IL)=ZERO
37962 END IF
37963 END DO
37964 END DO
37965 END IF
37966 HCS = 0.
37967C
37968 DO 1 ID1 = 1, 12
37969 IF (DISF(ID1,1).LT.EPS) GOTO 1
37970 IF (ID1.GT.6) THEN
37971 ID2 = ID1 - 6
37972 ELSE
37973 ID2 = ID1 + 6
37974 END IF
37975 IQ = ID1 - ((ID1-1)/2)*2
37976 IF (DISF(ID2,2).LT.EPS) GOTO 1
37977 DIST = DISF(ID1,1)*DISF(ID2,2)
37978 DO IL = 1,6
37979 DO I = 1,2
37980 DO J = 1,2
37981 IL1 = IL+I*12
37982 IL2 = IL+J*12
37983 HCS = HCS + DIST*ME2(I,J,IL,IQ)
37984 IF (GENEV.AND.HCS.GT.RCS) THEN
37985 CALL HWHSSS(IL1,2,IL2,3,2134,30)
37986 GOTO 9
37987 ENDIF
37988 END DO
37989 END DO
37990 END DO
37991 1 CONTINUE
37992c _ _ _ _
37993c ud(+), ud(-), du(-), du(+)
37994 DO 2 IQ1 = 1, 3
37995 DO IQ2 = 1, 3
37996 IF(VCKM(IQ1,IQ2).GT.EPS) THEN
37997c _
37998c ud (+)
37999 ID1 = IQ1 * 2
38000 ID2 = IQ2 * 2 + 5
38001 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
38002 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
38003 DO IL = 1,3
38004 IL1 = IL*2-1
38005 IL2 = IL1+1
38006 HCS = HCS + DIST*ME2W(1,IL)
38007 IF (GENEV.AND.HCS.GT.RCS) THEN
38008 CALL HWHSSS(IL1,5,IL2,4,2134,30)
38009 GOTO 9
38010 ENDIF
38011 END DO
38012 HCS = HCS + DIST*ME2W(2,3)
38013 IF (GENEV.AND.HCS.GT.RCS) THEN
38014 CALL HWHSSS(5,7,6,4,2134,30)
38015 GOTO 9
38016 ENDIF
38017 END IF
38018c _
38019c du (+)
38020 ID1 = IQ2 * 2 + 5
38021 ID2 = IQ1 * 2
38022 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
38023 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
38024 DO IL = 1,3
38025 IL1 = IL*2-1
38026 IL2 = IL1+1
38027 HCS = HCS + DIST*ME2W(1,IL)
38028 IF (GENEV.AND.HCS.GT.RCS) THEN
38029 CALL HWHSSS(IL1,5,IL2,4,2134,30)
38030 GOTO 9
38031 ENDIF
38032 END DO
38033 HCS = HCS + DIST*ME2W(2,3)
38034 IF (GENEV.AND.HCS.GT.RCS) THEN
38035 CALL HWHSSS(5,7,6,4,2134,30)
38036 GOTO 9
38037 ENDIF
38038 END IF
38039c _
38040c du (-)
38041 ID1 = IQ2 * 2 - 1
38042 ID2 = IQ1 * 2 + 6
38043 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
38044 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
38045 DO IL = 1,3
38046 IL1 = IL*2-1
38047 IL2 = IL1+1
38048 HCS = HCS + DIST*ME2W(1,IL)
38049 IF (GENEV.AND.HCS.GT.RCS) THEN
38050 CALL HWHSSS(IL1,4,IL2,5,2134,30)
38051 GOTO 9
38052 ENDIF
38053 END DO
38054 HCS = HCS + DIST*ME2W(2,3)
38055 IF (GENEV.AND.HCS.GT.RCS) THEN
38056 CALL HWHSSS(5,6,6,5,2134,30)
38057 GOTO 9
38058 ENDIF
38059 END IF
38060c _
38061c ud (-)
38062 ID1 = IQ1 * 2 + 6
38063 ID2 = IQ2 * 2 - 1
38064 IF ((DISF(ID1,1).GT.EPS).AND.(DISF(ID2,2).GT.EPS)) THEN
38065 DIST = VCKM(IQ1,IQ2)*DISF(ID1,1)*DISF(ID2,2)
38066 DO IL = 1,3
38067 IL1 = IL*2-1
38068 IL2 = IL1+1
38069 HCS = HCS + DIST*ME2W(1,IL)
38070 IF (GENEV.AND.HCS.GT.RCS) THEN
38071 CALL HWHSSS(IL1,4,IL2,5,2134,30)
38072 GOTO 9
38073 ENDIF
38074 END DO
38075 HCS = HCS + DIST*ME2W(2,3)
38076 IF (GENEV.AND.HCS.GT.RCS) THEN
38077 CALL HWHSSS(5,6,6,5,2134,30)
38078 GOTO 9
38079 ENDIF
38080 END IF
38081 END IF
38082 END DO
38083 2 CONTINUE
38084 EVWGT = HCS
38085 RETURN
38086C---GENERATE EVENT
38087 9 IDN(1)=ID1
38088 IDN(2)=ID2
38089 IDCMF=15
38090 CALL HWETWO(.TRUE.,.TRUE.)
38091 IF (AZSPIN) THEN
38092C Calculate coefficients for constructing spin density matrices
38093C Set to zero for now
38094 CALL HWVZRO(7,GCOEF)
38095 END IF
38096 END
38097CDECK ID>, HWHSSQ.
38098*CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri
38099*-- Author : Kosuke Odagiri
38100C-----------------------------------------------------------------------
38101 SUBROUTINE HWHSSQ
38102C-----------------------------------------------------------------------
38103C SUSY HARD 2 PARTON -> 2 SPARTON PROCESSES
38104C-----------------------------------------------------------------------
c63d70bc 38105 INCLUDE 'herwig65.inc'
65767955 38106 DOUBLE PRECISION HWRGEN, HWUALF, EPS, HCS, RCS, DIST, NC, NC2,
38107 & NC2C, ML2(6), ML4(6), MR2(6), MR4(6), MG2, SM, DM, QPE,
38108 & SQPE, FACTR, AFAC, AF, BONE, CFAC, CFC2, CFC3, CONE,
38109 & CONN, CONT, CONU, CONL, CONR, DFAC, DONE, PF, S,
38110 & S2, TT, TT2, TMG, TMG2, UU, UU2, UMG, UMG2,
38111 & L, L2, TTML, UUML, R, R2, TTMR, UUMR, SN2TH
38112 DOUBLE PRECISION
38113 & AUSTLL(6), AUSTRR(6),
38114 & ASTULL(6,6), ASTURR(6,6), ASTULR(6,6), ASTURL(6,6),
38115 & AUTSLL(6,6), AUTSRR(6,6), AUTSLR(6,6), AUTSRL(6,6),
38116 & BSTULL(6), BSTURR(6), BSTULR(6), BSTURL(6),
38117 & BSUTLL(6), BSUTRR(6), BSUTLR(6), BSUTRL(6),
38118 & BUTSLL(6), BUTSRR(6), BUTSLR(6), BUTSRL(6),
38119 & BUSTLL(6), BUSTRR(6), BUSTLR(6), BUSTRL(6),
38120 & CSTU(6), CSUT(6), CSTUL(6), CSTUR(6), CSUTL(6), CSUTR(6),
38121 & CTSUL(6), CTSUR(6), CTUSL(6), CTUSR(6), DUTS, DTSU, DSTU
38122 INTEGER IQ, IQ1, IQ2, ID1, ID2, ID2MIN, IGL, SSL, SSR, GLU
38123 EXTERNAL HWRGEN, HWUALF
38124 SAVE HCS, AUSTLL, AUSTRR, ASTULL, ASTURR, ASTULR, ASTURL,
38125 & AUTSLL, AUTSRR, AUTSLR, AUTSRL, BSTULL, BSTURR, BSTULR,
38126 & BSTURL, BSUTLL, BSUTRR, BSUTLR, BSUTRL, BUTSLL, BUTSRR, BUTSLR,
38127 & BUTSRL, BUSTLL, BUSTRR, BUSTLR, BUSTRL, CSTU, CSUT, CSTUL, CSTUR,
38128 & CSUTL, CSUTR, CTSUL, CTSUR, CTUSL, CTUSR, DUTS, DTSU, DSTU
38129 PARAMETER (EPS = 1.D-9, IGL = 49, SSL = 400, SSR = 412, GLU = 449)
38130 CALL HWSGEN(.FALSE.)
38131 IF (GENEV) THEN
38132 RCS = HCS*HWRGEN(0)
38133 ELSE
38134 SN2TH = 0.25D0 - 0.25D0*COSTH**2
38135 S = XX(1)*XX(2)*PHEP(5,3)**2
38136 FACTR = FACTSS*HWUALF(1,EMSCA)**2
38137 NC = CAFAC
38138 NC2 = NC**2
38139 NC2C = ONE - ONE/NC2
38140 AFAC = FACTR*NC2C/FOUR
38141 CFAC = FACTR*CFFAC/FOUR
38142 CFC2 = FACTR/CFFAC/FOUR
38143 CFC3 = FACTR/FOUR
38144 DFAC = FACTR/NC2C
38145 S2 = S**2
38146 MG2 = RMASS(GLU)**2
38147 DO 10 IQ = 1, 6
38148 IQ1 = SSL + IQ
38149 IQ2 = SSR + IQ
38150 ML2(IQ) = RMASS(IQ1)**2
38151 ML4(IQ) = ML2(IQ)**2
38152 MR2(IQ) = RMASS(IQ2)**2
38153 MR4(IQ) = MR2(IQ)**2
38154 10 CONTINUE
38155c gluino pair production
38156 QPE = S - FOUR*MG2
38157 IF (QPE.GE.ZERO) THEN
38158 SQPE = SQRT(S*QPE)
38159 PF = SQPE/S
38160 TT = (SQPE*COSTH - S) / TWO
38161 TT2 = TT**2
38162 UU = - S - TT
38163 UU2 = UU**2
38164c ~ ~
38165c g g -> g g
38166c
38167 DONE =
38168 & DFAC*PF/TWO*(UU2+TT2+FOUR*MG2*S*SQPE**2*SN2TH/TT/UU)/S2/TT/UU
38169 DUTS = DONE*UU2
38170 DTSU = DONE*TT2
38171 DSTU = DONE*S2
38172c _ ~ ~
38173c q q -> g g
38174c
38175 DO 21 IQ = 1, 6
38176 L = ML2(IQ)-MG2
38177 L2 = L**2
38178 TTML = TT-L
38179 UUML = UU-L
38180 R = MR2(IQ)-MG2
38181 R2 = R**2
38182 TTMR = TT-R
38183 UUMR = UU-R
38184 CONE = TWO*PF**2*SN2TH
38185 CONL = CONE/UUML/TTML
38186 CONR = CONE/UUMR/TTMR
38187 CONT = (UU2-L2)*CONL+(UU2-R2)*CONR+L2/TTML**2+R2/TTMR**2
38188 CONU = (TT2-L2)*CONL+(TT2-R2)*CONR+L2/UUML**2+R2/UUMR**2
38189 CONN = CFAC*(PF-PF/NC2/(CONT+CONU)*( S2*(CONL+CONR)+
38190 & L2*((TT-UU)*CONL/CONE)**2+R2*((TT-UU)*CONR/CONE)**2 ))
38191 CSTU(IQ) = CONT*CONN
38192 CSUT(IQ) = CONU*CONN
38193 21 CONTINUE
38194 ELSE
38195 DUTS = ZERO
38196 DTSU = ZERO
38197 DSTU = ZERO
38198 DO 23 IQ = 1, 6
38199 CSTU(IQ) = ZERO
38200 CSUT(IQ) = ZERO
38201 23 CONTINUE
38202 END IF
38203c left handed squark (identical flavour) pair production
38204 DO 22 IQ = 1, 6
38205 QPE = S - FOUR*ML2(IQ)
38206 IF (QPE.GE.ZERO) THEN
38207 SQPE = SQRT(S*QPE)
38208 PF = SQPE/S
38209 TT = (SQPE*COSTH - S) / TWO
38210 TT2 = TT**2
38211 UU = - S - TT
38212 UU2 = UU**2
38213c ~ ~*
38214c g g -> q q
38215c L L
38216 CONE = CFC2*PF*((SQPE*PF*SN2TH)**2+ML4(IQ))/TT2/UU2
38217 CONN = CONE-CONE*S2/(TT2+UU2)/NC2
38218 CSTUL(IQ) = CONN*UU2
38219 CSUTL(IQ) = CONN*TT2
38220c ~ ~
38221c q q -> q q
38222c L L
38223 TMG = TT+ML2(IQ)-MG2
38224 TMG2 = TMG**2
38225 UMG = UU+ML2(IQ)-MG2
38226 UMG2 = UMG**2
38227 BONE = AFAC*PF*MG2*S*(HALF-TMG*UMG/(TMG2+UMG2)/NC)
38228 BSTULL(IQ) = BONE/TMG2
38229 BSUTLL(IQ) = BONE/UMG2
38230c _ ~ ~*
38231c q q -> q q
38232c L L
38233 AF = AFAC*PF*PF**2*SN2TH
38234 BONE = AF/TMG2-AF*S/(HALF*S2+TMG2)/TMG/NC
38235 BUTSLL(IQ) = BONE*S2
38236 BUSTLL(IQ) = BONE*TWO*TMG2
38237c _ ~ ~*
38238c q q -> q'q' q =/= q'
38239c L L
38240 AUSTLL(IQ) = TWO*AF
38241 ELSE
38242 CSTUL(IQ) = ZERO
38243 CSUTL(IQ) = ZERO
38244 BSTULL(IQ) = ZERO
38245 BSUTLL(IQ) = ZERO
38246 BUTSLL(IQ) = ZERO
38247 BUSTLL(IQ) = ZERO
38248 AUSTLL(IQ) = ZERO
38249 END IF
38250c right handed squark (identical flavour) pair production
38251 QPE = S - FOUR*MR2(IQ)
38252 IF (QPE.GE.ZERO) THEN
38253 SQPE = SQRT(S*QPE)
38254 PF = SQPE/S
38255 TT = (SQPE*COSTH - S) / TWO
38256 TT2 = TT**2
38257 UU = - S - TT
38258 UU2 = UU**2
38259c ~ ~*
38260c g g -> q q
38261c R R
38262 CONE = CFC2*PF*((SQPE*PF*SN2TH)**2+MR4(IQ))/TT2/UU2
38263 CONN = CONE-CONE*S2/(TT2+UU2)/NC2
38264 CSTUR(IQ) = CONN*UU2
38265 CSUTR(IQ) = CONN*TT2
38266c ~ ~
38267c q q -> q q
38268c R R
38269 TMG = TT+MR2(IQ)-MG2
38270 TMG2 = TMG**2
38271 UMG = UU+MR2(IQ)-MG2
38272 UMG2 = UMG**2
38273 BONE = AFAC*PF*MG2*S*(HALF-TMG*UMG/(TMG2+UMG2)/NC)
38274 BSTURR(IQ) = BONE/TMG2
38275 BSUTRR(IQ) = BONE/UMG2
38276c _ ~ ~*
38277c q q -> q q
38278c R R
38279 AF = AFAC*PF*PF**2*SN2TH
38280 BONE = AF/TMG2-AF*S/(HALF*S2+TMG2)/TMG/NC
38281 BUTSRR(IQ) = BONE*S2
38282 BUSTRR(IQ) = BONE*TWO*TMG2
38283c _ ~ ~*
38284c q q -> q'q' q =/= q'
38285c R R
38286 AUSTRR(IQ) = TWO*AF
38287 ELSE
38288 CSTUR(IQ) = ZERO
38289 CSUTR(IQ) = ZERO
38290 BSTURR(IQ) = ZERO
38291 BSUTRR(IQ) = ZERO
38292 BUTSRR(IQ) = ZERO
38293 BUSTRR(IQ) = ZERO
38294 AUSTRR(IQ) = ZERO
38295 END IF
38296c left and right handed squark (identical flavour) pair production
38297 IQ1 = SSL + IQ
38298 IQ2 = SSR + IQ
38299 SM = RMASS(IQ1)+RMASS(IQ2)
38300 QPE = S - SM**2
38301 IF (QPE.GE.ZERO) THEN
38302 DM = RMASS(IQ1)-RMASS(IQ2)
38303 SQPE = SQRT( QPE*(S-DM**2) )
38304 PF = SQPE/S
38305 AF = AFAC*PF
38306 TT = (SQPE*COSTH - S - SM*DM) / TWO
38307 UU = - S - TT
38308 TMG = TT + ML2(IQ) - MG2
38309 TMG2 = TMG**2
38310 UMG = UU + MR2(IQ) - MG2
38311 UMG2 = UMG**2
38312c ~ ~
38313c q q -> q q
38314c L R
38315 BONE = AFAC*PF*SQPE**2*SN2TH
38316 BSTULR(IQ) = BONE/TMG2
38317 BSUTLR(IQ) = BONE/UMG2
38318c _ ~ ~*
38319c q q -> q q
38320c L R
38321 BUTSLR(IQ) = AFAC*PF*MG2*S/TMG2
38322 BUSTLR(IQ) = ZERO
38323 TT = (SQPE*COSTH - S + SM*DM) / TWO
38324 UU = - S - TT
38325 TMG = TT + MR2(IQ) - MG2
38326 TMG2 = TMG**2
38327 UMG = UU + ML2(IQ) - MG2
38328 UMG2 = UMG**2
38329c ~ ~
38330c q q -> q q
38331c R L
38332c BONE = AFAC*PF*SQPE**2*SN2TH
38333c BSTURL(IQ) = BONE/TMG2
38334c BSUTRL(IQ) = BONE/UMG2
38335 BSTURL(IQ) = ZERO
38336 BSUTRL(IQ) = ZERO
38337c _ ~ ~*
38338c q q -> q q
38339c R L
38340 BUTSRL(IQ) = AFAC*PF*MG2*S/TMG2
38341 BUSTRL(IQ) = ZERO
38342 ELSE
38343 BSTULR(IQ) = ZERO
38344 BSUTLR(IQ) = ZERO
38345 BUTSLR(IQ) = ZERO
38346 BUSTLR(IQ) = ZERO
38347 BSTURL(IQ) = ZERO
38348 BSUTRL(IQ) = ZERO
38349 BUTSRL(IQ) = ZERO
38350 BUSTRL(IQ) = ZERO
38351 END IF
38352 22 CONTINUE
38353c distinct flavours - gq, qq'
38354 DO 11 ID1 = 1, 6
38355 IQ1 = SSL + ID1
38356 SM = RMASS(GLU)+RMASS(IQ1)
38357 QPE = S - SM**2
38358 IF (QPE.GE.ZERO) THEN
38359 DM = RMASS(GLU)-RMASS(IQ1)
38360 SQPE = SQRT( QPE*(S-DM**2) )
38361 PF = SQPE/S
38362 TT = (SQPE*COSTH - S - SM*DM) / TWO
38363 TT2 = TT**2
38364 UU = - S - TT
38365 UU2 = UU**2
38366c ~ ~
38367c g q -> g q
38368c L
38369 CONE = (-UU+TWO*SM*DM*(ONE+MG2/TT+ML2(ID1)/UU))/S/TT/UU
38370 CONN = CFC3*PF*CONE*(ONE-TT2/(UU2+S2)/NC2)
38371 CTSUL(ID1) = CONN*UU2
38372 CTUSL(ID1) = CONN*S2
38373 ELSE
38374 CTSUL(ID1) = ZERO
38375 CTUSL(ID1) = ZERO
38376 END IF
38377 IQ2 = SSR + ID1
38378 SM = RMASS(GLU)+RMASS(IQ2)
38379 QPE = S - SM**2
38380 IF (QPE.GE.ZERO) THEN
38381 DM = RMASS(GLU)-RMASS(IQ2)
38382 SQPE = SQRT( QPE*(S-DM**2) )
38383 PF = SQPE/S
38384 TT = (SQPE*COSTH - S - SM*DM) / TWO
38385 TT2 = TT**2
38386 UU = - S - TT
38387 UU2 = UU**2
38388c ~ ~
38389c g q -> g q
38390c R
38391 CONE = (-UU+TWO*SM*DM*(ONE+MG2/TT+MR2(ID1)/UU))/S/TT/UU
38392 CONN = CFC3*PF*CONE*(ONE-TT2/(UU2+S2)/NC2)
38393 CTSUR(ID1) = CONN*UU2
38394 CTUSR(ID1) = CONN*S2
38395 ELSE
38396 CTSUR(ID1) = ZERO
38397 CTUSR(ID1) = ZERO
38398 END IF
38399 IF(ID1.EQ.6) GOTO 11
38400 ID2MIN = ID1+1
38401 DO 12 ID2 = ID2MIN, 6
38402 IQ1 = SSL + ID1
38403 IQ2 = SSL + ID2
38404 SM = RMASS(IQ1)+RMASS(IQ2)
38405 QPE = S - SM**2
38406 IF (QPE.GE.ZERO) THEN
38407 DM = RMASS(IQ1)-RMASS(IQ2)
38408 SQPE = SQRT( QPE*(S-DM**2) )
38409 PF = SQPE/S
38410 TT = (SQPE*COSTH - S - SM*DM) / TWO
38411 UU = - S - TT
38412 TMG = TT+ML2(ID1)-MG2
38413 AF = AFAC*PF/TMG/TMG
38414c ~ ~
38415c q q' -> q q'
38416c L L
38417 ASTULL(ID1,ID2) = AF*MG2*S
38418 ASTULL(ID2,ID1) = ASTULL(ID1,ID2)
38419c _ ~ ~*
38420c q q' -> q q'
38421c L L
38422 AUTSLL(ID1,ID2) = AF*SQPE**2*SN2TH
38423 AUTSLL(ID2,ID1) = AUTSLL(ID1,ID2)
38424 ELSE
38425 ASTULL(ID1,ID2) = ZERO
38426 ASTULL(ID2,ID1) = ZERO
38427 AUTSLL(ID1,ID2) = ZERO
38428 AUTSLL(ID2,ID1) = ZERO
38429 END IF
38430 IQ1 = SSR + ID1
38431 IQ2 = SSR + ID2
38432 SM = RMASS(IQ1)+RMASS(IQ2)
38433 QPE = S - SM**2
38434 IF (QPE.GE.ZERO) THEN
38435 DM = RMASS(IQ1)-RMASS(IQ2)
38436 SQPE = SQRT( QPE*(S-DM**2) )
38437 PF = SQPE/S
38438 TT = (SQPE*COSTH - S - SM*DM) / TWO
38439 UU = - S - TT
38440 TMG = TT+MR2(ID1)-MG2
38441 AF = AFAC*PF/TMG/TMG
38442c ~ ~
38443c q q' -> q q'
38444c R R
38445 ASTURR(ID1,ID2) = AF*MG2*S
38446 ASTURR(ID2,ID1) = ASTURR(ID1,ID2)
38447c _ ~ ~*
38448c q q' -> q q'
38449c R R
38450 AUTSRR(ID1,ID2) = AF*SQPE**2*SN2TH
38451 AUTSRR(ID2,ID1) = AUTSRR(ID1,ID2)
38452 ELSE
38453 ASTURR(ID1,ID2) = ZERO
38454 ASTURR(ID2,ID1) = ZERO
38455 AUTSRR(ID1,ID2) = ZERO
38456 AUTSRR(ID2,ID1) = ZERO
38457 END IF
38458 IQ1 = SSL + ID1
38459 IQ2 = SSR + ID2
38460 SM = RMASS(IQ1)+RMASS(IQ2)
38461 QPE = S - SM**2
38462 IF (QPE.GE.ZERO) THEN
38463 DM = RMASS(IQ1)-RMASS(IQ2)
38464 SQPE = SQRT( QPE*(S-DM**2) )
38465 PF = SQPE/S
38466 TT = (SQPE*COSTH - S - SM*DM) / TWO
38467 UU = - S - TT
38468 TMG = TT+ML2(ID1)-MG2
38469 AF = AFAC*PF/TMG/TMG
38470c ~ ~
38471c q q' -> q q'
38472c L R
38473 ASTULR(ID1,ID2) = AF*SQPE**2*SN2TH
38474 ASTULR(ID2,ID1) = ASTULR(ID1,ID2)
38475c _ ~ ~*
38476c q q' -> q q'
38477c L R
38478 AUTSLR(ID1,ID2) = AF*MG2*S
38479 AUTSLR(ID2,ID1) = AUTSLR(ID1,ID2)
38480 TT = (SQPE*COSTH - S + SM*DM) / TWO
38481 UU = - S - TT
38482 TMG = TT+MR2(ID1)-MG2
38483 AF = AFAC*PF/TMG/TMG
38484c ~ ~
38485c q q' -> q q'
38486c R L
38487 ASTURL(ID1,ID2) = AF*SQPE**2*SN2TH
38488 ASTURL(ID2,ID1) = ASTULR(ID1,ID2)
38489c _ ~ ~*
38490c q q' -> q q'
38491c R L
38492 AUTSRL(ID1,ID2) = AF*MG2*S
38493 AUTSRL(ID2,ID1) = AUTSLR(ID1,ID2)
38494 ELSE
38495 ASTULR(ID1,ID2) = ZERO
38496 ASTULR(ID2,ID1) = ZERO
38497 AUTSLR(ID1,ID2) = ZERO
38498 AUTSLR(ID2,ID1) = ZERO
38499 ASTURL(ID1,ID2) = ZERO
38500 ASTURL(ID2,ID1) = ZERO
38501 AUTSRL(ID1,ID2) = ZERO
38502 AUTSRL(ID2,ID1) = ZERO
38503 END IF
38504 12 CONTINUE
38505 11 CONTINUE
38506 END IF
38507 HCS = ZERO
38508 DO 6 ID1 = 1, 13
38509 IF (DISF(ID1,1).LT.EPS) GOTO 6
38510 DO 5 ID2 = 1, 13
38511 IF (DISF(ID2,2).LT.EPS) GOTO 5
38512 DIST = DISF(ID1,1)*DISF(ID2,2)
38513 IF (ID1.LT.7) THEN
38514 IQ1 = ID1
38515 IF (ID2.LT.7) THEN
38516 IQ2 = ID2
38517 IF (IQ1.NE.IQ2) THEN
38518c ~ ~
38519c qq' -> q q'
38520 HCS = HCS + ASTULL(IQ1,IQ2)*DIST
38521 IF (GENEV.AND.HCS.GT.RCS) THEN
38522 CALL HWHSSS(IQ1,0,IQ2,0,3421,10)
38523 GOTO 9
38524 ENDIF
38525 HCS = HCS + ASTURR(IQ1,IQ2)*DIST
38526 IF (GENEV.AND.HCS.GT.RCS) THEN
38527 CALL HWHSSS(IQ1,2,IQ2,2,3421,10)
38528 GOTO 9
38529 ENDIF
38530 HCS = HCS + ASTULR(IQ1,IQ2)*DIST
38531 IF (GENEV.AND.HCS.GT.RCS) THEN
38532 CALL HWHSSS(IQ1,0,IQ2,2,3421,10)
38533 GOTO 9
38534 ENDIF
38535 HCS = HCS + ASTURL(IQ1,IQ2)*DIST
38536 IF (GENEV.AND.HCS.GT.RCS) THEN
38537 CALL HWHSSS(IQ1,2,IQ2,0,3421,10)
38538 GOTO 9
38539 ENDIF
38540 ELSE
38541c ~ ~
38542c qq -> q q
38543 HCS = HCS + BSTULL(IQ1)*DIST
38544 IF (GENEV.AND.HCS.GT.RCS) THEN
38545 CALL HWHSSS(IQ1,0,IQ2,0,3421,10)
38546 GOTO 9
38547 ENDIF
38548 HCS = HCS + BSTURR(IQ1)*DIST
38549 IF (GENEV.AND.HCS.GT.RCS) THEN
38550 CALL HWHSSS(IQ1,2,IQ2,2,3421,10)
38551 GOTO 9
38552 ENDIF
38553 HCS = HCS + BSTULR(IQ1)*DIST
38554 IF (GENEV.AND.HCS.GT.RCS) THEN
38555 CALL HWHSSS(IQ1,0,IQ2,2,3421,10)
38556 GOTO 9
38557 ENDIF
38558 HCS = HCS + BSTURL(IQ1)*DIST
38559 IF (GENEV.AND.HCS.GT.RCS) THEN
38560 CALL HWHSSS(IQ1,2,IQ2,0,3421,10)
38561 GOTO 9
38562 ENDIF
38563 HCS = HCS + BSUTLL(IQ1)*DIST
38564 IF (GENEV.AND.HCS.GT.RCS) THEN
38565 CALL HWHSSS(IQ1,0,IQ2,0,4312,10)
38566 GOTO 9
38567 ENDIF
38568 HCS = HCS + BSUTRR(IQ1)*DIST
38569 IF (GENEV.AND.HCS.GT.RCS) THEN
38570 CALL HWHSSS(IQ1,2,IQ2,2,4312,10)
38571 GOTO 9
38572 ENDIF
38573 HCS = HCS + BSUTLR(IQ1)*DIST
38574 IF (GENEV.AND.HCS.GT.RCS) THEN
38575 CALL HWHSSS(IQ1,0,IQ2,2,4312,10)
38576 GOTO 9
38577 ENDIF
38578 HCS = HCS + BSUTRL(IQ1)*DIST
38579 IF (GENEV.AND.HCS.GT.RCS) THEN
38580 CALL HWHSSS(IQ1,2,IQ2,0,4312,10)
38581 GOTO 9
38582 ENDIF
38583 END IF
38584 ELSEIF (ID2.NE.13) THEN
38585 IQ2 = ID2-6
38586 IF (IQ1.NE.IQ2) THEN
38587c _ ~ ~*
38588c qq' -> q q'
38589 HCS = HCS + AUTSLL(IQ1,IQ2)*DIST
38590 IF (GENEV.AND.HCS.GT.RCS) THEN
38591 CALL HWHSSS(IQ1,0,IQ2,1,3142,10)
38592 GOTO 9
38593 ENDIF
38594 HCS = HCS + AUTSRR(IQ1,IQ2)*DIST
38595 IF (GENEV.AND.HCS.GT.RCS) THEN
38596 CALL HWHSSS(IQ1,2,IQ2,3,3142,10)
38597 GOTO 9
38598 ENDIF
38599 HCS = HCS + AUTSLR(IQ1,IQ2)*DIST
38600 IF (GENEV.AND.HCS.GT.RCS) THEN
38601 CALL HWHSSS(IQ1,0,IQ2,3,3142,10)
38602 GOTO 9
38603 ENDIF
38604 HCS = HCS + AUTSRL(IQ1,IQ2)*DIST
38605 IF (GENEV.AND.HCS.GT.RCS) THEN
38606 CALL HWHSSS(IQ1,2,IQ2,1,3142,10)
38607 GOTO 9
38608 ENDIF
38609 ELSE
38610c _ ~ ~*
38611c qq -> q'q' (q =/= q')
38612 DO 30 IQ = 1, 6
38613 IF (IQ .EQ.IQ1) GOTO 30
38614 HCS = HCS + AUSTLL(IQ )*DIST
38615 IF (GENEV.AND.HCS.GT.RCS) THEN
38616 CALL HWHSSS(IQ ,0,IQ ,1,2413,10)
38617 GOTO 9
38618 ENDIF
38619 HCS = HCS + AUSTRR(IQ )*DIST
38620 IF (GENEV.AND.HCS.GT.RCS) THEN
38621 CALL HWHSSS(IQ ,2,IQ ,3,2413,10)
38622 GOTO 9
38623 ENDIF
38624 30 CONTINUE
38625c _ ~ ~*
38626c qq -> q q
38627 HCS = HCS + BUTSLL(IQ1)*DIST
38628 IF (GENEV.AND.HCS.GT.RCS) THEN
38629 CALL HWHSSS(IQ1,0,IQ2,1,3142,10)
38630 GOTO 9
38631 ENDIF
38632 HCS = HCS + BUTSRR(IQ1)*DIST
38633 IF (GENEV.AND.HCS.GT.RCS) THEN
38634 CALL HWHSSS(IQ1,2,IQ2,3,3142,10)
38635 GOTO 9
38636 ENDIF
38637 HCS = HCS + BUTSLR(IQ1)*DIST
38638 IF (GENEV.AND.HCS.GT.RCS) THEN
38639 CALL HWHSSS(IQ1,0,IQ2,3,3142,10)
38640 GOTO 9
38641 ENDIF
38642 HCS = HCS + BUTSRL(IQ1)*DIST
38643 IF (GENEV.AND.HCS.GT.RCS) THEN
38644 CALL HWHSSS(IQ1,2,IQ2,1,3142,10)
38645 GOTO 9
38646 ENDIF
38647 HCS = HCS + BUSTLL(IQ1)*DIST
38648 IF (GENEV.AND.HCS.GT.RCS) THEN
38649 CALL HWHSSS(IQ1,0,IQ2,1,2413,10)
38650 GOTO 9
38651 ENDIF
38652 HCS = HCS + BUSTRR(IQ1)*DIST
38653 IF (GENEV.AND.HCS.GT.RCS) THEN
38654 CALL HWHSSS(IQ1,2,IQ2,3,2413,10)
38655 GOTO 9
38656 ENDIF
38657 HCS = HCS + BUSTLR(IQ1)*DIST
38658 IF (GENEV.AND.HCS.GT.RCS) THEN
38659 CALL HWHSSS(IQ1,0,IQ2,3,2413,10)
38660 GOTO 9
38661 ENDIF
38662 HCS = HCS + BUSTRL(IQ1)*DIST
38663 IF (GENEV.AND.HCS.GT.RCS) THEN
38664 CALL HWHSSS(IQ1,2,IQ2,1,2413,10)
38665 GOTO 9
38666 ENDIF
38667 IQ = IGL
38668c _ ~ ~
38669c qq -> g g
38670 HCS = HCS + CSTU(IQ1)*DIST
38671 IF (GENEV.AND.HCS.GT.RCS) THEN
38672 CALL HWHSSS(IQ ,0,IQ ,0,2413,10)
38673 GOTO 9
38674 ENDIF
38675 HCS = HCS + CSUT(IQ1)*DIST
38676 IF (GENEV.AND.HCS.GT.RCS) THEN
38677 CALL HWHSSS(IQ ,0,IQ ,0,2341,10)
38678 GOTO 9
38679 ENDIF
38680 END IF
38681 ELSE
38682 IQ2 = IGL
38683c ~ ~
38684c qg -> q g
38685 HCS = HCS + CTSUL(IQ1)*DIST
38686 IF (GENEV.AND.HCS.GT.RCS) THEN
38687 CALL HWHSSS(IQ1,0,IQ2,0,3142,10)
38688 GOTO 9
38689 ENDIF
38690 HCS = HCS + CTSUR(IQ1)*DIST
38691 IF (GENEV.AND.HCS.GT.RCS) THEN
38692 CALL HWHSSS(IQ1,2,IQ2,0,3142,10)
38693 GOTO 9
38694 ENDIF
38695 HCS = HCS + CTUSL(IQ1)*DIST
38696 IF (GENEV.AND.HCS.GT.RCS) THEN
38697 CALL HWHSSS(IQ1,0,IQ2,0,3421,10)
38698 GOTO 9
38699 ENDIF
38700 HCS = HCS + CTUSR(IQ1)*DIST
38701 IF (GENEV.AND.HCS.GT.RCS) THEN
38702 CALL HWHSSS(IQ1,2,IQ2,0,3421,10)
38703 GOTO 9
38704 ENDIF
38705 END IF
38706 ELSEIF (ID1.NE.13) THEN
38707 IQ1 = ID1 - 6
38708 IF (ID2.LT.7) THEN
38709 IQ2 = ID2
38710 IF (IQ1.NE.IQ2) THEN
38711c _ ~*~
38712c qq' -> q q'
38713 HCS = HCS + AUTSLL(IQ1,IQ2)*DIST
38714 IF (GENEV.AND.HCS.GT.RCS) THEN
38715 CALL HWHSSS(IQ1,1,IQ2,0,2413,10)
38716 GOTO 9
38717 ENDIF
38718 HCS = HCS + AUTSRR(IQ1,IQ2)*DIST
38719 IF (GENEV.AND.HCS.GT.RCS) THEN
38720 CALL HWHSSS(IQ1,3,IQ2,2,2413,10)
38721 GOTO 9
38722 ENDIF
38723 HCS = HCS + AUTSLR(IQ1,IQ2)*DIST
38724 IF (GENEV.AND.HCS.GT.RCS) THEN
38725 CALL HWHSSS(IQ1,1,IQ2,2,2413,10)
38726 GOTO 9
38727 ENDIF
38728 HCS = HCS + AUTSRL(IQ1,IQ2)*DIST
38729 IF (GENEV.AND.HCS.GT.RCS) THEN
38730 CALL HWHSSS(IQ1,3,IQ2,0,2413,10)
38731 GOTO 9
38732 ENDIF
38733 ELSE
38734c _ ~*~
38735c qq -> q'q' (q =/= q')
38736 DO 31 IQ = 1, 6
38737 IF (IQ .EQ.IQ1) GOTO 31
38738 HCS = HCS + AUSTLL(IQ)*DIST
38739 IF (GENEV.AND.HCS.GT.RCS) THEN
38740 CALL HWHSSS(IQ ,1,IQ ,0,3142,10)
38741 GOTO 9
38742 ENDIF
38743 HCS = HCS + AUSTRR(IQ)*DIST
38744 IF (GENEV.AND.HCS.GT.RCS) THEN
38745 CALL HWHSSS(IQ ,3,IQ ,2,3142,10)
38746 GOTO 9
38747 ENDIF
38748 31 CONTINUE
38749c _ ~*~
38750c qq -> q q
38751 HCS = HCS + BUTSLL(IQ1)*DIST
38752 IF (GENEV.AND.HCS.GT.RCS) THEN
38753 CALL HWHSSS(IQ1,1,IQ2,0,2413,10)
38754 GOTO 9
38755 ENDIF
38756 HCS = HCS + BUTSRR(IQ1)*DIST
38757 IF (GENEV.AND.HCS.GT.RCS) THEN
38758 CALL HWHSSS(IQ1,3,IQ2,2,2413,10)
38759 GOTO 9
38760 ENDIF
38761 HCS = HCS + BUTSLR(IQ1)*DIST
38762 IF (GENEV.AND.HCS.GT.RCS) THEN
38763 CALL HWHSSS(IQ1,1,IQ2,2,2413,10)
38764 GOTO 9
38765 ENDIF
38766 HCS = HCS + BUTSRL(IQ1)*DIST
38767 IF (GENEV.AND.HCS.GT.RCS) THEN
38768 CALL HWHSSS(IQ1,3,IQ2,0,2413,10)
38769 GOTO 9
38770 ENDIF
38771 HCS = HCS + BUSTLL(IQ1)*DIST
38772 IF (GENEV.AND.HCS.GT.RCS) THEN
38773 CALL HWHSSS(IQ1,1,IQ2,0,3142,10)
38774 GOTO 9
38775 ENDIF
38776 HCS = HCS + BUSTRR(IQ1)*DIST
38777 IF (GENEV.AND.HCS.GT.RCS) THEN
38778 CALL HWHSSS(IQ1,3,IQ2,2,3142,10)
38779 GOTO 9
38780 ENDIF
38781 HCS = HCS + BUSTLR(IQ1)*DIST
38782 IF (GENEV.AND.HCS.GT.RCS) THEN
38783 CALL HWHSSS(IQ1,1,IQ2,2,3142,10)
38784 GOTO 9
38785 ENDIF
38786 HCS = HCS + BUSTRL(IQ1)*DIST
38787 IF (GENEV.AND.HCS.GT.RCS) THEN
38788 CALL HWHSSS(IQ1,3,IQ2,0,3142,10)
38789 GOTO 9
38790 ENDIF
38791c _ ~ ~
38792c qq -> g g
38793 HCS = HCS + CSTU(IQ1)*DIST
38794 IF (GENEV.AND.HCS.GT.RCS) THEN
38795 CALL HWHSSS(IGL,0,IGL,0,3142,10)
38796 GOTO 9
38797 ENDIF
38798 HCS = HCS + CSUT(IQ1)*DIST
38799 IF (GENEV.AND.HCS.GT.RCS) THEN
38800 CALL HWHSSS(IGL,0,IGL,0,4123,10)
38801 GOTO 9
38802 ENDIF
38803 END IF
38804 ELSEIF (ID2.NE.13) THEN
38805 IQ2 = ID2 - 6
38806 IF (IQ1.NE.IQ2) THEN
38807c __ ~*~*
38808c qq' -> q q'
38809 HCS = HCS + ASTULL(IQ1,IQ2)*DIST
38810 IF (GENEV.AND.HCS.GT.RCS) THEN
38811 CALL HWHSSS(IQ1,1,IQ2,1,4312,10)
38812 GOTO 9
38813 ENDIF
38814 HCS = HCS + ASTURR(IQ1,IQ2)*DIST
38815 IF (GENEV.AND.HCS.GT.RCS) THEN
38816 CALL HWHSSS(IQ1,3,IQ2,3,4312,10)
38817 GOTO 9
38818 ENDIF
38819 HCS = HCS + ASTULR(IQ1,IQ2)*DIST
38820 IF (GENEV.AND.HCS.GT.RCS) THEN
38821 CALL HWHSSS(IQ1,1,IQ2,3,4312,10)
38822 GOTO 9
38823 ENDIF
38824 HCS = HCS + ASTURL(IQ1,IQ2)*DIST
38825 IF (GENEV.AND.HCS.GT.RCS) THEN
38826 CALL HWHSSS(IQ1,3,IQ2,1,4312,10)
38827 GOTO 9
38828 ENDIF
38829 ELSE
38830c __ ~*~*
38831c qq -> q q
38832 HCS = HCS + BSTULL(IQ1)*DIST
38833 IF (GENEV.AND.HCS.GT.RCS) THEN
38834 CALL HWHSSS(IQ1,1,IQ2,1,4312,10)
38835 GOTO 9
38836 ENDIF
38837 HCS = HCS + BSTURR(IQ1)*DIST
38838 IF (GENEV.AND.HCS.GT.RCS) THEN
38839 CALL HWHSSS(IQ1,3,IQ2,3,4312,10)
38840 GOTO 9
38841 ENDIF
38842 HCS = HCS + BSTULR(IQ1)*DIST
38843 IF (GENEV.AND.HCS.GT.RCS) THEN
38844 CALL HWHSSS(IQ1,1,IQ2,3,4312,10)
38845 GOTO 9
38846 ENDIF
38847 HCS = HCS + BSTURL(IQ1)*DIST
38848 IF (GENEV.AND.HCS.GT.RCS) THEN
38849 CALL HWHSSS(IQ1,3,IQ2,1,4312,10)
38850 GOTO 9
38851 ENDIF
38852 HCS = HCS + BSUTLL(IQ1)*DIST
38853 IF (GENEV.AND.HCS.GT.RCS) THEN
38854 CALL HWHSSS(IQ1,1,IQ2,1,3421,10)
38855 GOTO 9
38856 ENDIF
38857 HCS = HCS + BSUTRR(IQ1)*DIST
38858 IF (GENEV.AND.HCS.GT.RCS) THEN
38859 CALL HWHSSS(IQ1,3,IQ2,3,3421,10)
38860 GOTO 9
38861 ENDIF
38862 HCS = HCS + BSUTLR(IQ1)*DIST
38863 IF (GENEV.AND.HCS.GT.RCS) THEN
38864 CALL HWHSSS(IQ1,1,IQ2,3,3421,10)
38865 GOTO 9
38866 ENDIF
38867 HCS = HCS + BSUTRL(IQ1)*DIST
38868 IF (GENEV.AND.HCS.GT.RCS) THEN
38869 CALL HWHSSS(IQ1,3,IQ2,1,3421,10)
38870 GOTO 9
38871 ENDIF
38872 END IF
38873 ELSE
38874 IQ2 = IGL
38875c _ ~*~
38876c qg -> q g
38877 HCS = HCS + CTSUL(IQ1)*DIST
38878 IF (GENEV.AND.HCS.GT.RCS) THEN
38879 CALL HWHSSS(IQ1,1,IQ2,0,2413,10)
38880 GOTO 9
38881 ENDIF
38882 HCS = HCS + CTSUR(IQ1)*DIST
38883 IF (GENEV.AND.HCS.GT.RCS) THEN
38884 CALL HWHSSS(IQ1,3,IQ2,0,2413,10)
38885 GOTO 9
38886 ENDIF
38887 HCS = HCS + CTUSL(IQ1)*DIST
38888 IF (GENEV.AND.HCS.GT.RCS) THEN
38889 CALL HWHSSS(IQ1,1,IQ2,0,4312,10)
38890 GOTO 9
38891 ENDIF
38892 HCS = HCS + CTUSR(IQ1)*DIST
38893 IF (GENEV.AND.HCS.GT.RCS) THEN
38894 CALL HWHSSS(IQ1,3,IQ2,0,4312,10)
38895 GOTO 9
38896 ENDIF
38897 END IF
38898 ELSE
38899 IQ1 = IGL
38900 IF (ID2.LT.7) THEN
38901 IQ2 = ID2
38902c ~ ~
38903c gq -> g q
38904 HCS = HCS + CTSUL(IQ2)*DIST
38905 IF (GENEV.AND.HCS.GT.RCS) THEN
38906 CALL HWHSSS(IQ1,0,IQ2,0,2413,10)
38907 GOTO 9
38908 ENDIF
38909 HCS = HCS + CTSUR(IQ2)*DIST
38910 IF (GENEV.AND.HCS.GT.RCS) THEN
38911 CALL HWHSSS(IQ1,0,IQ2,2,2413,10)
38912 GOTO 9
38913 ENDIF
38914 HCS = HCS + CTUSL(IQ2)*DIST
38915 IF (GENEV.AND.HCS.GT.RCS) THEN
38916 CALL HWHSSS(IQ1,0,IQ2,0,3421,10)
38917 GOTO 9
38918 ENDIF
38919 HCS = HCS + CTUSR(IQ2)*DIST
38920 IF (GENEV.AND.HCS.GT.RCS) THEN
38921 CALL HWHSSS(IQ1,0,IQ2,2,3421,10)
38922 GOTO 9
38923 ENDIF
38924 ELSEIF (ID2.LT.13) THEN
38925 IQ2 = ID2 - 6
38926c _ ~ ~*
38927c gq -> g q
38928 HCS = HCS + CTSUL(IQ2)*DIST
38929 IF (GENEV.AND.HCS.GT.RCS) THEN
38930 CALL HWHSSS(IQ1,0,IQ2,1,3142,10)
38931 GOTO 9
38932 ENDIF
38933 HCS = HCS + CTSUR(IQ2)*DIST
38934 IF (GENEV.AND.HCS.GT.RCS) THEN
38935 CALL HWHSSS(IQ1,0,IQ2,3,3142,10)
38936 GOTO 9
38937 ENDIF
38938 HCS = HCS + CTUSL(IQ2)*DIST
38939 IF (GENEV.AND.HCS.GT.RCS) THEN
38940 CALL HWHSSS(IQ1,0,IQ2,1,4312,10)
38941 GOTO 9
38942 ENDIF
38943 HCS = HCS + CTUSR(IQ2)*DIST
38944 IF (GENEV.AND.HCS.GT.RCS) THEN
38945 CALL HWHSSS(IQ1,0,IQ2,3,4312,10)
38946 GOTO 9
38947 ENDIF
38948 ELSE
38949 IQ2 = IGL
38950c ~ ~*
38951c gg -> q q
38952 DO 32 IQ = 1, 6
38953 HCS = HCS + CSTUL(IQ)*DIST
38954 IF (GENEV.AND.HCS.GT.RCS) THEN
38955 CALL HWHSSS(IQ ,0,IQ ,1,2413,10)
38956 GOTO 9
38957 ENDIF
38958 HCS = HCS + CSTUR(IQ)*DIST
38959 IF (GENEV.AND.HCS.GT.RCS) THEN
38960 CALL HWHSSS(IQ ,2,IQ ,3,2413,10)
38961 GOTO 9
38962 ENDIF
38963 HCS = HCS + CSUTL(IQ)*DIST
38964 IF (GENEV.AND.HCS.GT.RCS) THEN
38965 CALL HWHSSS(IQ ,0,IQ ,1,4123,10)
38966 GOTO 9
38967 ENDIF
38968 HCS = HCS + CSUTR(IQ)*DIST
38969 IF (GENEV.AND.HCS.GT.RCS) THEN
38970 CALL HWHSSS(IQ ,2,IQ ,3,4123,10)
38971 GOTO 9
38972 ENDIF
38973 32 CONTINUE
38974c ~ ~
38975c gg -> g g
38976 HCS = HCS + DTSU*DIST
38977 IF (GENEV.AND.HCS.GT.RCS) THEN
38978 CALL HWHSSS(IQ1,0,IQ2,0,2341,10)
38979 GOTO 9
38980 ENDIF
38981 HCS = HCS + DSTU*DIST
38982 IF (GENEV.AND.HCS.GT.RCS) THEN
38983 CALL HWHSSS(IQ1,0,IQ2,0,3421,10)
38984 GOTO 9
38985 ENDIF
38986 HCS = HCS + DUTS*DIST
38987 IF (GENEV.AND.HCS.GT.RCS) THEN
38988 CALL HWHSSS(IQ1,0,IQ2,0,2413,10)
38989 GOTO 9
38990 ENDIF
38991 END IF
38992 END IF
38993 5 CONTINUE
38994 6 CONTINUE
38995 EVWGT = HCS
38996 RETURN
38997C---GENERATE EVENT
38998 9 IDN(1)=ID1
38999 IDN(2)=ID2
39000 IDCMF=15
39001 CALL HWETWO(.TRUE.,.TRUE.)
39002 IF (AZSPIN) THEN
39003C Calculate coefficients for constructing spin density matrices
39004C Set to zero for now
39005 CALL HWVZRO(7,GCOEF)
39006 END IF
39007 END
39008CDECK ID>, HWHSSP.
39009*CMZ :- -25/06/99 20.33.45 by Kosuke Odagiri
39010*-- Author : Kosuke Odagiri & Bryan Webber
39011C-----------------------------------------------------------------------
39012 SUBROUTINE HWHSSP
39013C-----------------------------------------------------------------------
39014C SUSY HARD 2 PARTON -> 2 SPARTON/GAUGINO/SLEPTON PROCESSES
39015C-----------------------------------------------------------------------
c63d70bc 39016 INCLUDE 'herwig65.inc'
65767955 39017 DOUBLE PRECISION SAVWT(3),RANWT,HWRGEN,HWRUNI,Z1,Z2,ET,EJ,
39018 & QPE,S,T,U,KK,KK2,YJ1INF,YJ1SUP,YJ2INF,YJ2SUP,SVEMSC
39019 INTEGER ISP
39020 EXTERNAL HWRGEN,HWRUNI
39021 SAVE SAVWT,SVEMSC
39022 IF (.NOT.GENEV) THEN
39023 EVWGT=ZERO
39024 CALL HWRPOW(ET,EJ)
39025 KK = ET/PHEP(5,3)
39026 KK2=KK**2
39027 IF (KK.GE.ONE) RETURN
39028 YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) )
39029 YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) )
39030 IF (YJ1INF.GE.YJ1SUP) RETURN
39031 Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP))
39032 YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) )
39033 YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) )
39034 IF (YJ2INF.GE.YJ2SUP) RETURN
39035 Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP))
39036 XX(1)=HALF*(Z1+Z2)*KK
39037 IF (XX(1).GE.ONE) RETURN
39038 XX(2)=XX(1)/(Z1*Z2)
39039 IF (XX(2).GE.ONE) RETURN
39040 S=XX(1)*XX(2)*PHEP(5,3)**2
39041 QPE=S-(TWO*RMMNSS)**2
39042 IF (QPE.LE.ZERO) RETURN
39043 COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE)
39044 IF (ABS(COSTH).GT.ONE) RETURN
39045 T=-(ONE+Z2/Z1)*(HALF*ET)**2
39046 U=-S-T
39047C---SET EMSCA TO HEAVY HARD PROCESS SCALE
39048 SVEMSC = SQRT(TWO*S*T*U/(S*S+T*T+U*U))
39049 FACTSS = GEV2NB*HALF*PIFAC*EJ*ET/S**2
39050 & * (YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF)
39051 & * SQRT(S/QPE)
39052 ENDIF
39053 EMSCA=SVEMSC
39054 ISP=MOD(IPROC,100)
39055 IF (ISP.EQ.0) THEN
39056 IF (GENEV) THEN
39057 RANWT=SAVWT(3)*HWRGEN(0)
39058 IF (RANWT.LT.SAVWT(1)) THEN
39059 CALL HWHSSQ
39060 ELSEIF (RANWT.LT.SAVWT(2)) THEN
39061 CALL HWHSSG
39062 ELSE
39063 CALL HWHSSL
39064 ENDIF
39065 ELSE
39066 CALL HWHSSQ
39067 SAVWT(1)=EVWGT
39068 CALL HWHSSG
39069 SAVWT(2)=SAVWT(1)+EVWGT
39070 CALL HWHSSL
39071 SAVWT(3)=SAVWT(2)+EVWGT
39072 EVWGT=SAVWT(3)
39073 ENDIF
39074 ELSEIF (ISP.EQ.10) THEN
39075 CALL HWHSSQ
39076 ELSEIF (ISP.EQ.20) THEN
39077 CALL HWHSSG
39078 ELSEIF (ISP.EQ.30) THEN
39079 CALL HWHSSL
39080 ELSE
39081C---UNRECOGNIZED PROCESS
39082 CALL HWWARN('HWHSSP',500)
39083 ENDIF
39084 END
39085CDECK ID>, HWHSSS.
39086*CMZ :- -18/05/99 20.33.45 by Kosuke Odagiri
39087*-- Author : Kosuke Odagiri
39088C-----------------------------------------------------------------------
39089 SUBROUTINE HWHSSS(ID3,R3,ID4,R4,IPERM,IHPR)
39090C-----------------------------------------------------------------------
39091C IDENTIFIES HARD SUSY SUBPROCESS
39092C-----------------------------------------------------------------------
c63d70bc 39093 INCLUDE 'herwig65.inc'
65767955 39094 INTEGER ID3, R3, ID4, R4, IPERM, IHPR, SSL
39095 PARAMETER (SSL = 400)
39096 IHPRO = 3000 + IHPR
39097 IDN(3) = SSL + ID3 + R3*6
39098 IDN(4) = SSL + ID4 + R4*6
39099 ICO(1) = IPERM/1000
39100 ICO(2) = IPERM/100 - 10*ICO(1)
39101 ICO(3) = IPERM/10 - 10*(IPERM/100)
39102 ICO(4) = IPERM - 10*(IPERM/10)
39103 END
39104CDECK ID>, HWHV1J.
39105*CMZ :- -18/05/99 14.37.45 by Mike Seymour
39106*-- Author : Mike Seymour
39107C-----------------------------------------------------------------------
39108 SUBROUTINE HWHV1J
39109C-----------------------------------------------------------------------
39110C V + 1 JET PRODUCTION, WHERE V=W (IHPRO.LT.5) OR Z (IHPRO.GE.5).
39111C USES CROSS-SECTIONS OF EHLQ FOR ANNIHILATION AND COMPTON SCATTERING
39112C IHPRO=0 FOR BOTH, 1 FOR ANNIHILATION, AND 2 FOR COMPTON.
39113C-----------------------------------------------------------------------
c63d70bc 39114 INCLUDE 'herwig65.inc'
65767955 39115 DOUBLE PRECISION HWRGEN,HWRUNI,DISFAC(2,12,2),EMV2,DISMAX,S,T,U,
39116 & SHAT,THAT,UHAT,Z,HWUALF,PT,EMT,GFACTR,SIGANN,SIGCOM(2),CSFAC,ET,
39117 & EJ,YMIN,YMAX,VYMIN,VYMAX,EMAX,CV,CA,BR,EMV,GAMV,HWUAEM,TMIN,TMAX
39118 INTEGER HWRINT,IDINIT(2,12,2),ICOFLO(4,2),I,J,K,L,M,ID1,ID2,
39119 $ IDV,IDI,IDM
39120 EXTERNAL HWRINT
39121 SAVE DISFAC,SHAT,THAT,EMV,EMV2,IDV,IDI
39122 SAVE IDINIT,ICOFLO
39123C---IDINIT HOLDS THE INITIAL STATES FOR ANNIHILATION PROCESSES
39124 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,
39125 $ 1,7,2,8,3,9,4,10,5,11,6,12,1,7,2,8,3,9,4,10,5,11,6,12/
39126C---ICOFLO HOLDS THE COLOR FLOW FOR EACH PROCESS
39127C---DISFAC HOLDS THE DISTRIBUTION FUNCTION*CROSS-SECTION FOR EACH
39128C POSSIBLE SUB-PROCESS.
39129C INDEX1=INITIAL STATE PERMUTATION (1=AS IDINIT/QG;2=OPPOSITE/GQ),
39130C 2=QUARK (FOR ANNIHILATION, >6 IMPLIES CABIBBO ROTATED PAIR),
39131C 3=PROCESS (1=ANNIHILATION, 2=COMPTON)
39132 DATA ICOFLO,DISFAC/2,4,3,1,4,1,3,2,48*0.D0/
39133 IF (GENEV) THEN
39134 DISMAX=0
39135 DO 110 I=1,2
39136 DO 110 J=1,12
39137 DO 110 K=1,2
39138 110 DISMAX=MAX(DISFAC(K,J,I),DISMAX)
39139 120 I=HWRINT(1,2)
39140 J=HWRINT(1,12)
39141 K=HWRINT(1,2)
39142 IF (HWRGEN(0)*DISMAX.GT.DISFAC(K,J,I)) GOTO 120
39143 IF (I.EQ.1) THEN
39144C---ANNIHILATION
39145 IDN(1)=IDINIT(K,J,IDI)
39146 IDN(2)=IDINIT(3-K,J,IDI)
39147 IDN(4)=13
39148 ELSE
39149C---COMPTON SCATTERING
39150 IDN(1)=J
39151 IDN(2)=13
39152 IF (IDV.EQ.200) THEN
39153 IDN(4)=J
39154 ELSE
39155 IF (J.EQ.5.OR.J.EQ.6.OR.J.GE.11.OR.HWRGEN(0).GT.SCABI) THEN
39156C---CHANGE QUARKS (1->2,2->1,3->4,4->3,...)
39157 IDN(4)=4*INT((J-1)/2)-J+3
39158 ELSE
39159C---CHANGE AND CABIBBO ROTATE QUARKS (1->4,2->3,3->2,...)
39160 IDN(4)=12*INT((J-1)/6)-J+5
39161 ENDIF
39162 ENDIF
39163 IF ((SQRT(EMV2)+RMASS(IDN(4)))**2.GT.SHAT) GOTO 120
39164 IF (K.EQ.2) THEN
39165C---SWAP INITIAL STATES
39166 IDN(3)=IDN(1)
39167 IDN(1)=IDN(2)
39168 IDN(2)=IDN(3)
39169 ENDIF
39170 ENDIF
39171 IF (IDV.EQ.200) THEN
39172 IDN(3)=200
39173 ELSE
39174C---W+ OR W-? USE CHARGE CONSERVATION TO WORK OUT
39175 IDN(3)=NINT(198.5-.1667*FLOAT(ICHRG(IDN(1))+ICHRG(IDN(2))))
39176 ENDIF
39177 M=K
39178 IF (I.EQ.2.AND.J.LE.6) M=3-K
39179 DO 130 L=1,4
39180 130 ICO(L)=ICOFLO(L,M)
39181 IDCMF=15
39182 COSTH=(SHAT+2*THAT-EMV2)/(SHAT-EMV2)
39183C---TRICK HWETWO INTO USING THE OFF-SHELL V MASS
39184 RMASS(IDN(3))=SQRT(EMV2)
39185C-- BRW fix 27/8/04: avoid double smearing of V mass
39186 CALL HWETWO(.FALSE.,.TRUE.)
39187 RMASS(IDN(3))=EMV
39188 RHOHEP(1,NHEP-1)=0.5
39189 RHOHEP(2,NHEP-1)=0.0
39190 RHOHEP(3,NHEP-1)=0.5
39191 ELSE
39192 EVWGT=0.
39193 IHPRO=MOD(IPROC,100)/10
39194 IF (IHPRO.LT.5) THEN
39195 IDV=198
39196 IDI=1
39197 IDM=10
39198 GAMV=GAMW
39199 ELSE
39200 IDV=200
39201 IDI=2
39202 IDM=6
39203 GAMV=GAMZ
39204 IHPRO=IHPRO-5
39205 ENDIF
39206 EMV=RMASS(IDV)
39207c---mhs---implement cut on number of widths from nominal mass
39208 TMIN=-ATAN(2*GAMMAX-GAMV*GAMMAX**2/EMV)
39209 TMAX=ATAN(2*GAMMAX+GAMV*GAMMAX**2/EMV)
39210 EMV2=EMV*(EMV+GAMV*TAN(HWRUNI(0,TMIN,TMAX)))
39211 IF (EMV2.LE.ZERO) RETURN
39212 CALL HWRPOW(ET,EJ)
39213 PT=0.5*ET
39214 EMT=SQRT(PT**2+EMV2)
39215 EMAX=0.5*(PHEP(5,3)+EMV2/PHEP(5,3))
39216 IF (EMAX.LE.EMT) RETURN
39217 VYMAX=0.5*LOG((EMAX+SQRT(EMAX**2-EMT**2))
39218 & /(EMAX-SQRT(EMAX**2-EMT**2)))
39219 VYMIN=-VYMAX
39220 IF (VYMAX.LE.VYMIN) RETURN
39221 Z=EXP(HWRUNI(0,VYMIN,VYMAX))
39222 S= PHEP(5,3)**2
39223 T=-PHEP(5,3)*EMT/Z+EMV2
39224 U=-PHEP(5,3)*EMT*Z+EMV2
39225 XXMIN=-U/(S+T-EMV2)
39226 IF (XXMIN.LT.ZERO.OR.XXMIN.GT.ONE) RETURN
39227 YMIN=MAX(LOG((XXMIN*PHEP(5,3)-EMT*Z)/PT),YJMIN)
39228 YMAX=MIN(LOG((PHEP(5,3)-EMT*Z)/PT),YJMAX)
39229 IF (YMAX.LE.YMIN) RETURN
39230 XX(1)=(Z*EMT+EXP(HWRUNI(2,YMIN,YMAX))*PT)/PHEP(5,3)
39231 IF (XX(1).LE.ZERO.OR.XX(1).GT.ONE) RETURN
39232 THAT =XX(1)*T+(1.-XX(1))*EMV2
39233 XX(2)=-THAT / (XX(1)*S+U-EMV2)
39234 IF (XX(2).LT.ZERO.OR.XX(2).GT.ONE) RETURN
39235 UHAT =XX(2)*U+(1.-XX(2))*EMV2
39236 SHAT =XX(1)*XX(2)*S
39237 EMSCA=EMT
39238 CALL HWSGEN(.FALSE.)
39239c---mhs minor improvement: replace thomson coupling by running coupling
39240c---mhs bug fix: missing factor of m^2/m0^2, where m0 is nominal mass
39241 GFACTR=GEV2NB*2.*PIFAC*HWUAEM(EMV2)*HWUALF(1,EMSCA)/(9.*SWEIN)
39242 $ *EMV2/EMV**2
39243 SIGANN=GFACTR*((THAT-EMV2)**2+(UHAT-EMV2)**2)
39244 & /(SHAT**2*THAT*UHAT)
39245 SIGCOM(2)=.375*GFACTR*(SHAT**2+UHAT**2+2*EMV2*THAT)
39246 & /(-UHAT*SHAT**3)
39247 SIGCOM(1)=.375*GFACTR*(SHAT**2+THAT**2+2*EMV2*UHAT)
39248 & /(-THAT*SHAT**3)
39249C---IF USER SPECIFIED A SUB-PROCESS, ZERO THE OTHER
39250 IF (IHPRO.EQ.1) THEN
39251 SIGCOM(1)=0.
39252 SIGCOM(2)=0.
39253 ENDIF
39254 IF (IHPRO.EQ.2) SIGANN=0.
39255 DO 210 I=1,IDM
39256 IF (IDV.EQ.200) THEN
39257 J=I
39258 IF(I.GT.6) J=I-6
39259 DISFAC(1,I,1)=4*SWEIN*(VFCH(J,1)**2+AFCH(J,1)**2)
39260 ELSE
39261 IF (I.LE.4) THEN
39262 DISFAC(1,I,1)=1-SCABI
39263 ELSEIF (I.GE.7) THEN
39264 DISFAC(1,I,1)=SCABI
39265 ELSE
39266 DISFAC(1,I,1)=1.
39267 ENDIF
39268 ENDIF
39269 DISFAC(2,I,1)=DISFAC(1,I,1) *
39270 & SIGANN*DISF(IDINIT(1,I,IDI),2)*DISF(IDINIT(2,I,IDI),1)
39271 DISFAC(1,I,1)=DISFAC(1,I,1) *
39272 & SIGANN*DISF(IDINIT(1,I,IDI),1)*DISF(IDINIT(2,I,IDI),2)
39273 210 CONTINUE
39274 DO 211 I=IDM+1,12
39275 DISFAC(1,I,1)=0
39276 DISFAC(2,I,1)=0
39277 211 CONTINUE
39278 DO 220 I=1,12
39279 IF (IDV.EQ.200) THEN
39280 J=I
39281 IF(I.GT.6) J=I-6
39282 DISFAC(1,I,2)=4*SWEIN*(VFCH(J,1)**2+AFCH(J,1)**2)
39283 ELSE
39284 DISFAC(1,I,2)=1.
39285c---mhs fix: switch off bg->Wt process since we neglect quark masses!
39286 IF (I.EQ.5.OR.I.EQ.11) DISFAC(1,I,2)=0
39287 ENDIF
39288 DISFAC(2,I,2)=DISFAC(1,I,2)*SIGCOM(2)*DISF(I,2)*DISF(13,1)
39289 DISFAC(1,I,2)=DISFAC(1,I,2)*SIGCOM(1)*DISF(I,1)*DISF(13,2)
39290 220 CONTINUE
39291 DO 230 I=1,2
39292 DO 230 J=1,12
39293 DO 230 K=1,2
39294 230 EVWGT=EVWGT+DISFAC(K,J,I)
39295 CSFAC=PT*EJ*(YMAX-YMIN)*(VYMAX-VYMIN)*(TMAX-TMIN)/PIFAC
39296C---INCLUDE BRANCHING RATIO OF V
39297 CALL HWDBOZ(IDV,ID1,ID2,CV,CA,BR,0)
39298 EVWGT=EVWGT*CSFAC*BR
39299 ENDIF
39300 END
39301CDECK ID>, HWHV2J.
39302*CMZ :- -14/03/01 09:03:25 by Peter Richardson
39303*-- Author : Peter Richardson
39304C-----------------------------------------------------------------------
39305 SUBROUTINE HWHV2J
39306C-----------------------------------------------------------------------
39307C Vector Boson production with two hard jets
39308C Master subroutine for all vector boson + 2 jet processes
39309C Currently implemented qqbar Z only
39310C-----------------------------------------------------------------------
c63d70bc 39311 INCLUDE 'herwig65.inc'
65767955 39312 INTEGER I,J,K,IDBS,IPRC,IDP(6),ORD,IB,ICMF,IHEP,IFLOW,IZ,IBRAD,
39313 & ICOL(5),IDZ,IQ
39314 DOUBLE PRECISION HWRGEN,HWRUNI,XMASS,PLAB,PRW,PCM,HWUAEM,BR,FLUX,
39315 & MBOS,MBOS2,ME,DT(4),B(6),HWUPCM,CV,CA,PST,HWUALF,GMBS,FPI4,
39316 & MQ(3),MQ2(3),MJAC,BRZED(12),PTP(5,2),PDOT(2),HWULDO,TWOPI2,
39317 & AMP,WI(IMAXCH)
39318 DOUBLE COMPLEX S,D,F
39319 LOGICAL FSTCLL,MASS,GEN
39320 EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWUALF,HWUAEM,HWULDO
39321 COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10)
39322 COMMON/HWHEWS/S(8,8,2),D(8,8)
39323 COMMON/HWHZBB/F(8,8)
39324 COMMON /HWPSOM/ WI
39325 SAVE ME,MBOS,MBOS2,GMBS,IDBS,IPRC,IDP,FSTCLL,MQ,MQ2,TWOPI2,FPI4,
39326 & IQ,MASS
39327 SAVE B,BRZED
39328 DATA B/-1.0D0,-1.0D0,1.0D0,1.0D0,1.0D0,1.0D0/
39329 DATA BRZED/0.154D0,0.120D0,0.154D0,0.120D0,0.152D0,0.000D0,
39330 & 0.033D0,0.067D0,0.033D0,0.067D0,0.033D0,0.067D0/
39331C--generate the event
39332 IF(GENEV) THEN
39333C--find the particles produced
39334 IF(IPRC.EQ.0) THEN
39335 WRITE(*,1000)
39336 STOP
39337 ELSEIF(IPRC.GT.0.AND.IPRC.LE.16) THEN
39338 CALL HWHDYQ(FSTCLL,ME,IFLOW,IDP,ORD,IQ,MASS)
39339 ELSE
39340 CALL HWWARN('HWHV2J',502)
39341 ENDIF
39342 IF(ORD.EQ.2) THEN
39343 IB = IDP(1)
39344 IDP(1) = IDP(2)
39345 IDP(2) = IB
39346 PRW(3,1) = -PRW(3,1)
39347 DO I=3,6
39348 PLAB(3,I)=-PLAB(3,I)
39349 ENDDO
39350 ENDIF
39351C--enter the incoming particles
39352 ICMF = NHEP+3
39353 DO I=1,2
39354 IHEP = NHEP+I
39355 CALL HWVEQU(5,PLAB(1,I),PHEP(1,IHEP))
39356 IDHW(IHEP) = IDP(I)
39357 IDHEP(IHEP)= IDPDG(IDP(I))
39358 ISTHEP(IHEP)=110+I
39359 JMOHEP(1,IHEP)=ICMF
39360 JMOHEP(I,ICMF)=IHEP
39361 JDAHEP(1,IHEP)=ICMF
39362 ENDDO
39363 IDHW(ICMF)=15
39364 IDHEP(ICMF)=IDPDG(15)
39365 ISTHEP(ICMF)=110
39366 CALL HWVSUM(4,PHEP(1,NHEP+1),PHEP(1,NHEP+2),PHEP(1,ICMF))
39367 CALL HWUMAS(PHEP(1,ICMF))
39368 JDAHEP(1,ICMF) = ICMF+1
39369 JDAHEP(2,ICMF) = ICMF+3
39370 NHEP = NHEP+3
39371C--Now the outgoing jets
39372 DO 10 I=1,2
39373 CALL HWVEQU(5,PLAB(1,2+I),PHEP(1,NHEP+I))
39374C--Set the status and pointers
39375 ISTHEP(NHEP+I)=113
39376 IDHW(NHEP+I)=IDP(2+I)
39377 IDHEP(NHEP+I)=IDPDG(IDP(2+I))
39378 JMOHEP(1,NHEP+I)=NHEP
39379 10 CONTINUE
39380 NHEP=NHEP+2
39381C--Now sort out the colour connections
39382 ICOL(1)=IFLOW/1000
39383 ICOL(2)=IFLOW/100-10*ICOL(1)
39384 ICOL(3)=IFLOW/10 -10*(IFLOW/100)
39385 ICOL(4)=IFLOW -10*(IFLOW/10)
39386 DO 30 I=1,4
39387 J=I
39388 IF (J.GT.2) J=J+1
39389 K=ICOL(I)
39390 IF (K.GT.2) K=K+1
39391 JMOHEP(2,NHEP-5+J)=NHEP+K-5
39392 30 JDAHEP(2,NHEP-5+K)=NHEP+J-5
39393C--Now add the Z to the event record
39394 CALL HWVEQU(5,PRW(1,1),PHEP(1,NHEP+1))
39395 CALL HWVZRO(4,VHEP(1,NHEP+1))
39396 CALL HWUDKL(200,PHEP(1,NHEP+1),DT)
39397 CALL HWVSUM(4,VHEP(1,NHEP+1),DT,DT)
39398 IDHW(NHEP+1)=IDBS
39399 IDHEP(NHEP+1)=IDPDG(IDBS)
39400 JMOHEP(1,NHEP+1)=ICMF
39401 JMOHEP(2,NHEP+1)=ICMF
39402 ISTHEP(NHEP+1)=114
39403 NHEP = NHEP+1
39404 IBRAD = NHEP
39405C--generate the inital-state shower
39406 CALL HWBGEN
39407C--now add the decay products of the Z
39408 IZ = JDAHEP(1,IBRAD)
39409 ISTHEP(IZ) = 195
39410 JDAHEP(1,IZ) = NHEP+1
39411 JDAHEP(2,IZ) = NHEP+2
39412 IDHW(NHEP+1) = IDP(5)
39413 IDHW(NHEP+2) = IDP(6)
39414 ISTHEP(NHEP+1) = 113
39415 ISTHEP(NHEP+2) = 114
39416 IDHEP(NHEP+1) = IDPDG(IDP(5))
39417 IDHEP(NHEP+2) = IDPDG(IDP(6))
39418 JMOHEP(1,NHEP+1) = IZ
39419 JMOHEP(1,NHEP+2) = IZ
39420 JMOHEP(2,NHEP+1) = NHEP+2
39421 JDAHEP(2,NHEP+1) = NHEP+2
39422 JMOHEP(2,NHEP+2) = NHEP+1
39423 JDAHEP(2,NHEP+2) = NHEP+1
39424 CALL HWVEQU(5,PLAB(1,5),PHEP(1,NHEP+1))
39425 CALL HWVEQU(5,PLAB(1,6),PHEP(1,NHEP+2))
39426 DO IHEP=NHEP+1,NHEP+2
39427 CALL HWVEQU(4,DT,VHEP(1,IHEP))
39428C--Boost the fermion momenta to the rest frame of the original Z
39429 CALL HWULOF(PRW(1,1),PHEP(1,IHEP),PHEP(1,IHEP))
39430C--Now boost back to the lab from rest frame of the Z after radiation
39431 CALL HWULOB(PHEP(1,IZ),PHEP(1,IHEP),PHEP(1,IHEP))
39432 ENDDO
39433 NHEP = NHEP+2
39434 ELSE
39435C--initialisation
39436 IF(FSTWGT) THEN
39437C--for second option minimum invariant mass of the jet pair
39438C--set the type of events to be generated
39439 TWOPI2= FOUR*PIFAC**2
39440 FPI4 = (FOUR*PIFAC)**4
39441 IPRC = MOD(IPROC,100)
39442 IF(IPRC.GE.0.AND.IPRC.LE.16) THEN
39443C--Z + 2 jets
39444 MBOS = RMASS(200)
39445 MBOS2 = MBOS**2
39446 GMBS = MBOS2*GAMZ**2
39447 IDBS = 200
39448 MQ(1) = ZERO
39449 MQ(2) = ZERO
39450 IF(IPRC.EQ.0) THEN
39451 IQ = 0
39452 ELSEIF(IPRC.GT.0.AND.IPRC.LE.6) THEN
39453 IQ = IPRC
39454 IF(MJJMIN.LT.TWO*RMASS(IQ)) MJJMIN = TWO*RMASS(IQ)
39455 ELSEIF(IPRC.GE.11.AND.IPRC.LE.16) THEN
39456 MASS = .TRUE.
39457 IQ = IPRC-10
39458 MQ(1) = RMASS(IQ)
39459 MQ(2) = RMASS(IQ)
39460 IF(MJJMIN.LT.(MQ(1)+MQ(2))) MJJMIN = MQ(1)+MQ(2)
39461 ELSE
39462 CALL HWWARN('HWHV2J',500)
39463 ENDIF
39464 DO I=1,2
39465 MQ2(I) = MQ(I)**2
39466 ENDDO
39467 ELSE
39468 CALL HWWARN('HWHV2J',503)
39469 ENDIF
39470 FSTCLL = .TRUE.
39471 ENDIF
39472C--generate the weight
39473 EVWGT = ZERO
39474C--find the mass of the gauge boson
39475 CALL HWHGB1(1,2,IDBS,MJAC,MQ2(3),(PHEP(5,3)-MQ(1)-MQ(2))**2,
39476 & EMMIN**2)
39477 MQ(3) = SQRT(MQ2(3))
39478 MJAC = MJAC/((MQ2(3)-MBOS2)**2+GMBS)
39479C--do the phase space
39480 CALL HWH2PS(FLUX,GEN,MQ,MQ2)
39481 AMP = ONE
39482 IF(.NOT.GEN) RETURN
39483C--copy the gauge boson momentum
39484 CALL HWVEQU(5,PLAB(1,5),PRW(1,1))
39485C--select the decay mode of the boson
39486 CALL HWDBOZ(IDBS,IDP(5),IDP(6),CV,CA,BR,0)
39487 IDZ = IDP(5)
39488 IF(IDZ.GT.6) IDZ = IDZ-114
39489 BR = BR/BRZED(IDZ)
39490 IF(IDZ.LE.6) AMP = AMP*THREE
39491C--Finds the momenta of the boson decay products
39492 PST=HWUPCM(PRW(5,1),ZERO,ZERO)
39493 PLAB(5,5)=ZERO
39494 PLAB(5,6)=ZERO
39495 IF(PRW(5,1).LT.(RMASS(IDP(5))+RMASS(IDP(6)))) RETURN
39496 CALL HWDTWO(PRW(1,1),PLAB(1,5),PLAB(1,6),PST,TWO,.FALSE.)
39497 MJAC = HALF*PST*MJAC/TWOPI2/MQ(3)
39498C--copy the momenta, change order and boost to CMF
39499 PTP(1,1) = ZERO
39500 PTP(2,1) = ZERO
39501 PTP(3,1) = HALF*(XX(1)-XX(2))*PHEP(5,3)
39502 PTP(4,1) = HALF*(XX(1)+XX(2))*PHEP(5,3)
39503 PTP(5,1) = PHEP(5,3)*SQRT(XX(1)*XX(2))
39504 DO I=1,6
39505 CALL HWULOF(PTP(1,1),PLAB(1,I),PTP(1,2))
39506 PCM(1,I)=PTP(3,2)
39507 PCM(2,I)=PTP(1,2)
39508 PCM(3,I)=PTP(2,2)
39509 PCM(4,I)=PTP(4,2)
39510 ENDDO
39511 IF(MASS) THEN
39512C--Massive momentum case
39513C--reorder the products
39514C--move b and bbar to 9 and 10
39515 DO I=3,4
39516 DO J=1,5
39517 PCM(J,I+6) = PCM(J,I)
39518 ENDDO
39519 ENDDO
39520C--select the reference momenta for the b and bbar and put in 3,4
39521C--the results is independent of this choice
39522 CALL HWVEQU(5,PCM(1,1),PCM(1,3))
39523 CALL HWVEQU(5,PCM(1,1),PCM(1,4))
39524C--find the massless vectors for the b and bbar
39525 PDOT(1) = HALF*MQ2(1)/HWULDO(PCM(1,3),PCM(1, 9))
39526 PDOT(2) = HALF*MQ2(2)/HWULDO(PCM(1,4),PCM(1,10))
39527 DO I=1,4
39528 PCM(I,7) = PCM(I,9) -PDOT(1)*PCM(I,3)
39529 PCM(I,8) = PCM(I,10)-PDOT(2)*PCM(I,4)
39530 ENDDO
39531 PCM(5,7) = ZERO
39532 PCM(5,8) = ZERO
39533C--use e+e- code to calculate the spinor products
39534 CALL HWHEW2(8,PCM(1,1),S(1,1,2),S(1,1,1),D)
39535 DO I=1,8
39536 DO J=1,8
39537 S(I,J,2) = -S(I,J,2)
39538 D(I,J) = TWO*D(I,J)
39539 ENDDO
39540 ENDDO
39541 ELSE
39542C--Massless case, use the e+e- code to calculate the spinor products
39543 CALL HWHEW2(6,PCM(1,1),S(1,1,2),S(1,1,1),D)
39544 DO I=1,6
39545 DO J=1,6
39546 D(I,J) = TWO*D(I,J)
39547 F(I,J) = B(I)*B(J)*D(I,J)
39548 S(I,J,2) = -S(I,J,2)
39549 ENDDO
39550 ENDDO
39551 ENDIF
39552C--now call the code to calculate the matrix element*PDF
39553 IF(IPRC.EQ.0) THEN
39554 WRITE(*,1000)
39555 STOP
39556 ELSEIF(IPRC.GT.0.AND.IPRC.LE.16) THEN
39557 CALL HWHDYQ(FSTCLL,ME,IFLOW,IDP,ORD,IQ,MASS)
39558 ELSE
39559 CALL HWWARN('HWHV2J',501)
39560 GOTO 999
39561 ENDIF
39562 AMP = AMP*MJAC*BR*FPI4*HWUAEM(EMSCA**2)**2*HWUALF(1,EMSCA)**2
39563 EVWGT = FLUX*ME*AMP
39564 IF(OPTM) THEN
39565 DO I=1,IMAXCH
39566 IF(CHON(I)) WI(I) = WI(I)*ME**2*AMP**2
39567 ENDDO
39568 ENDIF
39569 ENDIF
39570 RETURN
39571 1000 FORMAT('DRELL-YAN + 2 JETS NOT YET IMPLEMENTED')
39572 999 RETURN
39573 END
39574CDECK ID>, HWHVVJ.
39575*CMZ :- -11/05/01 09.19.45 by Bryan Webber
39576*-- Author : Bryan Webber
39577C-----------------------------------------------------------------------
39578 SUBROUTINE HWHVVJ
39579C-----------------------------------------------------------------------
39580C VV + 1 JET PRODUCTION, WHERE VV=WW,ZZ,WZ FOR IPROC=2850,2860,2870
39581C-----------------------------------------------------------------------
39582 IMPLICIT NONE
39583 PRINT *,' VV + 1 JET CALLED BUT NOT YET IMPLEMENTED'
39584 CALL HWWARN('HWHVVJ',500)
39585 END
39586CDECK ID>, HWHWEX.
39587*CMZ :- -26/04/91 14.55.45 by Federico Carminati
39588*-- Author : Mike Seymour
39589C-----------------------------------------------------------------------
39590 SUBROUTINE HWHWEX
39591C-----------------------------------------------------------------------
39592C TOP QUARK PRODUCTION VIA W EXCHANGE: MEAN EVWGT=TOP PROD C-S IN NB
39593C C-S IS SUM OF:
39594C UbarBbar, DBbar, DbarB, UB, CbarBbar, SBbar, SbarB, AND CB
39595C UNLESS USER SPECIFIES OTHERWISE BY MOD(IPROC,100)=1-8 RESPECTIVELY
39596C---DSDCOS HOLDS THE CROSS-SECTIONS FOR THE PROCESSES LISTED ABOVE
39597C (1-8) ARE WITH B FROM BEAM 1, (9-16) ARE WITH B FROM BEAM 2.
39598C-----------------------------------------------------------------------
c63d70bc 39599 INCLUDE 'herwig65.inc'
65767955 39600 DOUBLE PRECISION HWRGEN,HWRUNI,DSDCOS(16),EMT2,EMT,EMW2,EMW,
39601 & CMFMIN,TAUMIN,TAUMLN,S,T,U,ROOTS,DSMAX
39602 INTEGER HWRINT,IDHWEX(2,16),I
39603 EXTERNAL HWRGEN,HWRUNI,HWRINT
39604 SAVE DSDCOS,DSMAX
39605 EQUIVALENCE (EMW,RMASS(198)),(EMT,RMASS(6))
39606C---IDHWEX HOLDS THE IDs OF THE INCOMING PARTICLES FOR EACH SUB-PROCESS
39607 SAVE IDHWEX
39608 DATA IDHWEX/11,8,11,1,5,7,5,2,11,10,11,3,5,9,5,4,
39609 & 8,11,1,11,7,5,2,5,10,11,3,11,9,5,4,5/
39610 EMT2=EMT**2
39611 EMW2=EMW**2
39612 IF (GENEV) THEN
39613 300 IHPRO=HWRINT(1,16)
39614 IF (HWRGEN(0).GT.DSDCOS(IHPRO)/DSMAX) GOTO 300
39615 DO 10 I=1,2
39616 IDN(I)=IDHWEX(I,IHPRO)
39617 IF (IDN(I).EQ.5 .OR. IDN(I).EQ.11) THEN
39618C---CHANGE B QUARK INTO T QUARK
39619 IDN(I+2)=IDN(I)+1
39620 ELSEIF (HWRGEN(0).GT.SCABI) THEN
39621C---CHANGE QUARKS (1->2,2->1,3->4,4->3,7->8,8->7,...)
39622 IDN(I+2)=4*INT((IDN(I)-1)/2)-IDN(I)+3
39623 ELSE
39624C---CHANGE AND CABIBBO ROTATE QUARKS (1->4,2->3,3->2,4->1,7->10,...)
39625 IDN(I+2)=12*INT((IDN(I)-1)/6)-IDN(I)+5
39626 ENDIF
39627 ICO(I)=I+2
39628 ICO(I+2)=I
39629 10 CONTINUE
39630 IDCMF=15
39631 CALL HWETWO(.TRUE.,.TRUE.)
39632 ELSE
39633 EVWGT=0.
39634 CMFMIN=EMT
39635 TAUMIN=(CMFMIN/PHEP(5,3))**2
39636 TAUMLN=LOG(TAUMIN)
39637 ROOTS=PHEP(5,3)*SQRT(EXP(HWRUNI(0,ZERO,TAUMLN)))
39638 XXMIN=(ROOTS/PHEP(5,3))**2
39639 XLMIN=LOG(XXMIN)
39640 COSTH=HWRUNI(0,-ONE, ONE)
39641 S=ROOTS**2
39642 T=-0.5*S*(1-COSTH)
39643 U=-0.5*S*(1+COSTH)
39644 EMSCA=SQRT(2*S*T*U/(S*S+T*T+U*U))
39645 DSDCOS(1)=GEV2NB*PIFAC*.125*(ALPHEM/SWEIN)**2
39646 & *(S-EMT2)**2 / S / (EMW2 + 0.5*(S-EMT2)*(1-COSTH))**2
39647 DSDCOS(2)=DSDCOS(1) / 4
39648 & * (1 + EMT2/S + 2*COSTH + (1-EMT2/S)*COSTH**2)
39649 DSDCOS(3)=DSDCOS(2)
39650 DSDCOS(4)=DSDCOS(1)
39651C---IF USER SPECIFIED SUB-PROCESS THEN ZERO ALL THE OTHERS
39652 IHPRO=MOD(IPROC,100)
39653 IF (IHPRO.GT.8) THEN
39654 CALL HWWARN('HWHWEX',1)
39655 IHPRO=0
39656 ENDIF
39657 DO 100 I=1,8
39658 IF (I.LE.4) DSDCOS(I+4)=DSDCOS(I)
39659 IF (IHPRO.NE.0 .AND. IHPRO.NE.I) DSDCOS(I)=0
39660 DSDCOS(I+8)=DSDCOS(I)
39661 100 CONTINUE
39662 CALL HWSGEN(.TRUE.)
39663 DSMAX=0
39664 DO 200 I=1,16
39665 DSDCOS(I)=DSDCOS(I)*DISF(IDHWEX(1,I),1)*DISF(IDHWEX(2,I),2)
39666 EVWGT=EVWGT + 2*TAUMLN*XLMIN*DSDCOS(I)
39667 IF (DSDCOS(I).GT.DSMAX) DSMAX=DSDCOS(I)
39668 200 CONTINUE
39669 ENDIF
39670 END
39671CDECK ID>, HWHWPR.
39672*CMZ :- -18/05/99 14.22.13 by Mike Seymour
39673*-- Author : Bryan Webber
39674C-----------------------------------------------------------------------
39675 SUBROUTINE HWHWPR
39676C-----------------------------------------------------------------------
39677C W+/- PRODUCTION AND DECAY VIA DRELL-YAN PROCESS
39678C MEAN EVWGT IS SIG(W+/-)*(BRANCHING FRACTION) IN NB
39679C-----------------------------------------------------------------------
c63d70bc 39680 INCLUDE 'herwig65.inc'
65767955 39681 DOUBLE PRECISION HWRGEN,HWRUNI,HWUPCM,PRAN,PROB,COEF,CSFAC,EMW,
39682 & FTQK,PTOP,ETOP,EBOT,PMAX,FHAD,FTOT,BRAF,FLEP,TMIN,HWUAEM,TMAX
39683 INTEGER HWRINT,ICH,IC,IL,ID,IDEC,JDEC,IWP(2,16)
39684 LOGICAL HWRLOG
39685 EXTERNAL HWRGEN,HWRUNI,HWUPCM,HWRINT,HWRLOG
39686 SAVE CSFAC,IDEC,FLEP,FTQK,ETOP,PTOP,EBOT,PMAX,PROB
39687 SAVE IWP
39688 DATA IWP/2,7,1,8,7,2,8,1,4,9,3,10,9,4,10,3,
39689 & 2,9,3,8,9,2,8,3,4,7,1,10,7,4,10,1/
39690 IF (GENEV) THEN
39691C---GENERATE EVENT (X'S AND STRUCTURE FUNCTIONS ALREADY FOUND)
39692 PRAN=PROB*HWRGEN(0)
39693C---LOOP OVER PARTON FLAVOURS
39694 PROB=0.
39695 COEF=1.-SCABI
39696 DO 10 IC=1,16
39697 IF (IC.EQ.9) COEF=SCABI
39698 PROB=PROB+DISF(IWP(1,IC),1)*DISF(IWP(2,IC),2)*COEF
39699 IF (PROB.GE.PRAN) GOTO 20
39700 10 CONTINUE
39701C---STORE INCOMING PARTONS
39702 20 IDN(1)=IWP(1,IC)
39703 IDN(2)=IWP(2,IC)
39704 ICO(1)=2
39705 ICO(2)=1
39706C---ICH=1/2 FOR W+/-
39707 ICH=2-MOD(IC,2)
39708 IF ((IDEC.GT.49.AND.IDEC.LT.54).OR.
39709 & (IDEC.EQ.99.AND.HWRLOG(FLEP))) THEN
39710C---LEPTONIC DECAY
39711 IL=IDEC-50
39712 IF (IL.EQ.0.OR.IL.GT.3) IL=HWRINT(1,3)
39713 IDN(3)=2*IL+121-ICH
39714 IDN(4)=2*IL+124+ICH
39715C---W DECAY ANGLE (1+COSTH)**2
39716 COSTH=2.*HWRGEN(1)**0.3333-1.
39717 ELSEIF (IDEC.EQ.5.OR.IDEC.EQ.6.OR.
39718 & ((IDEC.EQ.0.OR.IDEC.EQ.99).AND.HWRLOG(FTQK))) THEN
39719C---W -> TOP + BOTTOM DECAY
39720 IDN(3)=7-ICH
39721 IDN(4)=10+ICH
39722 21 COSTH=HWRUNI(1,-ONE, ONE)
39723 IF ((ETOP+(PTOP*COSTH))*(EBOT+(PTOP*COSTH)).LT.
39724 & PMAX*HWRGEN(1)) GOTO 21
39725 ELSE
39726C---OTHER HADRONIC DECAY
39727 25 PROB=0.
39728 PRAN=2.*HWRGEN(2)
39729 COEF=1.-SCABI
39730 DO 30 ID=ICH,16,4
39731 IF (ID.GT.8) COEF=SCABI
39732 PROB=PROB+COEF
39733 IF (PROB.GE.PRAN) THEN
39734 IDN(3)=IWP(1,ID)
39735 IDN(4)=IWP(2,ID)
39736 GOTO 40
39737 ENDIF
39738 30 CONTINUE
39739 40 CONTINUE
39740 IF (IDEC.GT.0.AND.IDEC.LT.5) THEN
39741 JDEC=IDEC+6
39742 IF (IDN(3).NE.IDEC.AND.IDN(4).NE.IDEC
39743 & .AND.IDN(3).NE.JDEC.AND.IDN(4).NE.JDEC) GOTO 25
39744 ENDIF
39745 COSTH=2.*HWRGEN(1)**0.3333-1.
39746 ENDIF
39747 IDCMF=197+ICH
39748 IF (IDN(1).GT.6) COSTH=-COSTH
39749 ICO(3)=4
39750 ICO(4)=3
39751 CALL HWETWO(.TRUE.,.TRUE.)
39752 ELSE
39753 IDEC=MOD(IPROC,100)
39754 IF (IDEC.EQ.5.OR.IDEC.EQ.6) THEN
39755 TMIN=ATAN((RMASS(6)**2-RMASS(199)**2)/(GAMW*RMASS(199)))
39756 ELSE
39757 TMIN=-ATAN(RMASS(199)/GAMW)
39758 ENDIF
39759 EVWGT=0.
39760c---mhs---implement cut on number of widths from nominal mass
39761 TMIN=MAX(TMIN,-ATAN(2*GAMMAX-GAMW*GAMMAX**2/RMASS(199)))
39762 TMAX=ATAN(2*GAMMAX+GAMW*GAMMAX**2/RMASS(199))
39763 EMW=GAMW*TAN(HWRUNI(0,TMIN,TMAX))+RMASS(199)
39764 IF (EMW.LE.ZERO) RETURN
39765 EMW=SQRT(EMW*RMASS(199))
39766 IF (EMW.LE.QSPAC.OR.EMW.GE.PHEP(5,3)) RETURN
39767 EMSCA=EMW
39768 IF (EMLST.NE.EMW) THEN
39769 EMLST=EMW
39770 XXMIN=(EMW/PHEP(5,3))**2
39771 XLMIN=LOG(XXMIN)
39772 CSFAC=-GEV2NB*PIFAC**2*HWUAEM(EMSCA**2)
39773 & /(3.*SWEIN*RMASS(199)**2)*XLMIN
39774C---COMPUTE TOP AND LEPTONIC FRACTIONS
39775 FTQK=0.
39776 IF (NFLAV.GT.5) THEN
39777 PTOP=HWUPCM(EMW,RMASS(5),RMASS(6))
39778 IF (PTOP.GT.ZERO) THEN
39779 ETOP=SQRT(PTOP**2+RMASS(6)**2)
39780 EBOT=EMW-ETOP
39781 FTQK=2.*PTOP*(3.*ETOP*EBOT+PTOP**2)/EMW**3
39782 PMAX=(ETOP+PTOP)*(EBOT+PTOP)
39783 ENDIF
39784 ENDIF
39785 FHAD=FTQK+2.
39786 FTOT=FTQK+3.
39787C---MULTIPLY WEIGHT BY BRANCHING FRACTION
39788 IF (IDEC.EQ.0) THEN
39789 BRAF=FHAD
39790 ELSEIF (IDEC.LT.5.OR.IDEC.EQ.50) THEN
39791 BRAF=1.
39792 ELSEIF (IDEC.LT.7) THEN
39793 BRAF=FTQK
39794 ELSEIF (IDEC.EQ.99) THEN
39795 BRAF=FTOT
39796 ELSE
39797 BRAF=1/THREE
39798 ENDIF
39799c---mhs fix: normalization should be to on-shell total width
39800c (only different if chosen mass is above top threshold)
39801 CSFAC=CSFAC*BRAF/THREE*(TMAX-TMIN)/PIFAC
39802 FTQK=FTQK/FHAD
39803 FLEP=1./FTOT
39804 ENDIF
39805 CALL HWSGEN(.TRUE.)
39806C---LOOP OVER PARTON FLAVOURS
39807 PROB=0.
39808 COEF=1.-SCABI
39809 DO 100 IC=1,16
39810 IF (IC.EQ.9) COEF=SCABI
39811 PROB=PROB+DISF(IWP(1,IC),1)*DISF(IWP(2,IC),2)*COEF
39812 100 CONTINUE
39813 EVWGT=PROB*CSFAC
39814 ENDIF
39815 END
39816CDECK ID>, HWICHK.
39817*-- Author : M. Kirsanov
39818C-----------------------------------------------------------------------
39819 SUBROUTINE HWICHK
39820C-----------------------------------------------------------------------
c63d70bc 39821 INCLUDE 'herwig65.inc'
65767955 39822 IF(RMASS(1).LT.0.1.OR.RMASS(1).GT.1.0.OR.
39823 & FMRS(1,1,20,1).LT.0.1.OR.FMRS(1,1,20,1).GT.1.0) THEN
39824 STOP 'Block data hwudat not loaded, stop execution'
39825 ENDIF
39826 END
39827CDECK ID>, HWIODK.
39828*CMZ :- -27/07/99 13.33.03 by Mike Seymour
39829*-- Author : Ian Knowles
39830C-----------------------------------------------------------------------
39831 SUBROUTINE HWIODK(IUNIT,IOPT,IME)
39832C-----------------------------------------------------------------------
39833C If IUNIT > 0 writes out present HERWIG decay tables to unit IUNIT
39834C < 0 reads in decay tables from unit IUNIT
39835C The format used during the read/write is specified by IOPT
39836C =1 PDG; =2 HERWIG numeric; =3 HERWIG character name.
39837C When reading in if IME =1 matrix element codes >= 100 are accepted
39838C 0 are set zero.
39839C-----------------------------------------------------------------------
c63d70bc 39840 INCLUDE 'herwig65.inc'
65767955 39841 INTEGER IUNIT,IOPT,IME,JUNIT,I,J,K,L,IDKY,ITMP(5),IDUM
39842 CHARACTER*8 CDK(NMXDKS),CDKPRD(5,NMXDKS),CDUM
39843 JUNIT=ABS(IUNIT)
39844 OPEN(UNIT=JUNIT,FORM='FORMATTED',STATUS='UNKNOWN')
39845 IF (IUNIT.GT.0) THEN
39846C Write out the decay table
39847 WRITE(JUNIT,100) NDKYS
39848 IF (IOPT.EQ.1) THEN
39849 DO 20 I=1,NRES
39850 IF (NMODES(I).EQ.0) GOTO 20
39851 K=LSTRT(I)
39852 DO 10 J=1,NMODES(I)
39853 WRITE(JUNIT,110) IDPDG(I),BRFRAC(K),NME(K),
39854 & (IDPDG(IDKPRD(L,K)),L=1,5)
39855 10 K=LNEXT(K)
39856 20 CONTINUE
39857 ELSEIF (IOPT.EQ.2) THEN
39858 DO 40 I=1,NRES
39859 IF (NMODES(I).EQ.0) GOTO 40
39860 K=LSTRT(I)
39861 DO 30 J=1,NMODES(I)
39862 WRITE(JUNIT,120) I,BRFRAC(K),NME(K),(IDKPRD(L,K),L=1,5)
39863 30 K=LNEXT(K)
39864 40 CONTINUE
39865 ELSEIF (IOPT.EQ.3) THEN
39866 DO 60 I=1,NRES
39867 IF (NMODES(I).EQ.0) GOTO 60
39868 K=LSTRT(I)
39869 DO 50 J=1,NMODES(I)
39870 WRITE(JUNIT,130) RNAME(I),BRFRAC(K),NME(K),
39871 & (RNAME(IDKPRD(L,K)),L=1,5)
39872 50 K=LNEXT(K)
39873 60 CONTINUE
39874 ENDIF
39875 ELSEIF (IUNIT.LT.0) THEN
39876C Read in the decay table and convert to HERWIG numeric format
39877 READ(JUNIT,100) NDKYS
39878 IF (NDKYS.GT.NMXDKS) THEN
39879 CALL HWWARN('HWIODK',100)
39880 GOTO 999
39881 ENDIF
39882 IF (IOPT.EQ.1) THEN
39883 DO 70 I=1,NDKYS
39884 READ(JUNIT,110) IDKY,BRFRAC(I),NME(I),ITMP
39885 IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
39886 CALL HWUIDT(1,IDKY,IDK(I),CDUM)
39887 DO 70 J=1,5
39888 70 CALL HWUIDT(1,ITMP(J),IDKPRD(J,I),CDUM)
39889 ELSEIF (IOPT.EQ.2) THEN
39890 DO 80 I=1,NDKYS
39891 READ(JUNIT,120) IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5)
39892 IF (IDK(I).LT.0.OR.IDK(I).GT.NRES) IDK(I)=20
39893 80 IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
39894 ELSEIF (IOPT.EQ.3) THEN
39895 DO 90 I=1,NDKYS
39896 READ(JUNIT,130) CDK(I),BRFRAC(I),NME(I),(CDKPRD(J,I),J=1,5)
39897 IF (IME.EQ.0.AND.NME(I).GE.100) NME(I)=0
39898 CALL HWUIDT(3,IDUM,IDK(I),CDK(I))
39899 DO 90 J=1,5
39900 90 CALL HWUIDT(3,IDUM,IDKPRD(J,I),CDKPRD(J,I))
39901 ELSE
39902 CALL HWWARN('HWIODK',101)
39903 GOTO 999
39904 ENDIF
39905 ENDIF
39906 CLOSE(UNIT=JUNIT)
39907 100 FORMAT(1X,I4)
39908 110 FORMAT(1X,I7,1X,F7.5,1X,I3,5(1X,I7))
39909 120 FORMAT(1X,I3,1X,F7.5,6(1X,I3))
39910 130 FORMAT(1X,A8,1X,F7.5,1X,I3,5(1X,A8))
39911 999 RETURN
39912 END
39913CDECK ID>, HWIGIN.
39914*CMZ :- -12/10/01 09.50.50 by Peter Richardson
39915*-- Author : Bryan Webber
39916C----------------------------------------------------------------------
39917 SUBROUTINE HWIGIN
39918C-----------------------------------------------------------------------
39919C SETS INPUT PARAMETERS
39920C----------------------------------------------------------------------
c63d70bc 39921 INCLUDE 'herwig65.inc'
65767955 39922 DOUBLE PRECISION FAC,ANGLE
39923 INTEGER I,J,N,L
39924 CHARACTER*28 TITLE
39925 SAVE TITLE
39926 DATA TITLE/'HERWIG 6.510 31st Oct. 2005'/
39927 WRITE (6,10) TITLE
39928 10 FORMAT(//10X,A28//,
39929 & 10X,'Please reference: G. Marchesini, B.R. Webber,',/,
39930 & 10X,'G.Abbiendi, I.G.Knowles, M.H.Seymour & L.Stanco',/,
39931 & 10X,'Computer Physics Communications 67 (1992) 465',/,
39932 & 10X,' and',/,
39933 & 10X,'G.Corcella, I.G.Knowles, G.Marchesini, S.Moretti,'
39934 & ,/, 10X,'K.Odagiri, P.Richardson, M.H.Seymour & B.R.Webber,'
39935 & ,/, 10X,'JHEP 0101 (2001) 010')
39936 CALL HWICHK
39937C---PRINT OPTIONS:
39938C IPRINT=0 NO PRINTOUT
39939C 1 PRINT SELECTED INPUT PARAMETERS
39940C 2 1 + TABLE OF PARTICLE CODES AND PROPERTIES
39941C 3 2 + TABLES OF SUDAKOV FORM FACTORS
39942 IPRINT=1
39943C Format for track numbers in event listing
39944C PRNDEC=.TRUE. use decimal
39945C .FALSE. use hexadecimal
39946 PRNDEC=(NMXHEP.LE.9999)
39947C Number of significant figures to print out in event listing
39948C NPRFMT (< 2) compact 80 character stout and A4-long tex output,
39949C (= 2) 2 decimal places in stout, (> 2) - 5 decimal places in stout
39950 NPRFMT=1
39951C Print out vertex information
39952 PRVTX=.TRUE.
39953C Print out particle properties/event record to stout, tex or web
39954 PRNDEF=.TRUE.
39955 PRNTEX=.FALSE.
39956 PRNWEB=.FALSE.
39957C---MAX NO OF EVENTS TO PRINT
39958 MAXPR=1
39959C---UNIT FOR READING SUDAKOV FORM FACTORS (IF ZERO THEN COMPUTE THEM)
39960 LRSUD=0
39961C---UNIT FOR WRITING SUDAKOV FORM FACTORS (IF ZERO THEN NOT WRITTEN)
39962 LWSUD=77
39963C---UNIT FOR WRITING EVENT DATA IN HWANAL (IF ZERO THEN NOT WRITTEN)
39964 LWEVT=0
39965C---SEEDS FOR RANDOM NUMBER GENERATOR (CALLED HWRGEN)
39966 NRN(1)= 17673
39967 NRN(2)= 63565
39968C---ALLOW NEGATIVE WEIGHTS?
39969 NEGWTS=.FALSE.
39970C---AZIMUTHAL CORRELATIONS?
39971C THESE INCLUDE SOFT GLUON (INSIDE CONE)
39972 AZSOFT=.TRUE.
39973C AND NEAREST-NEIGHBOUR SPIN CORRELATIONS
39974 AZSPIN=.TRUE.
39975C---MATRIX-ELEMENT MATCHING FOR E+E-, DIS, DRELL-YAN AND TOP DECAY
39976C---HARD EMISSION
39977 HARDME=.TRUE.
39978C---SOFT EMISSION
39979 SOFTME=.TRUE.
39980C---GLUON ENERGY CUT FOR TOP DECAY CASE
39981 GCUTME=2
39982C Electromagnetic fine structure constant: Thomson limit
39983 ALPHEM=.0072993
39984C---QCD LAMBDA: CORRESPONDS TO 5-FLAVOUR LAMBDA-MS-BAR AT LARGE X ONLY
39985 QCDLAM=0.18
39986C---NUMBER OF COLOURS
39987 NCOLO=3
39988C---NUMBER OF FLAVOURS
39989 NFLAV=6
39990C---QUARK, GLUON AND PHOTON VIRTUAL MASS CUTOFFS IN
39991C PARTON SHOWER (ADDED TO MASSES GIVEN BELOW)
39992 VQCUT=0.48
39993 VGCUT=0.10
39994 VPCUT=0.40
39995 ALPFAC=1
39996C---D,U,S,C,B,T QUARK AND GLUON MASSES (IN THAT ORDER)
39997 RMASS(1)=0.32
39998 RMASS(2)=0.32
39999 RMASS(3)=0.5
40000 RMASS(4)=1.55
40001 RMASS(5)=4.95
40002 RMASS(6)=174.3
40003 RMASS(13)=0.75
40004C---W+/- AND Z0 MASSES
40005 RMASS(198)=80.42
40006 RMASS(199)=80.42
40007 RMASS(200)=91.188
40008C---HIGGS BOSON MASS
40009 RMASS(201)=115.
40010C---WIDTHS OF W, Z, HIGGS
40011 GAMW=2.12
40012 GAMZ=2.495
40013C SM Higgs width is actually recomputed by HWDHIG
40014C but this value corresponds to RMASS(201)=115.
40015 GAMH=0.0037
40016C Include additional neutral, massive vector boson (Z')
40017 ZPRIME=.FALSE.
40018C Z' mass and width
40019 RMASS(202)=500.
40020 GAMZP=5.
40021C Graviton properties
40022C Graviton mass and width (default mass 1 TeV and calculated width)
40023 EMGRV = 1000.0D0
40024 GAMGRV = ZERO
40025C Graviton coupling (this has dimensions of mass)
40026 GRVLAM = 10000.0D0
40027C Lepton (EPOLN) and anti-lepton (PPOLN) beam polarisations used in:
40028C e+e- --> ffbar/qqbar g; and l/lbar N DIS.
40029C Cpts. 1,2 Transverse polarisation; cpt. 3 longitudinal polarisation.
40030C Note require POLN(1)**2+POLN(2)**2+POLN(3)**2 < 1.
40031 DO 20 I=1,3
40032 EPOLN(I)=0.
40033 20 PPOLN(I)=0.
40034C-----------------------------------------------------------------------
40035C Specify couplings of weak vector bosons to fermions:
40036C
40037C electric current: QFCH(I)*e*G_mu (electric charge, e>0)
40038C weak neutral current: [VFCH(I,J).1+AFCH(I,J).G_5]*e*G_mu
40039C weak charged current: SQRT(VCKM(K,L)/2.)*g*(1+G_5)*G_mu
40040C
40041C I= 1- 6: d,u,s,c,b,t (quarks)
40042C =11-16: e,nu_e,mu,nu_mu,tau,nu_tau (leptons) (`I=IDHW-110')
40043C J=1 for minimal SM:
40044C =2 for Z' couplings (ZPRIME=.TRUE.)
40045C K=1,2,3 for u,c,t; L=1,2,3 for d,s,b
40046C-----------------------------------------------------------------------
40047C Minimal standard model neutral vector boson couplings
40048C VFCH(I,1)=(T3/2-Q*S^2_W)/(C_W*S_W); AFCH(I,1)=T3/(2*C_W*S_W)
40049C sin**2 Weinberg angle (PDG '94)
40050 SWEIN=.2319
40051 FAC=1./SQRT(SWEIN*(1.-SWEIN))
40052 DO 30 I=1,3
40053C Down-type quarks
40054 J=2*I-1
40055 QFCH(J)=-1./3.
40056 VFCH(J,1)=(-0.25+SWEIN/3.)*FAC
40057 AFCH(J,1)= -0.25*FAC
40058C Up-type quarks
40059 J=2*I
40060 QFCH(J)=+2./3.
40061 VFCH(J,1)=(+0.25-2.*SWEIN/3.)*FAC
40062 AFCH(J,1)= +0.25*FAC
40063C Charged leptons
40064 J=2*I+9
40065 QFCH(J)=-1.
40066 VFCH(J,1)=(-0.25+SWEIN)*FAC
40067 AFCH(J,1)= -0.25*FAC
40068C Neutrinos
40069 J=2*I+10
40070 QFCH(J)=0.
40071 VFCH(J,1)=+0.25*FAC
40072 AFCH(J,1)=+0.25*FAC
40073 30 CONTINUE
40074C Additional Z' couplings (To be set by the user)
40075 IF (.NOT.ZPRIME) THEN
40076 DO 40 I=1,6
40077 AFCH(I,2)=0.
40078 AFCH(10+I,2)=0.
40079 VFCH(I,2)=0.
40080 VFCH(10+I,2)=0.
40081 40 CONTINUE
40082 ENDIF
40083C--calculate left and right couplings of bosons for axial and vector ones
40084 DO 45 J=1,16
40085 IF(J.LE.6.OR.J.GE.11) THEN
40086 LFCH(J)=VFCH(J,1)+AFCH(J,1)
40087 RFCH(J)=VFCH(J,1)-AFCH(J,1)
40088 ENDIF
40089 45 CONTINUE
40090C Cabibbo-Kobayashi-Maskawa matrix elements squared (PDG '92):
40091C sin**2 of Cabibbo angle
40092 SCABI=.0488
40093C u ---> d,s,b
40094 VCKM(1,1)=1.-SCABI
40095 VCKM(1,2)=SCABI
40096 VCKM(1,3)=0.0
40097C c ---> d,s,b
40098 VCKM(2,1)=SCABI
40099 VCKM(2,2)=1.-SCABI-.002
40100 VCKM(2,3)=0.002
40101C t ---> d,b,s
40102 VCKM(3,1)=0.0
40103 VCKM(3,2)=0.002
40104 VCKM(3,3)=0.998
40105C---GAUGE BOSON DECAYS
40106 DO 50 I=1,12
40107 BRHIG(I)=1.D0/12
40108 ENHANC(I)=1.D0
40109 50 CONTINUE
40110 DO 55 I=1,MODMAX
40111 MODBOS(I)=0
40112 55 CONTINUE
40113C
40114C THE iTH GAUGE BOSON DECAY PER EVENT IS CONTROLLED BY MODBOS AS FOLLOWS
40115C MODBOS(i) W DECAY Z DECAY
40116C 0 all all
40117C 1 qqbar qqbar
40118C 2 enu e+e-
40119C 3 munu mu+mu-
40120C 4 taunu tau+tau-
40121C 5 enu & munu ee & mumu
40122C 6 all nunu
40123C 7 all bbbar
40124C >7 all all
40125C BOSON PAIRS (eg FROM HIGGS DECAY)ARE CHOSEN FROM MODBOS(i),MODBOS(i+1)
40126C
40127C---CONTROL OF LARGE EMH BEHAVIOUR (SEE HWHIGM FOR DETAILS)
40128 IOPHIG=3
40129 GAMMAX=10.
40130C Specify approximation used in HWHIGA
40131 IAPHIG=1
40132C---MASSES OF HYPOTHETICAL NEW QUARKS GO
40133C INTO 209-214 (ANTIQUARKS IN 215-220)
40134C ID = 209,210 ARE B',T' WITH DECAYS T'->B'->C
40135C 211,212 ARE B',T' WITH DECAYS T'->B'->T
40136C 215-218 ARE THEIR ANTIQUARKS
40137 RMASS(209)=200.
40138 RMASS(215)=200.
40139C---MAXIMUM CLUSTER MASS PARAMETERS
40140C N.B. LIMIT FOR Q1-Q2BAR CLUSTER MASS
40141C IS (CLMAX**CLPOW + (QM1+QM2)**CLPOW)**(1/CLPOW)
40142 CLMAX=3.35
40143 CLPOW=2.0
40144C For PSPLT(I), CLDIR(I) & CLSMR(I): I=1 light u,d,s,c cluster
40145C =2 heavy b cluster
40146C---MASS SPECTRUM OF PRODUCTS IN CLUSTER
40147C SPLITTING ABOVE CLMAX - FLAT IN M**PSPLT(*)
40148 PSPLT(1)=1.0
40149 PSPLT(2)=PSPLT(1)
40150C---KINEMATIC TREATMENT OF CLUSTER DECAY
40151C 0=ISOTROPIC, 1=REMEMBER DIRECTION OF PERTURBATIVELY PRODUCED QUARKS
40152 CLDIR(1)=1
40153 CLDIR(2)=CLDIR(1)
40154C IF CLDIR(*)=1, DO GAUSSIAN SMEARING OF DIRECTION:
40155C ACTUALLY EXPONENTIAL IN 1-COS(THETA) WITH MEAN CLSMR(*)
40156 CLSMR(1)=0.0
40157 CLSMR(2)=CLSMR(1)
40158C---OPTION FOR TREATMENT OF REMNANT CLUSTERS:
40159C 0=BOTH CHILDREN ARE SOFT, (EQUIVALENT TO PREVIOUS VERSIONS)
40160C 1=REMNANT CHILD IS SOFT, BUT PERTURBATIVE CHILD IS NORMAL
40161 IOPREM=1
40162C---TREATMENT OF LOWER LIMIT FOR SPACELIKE EVOLUTION
40163C 0=EVOLUTION STOPS AT QSPAC, BUT STRUCT FUNS CAN GET CALLED AT
40164C SMALLER SCALES IN FORCED EMISSION (EQUIVALENT TO V5.7 AND EARLIER)
40165C 1=EVOLUTION STOPS AT QSPAC, STRUCTURE FUNCTIONS FREEZE AT QSPAC
40166C 2=EVOLUTION CONTINUES TO INFRARED CUT, BUT S.F.S FREEZE AT QSPAC
40167 ISPAC=0
40168C---LOWER LIMIT FOR SPACELIKE EVOLUTION
40169 QSPAC=2.5
40170C---SWITCH OFF SPACE-LIKE SHOWERS
40171 NOSPAC=.FALSE.
40172C---INTRINSIC PT OF SPACELIKE PARTONS (RMS)
40173 PTRMS=0.0
40174C---MASS PARAMETER IN REMNANT FRAGMENTATION
40175 BTCLM=1.0
40176C---PARAMETERS CONTROLLING VERY SMALL-X BEHAVIOUR OF PDFS
40177 PDFX0=0
40178 PDFPOW=0
40179C---STRUCTURE FUNCTION SET:
40180C SET MODPDF(I)=MODE AND AUTPDF='AUTHOR GROUP' TO USE CERN LIBRARY
40181C PDFLIB PACKAGE FOR STRUCTURE FUNCTIONS IN BEAM I
40182 MODPDF(1)=34
40183 MODPDF(2)=34
40184 AUTPDF(1)='CTEQ'
40185 AUTPDF(2)='CTEQ'
40186C OR SET MODPDF(I)=-1 TO USE BUILT-IN STRUCTURE FUNCTION SET:
40187C 1,2 FOR DUKE+OWENS SETS 1,2 (SOFT/HARD GLUE)
40188C 3,4 FOR EICHTEN+AL SETS 1,2 (NUCLEONS ONLY)
40189C 5 FOR OWENS SET 1.1 (SOFT GLUE ONLY)
40190C 6 FOR MRST98LO central alpha_s/gluon
40191C 7 FOR MRST98LO higher gluon
40192C 8 FOR MRST98LO average of central and higher gluon (default)
40193 NSTRU=8
40194C PARAMETER FOR B CLUSTER DECAY TO 1 HADRON. IF MCL IS CLUSTER MASS
40195C AND MTH IS THRESHOLD FOR 2-HADRON DECAY, THEN PROBABILITY IS
40196C 1 IF MCL<MTH, 0 IF MCL>(1+B1LIM)*MTH, WITH LINEAR INTERPOLATION,
40197 B1LIM=0.0
40198C---B DECAY PACKAGE ('HERW'=>HERWIG, 'EURO'=>EURODEC, 'CLEO'=>CLEO)
40199 BDECAY='HERW'
40200C---TAU DECAY PACKAGE ('HERWIG'=>HERWIG, 'TAUOLA'=> TAUOLA)
40201 TAUDEC='HERWIG'
40202C--default options for TAUOLA (if used)
40203C JAK=0 ALL MODES
40204C JAK=1 ELECTRON MODE
40205C JAK=2 MUON MODE
40206C JAK=3 PION MODE
40207C JAK=4 RHO MODE
40208C JAK=5 A1 MODE
40209C JAK=6 K MODE
40210C JAK=7 K* MODE
40211C JAK=8 nPI MODE
40212C--tau decay modes (1 is tau+ and 2 is tau-)
40213 JAK1 = 0
40214 JAK2 = 0
40215C--radiative corrections in tau decay (1 on/ 0 off)
40216 ITDKRC=1
40217C--use PHOTOS in tau decays (1 PHOTOS/ 0 no PHOTOS)
40218 IFPHOT=1
40219C--use PHOTOS in ttbar production and decay
40220 ITOPRD=0
40221C---HARD SUBPROCESS SCALE TO BE USED IN 4-JET MATRIX ELEMENT OPTION
40222C IF (FIX4JT) THEN SCALE=C.M. ENERGY
40223C ELSE SCALE=2.*MIN(PI.PJ)
40224 FIX4JT=.FALSE.
40225C---HARD SUBPROCESS SCALE TO BE USED IN BOSON-GLUON FUSION
40226C IF (BGSHAT) THEN SCALE=SHAT
40227C ELSE SCALE=2.*SHAT*THAT*UHAT/(SHAT**2+THAT**2+UHAT**2)
40228 BGSHAT=.FALSE.
40229C---RECONSTRUCT DIS EVENTS IN BREIT FRAME
40230 BREIT=.TRUE.
40231C---TREAT ALL EVENTS IN THEIR CMF (ELSE USE LAB FRAME)
40232 USECMF=.TRUE.
40233C---TREAT W/Z DECAY IN ITS REST FRAME
40234 WZRFR=.TRUE.
40235C---PROBABILITY OF UNDERLYING SOFT EVENT:
40236 PRSOF=ONE
40237C---SOFT UNDERLYING OR MIN BIAS EVENT PARAMETERS
40238C DEFAULT VALUES ARE FROM UA5 COLLAB, NPB291(1987)445
40239C NCH_PPBAR(SQRT(S)) = PMBN1*S**PMBN2+PMBN3
40240 PMBN1= 9.11
40241 PMBN2= 0.115
40242 PMBN3=-9.50
40243C 1/K (IN NEG BINOMIAL) = PMBK1*LN(S)+PMBK2
40244 PMBK1= 0.029
40245 PMBK2=-0.104
40246C SOFT CLUSTER MASS SPECTRUM (M-M1-M2-PMBM1)*EXP(-PMBM2*M)
40247 PMBM1= 0.4
40248 PMBM2= 2.0
40249C SOFT CLUSTER PT SPECTRUM PT*EXP(-B*SQRT(PT**2+M**2))
40250C B=PMBP1 FOR D,U, PMBP2 FOR S,C, PMBP3 FOR DIQUARKS
40251 PMBP1= 5.2
40252 PMBP2= 3.0
40253 PMBP3= 5.2
40254C---MULTIPLICITY ENHANCEMENT FOR UNDERLYING SOFT EVENT:
40255C NCH = NCH_PPBAR(ENSOF*SQRT(S))
40256 ENSOF=1.
40257C PARAMETERS FOR MUELLER TANG FORMULA: IPROC=2400
40258C---THE VALUE TO USE FOR FIXED ALPHA_S IN DENOMINATOR
40259 ASFIXD=0.25
40260C---OMEGA0=12*LOG(2)*ALPHA_S/PI, BUT NOT NECESSARILY THE SAME ALPHA_S
40261 OMEGA0=0.3
40262C---MIN AND MAX JET RAPIDITIES IN QCD 2->2,
40263C HEAVY FLAVOUR, SUSY AND DIRECT PHOTON PROCESSES
40264 YJMAX=8.
40265 YJMIN=-YJMAX
40266C---MIN AND MAX PARTON TRANSVERSE MOMENTUM
40267C IN ELEMENTARY 2 -> 2 SUBPROCESSES
40268 PTMIN=1D1
40269 PTMAX=1D8
40270C---UPPER LIMIT ON HARD PROCESS SCALE
40271 QLIM=1D8
40272C---MAX PARTON THRUST IN 2->3 HARD PROCESSES
40273 THMAX=0.9
40274C Set parameters for 2->4 hard process
40275C Choose inter-jet metric (else JADE) and minimum y-cut
40276 DURHAM=.TRUE.
40277 Y4JT=0.01
40278C---TREATMENT OF COLOUR INTERFERENCE IN E+E- -> 4 JETS:
40279C qqbar-gg case:
40280C IOP4JT(1)=0 neglect, =1 extreme 2341; =2 extreme 3421
40281C qqbar-qqbar (identical quark flavour) case:
40282C IOP4JT(2)=0 neglect, =1 extreme 4123; =2 extreme 2143
40283 IOP4JT(1)=0
40284 IOP4JT(2)=0
40285C---MIN AND MAX DILEPTON INVARIANT MASS IN DRELL-YAN PROCESS
40286 EMMIN=0D0
40287 EMMAX=1D8
40288C---MIN AND MAX ABS(Q**2) IN DEEP INELASTIC LEPTON SCATTERING
40289 Q2MIN=0D0
40290 Q2MAX=1D10
40291C---MIN AND MAX ABS(Q**2) IN WEISZACKER-WILLIAMS APPROXIMATION
40292 Q2WWMN=0.
40293 Q2WWMX=4.
40294C---MIN AND MAX ENERGY FRACTION IN WEISZACKER-WILLIAMS APPROXIMATION
40295 YWWMIN=0.
40296 YWWMAX=1.
40297C---MINIMUM HADRONIC MASS FOR PHOTON-INDUCED PROCESSES (INCLUDING DIS)
40298 WHMIN=0.
40299C---IF PHOMAS IS NON-ZERO, PARTON DISTRIBUTION FUNCTIONS FOR OFF-SHELL
40300C PHOTONS IS DAMPED, WITH MASS PARAMETER = PHOMAS
40301 PHOMAS=0.
40302C---MIN AND MAX FLAVOURS GENERATED BY IPROC=9100,9110,9130
40303 IFLMIN=1
40304 IFLMAX=5
40305C---MAX Z IN J/PSI PHOTO- AND ELECTRO- PRODUCTION
40306 ZJMAX=0.9
40307C---MIN AND MAX BJORKEN-Y
40308 YBMIN=0.
40309 YBMAX=1.
40310C---MIN jet-jet mass in Drell-Yan+2 jets
40311 MJJMIN = 10.0D0
40312C---MAX COS(THETA) FOR W'S IN E+E- -> W+W-
40313 CTMAX=0.9999
40314C Minimum virtuality^2 of partons to use in calculating distances
40315 VMIN2=0.1
40316C Exageration factor for lifetimes of weakly decaying heavy particles
40317 EXAG=1.
40318C Include colour rearrangement in cluster formation
40319 CLRECO=.FALSE.
40320C Probability for colour rearrangement to occur
40321 PRECO=1./9.
40322C Minimum lifetime for particle to be considered stable
40323 PLTCUT=1.D-8
40324C Incude neutral B-meson mixing
40325 MIXING=.TRUE.
40326C Set B_s and B_d mixing parameters: X=Delta m/Gamma
40327 XMIX(1)=10.0
40328 XMIX(2)=0.70
40329C Y=Delta Gamma/2*Gamma
40330 YMIX(1)=0.2
40331 YMIX(2)=0.0
40332C Include a cut on particle decay lengths
40333 MAXDKL=.FALSE.
40334C Set option for decay length cut (see HWDXLM)
40335 IOPDKL=1
40336C Radius for cylindrical option (mm) (IOPDKL=1)
40337 DXRCYL=20.0D0
40338C Length for cylindrical option(IOPDKL=1)
40339 DXZMAX=500.0D0
40340C Radius for spherical option(IOPDKL=2)
40341 DXRSPH=100.0D0
40342C Smear the primary interaction vertex: see HWRPIP for details
40343 PIPSMR=.FALSE.
40344C Widths of Gaussian smearing in x,y,z (mm)
40345 VIPWID(1)=0.25D0
40346 VIPWID(2)=0.015D0
40347 VIPWID(3)=1.8D0
40348 DO 60 I=0,NMXRES
40349C Veto cluster decays into particle type I
40350 VTOCDK(I)=.FALSE.
40351C Veto unstable particle decays into modes involving particle type I
40352 60 VTORDK(I)=.FALSE.
40353C Veto f_0(980) and a_0(980) production in cluster decays
40354 VTOCDK(290)=.TRUE.
40355 VTOCDK(291)=.TRUE.
40356 VTOCDK(292)=.TRUE.
40357 VTOCDK(293)=.TRUE.
40358C---MINIMUM AND MAXIMUM S-HAT/S RANGE FOR PHOTON ISR
40359 TMNISR=1D-4
40360 ZMXISR=1-1D-6
40361C---COLISR IS .TRUE. TO MAKE ISR PHOTONS COLLINEAR WITH BEAMS
40362 COLISR=.FALSE.
40363C A Priori weights for mesons w.r.t. pionic n=1, 0-(+) states:
40364C old VECWT=REPWT(0,1,0) & TENWT=REPWT(0,2,0)
40365 DO 70 N=0,4
40366 DO 70 J=0,4
40367 DO 70 L=0,3
40368 70 REPWT(L,J,N)=1.
40369C and singlet (Lambda-like) and decuplet barons
40370 SNGWT=1.
40371 DECWT=1.
40372C---A PRIORI WEIGHTS FOR D,U,S,C,B,T QUARKS AND DIQUARKS (IN THAT ORDER)
40373 PWT(1)=1.
40374 PWT(2)=1.
40375 PWT(3)=1.
40376 PWT(4)=1.
40377 PWT(5)=1.
40378 PWT(6)=1.
40379 PWT(7)=1.
40380C Octet-Singlet isoscalar mixing angles in degrees
40381C (use ANGLE for ideal mixing, recommended for F0MIX & OMHMIX)
40382 ANGLE=ATAN(ONE/SQRT(TWO))*180./ACOS(-ONE)
40383C eta - eta'
40384 ETAMIX=-23.
40385C phi - omega
40386 PHIMIX=+36.
40387C h_1(1380) - h_1(1170)
40388 H1MIX=ANGLE
40389C MISSING - f_0(1370)
40390 F0MIX=ANGLE
40391C f_1(1420) - f_1(1285)
40392 F1MIX=ANGLE
40393C f'_2 - f_2
40394 F2MIX=+26.
40395C MISSING - omega(1600)
40396 OMHMIX=ANGLE
40397C eta_2(1645) - eta_2(1870)
40398 ET2MIX=ANGLE
40399C phi_3 - omega_3
40400 PH3MIX=+28.
40401C---PARAMETERS FOR NON-PERTURBATIVE SPLITTING OF GLUONS INTO
40402C DIQUARK-ANTIDIQUARK PAIRS:
40403C SCALE AT WHICH GLUONS CAN BE SPLIT INTO DIQUARKS
40404C (0.0 FOR NO SPLITTING)
40405 QDIQK=0.0
40406C PROBABILITY (PER UNIT LOG SCALE) OF DIQUARK SPLITTING
40407 PDIQK=5.0
40408C---PARAMETERS FOR IMPORTANCE SAMPLING
40409C ASSUME QCD 2->2 DSIG/DET FALLS LIKE ET**(-PTPOW)
40410C WHERE ET=SQRT(MQ**2+PT**2) FOR HEAVY FLAVOURS
40411 PTPOW=4.
40412C DEFAULT PTPOW=2 FOR SUSY PROCESSES
40413 IF (MOD(IPROC/100,100).EQ.30) PTPOW=2.
40414C ASSUME DRELL-YAN DSIG/DEM FALLS LIKE EM**(-EMPOW)
40415 EMPOW=4.
40416C ASSUME DEEP INELASTIC DSIG/DQ**2 FALLS LIKE (Q**2)**(-Q2POW)
40417 Q2POW=2.5
40418C---GENERATE UNWEIGHTED EVENTS (EVWGT=AVWGT)?
40419 NOWGT=.TRUE.
40420C---DEFAULT MEAN EVENT WEIGHT
40421 AVWGT=1.
40422C---ASSUMED MAXIMUM WEIGHT (ZERO TO RECOMPUTE)
40423 WGTMAX=0.
40424C---MINIMUM ACCEPTABLE EVENT GENERATION EFFICIENCY
40425 EFFMIN=1D-3
40426C---MAX NO OF (CODE.GE.100) ERRORS
40427 MAXER=MAX(10,MAXEV/100)
40428C---TIME (SEC) NEEDED TO TERMINATE GRACEFULLY
40429 TLOUT=5.
40430C---CURRENT NO OF EVENTS
40431 NEVHEP=0
40432C---CURRENT NO OF ENTRIES IN /HEPEVT/
40433 NHEP=0
40434C---ISTAT IS STATUS OF EVENT (I.E. STAGE IN PROCESSING)
40435 ISTAT=0
40436C---IERROR IS ERROR CODE
40437 IERROR=0
40438C---MORE TECHNICAL PARAMETERS - SHOULDN'T NEED ADJUSTMENT
40439C---PI
40440 PIFAC=ACOS(-1.D0)
40441C Speed of light (mm/s)
40442 CSPEED=2.99792D11
40443C Cross-section conversion factor (hbar.c/e)**2
40444 GEV2NB=389379.D0
40445C---NUMBER OF SHOTS FOR INITIAL MAX WEIGHT SEARCH
40446 IBSH=10000
40447C---RANDOM NO. SEEDS FOR INITIAL MAX WEIGHT SEARCH
40448 IBRN(1)=1246579
40449 IBRN(2)=8447766
40450C--Number of shots and steps for the optimisation procedure
40451 IOPSH = 1000
40452 IOPSTP = 10
40453C---NUMBER OF ENTRIES IN LOOKUP TABLES OF SUDAKOV FORM FACTORS
40454 NQEV=1024
40455C---MAXIMUM BIN SIZE IN Z FOR SPACELIKE BRANCHING
40456 ZBINM=0.05
40457C---MAXIMUM NUMBER OF Z BINS FOR SPACELIKE BRANCHING
40458 NZBIN=100
40459C---MAXIMUM NUMBER OF BRANCH REJECTIONS (TO AVOID INFINITE LOOPS)
40460 NBTRY=200
40461C---MAXIMUM NUMBER OF TRIES TO GENERATE CLUSTER DECAY
40462 NCTRY=200
40463C---MAXIMUM NUMBER OF TRIES TO GENERATE MASS REQUESTED
40464 NETRY=200
40465C---MAXIMUM NUMBER OF TRIES TO GENERATE SOFT SUBPROCESS
40466 NSTRY=200
40467C---MAXIMUM NUMBER OF TRIES TO GENERATE SPIN DECAYS
40468 NSNTRY=500
40469C---MAXIMUM NUMBER OF TRIES TO GENERATE FOUR/FIVE BODY DECAYS
40470 NDETRY=20000
40471C---PRECISION FOR GAUSSIAN INTEGRATION
40472 ACCUR=1.D-6
40473C---ORDER OF INTERPOLATION IN SUDAKOV TABLES
40474 INTER=3
40475C---ORDER TO USE FOR ALPHAS IN SUDAKOV TABLES
40476 SUDORD=1
40477C---DEFAULT UNIT FOR THE SUSY DATA FILE
40478 LRSUSY = 66
40479C---CONSERVATION OF RPARITY
40480 RPARTY = .TRUE.
40481C---CHECK WHETHER SUSY DATA INPUTTED
40482 SUSYIN = .FALSE.
40483C---SPIN CORRELATIONS IN TOP/TAU/SUSY DECAYS
40484 SYSPIN = .TRUE.
40485C---THREE BODY SUSY MATRIX ELEMENTS
40486 THREEB = .TRUE.
40487C---FOUR BODY SUSY MATRIX ELEMENTS
40488 FOURB = .FALSE.
40489C---OPTION FOR DIFFERENT COLOUR FLOWS IN SPIN CORRELATION
40490C---(1 is first option in DAMTP-2001-83 only for SM/MSSM)
40491C---(2 is second option in DAMTP-2001-83 needed for RPV)
40492 SPCOPT = 1
40493C---number of weights for maximum search for 3/4 body MEs
40494 NSEARCH = 500
40495C--unit to read three/four body decays from (if 0 computed)
40496 LRDEC = 0
40497C--unit to write three/four body decays to (if 0 not written)
40498 LWDEC = 88
40499C--WHETHER OR NOT TO OPTIMIZE THE WEIGHTS IN MULTICHANNEL PROCESSES
40500 OPTM = .FALSE.
40501C--initializes the multichannel integrals
40502 CALL HWIPHS(1)
40503C CIRCE INTERFACE
40504C---CIRCE IS CONTROLLED BY THESE NEW VARIABLES:
40505C---CIRCOP = CIRCE OPTION: 0=NO CIRCE, STANDARD HERWIG
40506C 1=NO CIRCE, HERWIG WITH COLLINEAR KINEMATICS
40507C 2=BEAMSTRAHLUNG FROM CIRCE
40508C 3=BEAMSTRAHLUNG FROM CIRCE PLUS BREMSTRAHLUNG
40509C THEREFORE 0 SHOULD BE REGARDED AS OFF AND 3 AS ON. THE OTHERS ARE
40510C MAINLY THERE FOR CROSS-CHECKING PURPOSES
40511 CIRCOP=0
40512C---CIRCAC, CIRCVR, CIRCRV, CIRCCH = CIRCE INPUTS ACC, VER, REV AND CHAT
40513C EG CIRCAC=1=SBAND, CIRCAC=2=TESLA, CIRCAC=3=XBAND
40514 CIRCAC=2
40515 CIRCVR=7
40516 CIRCRV=9999 12 31
40517 CIRCCH=0
40518C---END OF CIRCE VARIABLES
40519C--options for Les Houches Accord
40520C--allow self connected gluons (.TRUE.) or forbid (.FALSE.)
40521 LHGLSF = .FALSE.
40522C--generate the soft event (.TRUE.) or don't (.FALSE.)
40523 LHSOFT = .TRUE.
40524C--conserve longitudinal momentum (.true.) or rapidity of hard process
40525 PRESPL = .TRUE.
40526 END
40527CDECK ID>, HWIGUP.
40528*CMZ :- -15/07/02 16.42.23 by Peter Richardson
40529*-- Author : Peter Richardson
40530C----------------------------------------------------------------------
40531 SUBROUTINE HWIGUP
40532C----------------------------------------------------------------------
40533C Use the GUPI (Generic User Process Interface) run common block
40534C to initialise HERWIG -- Initialization for Les Houches interface
40535C----------------------------------------------------------------------
c63d70bc 40536 INCLUDE 'herwig65.inc'
65767955 40537 INTEGER MAXPUP
40538 PARAMETER(MAXPUP=100)
40539 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
40540 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
40541 COMMON /HEPRUP/ IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
40542 & IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),
40543 & XMAXUP(MAXPUP),LPRUP(MAXPUP)
40544 CHARACTER *8 DUMMY,PDFNUC(9),PDFPI(9),PDFPHT(9)
40545 INTEGER I,IDB(2)
40546 SAVE PDFNUC,PDFPI ,PDFPHT
40547 DATA PDFNUC/ 'DO','DFLM','MRS','CTEQ','GRV','ABFOW','BM',
40548 & ' ',' '/
40549 DATA PDFPI / 'OW-P',' ','SMRS-P',' ','GRV-P',
40550 & 'ABFKW-P',' ',' ',' '/
40551 DATA PDFPHT /'DO-G','DG-G','LAC-G','GS-G','GRV-G','ACG-G',
40552 & ' ','WHIT-G','SaSph'/
40553C--call the user routine to do the initialisation
40554 CALL UPINIT_GUP
40555C$$$$$$ I modified the previous sentence UPINIT for UPINIT_GUP (otherwise it can't call it, why??? I have no idea!!)
40556C--setup the beam particles and momentum
40557 CALL HWUIDT(1,IDBMUP(1),IDB(1),DUMMY)
40558 PART1=DUMMY
40559 CALL HWUIDT(1,IDBMUP(2),IDB(2),DUMMY)
40560 PART2=DUMMY
40561 PBEAM1 = SQRT(EBMUP(1)**2-RMASS(IDB(1))**2)
40562 PBEAM2 = SQRT(EBMUP(2)**2-RMASS(IDB(2))**2)
40563C--set up for PDFLIB if need
40564 DO I=1,2
40565 IF(PDFGUP(I).NE.-1) THEN
40566 IF(PDFGUP(I).LT.1.OR.PDFGUP(I).GT.9) CALL HWWARN('HWIGUP',500)
40567 MODPDF(I) = PDFSUP(I)
40568C--proton/neutron beams
40569 IF(ABS(IDBMUP(I)).EQ.2212.OR.ABS(IDBMUP(I)).EQ.2112) THEN
40570 AUTPDF(I) = PDFNUC(PDFGUP(I))
40571C--photon beams
40572 ELSEIF(ABS(IDBMUP(I)).EQ.22) THEN
40573 AUTPDF(I) = PDFPHT(PDFGUP(I))
40574C--pion beams
40575 ELSEIF(ABS(IDBMUP(I)).EQ.211) THEN
40576 AUTPDF(I) = PDFPI(PDFGUP(I))
40577C--unknown beam type
40578 ELSE
40579 CALL HWWARN('HWIGUP',500)
40580 ENDIF
40581 ENDIF
40582 ENDDO
40583C--decide what to do about the weights
40584 IF(ABS(IDWTUP).EQ.1) THEN
40585 WGTMAX = ZERO
40586 AVWGT = ONE
40587 AVABW = ONE
40588 NOWGT = .TRUE.
40589C--sum up the magnitudes of the maximum weight
40590 LHMXSM = ZERO
40591 DO I=1,NPRUP
40592 LHXMAX(I) = XMAXUP(I)*1.0D-3
40593 LHMXSM = LHMXSM+ABS(LHXMAX(I))
40594 ENDDO
40595 ITYPLH = 0
40596 ELSEIF(ABS(IDWTUP).EQ.2) THEN
40597 WGTMAX = ZERO
40598 AVWGT = ONE
40599 AVABW = ONE
40600 NOWGT = .TRUE.
40601C--sum the cross sections and obtain the total
40602 LHMXSM = ZERO
40603 DO I=1,NPRUP
40604 LHXSCT(I) = XSECUP(I)*1.0D-3
40605 LHXMAX(I) = XMAXUP(I)*1.0D-3
40606 LHMXSM = LHMXSM+ABS(LHXSCT(I))
40607 ENDDO
40608 ITYPLH = 0
40609 ELSEIF(ABS(IDWTUP).EQ.3) THEN
40610 WGTMAX = ONE
40611 AVWGT = ONE
40612 AVABW = ONE
40613 NOWGT = .TRUE.
40614 ELSEIF(ABS(IDWTUP).EQ.4) THEN
40615 WGTMAX = ONE
40616 AVWGT = ONE
40617 NOWGT = .FALSE.
40618 ENDIF
40619 IF(IDWTUP.LT.0) NEGWTS = .TRUE.
40620C--zero the weight
40621 DO I=1,NPRUP
40622 LHWGT (I) = ZERO
40623 LHWGTS(I) = ZERO
40624 LHIWGT(I) = 0
40625 LHNEVT(I) = 0
40626 ENDDO
40627 END
40628CDECK ID>, HWIMDE.
40629*CMZ :- -12/10/01 17.14.22 by Peter Richardson
40630*-- Author : Peter Richardson
40631C-----------------------------------------------------------------------
40632 SUBROUTINE HWIMDE
40633C-----------------------------------------------------------------------
40634C Subroutine to merge Higgs WW/ZZ decay modes for four body ME
40635C-----------------------------------------------------------------------
c63d70bc 40636 INCLUDE 'herwig65.inc'
65767955 40637 INTEGER IH,I,NMODE,J,K
40638 LOGICAL REMOVE
40639 DOUBLE PRECISION BR
40640 REMOVE = .FALSE.
40641C--first identify the WW modes
40642 DO IH=203,204
40643 BR = ZERO
40644 NMODE = 0
40645 DO I=NDECSY,NDKYS
40646 IF(IDK(I).EQ.IH.AND.((IDKPRD(3,I).NE.0.AND.IDKPRD(4,I).EQ.0
40647 & .AND.(IDKPRD(1,I).EQ.198.OR.IDKPRD(1,I).EQ.199).AND.
40648 & ((IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12).OR.
40649 & (IDKPRD(2,I).GE.121.AND.IDKPRD(3,I).GE.121.AND.
40650 & IDKPRD(2,I).LE.132.AND.IDKPRD(3,I).LE.132)))
40651 & .OR.((IDKPRD(4,I).NE.0.AND.IDKPRD(5,I).EQ.0.AND.
40652 & (((IDKPRD(1,I).LE.12 .AND.IDKPRD(2,I).LE.12).OR.
40653 & (IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).GE.121.AND.
40654 & IDKPRD(1,I).LE.132.AND.IDKPRD(2,I).LE.132))
40655 & .AND.ICHRG(IDKPRD(1,I))+ICHRG(IDKPRD(2,I)).NE.0)
40656 & .AND.
40657 & (((IDKPRD(3,I).LE.12 .AND.IDKPRD(4,I).LE.12).OR.
40658 & (IDKPRD(3,I).GE.121.AND.IDKPRD(4,I).GE.121.AND.
40659 & IDKPRD(3,I).LE.132.AND.IDKPRD(4,I).LE.132))
40660 & .AND.ICHRG(IDKPRD(3,I))+ICHRG(IDKPRD(4,I)).NE.0))))) THEN
40661 BR=BR+BRFRAC(I)
40662 NME(I) = -100
40663 NMODE=NMODE+1
40664 ENDIF
40665 ENDDO
40666C--add the new mode to the event record
40667 IF(NMODE.GT.0) THEN
40668 REMOVE = .TRUE.
40669 NDKYS = NDKYS+1
40670 IDK(NDKYS) = IH
40671 BRFRAC(NDKYS) = BR
40672 NME(I) = 0
40673 IDKPRD(1,NDKYS) = 198
40674 IDKPRD(2,NDKYS) = 199
40675 DO I=3,5
40676 IDKPRD(I,NDKYS) = 0
40677 ENDDO
40678 ENDIF
40679 ENDDO
40680C--now do the ZZ modes
40681 DO IH=203,204
40682 BR = ZERO
40683 NMODE = 0
40684 DO I=NDECSY,NDKYS
40685 IF(IDK(I).EQ.IH.AND.(IDKPRD(3,I).NE.0.AND.IDKPRD(4,I).EQ.0
40686 & .AND.IDKPRD(1,I).EQ.200.AND.
40687 & ((IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12).OR.
40688 & (IDKPRD(2,I).GE.121.AND.IDKPRD(3,I).GE.121.AND.
40689 & IDKPRD(2,I).LE.132.AND.IDKPRD(3,I).LE.132))
40690 & .OR.((IDKPRD(4,I).NE.0.AND.IDKPRD(5,I).EQ.0.AND.
40691 & (((IDKPRD(1,I).LE.12 .AND.IDKPRD(2,I).LE.12).OR.
40692 & (IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).GE.121.AND.
40693 & IDKPRD(1,I).LE.132.AND.IDKPRD(2,I).LE.132))
40694 & .AND.ICHRG(IDKPRD(1,I))+ICHRG(IDKPRD(2,I)).EQ.0)
40695 & .AND.
40696 & (((IDKPRD(3,I).LE.12 .AND.IDKPRD(4,I).LE.12).OR.
40697 & (IDKPRD(3,I).GE.121.AND.IDKPRD(4,I).GE.121.AND.
40698 & IDKPRD(3,I).LE.132.AND.IDKPRD(4,I).LE.132))
40699 & .AND.ICHRG(IDKPRD(3,I))+ICHRG(IDKPRD(4,I)).EQ.0))))) THEN
40700 BR=BR+BRFRAC(I)
40701 NME(I) = -100
40702 NMODE=NMODE+1
40703 ENDIF
40704 ENDDO
40705C--add the new mode to the event record
40706 IF(NMODE.GT.0) THEN
40707 REMOVE = .TRUE.
40708 NDKYS = NDKYS+1
40709 IDK(NDKYS) = IH
40710 BRFRAC(NDKYS) = BR
40711 NME(I) = 0
40712 IDKPRD(1,NDKYS) = 200
40713 IDKPRD(2,NDKYS) = 200
40714 DO I=3,5
40715 IDKPRD(I,NDKYS) = 0
40716 ENDDO
40717 ENDIF
40718 ENDDO
40719 IF(.NOT.REMOVE) RETURN
40720C--now remove the modes we have marked
40721 I = 0
40722 DO J=NDECSY,NDKYS
40723 10 IF(NME(I+J).EQ.-100) I=I+1
40724 IDK(J) = IDK(J+I)
40725 BRFRAC(J)=BRFRAC(I+J)
40726 NME(J) = NME(I+J)
40727 DO K=1,5
40728 IDKPRD(K,J)=IDKPRD(K,I+J)
40729 ENDDO
40730 IF(NME(J).EQ.-100) GOTO 10
40731 ENDDO
40732C--reset the number of modes
40733 NDKYS = NDKYS-I
40734 END
40735CDECK ID>, HWIPHS.
40736*CMZ :- -02/04/01 12.11.55 by Peter Richardson
40737*-- Author : Peter Richardson
40738C-----------------------------------------------------------------------
40739 SUBROUTINE HWIPHS(IOPT)
40740C-----------------------------------------------------------------------
40741C Subroutine to initialise the multichannel integration
40742C IOPT = 1 sets the weights for the different channels to their
40743C default values
40744C IOPT = 2 optimises the weights for the process selected
40745C-----------------------------------------------------------------------
c63d70bc 40746 INCLUDE 'herwig65.inc'
65767955 40747 INTEGER I,IPRC,ICH,IOPT,ISTP,IWGT,IFER,IANT,IGAU,IQRK
40748 LOGICAL CALLED,TEV,LHC
40749 DOUBLE PRECISION CHNPST(IMAXCH,IMAXOP),D(IMAXOP),CHWGTS(IMAXCH),
40750 & TOTAL,DEM,DMIN,CV,CA,BR,WA(IMAXCH),WITOT,WI(IMAXCH),
40751 & TEVGWT(10,5),LHCGWT(10,5),TEVQWT(6,6,2),LHCQWT(6,6,2)
40752 COMMON /HWPSOM/ WI
40753 SAVE CALLED,DEM,TEVGWT,LHCGWT,TEVQWT,LHCQWT
40754 DATA CALLED/.FALSE./
40755 DATA TEVGWT/0.19684D0,0.00403D0,0.63772D0,0.01209D0,0.01321D0,
40756 & 0.00054D0,0.12984D0,0.00257D0,0.00296D0,0.00019D0,
40757 & 0.24146D0,0.00944D0,0.33949D0,0.01430D0,0.01918D0,
40758 & 0.00169D0,0.33919D0,0.01433D0,0.01931D0,0.00161D0,
40759 & 0.22270D0,0.00004D0,0.38873D0,0.00007D0,0.00009D0,
40760 & 0.00000D0,0.38820D0,0.00007D0,0.00009D0,0.00000D0,
40761 & 0.03228D0,0.00629D0,0.43227D0,0.01147D0,0.00010D0,
40762 & 0.03685D0,0.43270D0,0.01193D0,0.00010D0,0.03602D0,
40763 & 0.05828D0,0.00018D0,0.46870D0,0.00033D0,0.00047D0,
40764 & 0.00092D0,0.46940D0,0.00033D0,0.00047D0,0.00094D0/
40765 DATA LHCGWT/0.10679D0,0.00075D0,0.50915D0,0.00105D0,0.00126D0,
40766 & 0.00039D0,0.37853D0,0.00080D0,0.00092D0,0.00037D0,
40767 & 0.18163D0,0.00456D0,0.38555D0,0.00906D0,0.01160D0,
40768 & 0.00095D0,0.38498D0,0.00920D0,0.01163D0,0.00084D0,
40769 & 0.16647D0,0.00003D0,0.41691D0,0.00007D0,0.00009D0,
40770 & 0.00000D0,0.41627D0,0.00007D0,0.00009D0,0.00000D0,
40771 & 0.01957D0,0.00578D0,0.42971D0,0.01087D0,0.00015D0,
40772 & 0.02305D0,0.47944D0,0.00750D0,0.00016D0,0.02377D0,
40773 & 0.03659D0,0.00027D0,0.45268D0,0.00041D0,0.00063D0,
40774 & 0.00062D0,0.50700D0,0.00045D0,0.00069D0,0.00066D0/
40775 DATA TEVQWT/0.37855D0,0.15212D0,0.38016D0,0.00048D0,0.00047D0,
40776 & 0.08822D0,0.37292D0,0.19051D0,0.36770D0,0.00178D0,
40777 & 0.00180D0,0.06529D0,0.37724D0,0.12202D0,0.37579D0,
40778 & 0.00013D0,0.00013D0,0.12470D0,0.36728D0,0.12100D0,
40779 & 0.36521D0,0.00014D0,0.00014D0,0.14622D0,0.37548D0,
40780 & 0.12144D0,0.37410D0,0.00013D0,0.00013D0,0.12873D0,
40781 & 0.08694D0,0.32633D0,0.07192D0,0.00000D0,0.00000D0,
40782 & 0.51481D0,0.37831D0,0.15131D0,0.38081D0,0.00079D0,
40783 & 0.00077D0,0.08801D0,0.37494D0,0.19012D0,0.36496D0,
40784 & 0.00243D0,0.00246D0,0.06509D0,0.37726D0,0.12071D0,
40785 & 0.37641D0,0.00031D0,0.00032D0,0.12499D0,0.36248D0,
40786 & 0.12007D0,0.36203D0,0.00242D0,0.00243D0,0.15057D0,
40787 & 0.31054D0,0.13065D0,0.30760D0,0.04158D0,0.04178D0,
40788 & 0.16785D0,0.04116D0,0.00125D0,0.04116D0,0.32149D0,
40789 & 0.32030D0,0.27465D0/
40790 DATA LHCQWT/0.45556D0,0.06337D0,0.45712D0,0.00022D0,0.00022D0,
40791 & 0.02351D0,0.43712D0,0.07332D0,0.45023D0,0.00021D0,
40792 & 0.00021D0,0.03890D0,0.44611D0,0.08021D0,0.44572D0,
40793 & 0.00176D0,0.00170D0,0.02450D0,0.47268D0,0.03728D0,
40794 & 0.46843D0,0.00004D0,0.00004D0,0.02152D0,0.45662D0,
40795 & 0.06644D0,0.45586D0,0.00065D0,0.00063D0,0.01980D0,
40796 & 0.18486D0,0.27252D0,0.19067D0,0.00000D0,0.00000D0,
40797 & 0.35195D0,0.45530D0,0.06307D0,0.45770D0,0.00037D0,
40798 & 0.00038D0,0.02318D0,0.43653D0,0.07295D0,0.45173D0,
40799 & 0.00036D0,0.00036D0,0.03807D0,0.47312D0,0.04168D0,
40800 & 0.46993D0,0.00010D0,0.00010D0,0.01506D0,0.47047D0,
40801 & 0.03721D0,0.46860D0,0.00101D0,0.00100D0,0.02172D0,
40802 & 0.44379D0,0.05231D0,0.45440D0,0.01608D0,0.01624D0,
40803 & 0.01717D0,0.25443D0,0.04115D0,0.25503D0,0.18346D0,
40804 & 0.18255D0,0.08337D0/
40805 IF(IERROR.NE.0) RETURN
40806C--initialize for tevatron or LHC based on energy
40807 TEV = NINT(PBEAM1/1000.0D0).EQ.1
40808 LHC = NINT(PBEAM1/1000.0D0).EQ.7
40809C--first the initalisation
40810 IF(IOPT.EQ.1) THEN
40811 IPRO = MOD(IPROC/100,100)
40812 IPRC=MOD(IPROC,100)
40813 DO I=1,20
40814 CHNPRB(I) = ZERO
40815 CHON(I) = .FALSE.
40816 ENDDO
40817C--gauge boson pair production
40818 IF(IPRO.EQ.28.AND.IPRC.LT.50) THEN
40819 IF(MOD(IPRC,5).NE.0.OR.IPRC.EQ.5.OR.IPRC.GT.25)
40820 & CALL HWWARN('HWIPHS',500)
40821 DO I=1,10
40822 CHON(I) = .TRUE.
40823 ENDDO
40824C--select the process
40825 IGAU = INT(IPRC/5)
40826 IF(IGAU.EQ.0) IGAU = IGAU+1
40827 IF(TEV) THEN
40828 DO I=1,10
40829 CHNPRB(I) = TEVGWT(I,IGAU)
40830 ENDDO
40831 ELSEIF(LHC) THEN
40832 DO I=1,10
40833 CHNPRB(I) = LHCGWT(I,IGAU)
40834 ENDDO
40835 ELSE
40836 DO I=1,10
40837 CHNPRB(I) = 0.1D0
40838 ENDDO
40839 ENDIF
40840 CALLED=.TRUE.
40841 DEM = ONE/DBLE(IOPSH)
40842C--Drell Yan + 2 jet production
40843 ELSEIF(IPRO.EQ.29) THEN
40844 DO I=1,6
40845 CHON(I) = .TRUE.
40846 ENDDO
40847 IF(IPRC.LE.6) THEN
40848 IGAU = 1
40849 ELSEIF(IPRC.GE.11.AND.IPRC.LE.16) THEN
40850 IGAU = 2
40851 ELSE
40852 CALL HWWARN('HWIPHS',502)
40853 ENDIF
40854 IQRK = MOD(IPRC,10)
40855 IF(IQRK.EQ.0.OR.IQRK.GT.6) CALL HWWARN('HWIPHS',503)
40856 IF(TEV) THEN
40857 DO I=1,6
40858 CHNPRB(I) = TEVQWT(I,IQRK,IGAU)
40859 ENDDO
40860 ELSEIF(LHC) THEN
40861 DO I=1,6
40862 CHNPRB(I) = LHCQWT(I,IQRK,IGAU)
40863 ENDDO
40864 ELSE
40865 DO I=1,6
40866 CHNPRB(I) = 1.0D0/6.0D0
40867 ENDDO
40868 ENDIF
40869 CALLED=.TRUE.
40870 DEM = ONE/DBLE(IOPSH)
40871 ELSE
40872 CALLED=.FALSE.
40873 RETURN
40874 ENDIF
40875 ELSE
40876 IF(.NOT.CALLED) RETURN
40877 TOTAL = ZERO
40878 DO I=1,IMAXCH
40879 IF(CHON(I)) TOTAL = TOTAL+CHNPRB(I)
40880 ENDDO
40881 IF(TOTAL.EQ.ZERO) CALL HWWARN('HWIPHS',501)
40882 IF(TOTAL.NE.ONE) THEN
40883 DO I=1,IMAXCH
40884 IF(CHON(I)) CHNPRB(I) = CHNPRB(I)/TOTAL
40885 ENDDO
40886 ENDIF
40887 IF(.NOT.OPTM) RETURN
40888 WRITE(*,50)
40889C--optimise the weights
40890 FSTWGT=.TRUE.
40891C---SET UP INITIAL STATE
40892 NHEP=1
40893 ISTHEP(NHEP)=101
40894 PHEP(1,NHEP)=0.
40895 PHEP(2,NHEP)=0.
40896 PHEP(3,NHEP)=PBEAM1
40897 PHEP(4,NHEP)=EBEAM1
40898 PHEP(5,NHEP)=RMASS(IPART1)
40899 JMOHEP(1,NHEP)=0
40900 JMOHEP(2,NHEP)=0
40901 JDAHEP(1,NHEP)=0
40902 JDAHEP(2,NHEP)=0
40903 IDHW(NHEP)=IPART1
40904 IDHEP(NHEP)=IDPDG(IPART1)
40905 NHEP=NHEP+1
40906 ISTHEP(NHEP)=102
40907 PHEP(1,NHEP)=0.
40908 PHEP(2,NHEP)=0.
40909 PHEP(3,NHEP)=-PBEAM2
40910 PHEP(4,NHEP)=EBEAM2
40911 PHEP(5,NHEP)=RMASS(IPART2)
40912 JMOHEP(1,NHEP)=0
40913 JMOHEP(2,NHEP)=0
40914 JDAHEP(1,NHEP)=0
40915 JDAHEP(2,NHEP)=0
40916 IDHW(NHEP)=IPART2
40917 IDHEP(NHEP)=IDPDG(IPART2)
40918C---NEXT ENTRY IS OVERALL CM FRAME
40919 NHEP=NHEP+1
40920 IDHW(NHEP)=14
40921 IDHEP(NHEP)=0
40922 ISTHEP(NHEP)=103
40923 JMOHEP(1,NHEP)=NHEP-2
40924 JMOHEP(2,NHEP)=NHEP-1
40925 JDAHEP(1,NHEP)=0
40926 JDAHEP(2,NHEP)=0
40927 CALL HWVSUM(4,PHEP(1,NHEP-1),PHEP(1,NHEP-2),PHEP(1,NHEP))
40928 CALL HWUMAS(PHEP(1,NHEP))
40929 DO ISTP=1,IOPSTP
40930 WRITE(*,100) ISTP
40931 DO ICH=1,IMAXCH
40932 CHWGTS(ICH) = ZERO
40933 CHNPST(ICH,ISTP) = CHNPRB(ICH)
40934 IF(CHON(ICH)) WRITE(*,200) ICH,CHNPRB(ICH)
40935 ENDDO
40936C--compute the weights for the various channels
40937 DO I=1,IOPSH
40938 IF(IPRO.EQ.28) THEN
40939 CALL HWHGBP
40940 FSTWGT=.FALSE.
40941 CALL HWDBZ2(200,IFER,IANT,CV,CA,BR,2,ZERO)
40942 ELSEIF(IPRO.EQ.29) THEN
40943 CALL HWHV2J
40944 FSTWGT=.FALSE.
40945 CALL HWDBOZ(200,IFER,IANT,CV,CA,BR,2)
40946 ENDIF
40947 DO ICH=1,IMAXCH
40948 IF(CHON(ICH)) CHWGTS(ICH) = CHWGTS(ICH)+WI(ICH)
40949 ENDDO
40950 ENDDO
40951 WITOT = ZERO
40952 DO ICH=1,IMAXCH
40953 IF(CHON(ICH)) THEN
40954 WA(ICH) = CHWGTS(ICH)*DEM
40955 WITOT = WITOT+WA(ICH)*CHNPRB(ICH)
40956 ENDIF
40957 ENDDO
40958C--now pick the next set of probablities for the different channels
40959 TOTAL = ZERO
40960 DO ICH=1,IMAXCH
40961 IF(CHON(ICH)) THEN
40962 CHNPRB(ICH) = CHNPRB(ICH)*SQRT(WA(ICH))
40963 TOTAL = TOTAL+CHNPRB(ICH)
40964 ENDIF
40965 ENDDO
40966 DO ICH=1,IMAXCH
40967 CHNPRB(ICH)=CHNPRB(ICH)/TOTAL
40968 ENDDO
40969 D(ISTP) = ZERO
40970 DO ICH=1,IMAXCH
40971 IF(CHON(ICH)) THEN
40972 IF(D(ISTP).EQ.ZERO) THEN
40973 D(ISTP) = ABS(WITOT-WA(ICH))
40974 ELSE
40975 D(ISTP) = MAX(D(ISTP),ABS(WITOT-WA(ICH)))
40976 ENDIF
40977 ENDIF
40978 ENDDO
40979 WRITE(*,300) D(ISTP)
40980 ENDDO
40981C--pick the best set of weights
40982 IWGT = 1
40983 DMIN = D(1)
40984 DO I=2,IOPSTP
40985 IF(D(I).LT.DMIN) THEN
40986 IWGT = I
40987 DMIN = D(I)
40988 ENDIF
40989 ENDDO
40990 WRITE(*,500) IWGT
40991 DO I=1,IMAXCH
40992 IF(CHON(I)) THEN
40993 CHNPRB(I)=CHNPST(I,IWGT)
40994 WRITE(*,200) I,CHNPRB(I)
40995 ENDIF
40996 ENDDO
40997 OPTM = .FALSE.
40998 ENDIF
40999 RETURN
41000 50 FORMAT(/10X,'OPTIMIZING THE WEIGHTS FOR MULTICHANNEL INTEGRATION')
41001 100 FORMAT(/10X,'PERFORMING ITERATION',I2,/10X)
41002 200 FORMAT( 12X,'CHNPRB(',I2,') = ',F7.5)
41003 300 FORMAT(/10X,'DIFFERENCE IN W BETWEEN CHANNELS',E15.5)
41004 500 FORMAT(/10X,'SELECTED ITERATION',I2)
41005 END
41006CDECK ID>, HWISPC.
41007*CMZ :- -27/07/99 16.38.25 by Peter Richardson
41008*-- Author : Peter Richardson
41009C-----------------------------------------------------------------------
41010 SUBROUTINE HWISPC
41011C-----------------------------------------------------------------------
41012C Calculates the couplings for the SUSY decays for spin correlations
41013C and 3/4 body matrix elements
41014C-----------------------------------------------------------------------
c63d70bc 41015 INCLUDE 'herwig65.inc'
65767955 41016 DOUBLE PRECISION HWUALF,PRE,MCHAR(2),QIJPP(4,4),SIJPP(4,4),
41017 & DIJ(2,2),QIJ(2,2),R(4,2),SIJ(2,2)
41018 INTEGER I,J,K,L,IH,IK,IL,IQ
41019 COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
41020 & OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
41021 DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
41022 & AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
41023 & HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
41024 & HZZ(2),ZAB(12,2,2),HHB(2,3)
41025 EXTERNAL HWUALF
41026 SAVE DIJ
41027 DATA DIJ/1.0D0,0.0D0,0.0D0,1.0D0/
41028 IF(IERROR.NE.0) RETURN
41029C--coupling constants
41030 SW = SQRT(SWEIN)
41031 CW = SQRT(ONE-SWEIN)
41032 TW = SW/CW
41033 E = SQRT(FOUR*PIFAC/128.0D0)
41034 G = E/SW
41035 RT = SQRT(TWO)
41036 ORT = ONE/RT
41037 MW = RMASS(198)
41038 MZ = RMASS(200)
41039 IF(.NOT.SUSYIN) RETURN
41040 GS = SQRT(HWUALF(3,RMASS(449))*FOUR*PIFAC)
41041C--couplings of the neutralinos to the squarks
41042 DO 1 L=1,4
41043 MCHAR(1) = ORT*G*ZMIXSS(L,3)/MW/COSB
41044 MCHAR(2) = ORT*G*ZMIXSS(L,4)/MW/SINB
41045 DO 1 I=1,3
41046 J = 2*I-1
41047 DO 2 K=1,2
41048 AFN(1,J,K,L) =-MCHAR(1)*RMASS(J)*QMIXSS(J,2,K)
41049 & -RT*E*QMIXSS(J,1,K)*SLFCH(J,L)
41050 2 AFN(2,J,K,L) =-ZSGNSS(L)*(MCHAR(1)*RMASS(J)*QMIXSS(J,1,K)
41051 & +RT*E*QMIXSS(J,2,K)*SRFCH(J,L))
41052 J = 2*I
41053 DO 1 K=1,2
41054 AFN(1,J,K,L) =-MCHAR(2)*RMASS(J)*QMIXSS(J,2,K)
41055 & -RT*E*QMIXSS(J,1,K)*SLFCH(J,L)
41056 1 AFN(2,J,K,L) =-ZSGNSS(L)*(MCHAR(2)*RMASS(J)*QMIXSS(J,1,K)
41057 & +RT*E*QMIXSS(J,2,K)*SRFCH(J,L))
41058C--couplings of the neutralinos to the sleptons
41059 DO 3 L=1,4
41060 MCHAR(1) = ORT*G*ZMIXSS(L,3)/MW/COSB
41061 DO 3 I=1,3
41062 J = 2*I-1
41063 IL = J+10
41064 IK = J+6
41065 DO 4 K=1,2
41066 AFN(1,IK,K,L) =-(MCHAR(1)*RMASS(110+IL)*LMIXSS(J,2,K)
41067 & +RT*E*LMIXSS(J,1,K)*SLFCH(IL,L))
41068 4 AFN(2,IK,K,L) =-ZSGNSS(L)*(MCHAR(1)*RMASS(110+IL)*LMIXSS(J,1,K)
41069 & +RT*E*LMIXSS(J,2,K)*SRFCH(IL,L))
41070 J = J+1
41071 IL = IL+1
41072 IK = IK+1
41073 DO 3 K=1,2
41074 AFN(1,IK,K,L) =-RT*E*LMIXSS(J,1,K)*SLFCH(IL,L)
41075 3 AFN(2,IK,K,L) = ZERO
41076C--couplings of the gluinos to the squarks
41077 DO 5 I=1,6
41078 DO 5 K=1,2
41079 AFG(1,I,K) = -GS*RT*QMIXSS(I,1,K)
41080 5 AFG(2,I,K) = +GS*RT*QMIXSS(I,2,K)
41081C--couplings of the charginos to the squarks
41082 DO 6 L=1,2
41083 MCHAR(1) =-WMXVSS(L,2)*ORT/MW/SINB
41084 MCHAR(2) =-WMXUSS(L,2)*ORT/MW/COSB
41085 DO 6 I=1,3
41086 J = 2*I-1
41087 DO 7 K=1,2
41088 AFC(1,J,K,L) = -G*( WMXUSS(L,1)*QMIXSS(J,1,K)
41089 & +MCHAR(2)*RMASS(J)*QMIXSS(J,2,K))
41090 7 AFC(2,J,K,L) = -G*WSGNSS(L)*MCHAR(1)*
41091 & RMASS(J+1)*QMIXSS(J,1,K)
41092 J = 2*I
41093 DO 6 K=1,2
41094 AFC(1,J,K,L) = -G*WSGNSS(L)*( WMXVSS(L,1)*QMIXSS(J,1,K)
41095 & +MCHAR(1)*RMASS(J)*QMIXSS(J,2,K))
41096 6 AFC(2,J,K,L) = -G*MCHAR(2)*RMASS(J-1)*QMIXSS(J,1,K)
41097C--couplings of the charginos to the sleptons
41098 DO 8 L=1,2
41099 MCHAR(1) = -WMXUSS(L,2)*ORT/MW/COSB
41100 DO 8 I=1,3
41101 J = 2*I-1
41102 IL = J+6
41103 DO 9 K=1,2
41104 AFC(1,IL,K,L) = -G*(WMXUSS(L,1)*LMIXSS(J,1,K)
41105 & +RMASS(120+J)*MCHAR(1)*LMIXSS(J,2,K))
41106 9 AFC(2,IL,K,L) = ZERO
41107 J = J+1
41108 IL = IL+1
41109 DO 8 K=1,2
41110 AFC(1,IL,K,L) =-WSGNSS(L)*G*WMXVSS(L,1)
41111 8 AFC(2,IL,K,L) =-MCHAR(1)*G*RMASS(119+J)
41112C--couplings of chargino-neutralino to the W
41113 DO 10 I=1,4
41114 DO 10 J=1,2
41115 OIJ(1,I,J) = G*( ORT*ZMXNSS(I,3)*WMXUSS(J,2)
41116 & +ZMXNSS(I,2)*WMXUSS(J,1))
41117 10 OIJ(2,I,J) = ZSGNSS(I)*WSGNSS(J)*G*(-ORT*ZMXNSS(I,4)*WMXVSS(J,2)
41118 & +ZMXNSS(I,2)*WMXVSS(J,1))
41119C--couplings of chargino-chargino to the Z
41120 PRE = G/CW
41121 DO 11 I=1,2
41122 DO 11 J=1,2
41123 OIJP(1,I,J) = PRE*(-WMXUSS(I,1)*WMXUSS(J,1)
41124 & -HALF*WMXUSS(I,2)*WMXUSS(J,2)+DIJ(I,J)*SWEIN)
41125 11 OIJP(2,I,J) = WSGNSS(I)*WSGNSS(J)*PRE*(-WMXVSS(I,1)*WMXVSS(J,1)
41126 & -HALF*WMXVSS(I,2)*WMXVSS(J,2)+DIJ(I,J)*SWEIN)
41127C--couplings of neutralino-neutralino to the Z
41128 PRE = HALF*G/CW
41129 DO 12 I=1,4
41130 DO 12 J=1,4
41131 OIJPP(1,I,J) = PRE*(ZMIXSS(I,3)*ZMIXSS(J,3)
41132 & -ZMIXSS(I,4)*ZMIXSS(J,4))
41133 12 OIJPP(2,I,J) = -ZSGNSS(I)*ZSGNSS(J)*OIJPP(1,I,J)
41134C--couplings of the neutralino-neutralino to the Higgs
41135 DO 13 I=1,4
41136 DO 13 J=1,4
41137 QIJPP(I,J) = HALF*ZSGNSS(I)*
41138 & (ZMXNSS(I,3)*(ZMXNSS(J,2)-ZMXNSS(J,1)*TW)
41139 & +ZMXNSS(J,3)*(ZMXNSS(I,2)-ZMXNSS(I,1)*TW))
41140 13 SIJPP(I,J) = HALF*ZSGNSS(I)*
41141 & (ZMXNSS(I,4)*(ZMXNSS(J,2)-ZMXNSS(J,1)*TW)
41142 & +ZMXNSS(J,4)*(ZMXNSS(I,2)-ZMXNSS(I,1)*TW))
41143 DO 14 I=1,4
41144 DO 14 J=1,4
41145 HNN(1,1,I,J) = G*(QIJPP(I,J)*SINA+SIJPP(I,J)*COSA)
41146 HNN(2,1,I,J) = G*(QIJPP(J,I)*SINA+SIJPP(J,I)*COSA)
41147 HNN(1,2,I,J) = G*(SIJPP(I,J)*SINA-QIJPP(I,J)*COSA)
41148 HNN(2,2,I,J) = G*(SIJPP(J,I)*SINA-QIJPP(J,I)*COSA)
41149 HNN(1,3,I,J) = G*(QIJPP(I,J)*SINB-SIJPP(I,J)*COSB)
41150 14 HNN(2,3,I,J) =-G*(QIJPP(J,I)*SINB-SIJPP(J,I)*COSB)
41151C--couplings of chargino-chargino to the Higgs
41152 DO 15 I=1,2
41153 DO 15 J=1,2
41154 QIJ(I,J) = ORT*WSGNSS(I)*WMXVSS(I,1)*WMXUSS(J,2)
41155 15 SIJ(I,J) = ORT*WSGNSS(I)*WMXVSS(I,2)*WMXUSS(J,1)
41156 DO 16 I=1,2
41157 DO 16 J=1,2
41158 HCC(1,1,I,J) = G*(QIJ(I,J)*SINA-SIJ(I,J)*COSA)
41159 HCC(2,1,I,J) = G*(QIJ(J,I)*SINA-SIJ(J,I)*COSA)
41160 HCC(1,2,I,J) =-G*(QIJ(I,J)*COSA+SIJ(I,J)*SINA)
41161 HCC(2,2,I,J) =-G*(QIJ(J,I)*COSA+SIJ(J,I)*SINA)
41162 HCC(1,3,I,J) = G*(QIJ(I,J)*SINB+SIJ(I,J)*COSB)
41163 16 HCC(2,3,I,J) =-G*(QIJ(J,I)*SINB+SIJ(J,I)*COSB)
41164C--couplings of chargino-neutralino to the Higgs
41165 DO 17 I=1,4
41166 DO 17 J=1,2
41167 HNC(1,I,J) =-G*ZSGNSS(I)*SINB*(ZMXNSS(I,3)*WMXUSS(J,1)
41168 & -ORT*(ZMXNSS(I,2)+ZMXNSS(I,1)*TW)*WMXUSS(J,2))
41169 17 HNC(2,I,J) =-G*WSGNSS(J)*COSB*(ZMXNSS(I,4)*WMXVSS(J,1)
41170 & +ORT*(ZMXNSS(I,2)+ZMXNSS(I,1)*TW)*WMXVSS(J,2))
41171C--fermion couplings to the Higgs
41172 R(1,1) = HALF*G*SINA/MW/COSB
41173 R(1,2) =-HALF*G*COSA/MW/SINB
41174 R(2,1) =-HALF*G*COSA/MW/COSB
41175 R(2,2) =-HALF*G*SINA/MW/SINB
41176 R(3,1) = HALF*G*TANB/MW
41177 R(3,2) = HALF*G*COTB/MW
41178 R(4,1) = G*ORT*TANB/MW
41179 R(4,2) = G*ORT*COTB/MW
41180 DO 18 I=1,3
41181 J = 2*I-1
41182 K = 2*I
41183 IL = J+6
41184 IQ = K+6
41185 DO 19 IK=1,3
41186 DO 19 L=1,2
41187 HFF(L,IK,J ) = R(IK,1)*RMASS(J)
41188 HFF(L,IK,K ) = R(IK,2)*RMASS(K)
41189 HFF(L,IK,IL) = R(IK,1)*RMASS(114+IL)
41190 19 HFF(L,IK,IQ) = ZERO
41191 HFF(2,3,J ) = -HFF(2,3, J)
41192 HFF(2,3,K ) = -HFF(2,3, K)
41193 HFF(2,3,IL) = -HFF(2,3,IL)
41194 HFF(1,4,I) = RMASS(J)*R(4,1)
41195 HFF(2,4,I) = RMASS(K)*R(4,2)
41196 HFF(1,4,I+3) = RMASS(114+IL)*R(4,1)
41197 18 HFF(2,4,I+3) = ZERO
41198C--couplings of the Higgs to gauge boson pairs
41199 HWW(1) = G*MW*SINBMA
41200 HWW(2) = G*MW*COSBMA
41201 HZZ(1) = G*MZ*SINBMA/CW
41202 HZZ(2) = G*MZ*COSBMA/CW
41203C--couplings of the Z to the sfermions
41204 DO 20 I=1,3
41205 IQ = 2*I-1
41206 IL = 2*I
41207 IK = 2*I+5
41208 IH = 2*I+6
41209 DO 20 J=1,2
41210 DO 20 K=1,2
41211 ZAB(IQ,J,K) = G/CW*HALF*( QMIXSS(IQ,1,J)*QMIXSS(IQ,1,K)
41212 & -TWO*DIJ(J,K) *SWEIN/THREE)
41213 ZAB(IL,J,K) = G/CW*HALF*(-QMIXSS(IL,1,J)*QMIXSS(IL,1,K)
41214 & -FOUR*DIJ(J,K)*SWEIN/THREE)
41215 ZAB(IK,J,K) = G/CW*HALF*( LMIXSS(IQ,1,J)*LMIXSS(IQ,1,K)
41216 & -TWO*DIJ(J,K)*SWEIN)
41217 20 ZAB(IH,J,K) =-G/CW*HALF*DIJ(J,1)*DIJ(K,1)
41218C--couplings of the Higgs Higgs to the gauge bosons
41219 HHB(1,1) = HALF*G*COSBMA
41220 HHB(1,2) = HALF*G*SINBMA
41221 HHB(1,3) = HALF*G
41222 HHB(2,1) =-HALF*G*COSBMA/CW
41223 HHB(2,2) = HALF*G*SINBMA/CW
41224 HHB(2,3) = ZERO
41225 END
41226CDECK ID>, HWISPN.
41227*CMZ :- -12/10/01 17.22.48 by Peter Richardson
41228*-- Author : Peter Richardson
41229C-----------------------------------------------------------------------
41230 SUBROUTINE HWISPN
41231C-----------------------------------------------------------------------
41232C Initialise all the decay modes for three/four body MEs and spin
41233C correlations
41234C-----------------------------------------------------------------------
c63d70bc 41235 INCLUDE 'herwig65.inc'
65767955 41236 INTEGER I,J,K,NDKYST
41237C--set the number of two and three body modes to zero
41238 N2MODE = 0
41239 N3MODE = 0
41240 NBMODE = 0
41241 N4MODE = 0
41242C--if not reading in decay info calculate it
41243 IF(LRDEC.EQ.0) THEN
41244C--initialise the couplings for the various decay modes
41245 CALL HWISPC
41246C--Top decays and SUSY three body decays (including SUSY gauge
41247C--boson 2 body modes which are treated as three body)
41248 IF(THREEB) CALL HWISP3
41249 IF(IERROR.NE.0) RETURN
41250C--then four body modes if needed
41251 IF(FOURB) CALL HWISP4
41252 IF(IERROR.NE.0) RETURN
41253C--Two body modes if needed for spin correlations
41254 IF(SYSPIN) CALL HWISP2
41255 IF(IERROR.NE.0) RETURN
41256C--otherwise read it in
41257 ELSEIF(LRDEC.GT.0) THEN
41258C--open the unit
41259 IF (IPRINT.NE.0) WRITE (6,1) LRDEC
41260 1 FORMAT(/10X,'READING MATRIX ELEMENT TABLE ON UNIT',I4)
41261 OPEN(UNIT=LRDEC,FORM='UNFORMATTED',STATUS='UNKNOWN')
41262C--read options
41263 READ(UNIT=LRDEC) NDKYST
41264 IF(NDKYS.NE.NDKYST) CALL HWWARN('HWISPN',501)
41265 READ(UNIT=LRDEC) SYSPIN,THREEB,FOURB
41266C--read two body decays
41267 IF(SYSPIN) THEN
41268 READ(UNIT=LRDEC) N2MODE
41269 DO 2 I=1,N2MODE
41270 2 READ(UNIT=LRDEC) (A2MODE(J,I),J=1,2),P2MODE(I),WT2MAX(I),
41271 & ID2PRT(I),I2DRTP(I)
41272 ENDIF
41273C--read three body decays
41274 IF(SYSPIN.OR.THREEB) THEN
41275 READ(UNIT=LRDEC) N3MODE
41276 DO 3 I=1,N3MODE
41277 READ(UNIT=LRDEC) P3MODE(I),WT3MAX(I),ID3PRT(I),NDI3BY(I),
41278 & ((SPN3CF(J,K,I),J=1,NCFMAX),K=1,NCFMAX),N3NCFL(I)
41279 DO 3 J=1,NDI3BY(I)
41280 3 READ(UNIT=LRDEC) (A3MODE(K,J,I),K=1,2),(B3MODE(K,J,I),K=1,2),
41281 & I3DRTP(J,I),I3MODE(J,I),I3DRCF(J,I)
41282C--read two body gauge boson modes
41283 READ(UNIT=LRDEC) NBMODE
41284 DO 4 I=1,NBMODE
41285 4 READ(UNIT=LRDEC) (ABMODE(J,I),J=1,2),
41286 & ((BBMODE(J,K,I),J=1,2),K=1,12),(PBMODE(K,I),K=1,12),
41287 & (WTBMAX(K,I),K=1,12),IDBPRT(I),IBMODE(I),IBDRTP(I)
41288 ENDIF
41289C--read four body decays
41290 IF(FOURB) THEN
41291 READ(UNIT=LRDEC) N4MODE
41292 DO 5 I=1,N4MODE
41293 5 READ(UNIT=LRDEC) ((A4MODE(J,K,I),J=1,2),K=1,12),
41294 & ((B4MODE(J,K,I),J=1,2),K=1,12),
41295 & ((P4MODE(J,K,I),J=1,12),K=1,12),
41296 & ((WT4MAX(J,K,I),J=1,12),K=1,12),ID4PRT(I),
41297 & (I4MODE(J,I),J=1,2)
41298 ENDIF
41299C--finally read in the matrix element codes
41300 READ(UNIT=LRDEC) NME
41301 ELSE
41302 CALL HWWARN('HWISPN',500)
41303 ENDIF
41304C--write the decay information if needed
41305 IF(LWDEC.GT.0) THEN
41306C--open the file
41307 IF (IPRINT.NE.0) WRITE (6,6) LWDEC
41308 6 FORMAT(/10X,'WRITING MATRIX ELEMENT TABLE ON UNIT',I4)
41309 OPEN(UNIT=LWDEC,FORM='UNFORMATTED',STATUS='UNKNOWN')
41310C--write options
41311 WRITE(UNIT=LWDEC) NDKYS
41312 WRITE(UNIT=LWDEC) SYSPIN,THREEB,FOURB
41313C--write two body decays
41314 IF(SYSPIN) THEN
41315 WRITE(UNIT=LWDEC) N2MODE
41316 DO 7 I=1,N2MODE
41317 7 WRITE(UNIT=LWDEC) (A2MODE(J,I),J=1,2),P2MODE(I),WT2MAX(I),
41318 & ID2PRT(I),I2DRTP(I)
41319 ENDIF
41320C--write three body decays
41321 IF(SYSPIN.OR.THREEB) THEN
41322 WRITE(UNIT=LWDEC) N3MODE
41323 DO 8 I=1,N3MODE
41324 WRITE(UNIT=LWDEC) P3MODE(I),WT3MAX(I),ID3PRT(I),NDI3BY(I),
41325 & ((SPN3CF(J,K,I),J=1,NCFMAX),K=1,NCFMAX),N3NCFL(I)
41326 DO 8 J=1,NDI3BY(I)
41327 8 WRITE(UNIT=LWDEC) (A3MODE(K,J,I),K=1,2),(B3MODE(K,J,I),K=1,2),
41328 & I3DRTP(J,I),I3MODE(J,I),I3DRCF(J,I)
41329C--write two body gauge boson modes
41330 WRITE(UNIT=LWDEC) NBMODE
41331 DO 9 I=1,NBMODE
41332 9 WRITE(UNIT=LWDEC) (ABMODE(J,I),J=1,2),
41333 & ((BBMODE(J,K,I),J=1,2),K=1,12),(PBMODE(K,I),K=1,12),
41334 & (WTBMAX(K,I),K=1,12),IDBPRT(I),IBMODE(I),IBDRTP(I)
41335 ENDIF
41336C--write four body decays
41337 IF(FOURB) THEN
41338 WRITE(UNIT=LWDEC) N4MODE
41339 DO 10 I=1,N4MODE
41340 10 WRITE(UNIT=LWDEC) ((A4MODE(J,K,I),J=1,2),K=1,12),
41341 & ((B4MODE(J,K,I),J=1,2),K=1,12),
41342 & ((P4MODE(J,K,I),J=1,12),K=1,12),
41343 & ((WT4MAX(J,K,I),J=1,12),K=1,12),ID4PRT(I),
41344 & (I4MODE(J,I),J=1,2)
41345 ENDIF
41346C--finally write the matrix element codes
41347 WRITE(UNIT=LWDEC) NME
41348 ENDIF
41349 END
41350CDECK ID>, HWISP2.
41351*CMZ :- -30/09/02 14:05:28 by Peter Richardson
41352*-- Author : Peter Richardson
41353C-----------------------------------------------------------------------
41354 SUBROUTINE HWISP2
41355C-----------------------------------------------------------------------
41356C Initialise the SUSY two body modes for spin correlations
41357C-----------------------------------------------------------------------
c63d70bc 41358 INCLUDE 'herwig65.inc'
65767955 41359 INTEGER I,J,IL,IH,L,L1,IM,O(2),II,JJ,III,JJJ,KKK
41360 COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
41361 & OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
41362 DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
41363 & AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
41364 & HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
41365 & HZZ(2),ZAB(12,2,2),HHB(2,3),FPI
41366 SAVE O,FPI
41367 DATA O/2,1/
41368 DATA FPI/0.09298D0/
41369 IF(IERROR.NE.0.OR..NOT.SUSYIN) RETURN
41370C--now the two body modes for spin corrections
41371 DO 1000 JJ=1,NRES
41372 DO 1000 II=1,NMODES(JJ)
41373 IF(II.EQ.1) THEN
41374 I = LSTRT(JJ)
41375 ELSE
41376 I = LNEXT(I)
41377 ENDIF
41378 IF(IDKPRD(2,I).EQ.0.OR.IDKPRD(3,I).NE.0.OR.
41379 & (NME(I).GT.10000.AND.NME(I).LT.50000)) GOTO 1000
41380 L1 = IDK(I)-449
41381C--two body top to charged higgs decay
41382 IF(IDK(I).EQ.6.AND.IDKPRD(1,I).EQ.206.AND.
41383 & IDKPRD(2,I).EQ.5) THEN
41384 N2MODE = N2MODE+1
41385 IF(N2MODE.GT.NMODE2) THEN
41386 CALL HWWARN('HWISP2',100)
41387 GOTO 999
41388 ENDIF
41389 NME(I) = 30000+N2MODE
41390 ID2PRT(N2MODE) = I
41391 I2DRTP(N2MODE) = 2
41392 P2MODE(N2MODE) = ONE
41393 DO 201 J=1,2
41394 201 A2MODE(J,N2MODE) = HFF(O(J),4,3)
41395C--two body antitop to charged higgs
41396 ELSEIF(IDK(I).EQ.12.AND.IDKPRD(1,I).EQ.207.AND.
41397 & IDKPRD(2,I).EQ.11) THEN
41398 N2MODE = N2MODE+1
41399 IF(N2MODE.GT.NMODE2) THEN
41400 CALL HWWARN('HWISP2',101)
41401 GOTO 999
41402 ENDIF
41403 NME(I) = 30000+N2MODE
41404 ID2PRT(N2MODE) = I
41405 I2DRTP(N2MODE) = 14
41406 P2MODE(N2MODE) = ONE
41407 DO 202 J=1,2
41408 202 A2MODE(J,N2MODE) = HFF( J ,4,3)
41409C--two body modes of the gluino
41410 ELSEIF(L1.EQ.0) THEN
41411 L = IDKPRD(1,I)-449
41412C--gluino to antisfermion fermion
41413 IF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41414 N2MODE = N2MODE+1
41415 IF(N2MODE.GT.NMODE2) THEN
41416 CALL HWWARN('HWISP2',102)
41417 GOTO 999
41418 ENDIF
41419 NME(I) = 30000+N2MODE
41420 ID2PRT(N2MODE) = I
41421 I2DRTP(N2MODE) = 2
41422 P2MODE(N2MODE) = HALF
41423 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41424 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41425 DO 1 J=1,2
41426 1 A2MODE(J,N2MODE) = AFG(J,IL,IM)
41427C--gluino to sfermion antifermion
41428 ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41429 N2MODE = N2MODE+1
41430 IF(N2MODE.GT.NMODE2) THEN
41431 CALL HWWARN('HWISP2',103)
41432 GOTO 999
41433 ENDIF
41434 NME(I) = 30000+N2MODE
41435 ID2PRT(N2MODE) = I
41436 I2DRTP(N2MODE) = 3
41437 P2MODE(N2MODE) = HALF
41438 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41439 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41440 DO 2 J=1,2
41441 2 A2MODE(J,N2MODE) = AFG(O(J),IL,IM)
41442C--gluino to neutralino gluon
41443 ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.13) THEN
41444 N2MODE = N2MODE+1
41445 IF(N2MODE.GT.NMODE2) THEN
41446 CALL HWWARN('HWISP2',104)
41447 GOTO 999
41448 ENDIF
41449 NME(I) = 30000+N2MODE
41450 ID2PRT(N2MODE) = I
41451 I2DRTP(N2MODE) = 4
41452 P2MODE(N2MODE) = 8.0D0*PIFAC*RMASS(IDK(I))**3/
41453 & (RMASS(IDK(I))**2-RMASS(IDKPRD(1,I))**2)**3*
41454 & HBAR/RLTIM(IDK(I))*BRFRAC(I)
41455 A2MODE(1,N2MODE) = ZSGNSS(L)
41456C--gluino to gravitino gluon
41457 ELSEIF(IDKPRD(1,I).EQ.458.AND.IDKPRD(2,I).EQ.13) THEN
41458 N2MODE = N2MODE+1
41459 IF(N2MODE.GT.NMODE2) THEN
41460 CALL HWWARN('HWISP2',105)
41461 GOTO 999
41462 ENDIF
41463 NME(I) = 30000+N2MODE
41464 ID2PRT(N2MODE) = I
41465 I2DRTP(N2MODE) = 9
41466 P2MODE(N2MODE) = ONE/24.0D0
41467 ENDIF
41468C--two body modes of the neutralinos
41469 ELSEIF(L1.GE.1.AND.L1.LE.4) THEN
41470 L = IDKPRD(1,I)-449
41471 IH = IDKPRD(2,I)-202
41472C--first the neutralino modes to neutralino Higgs
41473 IF(L.GE.1.AND.L.LE.4.AND.IH.GE.1.AND.IH.LE.3) THEN
41474 N2MODE = N2MODE+1
41475 IF(N2MODE.GE.NMODE2) THEN
41476 CALL HWWARN('HWISP2',106)
41477 GOTO 999
41478 ENDIF
41479 NME(I) = 30000+N2MODE
41480 ID2PRT(N2MODE) = I
41481 I2DRTP(N2MODE) = 1
41482 P2MODE(N2MODE) = ONE
41483 DO 3 J=1,2
41484 3 A2MODE(J,N2MODE) = HNN(J,IH,L,L1)
41485C--neutralino to positive chargino negative Higgs
41486 ELSEIF((L.EQ.5.OR.L.EQ.6).AND.IH.EQ.5) THEN
41487 L = L-4
41488 N2MODE = N2MODE+1
41489 IF(N2MODE.GE.NMODE2) THEN
41490 CALL HWWARN('HWISP2',107)
41491 GOTO 999
41492 ENDIF
41493 NME(I) = 30000+N2MODE
41494 ID2PRT(N2MODE) = I
41495 I2DRTP(N2MODE) = 1
41496 P2MODE(N2MODE) = ONE
41497 DO 4 J=1,2
41498 4 A2MODE(J,N2MODE) = HNC(O(J),L1,L)
41499C--neutralino to negative chargino positive Higgs
41500 ELSEIF((L.EQ.7.OR.L.EQ.8).AND.IH.EQ.6) THEN
41501 L = L-6
41502 N2MODE = N2MODE+1
41503 IF(N2MODE.GE.NMODE2) THEN
41504 CALL HWWARN('HWISP2',108)
41505 GOTO 999
41506 ENDIF
41507 NME(I) = 30000+N2MODE
41508 ID2PRT(N2MODE) = I
41509 I2DRTP(N2MODE) = 1
41510 P2MODE(N2MODE) = ONE
41511 DO 5 J=1,2
41512 5 A2MODE(J,N2MODE) = HNC(J,L1,L)
41513C--neutralino to antisfermion sfermion
41514 ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41515 N2MODE = N2MODE+1
41516 IF(N2MODE.GT.NMODE2) THEN
41517 CALL HWWARN('HWISP2',109)
41518 GOTO 999
41519 ENDIF
41520 NME(I) = 30000+N2MODE
41521 ID2PRT(N2MODE) = I
41522 I2DRTP(N2MODE) = 2
41523 P2MODE(N2MODE) = ONE
41524 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41525 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41526 IF(IL.LE.6) P2MODE(N2MODE) = THREE
41527 DO 6 J=1,2
41528 6 A2MODE(J,N2MODE) = AFN(J,IL,IM,L1)
41529C--neutralino to sfermion antifermion
41530 ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41531 N2MODE = N2MODE+1
41532 IF(N2MODE.GT.NMODE2) THEN
41533 CALL HWWARN('HWISP2',110)
41534 GOTO 999
41535 ENDIF
41536 NME(I) = 30000+N2MODE
41537 ID2PRT(N2MODE) = I
41538 I2DRTP(N2MODE) = 3
41539 P2MODE(N2MODE) = ONE
41540 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41541 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41542 IF(IL.LE.6) P2MODE(N2MODE) = THREE
41543 DO 7 J=1,2
41544 7 A2MODE(J,N2MODE) = AFN(O(J),IL,IM,L1)
41545C--neutralino to neutralino photon
41546 ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.59) THEN
41547 N2MODE = N2MODE+1
41548 IF(N2MODE.GT.NMODE2) THEN
41549 CALL HWWARN('HWISP2',111)
41550 GOTO 999
41551 ENDIF
41552 NME(I) = 30000+N2MODE
41553 ID2PRT(N2MODE) = I
41554 I2DRTP(N2MODE) = 4
41555 P2MODE(N2MODE) = 8.0D0*PIFAC*RMASS(IDK(I))**3/
41556 & (RMASS(IDK(I))**2-RMASS(IDKPRD(1,I))**2)**3*
41557 & HBAR/RLTIM(IDK(I))*BRFRAC(I)
41558 A2MODE(1,N2MODE) = ZSGNSS(L)*ZSGNSS(L1)
41559C--neutralino to gravitino photon for GMSB
41560 ELSEIF(IDKPRD(1,I).EQ.458.AND.IDKPRD(2,I).EQ.59) THEN
41561 N2MODE = N2MODE+1
41562 IF(N2MODE.GT.NMODE2) THEN
41563 CALL HWWARN('HWISP2',112)
41564 GOTO 999
41565 ENDIF
41566 NME(I) = 30000+N2MODE
41567 ID2PRT(N2MODE) = I
41568 I2DRTP(N2MODE) = 9
41569 P2MODE(N2MODE) = ZMIXSS(L1,1)**2/24.0D0
41570C--neutralino to gravitino Higgs for GMSB
41571 ELSEIF(IDKPRD(1,I).EQ.458.AND.IH.GE.1.AND.IH.LE.3) THEN
41572 N2MODE = N2MODE+1
41573 IF(N2MODE.GT.NMODE2) THEN
41574 CALL HWWARN('HWISP2',113)
41575 GOTO 999
41576 ENDIF
41577 NME(I) = 30000+N2MODE
41578 ID2PRT(N2MODE) = I
41579 I2DRTP(N2MODE) = 10
41580 IF(IH.EQ.1) THEN
41581 P2MODE(N2MODE) = ZMIXSS(L1,3)*SINA-ZMIXSS(L1,4)*COSA
41582 ELSEIF(IH.EQ.2) THEN
41583 P2MODE(N2MODE) = ZMIXSS(L1,3)*COSA+ZMIXSS(L1,4)*SINA
41584 ELSE
41585 P2MODE(N2MODE) = ZMIXSS(L1,3)*SINB+ZMIXSS(L1,4)*COSB
41586 ENDIF
41587 P2MODE(N2MODE) = P2MODE(N2MODE)**2/3.0D0
41588 ELSE
41589 CALL HWWARN('HWISP2',1)
41590 ENDIF
41591C--two body modes of the positive charginos
41592 ELSEIF(L1.EQ.5.OR.L1.EQ.6) THEN
41593 L1 = L1-4
41594 L = IDKPRD(1,I)-449
41595 IH = IDKPRD(2,I)-202
41596C--first the chargino modes to chargino Higgs
41597 IF((L.EQ.5.OR.L.EQ.6).AND.IH.GE.1.AND.IH.LE.3) THEN
41598 L = L-4
41599 N2MODE = N2MODE+1
41600 IF(N2MODE.GT.NMODE2) THEN
41601 CALL HWWARN('HWISP2',114)
41602 GOTO 999
41603 ENDIF
41604 NME(I) = 30000+N2MODE
41605 ID2PRT(N2MODE) = I
41606 I2DRTP(N2MODE) = 1
41607 P2MODE(N2MODE) = ONE
41608 DO 8 J=1,2
41609 8 A2MODE(J,N2MODE) = HCC(J,IH,L,L1)
41610C--then the chargino modes to neutralino Higgs
41611 ELSEIF(L.GE.1.AND.L.LE.4.AND.IH.EQ.4) THEN
41612 N2MODE = N2MODE+1
41613 IF(N2MODE.GT.NMODE2) THEN
41614 CALL HWWARN('HWISP2',115)
41615 GOTO 999
41616 ENDIF
41617 NME(I) = 30000+N2MODE
41618 ID2PRT(N2MODE) = I
41619 I2DRTP(N2MODE) = 1
41620 P2MODE(N2MODE) = ONE
41621 DO 9 J=1,2
41622 9 A2MODE(J,N2MODE) = HNC(J,L,L1)
41623C--chargino modes to antisfermion fermion
41624 ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41625 N2MODE = N2MODE+1
41626 IF(N2MODE.GT.NMODE2) THEN
41627 CALL HWWARN('HWISP2',116)
41628 GOTO 999
41629 ENDIF
41630 NME(I) = 30000+N2MODE
41631 ID2PRT(N2MODE) = I
41632 I2DRTP(N2MODE) = 2
41633 P2MODE(N2MODE) = ONE
41634 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41635 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41636 IF(IL.LE.6) P2MODE(N2MODE) = THREE
41637 DO 10 J=1,2
41638 10 A2MODE(J,N2MODE) = AFC(J,IL,IM,L1)
41639C--chargino modes to sfermion antifermion
41640 ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41641 N2MODE = N2MODE+1
41642 IF(N2MODE.GT.NMODE2) THEN
41643 CALL HWWARN('HWISP2',117)
41644 GOTO 999
41645 ENDIF
41646 NME(I) = 30000+N2MODE
41647 ID2PRT(N2MODE) = I
41648 I2DRTP(N2MODE) = 3
41649 P2MODE(N2MODE) = ONE
41650 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41651 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41652 IF(IL.LE.6) P2MODE(N2MODE) = THREE
41653 DO 11 J=1,2
41654 11 A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L1)
41655C--chargino --> neutralino pi+
41656 ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.38) THEN
41657 N2MODE = N2MODE+1
41658 IF(N2MODE.GT.NMODE2) THEN
41659 CALL HWWARN('HWISP2',118)
41660 GOTO 999
41661 ENDIF
41662 NME(I) = 30000+N2MODE
41663 ID2PRT(N2MODE) = I
41664 I2DRTP(N2MODE) = 7
41665 P2MODE(N2MODE) = FPI**2*G**2
41666 DO 12 J=1,2
41667 12 A2MODE(J,N2MODE) = OIJ(J,L,L1)
41668 ENDIF
41669C--two body modes of the negative charginos
41670 ELSEIF(L1.EQ.7.OR.L1.EQ.8) THEN
41671 L1 = L1-6
41672 L = IDKPRD(1,I)-449
41673 IH = IDKPRD(2,I)-202
41674C--first the chargino modes to chargino Higgs
41675 IF((L.EQ.7.OR.L.EQ.8).AND.IH.GE.1.AND.IH.LE.3) THEN
41676 L = L-6
41677 N2MODE = N2MODE+1
41678 IF(N2MODE.GT.NMODE2) THEN
41679 CALL HWWARN('HWISP2',119)
41680 GOTO 999
41681 ENDIF
41682 NME(I) = 30000+N2MODE
41683 ID2PRT(N2MODE) = I
41684 I2DRTP(N2MODE) = 1
41685 P2MODE(N2MODE) = ONE
41686 DO 13 J=1,2
41687 13 A2MODE(J,N2MODE) = HCC(O(J),IH,L,L1)
41688C--then the chargino modes to neutralino Higgs
41689 ELSEIF(L.GE.1.AND.L.LE.4.AND.IH.EQ.5) THEN
41690 N2MODE = N2MODE+1
41691 IF(N2MODE.GT.NMODE2) THEN
41692 CALL HWWARN('HWISP2',120)
41693 GOTO 999
41694 ENDIF
41695 NME(I) = 30000+N2MODE
41696 ID2PRT(N2MODE) = I
41697 I2DRTP(N2MODE) = 1
41698 P2MODE(N2MODE) = ONE
41699 DO 14 J=1,2
41700 14 A2MODE(J,N2MODE) = HNC(O(J),L,L1)
41701C--chargino to antisfermion fermion
41702 ELSEIF(IDPDG(IDKPRD(2,I)).GT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41703 N2MODE = N2MODE+1
41704 IF(N2MODE.GT.NMODE2) THEN
41705 CALL HWWARN('HWISP2',121)
41706 GOTO 999
41707 ENDIF
41708 NME(I) = 30000+N2MODE
41709 ID2PRT(N2MODE) = I
41710 I2DRTP(N2MODE) = 2
41711 P2MODE(N2MODE) = ONE
41712 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41713 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41714 IF(IL.LE.6) P2MODE(N2MODE) = THREE
41715 DO 15 J=1,2
41716 15 A2MODE(J,N2MODE) = AFC(J,IL,IM,L1)
41717C--chargino to sfermion antifermion
41718 ELSEIF(IDPDG(IDKPRD(2,I)).LT.0.AND.L.GE.-48.AND.L.LE.-1) THEN
41719 N2MODE = N2MODE+1
41720 IF(N2MODE.GT.NMODE2) THEN
41721 CALL HWWARN('HWISP2',122)
41722 GOTO 999
41723 ENDIF
41724 NME(I) = 30000+N2MODE
41725 ID2PRT(N2MODE) = I
41726 I2DRTP(N2MODE) = 3
41727 P2MODE(N2MODE) = ONE
41728 IM = MOD(INT((IDKPRD(1,I)-389)/12)+1,2)+1
41729 IL = 6*INT((IDKPRD(1,I)-401)/24)+MOD(IDKPRD(1,I)-401,6)+1
41730 IF(IL.LE.6) P2MODE(N2MODE) = THREE
41731 DO 16 J=1,2
41732 16 A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L1)
41733C--chargino --> neutralino pi-
41734 ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.30) THEN
41735 N2MODE = N2MODE+1
41736 IF(N2MODE.GT.NMODE2) THEN
41737 CALL HWWARN('HWISP2',123)
41738 GOTO 999
41739 ENDIF
41740 NME(I) = 30000+N2MODE
41741 ID2PRT(N2MODE) = I
41742 I2DRTP(N2MODE) = 7
41743 P2MODE(N2MODE) = FPI**2*G**2
41744 DO 17 J=1,2
41745 17 A2MODE(J,N2MODE) =-OIJ(O(J),L,L1)
41746 ENDIF
41747 ELSEIF(L1.GE.-48.AND.L1.LT.0) THEN
41748C--sfermion decay modes
41749 L = IDKPRD(1,I)-449
41750C--first sfermion modes to gluinos
41751 IF(L.EQ.0) THEN
41752C--first sfermion --> fermion gluino
41753 IF(IDPDG(IDKPRD(2,I)).GT.0) THEN
41754 N2MODE = N2MODE+1
41755 IF(N2MODE.GT.NMODE2) THEN
41756 CALL HWWARN('HWISP2',124)
41757 GOTO 999
41758 ENDIF
41759 NME(I) = 30000+N2MODE
41760 ID2PRT(N2MODE) = I
41761 I2DRTP(N2MODE) = 6
41762 P2MODE(N2MODE) = FOUR/THREE
41763 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41764 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41765 DO 18 J=1,2
41766 18 A2MODE(J,N2MODE) = AFG(J,IL,IM)
41767C--then antisfermion --> antifermion gluino
41768 ELSE
41769 N2MODE = N2MODE+1
41770 IF(N2MODE.GT.NMODE2) THEN
41771 CALL HWWARN('HWISP2',125)
41772 GOTO 999
41773 ENDIF
41774 NME(I) = 30000+N2MODE
41775 ID2PRT(N2MODE) = I
41776 I2DRTP(N2MODE) = 5
41777 P2MODE(N2MODE) = FOUR/THREE
41778 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41779 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41780 DO 19 J=1,2
41781 19 A2MODE(J,N2MODE) = AFG(O(J),IL,IM)
41782 ENDIF
41783C--then sfermion modes to neutralinos
41784 ELSEIF(L.GE.1.AND.L.LE.4) THEN
41785C--first sfermion --> fermion neutralino
41786 IF(IDPDG(IDKPRD(2,I)).GT.0) THEN
41787 N2MODE = N2MODE+1
41788 IF(N2MODE.GT.NMODE2) THEN
41789 CALL HWWARN('HWISP2',126)
41790 GOTO 999
41791 ENDIF
41792 NME(I) = 30000+N2MODE
41793 ID2PRT(N2MODE) = I
41794 I2DRTP(N2MODE) = 6
41795 P2MODE(N2MODE) = ONE
41796 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41797 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41798 DO 20 J=1,2
41799 20 A2MODE(J,N2MODE) = AFN(J,IL,IM,L)
41800C--then antisfermion --> fermion neutralino
41801 ELSE
41802 N2MODE = N2MODE+1
41803 IF(N2MODE.GT.NMODE2) THEN
41804 CALL HWWARN('HWISP2',127)
41805 GOTO 999
41806 ENDIF
41807 NME(I) = 30000+N2MODE
41808 ID2PRT(N2MODE) = I
41809 I2DRTP(N2MODE) = 5
41810 P2MODE(N2MODE) = ONE
41811 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41812 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41813 DO 21 J=1,2
41814 21 A2MODE(J,N2MODE) = AFN(O(J),IL,IM,L)
41815 ENDIF
41816C--sfermion modes to charginos
41817 ELSEIF(L.GE.5.AND.L.LE.8) THEN
41818 L = MOD(L-5,2)+1
41819C--first sfermion --> fermion chargino
41820 IF(IDPDG(IDKPRD(2,I)).GT.0) THEN
41821 N2MODE = N2MODE+1
41822 IF(N2MODE.GT.NMODE2) THEN
41823 CALL HWWARN('HWISP2',128)
41824 GOTO 999
41825 ENDIF
41826 NME(I) = 30000+N2MODE
41827 ID2PRT(N2MODE) = I
41828 I2DRTP(N2MODE) = 6
41829 P2MODE(N2MODE) = ONE
41830 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41831 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41832 DO 22 J=1,2
41833 22 A2MODE(J,N2MODE) = AFC(J,IL,IM,L)
41834C--then antisfermion --> fermion chargino
41835 ELSE
41836 N2MODE = N2MODE+1
41837 IF(N2MODE.GT.NMODE2) THEN
41838 CALL HWWARN('HWISP2',129)
41839 GOTO 999
41840 ENDIF
41841 NME(I) = 30000+N2MODE
41842 ID2PRT(N2MODE) = I
41843 I2DRTP(N2MODE) = 5
41844 P2MODE(N2MODE) = ONE
41845 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41846 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41847 DO 23 J=1,2
41848 23 A2MODE(J,N2MODE) = AFC(O(J),IL,IM,L)
41849 ENDIF
41850C--sfermion modes to fermion gravitino
41851 ELSEIF(IDKPRD(2,I).EQ.458) THEN
41852 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
41853 N2MODE = N2MODE+1
41854 IF(N2MODE.GT.NMODE2) THEN
41855 CALL HWWARN('HWISP2',130)
41856 GOTO 999
41857 ENDIF
41858 NME(I) = 30000+N2MODE
41859 ID2PRT(N2MODE) = I
41860 I2DRTP(N2MODE) = 11
41861 P2MODE(N2MODE) = ONE/THREE
41862 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41863 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41864 IF(IL.LE.6) THEN
41865 DO 40 J=1,2
41866 40 A2MODE(J,N2MODE) = QMIXSS(IL,O(J),IM)
41867 ELSE
41868 DO 41 J=1,2
41869 41 A2MODE(J,N2MODE) = LMIXSS(IL-6,O(J),IM)
41870 ENDIF
41871 ELSE
41872 N2MODE = N2MODE+1
41873 IF(N2MODE.GT.NMODE2) THEN
41874 CALL HWWARN('HWISP2',131)
41875 GOTO 999
41876 ENDIF
41877 NME(I) = 30000+N2MODE
41878 ID2PRT(N2MODE) = I
41879 I2DRTP(N2MODE) = 12
41880 P2MODE(N2MODE) = ONE/THREE
41881 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
41882 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
41883 IF(IL.LE.6) THEN
41884 DO 42 J=1,2
41885 42 A2MODE(J,N2MODE) = QMIXSS(IL,O(J),IM)
41886 ELSE
41887 DO 43 J=1,2
41888 43 A2MODE(J,N2MODE) = LMIXSS(IL-6,O(J),IM)
41889 ENDIF
41890 ENDIF
41891C--R-parity violating decay modes
41892C--LLE modes
41893 ELSEIF(IDK(I).GE.425.AND.IDK(I).LE.448.AND.
41894 & IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
41895 & IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132) THEN
41896C--charged slepton decays
41897 IF(MOD(IDK(I),2).EQ.1) THEN
41898C--right slepton decay
41899 IF(IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I))).EQ.
41900 & IDPDG(IDKPRD(2,I))/ABS(IDPDG(IDKPRD(2,I)))) THEN
41901C--particle decay
41902 N2MODE = N2MODE+1
41903 IF(N2MODE.GT.NMODE2) THEN
41904 CALL HWWARN('HWISP2',132)
41905 GOTO 999
41906 ENDIF
41907 NME(I) = 30000+N2MODE
41908 ID2PRT(N2MODE) = I
41909 P2MODE(N2MODE) = ONE
41910 IF(IDPDG(IDK(I)).GT.0) THEN
41911 KKK = (IDK(I)-423)/2
41912 IF(KKK.GT.3) THEN
41913 KKK = KKK-6
41914 IM = 2
41915 ELSE
41916 IM = 1
41917 ENDIF
41918 IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
41919 III = (IDKPRD(1,I)-120)/2
41920 JJJ = (IDKPRD(2,I)-119)/2
41921 ELSE
41922 III = (IDKPRD(2,I)-120)/2
41923 JJJ = (IDKPRD(1,I)-119)/2
41924 ENDIF
41925 I2DRTP(N2MODE) = 6
41926 A2MODE(1,N2MODE) = LMIXSS(2*KKK-1,2,IM)*
41927 & LAMDA1(III,JJJ,KKK)
41928 A2MODE(2,N2MODE) = 0.0D0
41929 ELSE
41930C--antiparticle decay
41931 KKK = (IDK(I)-429)/2
41932 IF(KKK.GT.3) THEN
41933 KKK = KKK-6
41934 IM = 2
41935 ELSE
41936 IM = 1
41937 ENDIF
41938 IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
41939 III = (IDKPRD(1,I)-126)/2
41940 JJJ = (IDKPRD(2,I)-125)/2
41941 ELSE
41942 III = (IDKPRD(2,I)-126)/2
41943 JJJ = (IDKPRD(1,I)-125)/2
41944 ENDIF
41945 I2DRTP(N2MODE) = 13
41946 A2MODE(1,N2MODE) = 0.0D0
41947 A2MODE(2,N2MODE) = LMIXSS(2*KKK-1,2,IM)*
41948 & LAMDA1(III,JJJ,KKK)
41949 ENDIF
41950C--left slepton decay
41951 ELSE
41952 N2MODE = N2MODE+1
41953 IF(N2MODE.GT.NMODE2) THEN
41954 CALL HWWARN('HWISP2',133)
41955 GOTO 999
41956 ENDIF
41957 NME(I) = 30000+N2MODE
41958 ID2PRT(N2MODE) = I
41959 P2MODE(N2MODE) = ONE
41960 IF(IDPDG(IDK(I)).GT.0) THEN
41961 JJJ = (IDK(I)-423)/2
41962 IF(JJJ.GT.3) THEN
41963 JJJ = JJJ-6
41964 IM = 2
41965 ELSE
41966 IM = 1
41967 ENDIF
41968 IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
41969 III = (IDKPRD(1,I)-126)/2
41970 KKK = (IDKPRD(2,I)-119)/2
41971 I2DRTP(N2MODE) = 8
41972 ELSE
41973 III = (IDKPRD(2,I)-126)/2
41974 KKK = (IDKPRD(1,I)-119)/2
41975 I2DRTP(N2MODE) = 5
41976 ENDIF
41977 A2MODE(1,N2MODE) = 0.0D0
41978 A2MODE(2,N2MODE) = LMIXSS(2*JJJ-1,1,IM)*
41979 & LAMDA1(III,JJJ,KKK)
41980 ELSE
41981 JJJ = (IDK(I)-429)/2
41982 IF(JJJ.GT.3) THEN
41983 JJJ = JJJ-6
41984 IM = 2
41985 ELSE
41986 IM = 1
41987 ENDIF
41988 IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
41989 III = (IDKPRD(1,I)-120)/2
41990 KKK = (IDKPRD(2,I)-125)/2
41991 I2DRTP(N2MODE) = 5
41992 ELSE
41993 III = (IDKPRD(2,I)-120)/2
41994 KKK = (IDKPRD(1,I)-125)/2
41995 I2DRTP(N2MODE) = 8
41996 ENDIF
41997 A2MODE(1,N2MODE) = LMIXSS(2*JJJ-1,1,IM)*
41998 & LAMDA1(III,JJJ,KKK)
41999 A2MODE(2,N2MODE) = 0.0D0
42000 ENDIF
42001 ENDIF
42002C--sneutrino decays
42003 ELSEIF(MOD(IDK(I),2).EQ.0.AND.IDK(I).LE.436) THEN
42004C--sneutrino decay
42005 N2MODE = N2MODE+1
42006 IF(N2MODE.GT.NMODE2) THEN
42007 CALL HWWARN('HWISP2',134)
42008 GOTO 999
42009 ENDIF
42010 NME(I) = 30000+N2MODE
42011 ID2PRT(N2MODE) = I
42012 P2MODE(N2MODE) = ONE
42013 IF(IDPDG(IDK(I)).GT.0) THEN
42014 III = (IDK(I)-424)/2
42015 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
42016 KKK = (IDKPRD(1,I)-119)/2
42017 JJJ = (IDKPRD(2,I)-125)/2
42018 I2DRTP(N2MODE) = 5
42019 ELSE
42020 JJJ = (IDKPRD(1,I)-125)/2
42021 KKK = (IDKPRD(2,I)-119)/2
42022 I2DRTP(N2MODE) = 8
42023 ENDIF
42024 A2MODE(1,N2MODE) = 0.0D0
42025 A2MODE(2,N2MODE) = LAMDA1(III,JJJ,KKK)
42026C--antisneutrino decay
42027 ELSE
42028 III = (IDK(I)-430)/2
42029 IF(IDPDG(IDKPRD(1,I)).LT.0) THEN
42030 KKK = (IDKPRD(1,I)-125)/2
42031 JJJ = (IDKPRD(2,I)-119)/2
42032 I2DRTP(N2MODE) = 8
42033 ELSE
42034 JJJ = (IDKPRD(1,I)-119)/2
42035 KKK = (IDKPRD(2,I)-125)/2
42036 I2DRTP(N2MODE) = 5
42037 ENDIF
42038 A2MODE(1,N2MODE) = LAMDA1(III,JJJ,KKK)
42039 A2MODE(2,N2MODE) = 0.0D0
42040 ENDIF
42041 ENDIF
42042C--LQD modes
42043C--squark decays
42044 ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.424.AND.
42045 & IDKPRD(1,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
42046 & IDKPRD(2,I).LE.12) THEN
42047C--up type squark decay
42048 IF(MOD(IDK(I),2).EQ.0) THEN
42049 N2MODE = N2MODE+1
42050 IF(N2MODE.GT.NMODE2) THEN
42051 CALL HWWARN('HWISP2',135)
42052 GOTO 999
42053 ENDIF
42054 NME(I) = 30000+N2MODE
42055 ID2PRT(N2MODE) = I
42056 P2MODE(N2MODE) = ONE
42057 IF(IDPDG(IDK(I)).GT.0) THEN
42058 JJJ = (IDK(I)-400)/2
42059 IF(JJJ.GT.3) THEN
42060 JJJ = JJJ-6
42061 IM = 2
42062 ELSE
42063 IM = 1
42064 ENDIF
42065 III = (IDKPRD(1,I)-125)/2
42066 KKK = (IDKPRD(2,I)+1)/2
42067 I2DRTP(N2MODE) = 8
42068 A2MODE(1,N2MODE) = ZERO
42069 A2MODE(2,N2MODE) = QMIXSS(2*JJJ,1,IM)*
42070 & LAMDA2(III,JJJ,KKK)
42071 ELSE
42072 JJJ = (IDK(I)-406)/2
42073 IF(JJJ.GT.3) THEN
42074 JJJ = JJJ-6
42075 IM = 2
42076 ELSE
42077 IM = 1
42078 ENDIF
42079 III = (IDKPRD(1,I)-119)/2
42080 KKK = (IDKPRD(2,I)-5)/2
42081 I2DRTP(N2MODE) = 5
42082 A2MODE(1,N2MODE) = QMIXSS(2*JJJ,1,IM)*
42083 & LAMDA2(III,JJJ,KKK)
42084 A2MODE(2,N2MODE) = ZERO
42085 ENDIF
42086C--down type squark to lepton up
42087 ELSEIF(MOD(IDK(I),2).EQ.1.AND.MOD(IDKPRD(1,I),2).EQ.1) THEN
42088 N2MODE = N2MODE+1
42089 IF(N2MODE.GT.NMODE2) THEN
42090 CALL HWWARN('HWISP2',136)
42091 GOTO 999
42092 ENDIF
42093 NME(I) = 30000+N2MODE
42094 ID2PRT(N2MODE) = I
42095 P2MODE(N2MODE) = ONE
42096C--particle
42097 IF(IDPDG(IDK(I)).GT.0) THEN
42098 KKK = (IDK(I)-399)/2
42099 IF(KKK.GT.3) THEN
42100 KKK = KKK-6
42101 IM = 2
42102 ELSE
42103 IM = 1
42104 ENDIF
42105 III = (IDKPRD(1,I)-119)/2
42106 JJJ = IDKPRD(2,I)/2
42107 I2DRTP(N2MODE) = 6
42108 A2MODE(1,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
42109 & LAMDA2(III,JJJ,KKK)
42110 A2MODE(2,N2MODE) = ZERO
42111C--antiparticle
42112 ELSE
42113 KKK = (IDK(I)-405)/2
42114 IF(KKK.GT.3) THEN
42115 KKK = KKK-6
42116 IM = 2
42117 ELSE
42118 IM = 1
42119 ENDIF
42120 III = (IDKPRD(1,I)-125)/2
42121 JJJ = (IDKPRD(2,I)-6)/2
42122 I2DRTP(N2MODE) = 13
42123 A2MODE(1,N2MODE) = ZERO
42124 A2MODE(2,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
42125 & LAMDA2(III,JJJ,KKK)
42126 ENDIF
42127C--down (left) squark --> nu d
42128 ELSEIF(MOD(IDK(I),2).EQ.1.AND.
42129 & IDPDG(IDK(I))/ABS(IDPDG(IDK(I))).EQ.
42130 & -IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I)))) THEN
42131 N2MODE = N2MODE+1
42132 IF(N2MODE.GT.NMODE2) THEN
42133 CALL HWWARN('HWISP2',137)
42134 GOTO 999
42135 ENDIF
42136 NME(I) = 30000+N2MODE
42137 ID2PRT(N2MODE) = I
42138 P2MODE(N2MODE) = ONE
42139 IF(IDPDG(IDK(I)).GT.0) THEN
42140 JJJ = (IDK(I)-399)/2
42141 IF(JJJ.GT.3) THEN
42142 JJJ = JJJ-6
42143 IM = 2
42144 ELSE
42145 IM = 1
42146 ENDIF
42147 III = (IDKPRD(1,I)-126)/2
42148 KKK = (IDKPRD(2,I)+1)/2
42149 I2DRTP(N2MODE) = 8
42150 A2MODE(1,N2MODE) = ZERO
42151 A2MODE(2,N2MODE) = QMIXSS(2*JJJ-1,1,IM)*
42152 & LAMDA2(III,JJJ,KKK)
42153 ELSE
42154 JJJ = (IDK(I)-405)/2
42155 IF(JJJ.GT.3) THEN
42156 JJJ = JJJ-6
42157 IM = 2
42158 ELSE
42159 IM = 1
42160 ENDIF
42161 III = (IDKPRD(1,I)-120)/2
42162 KKK = (IDKPRD(2,I)-5)/2
42163 I2DRTP(N2MODE) = 5
42164 A2MODE(1,N2MODE) = QMIXSS(2*JJJ-1,1,IM)*
42165 & LAMDA2(III,JJJ,KKK)
42166 A2MODE(2,N2MODE) = ZERO
42167 ENDIF
42168C--down (right) squark --> nu d
42169 ELSEIF(MOD(IDK(I),2).EQ.1.AND.
42170 & IDPDG(IDK(I))/ABS(IDPDG(IDK(I))).EQ.
42171 & IDPDG(IDKPRD(1,I))/ABS(IDPDG(IDKPRD(1,I)))) THEN
42172 N2MODE = N2MODE+1
42173 IF(N2MODE.GT.NMODE2) THEN
42174 CALL HWWARN('HWISP2',138)
42175 GOTO 999
42176 ENDIF
42177 NME(I) = 30000+N2MODE
42178 ID2PRT(N2MODE) = I
42179 P2MODE(N2MODE) = ONE
42180 IF(IDPDG(IDK(I)).GT.0) THEN
42181 KKK = (IDK(I)-399)/2
42182 IF(KKK.GT.3) THEN
42183 KKK = KKK-6
42184 IM = 2
42185 ELSE
42186 IM = 1
42187 ENDIF
42188 III = (IDKPRD(1,I)-120)/2
42189 JJJ = (IDKPRD(2,I)+1)/2
42190 I2DRTP(N2MODE) = 6
42191 A2MODE(1,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
42192 & LAMDA2(III,JJJ,KKK)
42193 A2MODE(2,N2MODE) = ZERO
42194 ELSE
42195 KKK = (IDK(I)-405)/2
42196 IF(KKK.GT.3) THEN
42197 KKK = KKK-6
42198 IM = 2
42199 ELSE
42200 IM = 1
42201 ENDIF
42202 III = (IDKPRD(1,I)-126)/2
42203 JJJ = (IDKPRD(2,I)-5)/2
42204 I2DRTP(N2MODE) = 13
42205 A2MODE(1,N2MODE) = ZERO
42206 A2MODE(2,N2MODE) = QMIXSS(2*KKK-1,2,IM)*
42207 & LAMDA2(III,JJJ,KKK)
42208 ENDIF
42209 ELSE
42210 CALL HWWARN('HWISP2',2)
42211 ENDIF
42212C--slepton decays
42213 ELSEIF(IDK(I).GE.425.AND.IDK(I).LE.448.AND.
42214 & IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12) THEN
42215C--sneutrino decay
42216 IF(MOD(IDK(I),2).EQ.0) THEN
42217 N2MODE = N2MODE+1
42218 IF(N2MODE.GT.NMODE2) THEN
42219 CALL HWWARN('HWISP2',140)
42220 GOTO 999
42221 ENDIF
42222 NME(I) = 30000+N2MODE
42223 ID2PRT(N2MODE) = I
42224 P2MODE(N2MODE) = THREE
42225C--particle
42226 IF(IDPDG(IDK(I)).GT.0) THEN
42227 III = (IDK(I)-424)/2
42228 JJJ = (IDKPRD(1,I)-5)/2
42229 KKK = (IDKPRD(2,I)+1)/2
42230 I2DRTP(N2MODE) = 8
42231 A2MODE(1,N2MODE) = 0.0D0
42232 A2MODE(2,N2MODE) = LAMDA2(III,JJJ,KKK)
42233C--antiparticle
42234 ELSE
42235 III = (IDK(I)-430)/2
42236 JJJ = (IDKPRD(1,I)+1)/2
42237 KKK = (IDKPRD(2,I)-5)/2
42238 I2DRTP(N2MODE) = 5
42239 A2MODE(1,N2MODE) = LAMDA2(III,JJJ,KKK)
42240 A2MODE(2,N2MODE) = 0.0D0
42241 ENDIF
42242C--slepton decay
42243 ELSEIF(MOD(IDK(I),2).EQ.1) THEN
42244 N2MODE = N2MODE+1
42245 IF(N2MODE.GT.NMODE2) THEN
42246 CALL HWWARN('HWISP2',141)
42247 GOTO 999
42248 ENDIF
42249 NME(I) = 30000+N2MODE
42250 ID2PRT(N2MODE) = I
42251 P2MODE(N2MODE) = THREE
42252C--particle
42253 IF(IDPDG(IDK(I)).GT.0) THEN
42254 III = (IDK(I)-423)/2
42255 IF(III.GT.3) THEN
42256 III = III -6
42257 IM = 2
42258 ELSE
42259 IM = 1
42260 ENDIF
42261 JJJ = (IDKPRD(1,I)-6)/2
42262 KKK = (IDKPRD(2,I)+1)/2
42263 I2DRTP(N2MODE) = 8
42264 A2MODE(1,N2MODE) = 0.0D0
42265 A2MODE(2,N2MODE) = LMIXSS(2*III-1,1,IM)*
42266 & LAMDA2(III,JJJ,KKK)
42267C--antiparticle
42268 ELSE
42269 III = (IDK(I)-429)/2
42270 IF(III.GT.3) THEN
42271 III = III -6
42272 IM = 2
42273 ELSE
42274 IM = 1
42275 ENDIF
42276 JJJ = IDKPRD(1,I)/2
42277 KKK = (IDKPRD(2,I)-5)/2
42278 I2DRTP(N2MODE) = 5
42279 A2MODE(1,N2MODE) = LMIXSS(2*III-1,1,IM)*
42280 & LAMDA2(III,JJJ,KKK)
42281 A2MODE(2,N2MODE) = 0.0D0
42282 ENDIF
42283 ELSE
42284 CALL HWWARN('HWISP2',3)
42285 ENDIF
42286C--UDD modes
42287 ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.424.AND.
42288 & IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12) THEN
42289C--up type squark decay
42290 IF(MOD(IDK(I),2).EQ.0) THEN
42291 N2MODE = N2MODE+1
42292 IF(N2MODE.GT.NMODE2) THEN
42293 CALL HWWARN('HWISP2',143)
42294 GOTO 999
42295 ENDIF
42296 NME(I) = 30000+N2MODE
42297 ID2PRT(N2MODE) = I
42298 P2MODE(N2MODE) = 2.0D0
42299C--squark decay
42300 IF(IDPDG(IDK(I)).GT.0) THEN
42301 III = (IDK(I)-400)/2
42302 IF(III.GT.3) THEN
42303 III = III-6
42304 IM = 2
42305 ELSE
42306 IM = 1
42307 ENDIF
42308 JJJ = (IDKPRD(1,I)-5)/2
42309 KKK = (IDKPRD(2,I)-5)/2
42310 I2DRTP(N2MODE) = 13
42311 A2MODE(1,N2MODE)=QMIXSS(2*III,2,IM)*LAMDA3(III,JJJ,KKK)
42312 A2MODE(2,N2MODE)=0.0D0
42313C--antisquark decay
42314 ELSE
42315 III = (IDK(I)-406)/2
42316 IF(III.GT.3) THEN
42317 III = III-6
42318 IM = 2
42319 ELSE
42320 IM = 1
42321 ENDIF
42322 JJJ = (IDKPRD(1,I)+1)/2
42323 KKK = (IDKPRD(2,I)+1)/2
42324 I2DRTP(N2MODE) = 6
42325 A2MODE(1,N2MODE) =0.0D0
42326 A2MODE(2,N2MODE) =QMIXSS(2*III,2,IM)*LAMDA3(III,JJJ,KKK)
42327 ENDIF
42328 ELSE
42329C--down type squark decay
42330 N2MODE = N2MODE+1
42331 IF(N2MODE.GT.NMODE2) THEN
42332 CALL HWWARN('HWISP2',144)
42333 GOTO 999
42334 ENDIF
42335 NME(I) = 30000+N2MODE
42336 ID2PRT(N2MODE) = I
42337 P2MODE(N2MODE) = 2.0D0
42338C--squark decay
42339 IF(IDPDG(IDK(I)).GT.0) THEN
42340 JJJ = (IDK(I)-399)/2
42341 IF(JJJ.GT.3) THEN
42342 JJJ = JJJ-6
42343 IM = 2
42344 ELSE
42345 IM = 1
42346 ENDIF
42347 III = (IDKPRD(1,I)-6)/2
42348 KKK = (IDKPRD(2,I)-5)/2
42349 I2DRTP(N2MODE) = 13
42350 A2MODE(1,N2MODE)= QMIXSS(2*JJJ-1,2,IM)*
42351 & LAMDA3(III,JJJ,KKK)
42352 A2MODE(2,N2MODE)= 0.0D0
42353C--antisquark decay
42354 ELSE
42355 JJJ = (IDK(I)-405)/2
42356 IF(JJJ.GT.3) THEN
42357 JJJ = JJJ-6
42358 IM = 2
42359 ELSE
42360 IM = 1
42361 ENDIF
42362 III = IDKPRD(1,I)/2
42363 KKK = (IDKPRD(2,I)+1)/2
42364 I2DRTP(N2MODE) = 6
42365 A2MODE(1,N2MODE) = 0.0D0
42366 A2MODE(2,N2MODE) = QMIXSS(2*JJJ-1,2,IM)*
42367 & LAMDA3(III,JJJ,KKK)
42368 ENDIF
42369 ENDIF
42370 ELSE
42371 IF(.NOT.(RSPIN(IDKPRD(1,I)).EQ.ZERO.AND.
42372 & RSPIN(IDKPRD(2,I)).EQ.ZERO)) CALL HWWARN('HWISP2',4)
42373 ENDIF
42374 ELSEIF(IDK(I).GE.203.AND.IDK(I).LE.207) THEN
42375 IH = IDK(I)-202
42376 L = IDKPRD(1,I)-449
42377 L1 = IDKPRD(2,I)-449
42378C--Neutral Higgs decays
42379 IF(IH.GE.1.AND.IH.LE.3) THEN
42380C--Higgs to neutralino neutralino
42381 IF(L.GE.1.AND.L.LE.4) THEN
42382 N2MODE = N2MODE+1
42383 IF(N2MODE.GT.NMODE2) THEN
42384 CALL HWWARN('HWISP2',146)
42385 GOTO 999
42386 ENDIF
42387 NME(I) = 30000+N2MODE
42388 ID2PRT(N2MODE) = I
42389 I2DRTP(N2MODE) = 6
42390 P2MODE(N2MODE) = ONE
42391 IF(L.EQ.L1) P2MODE(N2MODE) = HALF
42392 DO 24 J=1,2
42393 24 A2MODE(J,N2MODE) = HNN(J,IH,L,L1)
42394C--Higgs to chargino chargino
42395 ELSEIF(L.GE.5.AND.L.LE.8) THEN
42396 L = MOD(L -5,2)+1
42397 L1 = MOD(L1-5,2)+1
42398 N2MODE = N2MODE+1
42399 IF(N2MODE.GT.NMODE2) THEN
42400 CALL HWWARN('HWISP2',147)
42401 GOTO 999
42402 ENDIF
42403 NME(I) = 30000+N2MODE
42404 ID2PRT(N2MODE) = I
42405 I2DRTP(N2MODE) = 6
42406 P2MODE(N2MODE) = ONE
42407 DO 25 J=1,2
42408 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
42409 A2MODE(J,N2MODE) = HCC( J ,IH,L,L1)
42410 ELSE
42411 A2MODE(J,N2MODE) = HCC(O(J),IH,L,L1)
42412 ENDIF
42413 25 CONTINUE
42414C--Higgs to fermion antifermion
42415 ELSEIF((L.GE.-448.AND.L.LE.-437)
42416 & .OR.(L.GE.-328.AND.L.LE.-317)) THEN
42417 N2MODE = N2MODE+1
42418 IF(N2MODE.GT.NMODE2) THEN
42419 CALL HWWARN('HWISP2',148)
42420 GOTO 999
42421 ENDIF
42422 NME(I) = 30000+N2MODE
42423 ID2PRT(N2MODE) = I
42424 I2DRTP(N2MODE) = 5
42425 P2MODE(N2MODE) = ONE
42426 IL = IDKPRD(1,I)
42427 IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
42428 IF(IL.LE.6) P2MODE(N2MODE) = THREE
42429 DO 26 J=1,2
42430 26 A2MODE(J,N2MODE) = HFF(J,IH,IL)
42431 ELSE
42432 IF(.NOT.
42433 & (RSPIN(IDKPRD(1,I)).EQ.ZERO.AND.RSPIN(IDKPRD(2,I)).EQ.ZERO)
42434 & .AND..NOT.(IDKPRD(1,I).EQ.13.AND.IDKPRD(2,I).EQ.13)
42435 & .AND..NOT.(IDKPRD(1,I).EQ.59.AND.IDKPRD(2,I).EQ.59)
42436 & .AND..NOT.(IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200.AND.
42437 & IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200))
42438 & CALL HWWARN('HWISP2',5)
42439 ENDIF
42440C--charged Higgs decays
42441 ELSE
42442 IH = IDK(I)-205
42443 L = IDKPRD(1,I)-449
42444 L1 = IDKPRD(2,I)-449
42445C--positive Higgs decays
42446 IF(IH.EQ.1) THEN
42447C--decay to chargino neutralino
42448 IF(L.EQ.5.OR.L.EQ.6) THEN
42449 L = L-4
42450 N2MODE = N2MODE+1
42451 IF(N2MODE.GT.NMODE2) THEN
42452 CALL HWWARN('HWISP2',149)
42453 GOTO 999
42454 ENDIF
42455 NME(I) = 30000+N2MODE
42456 ID2PRT(N2MODE) = I
42457 I2DRTP(N2MODE) = 6
42458 P2MODE(N2MODE) = ONE
42459 DO 27 J=1,2
42460 27 A2MODE(J,N2MODE) = HNC(O(J),L1,L)
42461C--decay to neutralino chargino
42462 ELSEIF(L.GE.1.AND.L.LE.4) THEN
42463 L1 = L1-4
42464 N2MODE = N2MODE+1
42465 IF(N2MODE.GT.NMODE2) THEN
42466 CALL HWWARN('HWISP2',150)
42467 GOTO 999
42468 ENDIF
42469 NME(I) = 30000+N2MODE
42470 ID2PRT(N2MODE) = I
42471 I2DRTP(N2MODE) = 6
42472 P2MODE(N2MODE) = ONE
42473 DO 28 J=1,2
42474 28 A2MODE(J,N2MODE) = HNC(O(J),L1,L)
42475C--fermion antifermion decay modes
42476 ELSEIF((L.GE.-448.AND.L.LE.-437)
42477 & .OR.(L.GE.-328.AND.L.LE.-317)) THEN
42478 N2MODE = N2MODE+1
42479 IF(N2MODE.GT.NMODE2) THEN
42480 CALL HWWARN('HWISP2',151)
42481 GOTO 999
42482 ENDIF
42483 NME(I) = 30000+N2MODE
42484 ID2PRT(N2MODE) = I
42485 I2DRTP(N2MODE) = 5
42486 P2MODE(N2MODE) = ONE
42487 IL = IDKPRD(1,I)
42488 IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
42489 IL = INT((IL+1)/2)
42490 IF(IL.LE.3) P2MODE(N2MODE) = THREE
42491 DO 29 J=1,2
42492 29 A2MODE(J,N2MODE) = HFF(J,4,IL)
42493 ELSE
42494 IF(RSPIN(IDKPRD(1,I)).NE.ZERO.OR.RSPIN(IDKPRD(2,I)).NE.
42495 & ZERO) CALL HWWARN('HWISP2',6)
42496 ENDIF
42497C--negative Higgs decays
42498 ELSE
42499C--Higgs to chargino neutralino
42500 IF(L.EQ.7.OR.L.EQ.8) THEN
42501 L = L-6
42502 N2MODE = N2MODE+1
42503 IF(N2MODE.GT.NMODE2) THEN
42504 CALL HWWARN('HWISP2',152)
42505 GOTO 999
42506 ENDIF
42507 NME(I) = 30000+N2MODE
42508 ID2PRT(N2MODE) = I
42509 I2DRTP(N2MODE) = 6
42510 P2MODE(N2MODE) = ONE
42511 DO 30 J=1,2
42512 30 A2MODE(J,N2MODE) = HNC(J,L1,L)
42513C--Higgs to neutralino chargino
42514 ELSEIF(L.GE.1.AND.L.LE.4) THEN
42515 L1 = L1-6
42516 N2MODE = N2MODE+1
42517 IF(N2MODE.GT.NMODE2) THEN
42518 CALL HWWARN('HWISP2',153)
42519 GOTO 999
42520 ENDIF
42521 NME(I) = 30000+N2MODE
42522 ID2PRT(N2MODE) = I
42523 I2DRTP(N2MODE) = 6
42524 P2MODE(N2MODE) = ONE
42525 DO 31 J=1,2
42526 31 A2MODE(J,N2MODE) = HNC(J,L1,L)
42527C--fermion antifermion decay modes
42528 ELSEIF((L.GE.-448.AND.L.LE.-437)
42529 & .OR.(L.GE.-328.AND.L.LE.-317)) THEN
42530 N2MODE = N2MODE+1
42531 IF(N2MODE.GT.NMODE2) THEN
42532 CALL HWWARN('HWISP2',154)
42533 GOTO 999
42534 ENDIF
42535 NME(I) = 30000+N2MODE
42536 ID2PRT(N2MODE) = I
42537 I2DRTP(N2MODE) = 8
42538 P2MODE(N2MODE) = ONE
42539 IL = IDKPRD(1,I)
42540 IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
42541 IL = INT((IL+1)/2)
42542 IF(IL.LE.3) P2MODE(N2MODE) = THREE
42543 DO 32 J=1,2
42544 32 A2MODE(J,N2MODE) = HFF(O(J),4,IL)
42545 ELSE
42546 IF(RSPIN(IDKPRD(1,I)).NE.ZERO.OR.RSPIN(IDKPRD(1,I)).NE.
42547 & ZERO) CALL HWWARN('HWISP2',7)
42548 ENDIF
42549 ENDIF
42550 ENDIF
42551 ENDIF
42552 1000 CONTINUE
42553C--now find the maximum weights and compute the decay rates
42554 DO 2000 I=1,N2MODE
42555 IF(IPRINT.EQ.2) WRITE(6,5010) RNAME(IDK(ID2PRT(I))),
42556 & RNAME(IDKPRD(1,ID2PRT(I))),RNAME(IDKPRD(2,ID2PRT(I)))
42557 2000 CALL HWD2ME(I)
42558 RETURN
42559 5010 FORMAT(/'CALCULATING TWO BODY DECAY ',
42560 & A8,' --> ',A8,' ',A8/)
42561 999 RETURN
42562 END
42563CDECK ID>, HWISP3.
42564*CMZ :- -30/09/02 14:05:28 by Peter Richardson
42565*-- Author : Peter Richardson
42566C-----------------------------------------------------------------------
42567 SUBROUTINE HWISP3
42568C-----------------------------------------------------------------------
42569C Initialise the top/SUSY three body decay modes
42570C gravitino and RPV modes added by Peter Richardson
42571C-----------------------------------------------------------------------
c63d70bc 42572 INCLUDE 'herwig65.inc'
65767955 42573 INTEGER I,J,K,L,L1,IL,IQ,IQ1,IQ2,IFR,SIFR,IH,IH1,IM,O(2),II,JJ,
42574 & III,JJJ,KKK
42575 DOUBLE PRECISION SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN(2,12,2,4),
42576 & AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
42577 & HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
42578 & HZZ(2),ZAB(12,2,2),HHB(2,3)
42579 DOUBLE COMPLEX RHOIN(2,2)
42580 COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
42581 & OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
42582 SAVE O
42583 DATA O/2,1/
42584 IF(IERROR.NE.0) RETURN
42585C--loop over the decays and find the top decays
42586 DO 1000 JJ=6,12,6
42587 DO 1000 II=1,NMODES(JJ)
42588 IF(II.EQ.1) THEN
42589 I = LSTRT(JJ)
42590 ELSE
42591 I = LNEXT(I)
42592 ENDIF
42593C--top decay via W
42594 IF(IDK(I).EQ.6.AND.NME(I).EQ.100) THEN
42595 N3MODE = N3MODE+1
42596 IF(N3MODE.GT.NMODE3) THEN
42597 CALL HWWARN('HWISP3',100)
42598 GOTO 999
42599 ENDIF
42600 P3MODE(N3MODE) = ONE
42601 IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
42602 SPN3CF(1,1,N3MODE) = ONE
42603 N3NCFL(N3MODE) = 1
42604 ID3PRT(N3MODE) = I
42605 NME(I) = 10000+N3MODE
42606 NDI3BY(N3MODE) = 1
42607 I3DRTP(1,N3MODE) = 1
42608 I3DRCF(1,N3MODE) = 1
42609 I3MODE(1,N3MODE) = 198
42610 A3MODE(1,1,N3MODE) = ZERO
42611 A3MODE(2,1,N3MODE) = -G*ORT
42612 B3MODE(1,1,N3MODE) = ZERO
42613 B3MODE(2,1,N3MODE) = -G*ORT
42614C--antitop decay via W
42615 ELSEIF(IDK(I).EQ.12.AND.NME(I).EQ.100) THEN
42616 N3MODE = N3MODE+1
42617 IF(N3MODE.GT.NMODE3) THEN
42618 CALL HWWARN('HWISP3',101)
42619 GOTO 999
42620 ENDIF
42621 P3MODE(N3MODE) = ONE
42622 IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
42623 SPN3CF(1,1,N3MODE) = ONE
42624 N3NCFL(N3MODE) = 1
42625 ID3PRT(N3MODE) = I
42626 NME(I) = 10000+N3MODE
42627 NDI3BY(N3MODE) = 1
42628 I3DRTP(1,N3MODE) = 5
42629 I3DRCF(1,N3MODE) = 1
42630 I3MODE(1,N3MODE) = 199
42631 A3MODE(1,1,N3MODE) = ZERO
42632 A3MODE(2,1,N3MODE) = -G*ORT
42633 B3MODE(1,1,N3MODE) = ZERO
42634 B3MODE(2,1,N3MODE) = -G*ORT
42635C--top decay via charged Higgs
42636 ELSEIF(IDK(I).EQ.6.AND.NME(I).EQ.200) THEN
42637 N3MODE = N3MODE+1
42638 IF(N3MODE.GT.NMODE3) THEN
42639 CALL HWWARN('HWISP3',102)
42640 GOTO 999
42641 ENDIF
42642 P3MODE(N3MODE) = ONE
42643 IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
42644 SPN3CF(1,1,N3MODE) = ONE
42645 N3NCFL(N3MODE) = 1
42646 ID3PRT(N3MODE) = I
42647 NME(I) = 10000+N3MODE
42648 NDI3BY(N3MODE) = 1
42649 I3DRTP(1,N3MODE) = 2
42650 I3DRCF(1,N3MODE) = 1
42651 I3MODE(1,N3MODE) = 206
42652 IL = IDKPRD(1,I)
42653 IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
42654 IL = INT((IL+1)/2)
42655 DO 201 J=1,2
42656 A3MODE(J,1,N3MODE) = HFF(O(J),4,3)
42657 201 B3MODE(J,1,N3MODE) = HFF( J ,4,IL)
42658C--antitop decay via charged Higgs
42659 ELSEIF(IDK(I).EQ.12.AND.NME(I).EQ.200) THEN
42660 N3MODE = N3MODE+1
42661 IF(N3MODE.GT.NMODE3) THEN
42662 CALL HWWARN('HWISP3',103)
42663 GOTO 999
42664 ENDIF
42665 P3MODE(N3MODE) = ONE
42666 IF(IDKPRD(1,I).LE.12) P3MODE(N3MODE) = THREE
42667 SPN3CF(1,1,N3MODE) = ONE
42668 N3NCFL(N3MODE) = 1
42669 ID3PRT(N3MODE) = I
42670 NME(I) = 10000+N3MODE
42671 NDI3BY(N3MODE) = 1
42672 I3DRTP(1,N3MODE) = 17
42673 I3DRCF(1,N3MODE) = 1
42674 I3MODE(1,N3MODE) = 207
42675 IL = IDKPRD(1,I)
42676 IL = IL-6*INT((IL-1)/6)+6*INT((IL-1)/120)
42677 IL = INT((IL+1)/2)
42678 DO 202 J=1,2
42679 A3MODE(J,1,N3MODE) = HFF( J ,4,3)
42680 202 B3MODE(J,1,N3MODE) = HFF(O(J),4,IL)
42681 ENDIF
42682 1000 CONTINUE
42683 IF(.NOT.SUSYIN) GOTO 2999
42684C--loop over all the SUSY decay modes and find the ones we want
42685C--first the true three body gaugino decays
42686 DO 2000 JJ=1,NRES
42687 DO 2000 II=1,NMODES(JJ)
42688 IF(II.EQ.1) THEN
42689 I = LSTRT(JJ)
42690 ELSE
42691 I = LNEXT(I)
42692 ENDIF
42693 L = IDKPRD(1,I)-449
42694 IF(IDKPRD(3,I).EQ.0.OR.IDKPRD(4,I).NE.0) GOTO 2500
42695C--gluino modes first
42696 IF(IDK(I).EQ.449) THEN
42697C--first the gluino modes to quark-antiquark neutralino
42698 IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
42699 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
42700 IQ = IDKPRD(2,I)
42701 IF(IQ.GT.6) IQ=IQ-6
42702 IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',200)
42703 N3MODE = N3MODE+1
42704 IF(N3MODE.GT.NMODE3) THEN
42705 CALL HWWARN('HWISP3',104)
42706 GOTO 999
42707 ENDIF
42708 P3MODE(N3MODE) = HALF
42709 SPN3CF(1,1,N3MODE) = ONE
42710 N3NCFL(N3MODE) = 1
42711 ID3PRT(N3MODE) = I
42712 NME(I) = 10000+N3MODE
42713 NDI3BY(N3MODE) = 4
42714C--only squark exchange diagrams
42715 DO 1 K=1,2
42716 I3DRTP(K ,N3MODE) = 3
42717 I3DRCF(K ,N3MODE) = 1
42718 I3DRTP(K+2,N3MODE) = 4
42719 I3DRCF(K+2,N3MODE) = 1
42720 I3MODE(K ,N3MODE) = 12*(K-1)+400+IQ
42721 I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ
42722 DO 1 J=1,2
42723 A3MODE(J,K ,N3MODE) = AFG( J ,IQ,K)
42724 B3MODE(J,K ,N3MODE) = AFN(O(J),IQ,K,L)
42725 A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ,K)
42726 1 B3MODE(J,K+2,N3MODE) = ZSGNSS(L)*AFN( J ,IQ,K,L)
42727C--then the gluino modes to quark-antiquark +ve chargino
42728 ELSEIF(L.EQ.5.OR.L.EQ.6.AND.(IDKPRD(2,I).LE.12.OR.
42729 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
42730 L = L-4
42731 IQ = IDKPRD(2,I)
42732 IF(IQ.GT.6) IQ=IQ-6
42733 IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',201)
42734 IQ = (IQ+MOD(IQ,2))/2
42735 IQ1 = 2*IQ-1
42736 IQ2 = 2*IQ
42737 N3MODE = N3MODE+1
42738 IF(N3MODE.GT.NMODE3) THEN
42739 CALL HWWARN('HWISP3',105)
42740 GOTO 999
42741 ENDIF
42742 P3MODE(N3MODE) = HALF
42743 SPN3CF(1,1,N3MODE) = ONE
42744 N3NCFL(N3MODE) = 1
42745 ID3PRT(N3MODE) = I
42746 NME(I) = 10000+N3MODE
42747 NDI3BY(N3MODE) = 4
42748C--only squark exchange diagrams
42749 DO 2 K=1,2
42750 I3DRTP(K ,N3MODE) = 3
42751 I3DRCF(K ,N3MODE) = 1
42752 I3DRTP(K+2,N3MODE) = 4
42753 I3DRCF(K+2,N3MODE) = 1
42754 I3MODE(K ,N3MODE) = 12*(K-1)+400+IQ1
42755 I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ2
42756 DO 2 J=1,2
42757 A3MODE(J,K ,N3MODE) = AFG( J ,IQ1,K)
42758 B3MODE(J,K ,N3MODE) = AFC(O(J),IQ1,K,L)
42759 A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ2,K)
42760 2 B3MODE(J,K+2,N3MODE) = AFC( J ,IQ2,K,L)
42761C--then the gluino modes to quark-antiquark -ve chargino
42762 ELSEIF(L.EQ.7.OR.L.EQ.8.AND.(IDKPRD(2,I).LE.12.OR.
42763 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
42764 L = L-6
42765 IQ = IDKPRD(2,I)
42766 IF(IQ.GT.6) IQ=IQ-6
42767 IF(IQ.GT.6.OR.IQ.LT.1) CALL HWWARN('HWISP3',202)
42768 IQ = (IQ+MOD(IQ,2))/2
42769 IQ1 = 2*IQ
42770 IQ2 = 2*IQ-1
42771 N3MODE = N3MODE+1
42772 IF(N3MODE.GT.NMODE3) THEN
42773 CALL HWWARN('HWISP3',106)
42774 GOTO 999
42775 ENDIF
42776 P3MODE(N3MODE) = HALF
42777 SPN3CF(1,1,N3MODE) = ONE
42778 N3NCFL(N3MODE) = 1
42779 ID3PRT(N3MODE) = I
42780 NME(I) = 10000+N3MODE
42781 NDI3BY(N3MODE) = 4
42782C--only squark exchange diagrams
42783 DO 3 K=1,2
42784 I3DRTP(K ,N3MODE) = 3
42785 I3DRCF(K ,N3MODE) = 1
42786 I3DRTP(K+2,N3MODE) = 4
42787 I3DRCF(K+2,N3MODE) = 1
42788 I3MODE(K ,N3MODE) = 12*(K-1)+400+IQ1
42789 I3MODE(K+2,N3MODE) = 12*(K-1)+406+IQ2
42790 DO 3 J=1,2
42791 A3MODE(J,K ,N3MODE) = AFG( J ,IQ1,K)
42792 B3MODE(J,K ,N3MODE) = AFC(O(J),IQ1,K,L)
42793 A3MODE(J,K+2,N3MODE) = AFG(O(J),IQ2,K)
42794 3 B3MODE(J,K+2,N3MODE) = AFC( J ,IQ2,K,L)
42795C--RPV decay modes
42796C--LQD first
42797 ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
42798 & IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12) THEN
42799 N3MODE = N3MODE+1
42800 IF(N3MODE.GT.NMODE3) THEN
42801 CALL HWWARN('HWISP3',107)
42802 GOTO 999
42803 ENDIF
42804 ID3PRT(N3MODE) = I
42805 NME(I) = 10000+N3MODE
42806 P3MODE(N3MODE) = HALF
42807 SPN3CF(1,1,N3MODE) = ONE
42808 N3NCFL(N3MODE) = 1
42809 NDI3BY(N3MODE) = 4
42810 DO 98 J=1,4
42811 98 I3DRCF(J,N3MODE) = 1
42812C--first the neutrino mode
42813 IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
42814C--particle mode
42815 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
42816 III = (IDKPRD(1,I)-120)/2
42817 JJJ = (IDKPRD(2,I)+1)/2
42818 KKK = (IDKPRD(3,I)-5)/2
42819 DO 99 K=1,2
42820 I3DRTP(K ,N3MODE) = 3
42821 I3DRTP(K+2,N3MODE) = 4
42822 I3MODE(K ,N3MODE) = 399+2*JJJ+(K-1)*12
42823 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
42824 B3MODE(2,K ,N3MODE) = 0.0D0
42825 B3MODE(1,K ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
42826 & LAMDA2(III,JJJ,KKK)
42827 B3MODE(2,K+2,N3MODE) = 0.0D0
42828 B3MODE(1,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
42829 & LAMDA2(III,JJJ,KKK)
42830 DO 99 J=1,2
42831 A3MODE(J,K ,N3MODE) = AFG( J ,2*JJJ-1,K)
42832 99 A3MODE(J,K+2,N3MODE) = AFG(O(J),2*KKK-1,K)
42833C--antiparticle mode
42834 ELSE
42835 III = (IDKPRD(1,I)-126)/2
42836 JJJ = (IDKPRD(2,I)-5)/2
42837 KKK = (IDKPRD(3,I)+1)/2
42838 DO 101 K=1,2
42839 I3DRTP(K ,N3MODE) = 9
42840 I3DRTP(K+2,N3MODE) = 10
42841 I3MODE(K ,N3MODE) = 399+2*JJJ+(K-1)*12
42842 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
42843 B3MODE(1,K ,N3MODE) = 0.0D0
42844 B3MODE(2,K ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
42845 & LAMDA2(III,JJJ,KKK)
42846 B3MODE(1,K+2,N3MODE) = 0.0D0
42847 B3MODE(2,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
42848 & LAMDA2(III,JJJ,KKK)
42849 DO 101 J=1,2
42850 A3MODE(J,K ,N3MODE) = AFG(O(J),2*JJJ-1,K)
42851 101 A3MODE(J,K+2,N3MODE) = AFG( J ,2*KKK-1,K)
42852 ENDIF
42853C--then the charged lepton mode
42854 ELSE
42855C--particle mode
42856 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
42857 III = (IDKPRD(1,I)-119)/2
42858 JJJ = IDKPRD(2,I)/2
42859 KKK = (IDKPRD(3,I)-5)/2
42860 DO 102 K=1,2
42861 I3DRTP(K ,N3MODE) = 3
42862 I3DRTP(K+2,N3MODE) = 4
42863 I3MODE(K ,N3MODE) = 400+2*JJJ+(K-1)*12
42864 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
42865 B3MODE(2,K ,N3MODE) = 0.0D0
42866 B3MODE(1,K ,N3MODE) = QMIXSS(2*JJJ,1,K)*
42867 & LAMDA2(III,JJJ,KKK)
42868 B3MODE(2,K+2,N3MODE) = 0.0D0
42869 B3MODE(1,K+2,N3MODE) = QMIXSS(2*KKK-1,2,K)*
42870 & LAMDA2(III,JJJ,KKK)
42871 DO 102 J=1,2
42872 A3MODE(J,K ,N3MODE) = AFG( J ,2*JJJ ,K)
42873 102 A3MODE(J,K+2,N3MODE) = AFG(O(J),2*KKK-1,K)
42874C--antiparticle mode
42875 ELSE
42876 III = (IDKPRD(1,I)-125)/2
42877 JJJ = (IDKPRD(2,I)-6)/2
42878 KKK = (IDKPRD(3,I)+1)/2
42879 DO 103 K=1,2
42880 I3DRTP(K ,N3MODE) = 9
42881 I3DRTP(K+2,N3MODE) = 10
42882 I3MODE(K ,N3MODE) = 400+2*JJJ+(K-1)*12
42883 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
42884 B3MODE(1,K ,N3MODE) = 0.0D0
42885 B3MODE(2,K ,N3MODE) = QMIXSS(2*JJJ,1,K)*
42886 & LAMDA2(III,JJJ,KKK)
42887 B3MODE(1,K+2,N3MODE) = 0.0D0
42888 B3MODE(2,K+2,N3MODE) = QMIXSS(2*KKK-1,2,K)*
42889 & LAMDA2(III,JJJ,KKK)
42890 DO 103 J=1,2
42891 A3MODE(J,K ,N3MODE) = AFG(O(J),2*JJJ ,K)
42892 103 A3MODE(J,K+2,N3MODE) = AFG( J ,2*KKK-1,K)
42893 ENDIF
42894 ENDIF
42895C--then UDD
42896 ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
42897 & IDKPRD(3,I).LE.12) THEN
42898 N3MODE = N3MODE+1
42899 IF(N3MODE.GT.NMODE3) THEN
42900 CALL HWWARN('HWISP3',108)
42901 GOTO 999
42902 ENDIF
42903 P3MODE(N3MODE) = ONE
42904 N3NCFL(N3MODE) = 3
42905 ID3PRT(N3MODE) = I
42906 NME(I) = 10000+N3MODE
42907 NDI3BY(N3MODE) = 6
42908 DO 70 J=1,3
42909 DO 70 K=1,3
42910 IF(J.NE.K) THEN
42911 SPN3CF(J,K,N3MODE) = -HALF
42912 ELSE
42913 SPN3CF(J,K,N3MODE) = ONE
42914 ENDIF
42915 70 CONTINUE
42916C--particle mode
42917 IF(IDKPRD(1,I).LE.6) THEN
42918C--antiparticle mode
42919 III = IDKPRD(1,I)/2
42920 JJJ = (IDKPRD(2,I)+1)/2
42921 KKK = (IDKPRD(3,I)+1)/2
42922 DO 71 K=1,2
42923 I3DRTP(K ,N3MODE) = 11
42924 I3DRCF(K ,N3MODE) = 1
42925 I3DRTP(K+2,N3MODE) = 12
42926 I3DRCF(K+2,N3MODE) = 2
42927 I3DRTP(K+4,N3MODE) = 13
42928 I3DRCF(K+4,N3MODE) = 3
42929 I3MODE(K ,N3MODE) = 400+2*III+(K-1)*12
42930 I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
42931 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
42932 B3MODE(2,K ,N3MODE) = QMIXSS(2*III,2,K)*
42933 & LAMDA3(III,JJJ,KKK)
42934 B3MODE(2,K+2,N3MODE) = QMIXSS(2*JJJ-1,2,K)*
42935 & LAMDA3(III,JJJ,KKK)
42936 B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
42937 & LAMDA3(III,JJJ,KKK)
42938 B3MODE(1,K ,N3MODE) = 0.0D0
42939 B3MODE(1,K+2,N3MODE) = 0.0D0
42940 B3MODE(1,K+4,N3MODE) = 0.0D0
42941 DO 71 J=1,2
42942 A3MODE(J,K ,N3MODE) = AFG(J,2*III ,K)
42943 A3MODE(J,K+2,N3MODE) = AFG(J,2*JJJ-1,K)
42944 71 A3MODE(J,K+4,N3MODE) = AFG(J,2*KKK-1,K)
42945 ELSE
42946 III = (IDKPRD(1,I)-6)/2
42947 JJJ = (IDKPRD(2,I)-5)/2
42948 KKK = (IDKPRD(3,I)-5)/2
42949 DO 72 K=1,2
42950 I3DRTP(K ,N3MODE) = 14
42951 I3DRCF(K ,N3MODE) = 1
42952 I3DRTP(K+2,N3MODE) = 15
42953 I3DRCF(K+2,N3MODE) = 2
42954 I3DRTP(K+4,N3MODE) = 16
42955 I3DRCF(K+4,N3MODE) = 3
42956 I3MODE(K ,N3MODE) = 400+2*III+(K-1)*12
42957 I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
42958 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
42959 B3MODE(1,K ,N3MODE) = QMIXSS(2*III,2,K)*
42960 & LAMDA3(III,JJJ,KKK)
42961 B3MODE(1,K+2,N3MODE) = QMIXSS(2*JJJ-1,2,K)*
42962 & LAMDA3(III,JJJ,KKK)
42963 B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
42964 & LAMDA3(III,JJJ,KKK)
42965 B3MODE(2,K ,N3MODE) = 0.0D0
42966 B3MODE(2,K+2,N3MODE) = 0.0D0
42967 B3MODE(2,K+4,N3MODE) = 0.0D0
42968 DO 72 J=1,2
42969 A3MODE(J,K ,N3MODE) = AFG(O(J),2*III ,K)
42970 A3MODE(J,K+2,N3MODE) = AFG(O(J),2*JJJ-1,K)
42971 72 A3MODE(J,K+4,N3MODE) = AFG(O(J),2*KKK-1,K)
42972 ENDIF
42973C--unrecognized decay issue warning
42974 ELSE
42975 CALL HWWARN('HWISP3',1)
42976 ENDIF
42977 ELSEIF(IDK(I).GE.450.AND.IDK(I).LE.453) THEN
42978 L1 = IDK(I)-449
42979C--neutralino modes next
42980 IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
42981 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
42982C--first the neutralino modes to fermion-antifermion neutralino
42983 IFR = IDKPRD(2,I)
42984 J = INT((IFR-1)/120)
42985 IFR = IFR-6*INT((IFR-1)/6)+6*J
42986 IL = IFR+4*J
42987 SIFR = IFR+18*J
42988 N3MODE = N3MODE+1
42989 IF(N3MODE.GT.NMODE3) THEN
42990 CALL HWWARN('HWISP3',109)
42991 GOTO 999
42992 ENDIF
42993 P3MODE(N3MODE) = ONE
42994 IF(IFR.LE.6) P3MODE(N3MODE)=THREE
42995 SPN3CF(1,1,N3MODE) = ONE
42996 N3NCFL(N3MODE) = 1
42997 ID3PRT(N3MODE) = I
42998 NME(I) = 10000+N3MODE
42999 NDI3BY(N3MODE) = 4
43000C--sfermion exchange diagrams
43001 DO 4 K=1,2
43002 I3DRTP(K ,N3MODE) = 3
43003 I3DRCF(K ,N3MODE) = 1
43004 I3DRTP(K+2,N3MODE) = 4
43005 I3DRCF(K+2,N3MODE) = 1
43006 I3MODE(K ,N3MODE) = 12*(K-1)+400+SIFR
43007 I3MODE(K+2,N3MODE) = 12*(K-1)+406+SIFR
43008 DO 4 J=1,2
43009 A3MODE(J,K ,N3MODE) = AFN( J ,IFR,K,L1)
43010 B3MODE(J,K ,N3MODE) = AFN(O(J),IFR,K,L )
43011 A3MODE(J,K+2,N3MODE) = ZSGNSS(L1)*AFN(O(J),IFR,K,L1)
43012 4 B3MODE(J,K+2,N3MODE) = ZSGNSS(L )*AFN( J ,IFR,K,L )
43013C--now add higgs diagrams if third generation fermion, if Higgs off shell
43014 IF(IFR.EQ.5.OR.IFR.EQ.6.OR.IFR.EQ.11) THEN
43015 DO 5 J=1,3
43016 IF(RMASS(IDK(I)).LT.
43017 & RMASS(203+J)+RMASS(IDKPRD(1,I))) THEN
43018 NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
43019 I3DRTP( NDI3BY(N3MODE),N3MODE) = 2
43020 I3DRCF( NDI3BY(N3MODE),N3MODE) = 1
43021 I3MODE( NDI3BY(N3MODE),N3MODE) = 203+J
43022 DO 6 K=1,2
43023 A3MODE(K,NDI3BY(N3MODE),N3MODE) = HNN(K,J,L,L1)
43024 6 B3MODE(K,NDI3BY(N3MODE),N3MODE) = HFF(K,J,IFR)
43025 ENDIF
43026 5 CONTINUE
43027 ENDIF
43028C-- and gauge boson diagrams if Z not on-shell
43029 IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN
43030 NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
43031 I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
43032 I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
43033 I3MODE(NDI3BY(N3MODE),N3MODE) = 200
43034 DO 7 J=1,2
43035 7 A3MODE(J,NDI3BY(N3MODE),N3MODE) = OIJPP(J,L,L1)
43036 B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL)
43037 B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL)
43038 ENDIF
43039 ELSEIF(L.EQ.5.OR.L.EQ.6.AND.(IDKPRD(2,I).LE.12.OR.
43040 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
43041C--then the neutralino modes to fermion-antifermion +ve chargino
43042C--NB ISAJET ONLY HAS W EXCHANGE AND THEREFORE SO DO WE
43043 IF(RMASS(IDK(I)).GT.MW+RMASS(IDKPRD(1,I))) GOTO 2000
43044 L = L-4
43045 N3MODE = N3MODE+1
43046 IF(N3MODE.GT.NMODE3) THEN
43047 CALL HWWARN('HWISP3',110)
43048 GOTO 999
43049 ENDIF
43050 ID3PRT(N3MODE) = I
43051 NME(I) = 10000+N3MODE
43052 NDI3BY(N3MODE) = 1
43053 P3MODE(N3MODE) = ONE
43054 IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
43055 SPN3CF(1,1,N3MODE) = ONE
43056 N3NCFL(N3MODE) = 1
43057C--gauge boson diagram
43058 I3DRTP(1,N3MODE) = 1
43059 I3DRCF(1,N3MODE) = 1
43060 I3MODE(1,N3MODE) = 199
43061 DO 8 J=1,2
43062 8 A3MODE(J,1,N3MODE) = OIJ(J,L1,L)
43063 B3MODE(1,1,N3MODE) = ZERO
43064 B3MODE(2,1,N3MODE) = -G*ORT
43065 ELSEIF(L.EQ.7.OR.L.EQ.8.AND.(IDKPRD(2,I).LE.12.OR.
43066 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
43067C--then the neutralino modes to fermion-antifermion -ve chargino
43068C--NB ISAJET ONLY HAS W EXCHANGE AND THEREFORE SO DO WE
43069 IF(RMASS(IDK(I)).GT.MW+RMASS(IDKPRD(1,I))) GOTO 2000
43070 L = L-6
43071 N3MODE = N3MODE+1
43072 IF(N3MODE.GT.NMODE3) THEN
43073 CALL HWWARN('HWISP3',111)
43074 GOTO 999
43075 ENDIF
43076 ID3PRT(N3MODE) = I
43077 NME(I) = 10000+N3MODE
43078 NDI3BY(N3MODE) = 1
43079 P3MODE(N3MODE) = ONE
43080 IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
43081 SPN3CF(1,1,N3MODE) = ONE
43082 N3NCFL(N3MODE) = 1
43083C--gauge boson diagram
43084 I3DRTP(1,N3MODE) = 1
43085 I3DRCF(1,N3MODE) = 1
43086 I3MODE(1,N3MODE) = 198
43087 DO 9 J=1,2
43088 9 A3MODE(J,1,N3MODE) =-OIJ(O(J),L1,L)
43089 B3MODE(1,1,N3MODE) = ZERO
43090 B3MODE(2,1,N3MODE) = -G*ORT
43091C--gravitino E+e- modes
43092 ELSEIF(L.EQ.9.AND.(IDKPRD(2,I).LE.12.OR.
43093 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
43094 IFR = IDKPRD(2,I)
43095 J = INT((IFR-1)/120)
43096 IFR = IFR-6*INT((IFR-1)/6)+6*J
43097 IL = IFR+4*J
43098 N3MODE = N3MODE+1
43099 IF(N3MODE.GT.NMODE3) THEN
43100 CALL HWWARN('HWISP3',112)
43101 GOTO 999
43102 ENDIF
43103 ID3PRT(N3MODE) = I
43104 NME(I) = 10000+N3MODE
43105 NDI3BY(N3MODE) = 1
43106 P3MODE(N3MODE) = ONE
43107 IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
43108 SPN3CF(1,1,N3MODE) = ONE
43109 N3NCFL(N3MODE) = 1
43110C--diagram
43111 I3DRTP(1,N3MODE) = 7
43112 I3DRCF(1,N3MODE) = 1
43113 I3MODE(1,N3MODE) = 59
43114 A3MODE(1,1,N3MODE) = 2.0D0/SQRT(6.0D0)*ZMIXSS(L1,1)
43115 A3MODE(2,1,N3MODE) = 0
43116 B3MODE(1,1,N3MODE) = -E*QFCH(IL)
43117 B3MODE(2,1,N3MODE) = -E*QFCH(IL)
43118C--R-parity violating modes
43119C--LLE modes
43120 ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
43121 & IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
43122 & IDKPRD(3,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN
43123 N3MODE = N3MODE+1
43124 IF(N3MODE.GT.NMODE3) THEN
43125 CALL HWWARN('HWISP3',113)
43126 GOTO 999
43127 ENDIF
43128 ID3PRT(N3MODE) = I
43129 NME(I) = 10000+N3MODE
43130 NDI3BY(N3MODE) = 5
43131 P3MODE(N3MODE) = ONE
43132 SPN3CF(1,1,N3MODE) = ONE
43133 N3NCFL(N3MODE) = 1
43134C--particle mode
43135 DO 53 J=1,6
43136 53 I3DRCF(J,N3MODE) = 1
43137 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
43138 III = (IDKPRD(1,I)-119)/2
43139 JJJ = (IDKPRD(2,I)-120)/2
43140 KKK = (IDKPRD(3,I)-125)/2
43141 DO 51 J=1,2
43142 I3DRTP(J ,N3MODE) = 2
43143 I3DRTP(J+2,N3MODE) = 4
43144 I3MODE(J ,N3MODE) = 423+2*III+(J-1)*12
43145 I3MODE(J+2,N3MODE) = 423+2*KKK+(J-1)*12
43146 B3MODE(1,J ,N3MODE) = LMIXSS(2*III-1,1,J)*
43147 & LAMDA1(III,JJJ,KKK)
43148 B3MODE(2,J ,N3MODE) = 0.0D0
43149 B3MODE(1,J+2,N3MODE) = LMIXSS(2*KKK-1,2,J)*
43150 & LAMDA1(III,JJJ,KKK)
43151 B3MODE(2,J+2,N3MODE) = 0.0D0
43152 DO 51 K=1,2
43153 A3MODE(K,J ,N3MODE) = AFN( K ,5+2*III,J,L1)
43154 51 A3MODE(K,J+2,N3MODE) = AFN(O(K),5+2*KKK,J,L1)
43155 DO 48 K=1,2
43156 48 A3MODE(K,5,N3MODE) = AFN( K ,6+2*JJJ,1,L1)
43157 I3DRTP(5,N3MODE) = 3
43158 I3MODE(5,N3MODE) = 430+2*JJJ
43159 B3MODE(1,5,N3MODE) = LAMDA1(III,JJJ,KKK)
43160 B3MODE(2,5,N3MODE) = 0.0D0
43161C--antiparticle mode
43162 ELSE
43163 III = (IDKPRD(1,I)-125)/2
43164 JJJ = (IDKPRD(2,I)-126)/2
43165 KKK = (IDKPRD(3,I)-119)/2
43166 DO 52 J=1,2
43167 I3DRTP(J ,N3MODE) = 8
43168 I3DRTP(J+2,N3MODE) = 10
43169 I3MODE(J ,N3MODE) = 423+2*III+(J-1)*12
43170 I3MODE(J+2,N3MODE) = 423+2*KKK+(J-1)*12
43171 B3MODE(2,J ,N3MODE) = LMIXSS(2*III-1,1,J)*
43172 & LAMDA1(III,JJJ,KKK)
43173 B3MODE(1,J ,N3MODE) = 0.0D0
43174 B3MODE(2,J+2,N3MODE) = LMIXSS(2*KKK-1,2,J)*
43175 & LAMDA1(III,JJJ,KKK)
43176 B3MODE(1,J+2,N3MODE) = 0.0D0
43177 DO 52 K=1,2
43178 A3MODE(K,J ,N3MODE) = AFN(O(K),5+2*III,J,L1)
43179 52 A3MODE(K,J+2,N3MODE) = AFN( K ,5+2*KKK,J,L1)
43180 DO 49 K=1,2
43181 49 A3MODE(K,5,N3MODE) = AFN(O(K),6+2*JJJ,1,L1)
43182 I3DRTP(5,N3MODE) = 9
43183 I3MODE(5,N3MODE) = 430+2*JJJ
43184 B3MODE(2,5,N3MODE) = LAMDA1(III,JJJ,KKK)
43185 B3MODE(1,5,N3MODE) = 0.0D0
43186 ENDIF
43187C--LQD modes
43188 ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
43189 & IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE.12) THEN
43190 N3MODE = N3MODE+1
43191 IF(N3MODE.GT.NMODE3) THEN
43192 CALL HWWARN('HWISP3',114)
43193 GOTO 999
43194 ENDIF
43195 ID3PRT(N3MODE) = I
43196 NME(I) = 10000+N3MODE
43197 P3MODE(N3MODE) = 3.0D0
43198 SPN3CF(1,1,N3MODE) = ONE
43199 N3NCFL(N3MODE) = 1
43200 DO 81 J=1,6
43201 81 I3DRCF(J,N3MODE) = 1
43202C--first the neutrino mode
43203 IF(MOD(IDKPRD(1,I),2).EQ.0) THEN
43204 NDI3BY(N3MODE) = 5
43205C--particle mode
43206 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
43207 III = (IDKPRD(1,I)-120)/2
43208 JJJ = (IDKPRD(2,I)+1)/2
43209 KKK = (IDKPRD(3,I)-5)/2
43210 DO 82 K=1,2
43211 I3DRTP(K ,N3MODE) = 3
43212 I3DRTP(K+2,N3MODE) = 4
43213 I3MODE(K ,N3MODE) = 399+2*JJJ+(K-1)*12
43214 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
43215 B3MODE(2,K ,N3MODE) = 0.0D0
43216 B3MODE(1,K ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
43217 & LAMDA2(III,JJJ,KKK)
43218 B3MODE(2,K+2,N3MODE) = 0.0D0
43219 B3MODE(1,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
43220 & LAMDA2(III,JJJ,KKK)
43221 DO 82 J=1,2
43222 A3MODE(J,K ,N3MODE) = AFN( J ,2*JJJ-1,K,L1)
43223 82 A3MODE(J,K+2,N3MODE) = AFN(O(J),2*KKK-1,K,L1)
43224 I3DRTP(5,N3MODE) = 2
43225 I3MODE(5,N3MODE) = 424+2*III
43226 B3MODE(2,5,N3MODE) = 0.0D0
43227 B3MODE(1,5,N3MODE) = -LAMDA2(III,JJJ,KKK)
43228 DO 83 J=1,2
43229 83 A3MODE(J,5,N3MODE) = AFN(J,6+2*III,1,L1)
43230C--antiparticle mode
43231 ELSE
43232 III = (IDKPRD(1,I)-126)/2
43233 JJJ = (IDKPRD(2,I)-5)/2
43234 KKK = (IDKPRD(3,I)+1)/2
43235 DO 84 K=1,2
43236 I3DRTP(K ,N3MODE) = 9
43237 I3DRTP(K+2,N3MODE) = 10
43238 I3MODE(K ,N3MODE) = 399+2*JJJ+(K-1)*12
43239 I3MODE(K+2,N3MODE) = 399+2*KKK+(K-1)*12
43240 B3MODE(1,K ,N3MODE) = 0.0D0
43241 B3MODE(2,K ,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
43242 & LAMDA2(III,JJJ,KKK)
43243 B3MODE(1,K+2,N3MODE) = 0.0D0
43244 B3MODE(2,K+2,N3MODE) = -QMIXSS(2*KKK-1,2,K)*
43245 & LAMDA2(III,JJJ,KKK)
43246 DO 84 J=1,2
43247 A3MODE(J,K ,N3MODE) = AFN(O(J),2*JJJ-1,K,L1)
43248 84 A3MODE(J,K+2,N3MODE) = AFN( J ,2*KKK-1,K,L1)
43249 I3DRTP(5,N3MODE) = 8
43250 I3MODE(5,N3MODE) = 424+2*III
43251 B3MODE(1,5,N3MODE) = 0.0D0
43252 B3MODE(2,5,N3MODE) = -LAMDA2(III,JJJ,KKK)
43253 DO 85 J=1,2
43254 85 A3MODE(J,5,N3MODE) = AFN(O(J),6+2*III,1,L1)
43255 ENDIF
43256C--then the charged lepton mode
43257 ELSE
43258 NDI3BY(N3MODE) = 6
43259C--particle mode
43260 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
43261 III = (IDKPRD(1,I)-119)/2
43262 JJJ = IDKPRD(2,I)/2
43263 KKK = (IDKPRD(3,I)-5)/2
43264 DO 86 K=1,2
43265 I3DRTP(K ,N3MODE) = 2
43266 I3DRTP(K+2,N3MODE) = 3
43267 I3DRTP(K+4,N3MODE) = 4
43268 I3MODE(K ,N3MODE) = 423+2*III+(K-1)*12
43269 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
43270 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
43271 B3MODE(2,K ,N3MODE) = 0.0D0
43272 B3MODE(1,K ,N3MODE) = LMIXSS(2*III-1,1,K)*
43273 & LAMDA2(III,JJJ,KKK)
43274 B3MODE(2,K+2,N3MODE) = 0.0D0
43275 B3MODE(1,K+2,N3MODE) = QMIXSS(2*JJJ,1,K)*
43276 & LAMDA2(III,JJJ,KKK)
43277 B3MODE(2,K+4,N3MODE) = 0.0D0
43278 B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
43279 & LAMDA2(III,JJJ,KKK)
43280 DO 86 J=1,2
43281 A3MODE(J,K ,N3MODE) = AFN( J ,2*III+5,K,L1)
43282 A3MODE(J,K+2,N3MODE) = AFN( J ,2*JJJ ,K,L1)
43283 86 A3MODE(J,K+4,N3MODE) = AFN(O(J),2*KKK-1,K,L1)
43284C--antiparticle mode
43285 ELSE
43286 III = (IDKPRD(1,I)-125)/2
43287 JJJ = (IDKPRD(2,I)-6)/2
43288 KKK = (IDKPRD(3,I)+1)/2
43289 DO 87 K=1,2
43290 I3DRTP(K ,N3MODE) = 8
43291 I3DRTP(K+2,N3MODE) = 9
43292 I3DRTP(K+4,N3MODE) = 10
43293 I3MODE(K ,N3MODE) = 423+2*III+(K-1)*12
43294 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
43295 I3MODE(K+4,N3MODE) = 399+2*KKK+(K-1)*12
43296 B3MODE(1,K ,N3MODE) = 0.0D0
43297 B3MODE(2,K ,N3MODE) = LMIXSS(2*III-1,1,K)*
43298 & LAMDA2(III,JJJ,KKK)
43299 B3MODE(1,K+2,N3MODE) = 0.0D0
43300 B3MODE(2,K+2,N3MODE) = QMIXSS(2*JJJ,1,K)*
43301 & LAMDA2(III,JJJ,KKK)
43302 B3MODE(1,K+4,N3MODE) = 0.0D0
43303 B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK-1,2,K)*
43304 & LAMDA2(III,JJJ,KKK)
43305 DO 87 J=1,2
43306 A3MODE(J,K ,N3MODE) = AFN(O(J),2*III+5,K,L1)
43307 A3MODE(J,K+2,N3MODE) = AFN(O(J),2*JJJ ,K,L1)
43308 87 A3MODE(J,K+4,N3MODE) = AFN( J ,2*KKK-1,K,L1)
43309 ENDIF
43310 ENDIF
43311C--UDD modes
43312 ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
43313 & IDKPRD(3,I).LE.12) THEN
43314 N3MODE = N3MODE+1
43315 IF(N3MODE.GT.NMODE3) THEN
43316 CALL HWWARN('HWISP3',115)
43317 GOTO 999
43318 ENDIF
43319 ID3PRT(N3MODE) = I
43320 NME(I) = 10000+N3MODE
43321 NDI3BY(N3MODE) = 6
43322 P3MODE(N3MODE) = 6.0D0
43323 SPN3CF(1,1,N3MODE) = ONE
43324 N3NCFL(N3MODE) = 1
43325 DO 61 J=1,6
43326 61 I3DRCF(J,N3MODE) = 1
43327C--particle mode
43328 IF(IDPDG(IDKPRD(1,I)).GT.0) THEN
43329 III = IDKPRD(1,I)/2
43330 JJJ = (IDKPRD(2,I)+1)/2
43331 KKK = (IDKPRD(3,I)+1)/2
43332 DO 62 J=1,2
43333 I3DRTP(J ,N3MODE) = 11
43334 I3DRTP(J+2,N3MODE) = 12
43335 I3DRTP(J+4,N3MODE) = 13
43336 I3MODE(J ,N3MODE) = 400+2*III+(J-1)*12
43337 I3MODE(J+2,N3MODE) = 399+2*JJJ+(J-1)*12
43338 I3MODE(J+4,N3MODE) = 399+2*KKK+(J-1)*12
43339 B3MODE(2,J ,N3MODE) = QMIXSS(2*III,2,J)*
43340 & LAMDA3(III,JJJ,KKK)
43341 B3MODE(2,J+2,N3MODE) = QMIXSS(2*JJJ-1,2,J)*
43342 & LAMDA3(III,JJJ,KKK)
43343 B3MODE(2,J+4,N3MODE) = QMIXSS(2*KKK-1,2,J)*
43344 & LAMDA3(III,JJJ,KKK)
43345 B3MODE(1,J ,N3MODE) = 0.0D0
43346 B3MODE(1,J+2,N3MODE) = 0.0D0
43347 B3MODE(1,J+4,N3MODE) = 0.0D0
43348 DO 62 K=1,2
43349 A3MODE(K,J ,N3MODE) = AFN(K,2*III ,J,L1)
43350 A3MODE(K,J+2,N3MODE) = AFN(K,2*JJJ-1,J,L1)
43351 62 A3MODE(K,J+4,N3MODE) = AFN(K,2*KKK-1,J,L1)
43352C--antiparticle mode
43353 ELSE
43354 III = (IDKPRD(1,I)-6)/2
43355 JJJ = (IDKPRD(2,I)-5)/2
43356 KKK = (IDKPRD(3,I)-5)/2
43357 DO 63 J=1,2
43358 I3DRTP(J ,N3MODE) = 14
43359 I3DRTP(J+2,N3MODE) = 15
43360 I3DRTP(J+4,N3MODE) = 16
43361 I3MODE(J ,N3MODE) = 400+2*III+(J-1)*12
43362 I3MODE(J+2,N3MODE) = 399+2*JJJ+(J-1)*12
43363 I3MODE(J+4,N3MODE) = 399+2*KKK+(J-1)*12
43364 B3MODE(2,J ,N3MODE) = 0.0D0
43365 B3MODE(2,J+2,N3MODE) = 0.0D0
43366 B3MODE(2,J+4,N3MODE) = 0.0D0
43367 B3MODE(1,J ,N3MODE) = QMIXSS(2*III,2,J)*
43368 & LAMDA3(III,JJJ,KKK)
43369 B3MODE(1,J+2,N3MODE) = QMIXSS(2*JJJ-1,2,J)*
43370 & LAMDA3(III,JJJ,KKK)
43371 B3MODE(1,J+4,N3MODE) = QMIXSS(2*KKK-1,2,J)*
43372 & LAMDA3(III,JJJ,KKK)
43373 DO 63 K=1,2
43374 A3MODE(K,J ,N3MODE) = AFN(O(K),2*III ,J,L1)
43375 A3MODE(K,J+2,N3MODE) = AFN(O(K),2*JJJ-1,J,L1)
43376 63 A3MODE(K,J+4,N3MODE) = AFN(O(K),2*KKK-1,J,L1)
43377 ENDIF
43378C--unrecognized decay issue warning
43379 ELSE
43380 CALL HWWARN('HWISP3',2)
43381 ENDIF
43382 ELSEIF(IDK(I).GE.454.AND.IDK(I).LE.455) THEN
43383C--+ve chargino modes
43384C--first the chargino modes to fermion-antifermion neutralino
43385 IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
43386 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
43387 IFR = IDKPRD(2,I)
43388 IFR = IFR+MOD(IFR,2)
43389 J = INT((IFR-1)/120)
43390 IFR = IFR-6*INT((IFR-1)/6)+6*J
43391 IL = IFR+4*J
43392 SIFR = IFR+18*J
43393 L1 = IDK(I)-453
43394 N3MODE = N3MODE+1
43395 IF(N3MODE.GT.NMODE3) THEN
43396 CALL HWWARN('HWISP3',116)
43397 GOTO 999
43398 ENDIF
43399 ID3PRT(N3MODE) = I
43400 NME(I) = 10000+N3MODE
43401 NDI3BY(N3MODE) = 4
43402 P3MODE(N3MODE) = ONE
43403 IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
43404 SPN3CF(1,1,N3MODE) = ONE
43405 N3NCFL(N3MODE) = 1
43406C--sfermion exchange diagrams
43407 DO 10 K=1,2
43408 I3DRTP(K ,N3MODE) = 3
43409 I3DRCF(K ,N3MODE) = 1
43410 I3DRTP(K+2,N3MODE) = 4
43411 I3DRCF(K+2,N3MODE) = 1
43412 I3MODE(K ,N3MODE) = 12*(K-1)+405+SIFR
43413 I3MODE(K+2,N3MODE) = 12*(K-1)+400+SIFR
43414 DO 10 J=1,2
43415 A3MODE(J,K ,N3MODE) = AFC( J ,IFR-1,K,L1)
43416 B3MODE(J,K ,N3MODE) = AFN(O(J),IFR-1,K,L )
43417 A3MODE(J,K+2,N3MODE) = AFC(O(J),IFR ,K,L1)
43418 10 B3MODE(J,K+2,N3MODE) = AFN( J ,IFR ,K,L )
43419C--gauge boson diagram
43420 IF(RMASS(IDK(I)).LT.MW+RMASS(IDKPRD(1,I))) THEN
43421 NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
43422 I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
43423 I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
43424 I3MODE(NDI3BY(N3MODE),N3MODE) = 198
43425 DO 11 J=1,2
43426 11 A3MODE(J,NDI3BY(N3MODE),N3MODE) = OIJ(J,L,L1)
43427 B3MODE(1,NDI3BY(N3MODE),N3MODE) = ZERO
43428 B3MODE(2,NDI3BY(N3MODE),N3MODE) = -G*ORT
43429 ENDIF
43430C--then the chargino modes to fermion-antifermion chargino
43431 ELSEIF(L.GE.5.AND.L.LE.8.AND.(IDKPRD(2,I).LE.12.OR.
43432 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
43433 L = L-4
43434 IFR = IDKPRD(2,I)
43435 J = INT((IFR-1)/120)
43436 IFR = IFR-6*INT((IFR-1)/6)+6*J
43437 IL = IFR+4*J
43438 SIFR = IFR+18*J
43439 IF(MOD(IFR,2).EQ.0) THEN
43440 IFR = IFR-1
43441 SIFR = SIFR-1
43442 ELSE
43443 IFR = IFR+1
43444 SIFR = SIFR+1
43445 ENDIF
43446 L1 = IDK(I)-453
43447 N3MODE = N3MODE+1
43448 IF(N3MODE.GT.NMODE3) THEN
43449 CALL HWWARN('HWISP3',117)
43450 GOTO 999
43451 ENDIF
43452 ID3PRT(N3MODE) = I
43453 NME(I) = 10000+N3MODE
43454 NDI3BY(N3MODE) = 2
43455 P3MODE(N3MODE) = ONE
43456 IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
43457 SPN3CF(1,1,N3MODE) = ONE
43458 N3NCFL(N3MODE) = 1
43459C--sfermion exchange diagrams
43460 IF(MOD(IL,2).EQ.0) THEN
43461 DO 12 K=1,2
43462 I3DRTP(K,N3MODE) = 3
43463 I3DRCF(K,N3MODE) = 1
43464 I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
43465 DO 12 J=1,2
43466 A3MODE(J,K,N3MODE) = AFC( J ,IFR,K,L1)
43467 12 B3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L )
43468 ELSE
43469 DO 13 K=1,2
43470 I3DRTP(K,N3MODE) = 4
43471 I3DRCF(K,N3MODE) = 1
43472 I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
43473 DO 13 J=1,2
43474 A3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L1)
43475 13 B3MODE(J,K,N3MODE) = AFC( J ,IFR,K,L )
43476 ENDIF
43477C--gauge boson diagram
43478 IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN
43479 NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
43480 I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
43481 I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
43482 I3MODE(NDI3BY(N3MODE),N3MODE) = 200
43483 DO 14 J=1,2
43484 14 A3MODE(J,NDI3BY(N3MODE),N3MODE) = OIJP(J,L,L1)
43485 B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL)
43486 B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL)
43487 ENDIF
43488C--R-parity violating decays
43489C--LLE first
43490 ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
43491 & IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
43492 & IDKPRD(1,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN
43493 L1 = IDK(I)-453
43494C--neutrino lepton neutrino
43495 IF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
43496 & MOD(IDKPRD(3,I),2).EQ.0) THEN
43497 N3MODE = N3MODE+1
43498 IF(N3MODE.GT.NMODE3) THEN
43499 CALL HWWARN('HWISP3',118)
43500 GOTO 999
43501 ENDIF
43502 ID3PRT(N3MODE) = I
43503 NME(I) = 10000+N3MODE
43504 NDI3BY(N3MODE) = 2
43505 P3MODE(N3MODE) = ONE
43506 N3NCFL(N3MODE) = 1
43507 SPN3CF(1,1,N3MODE) = ONE
43508 III = (IDKPRD(1,I)-126)/2
43509 JJJ = (IDKPRD(2,I)-125)/2
43510 KKK = (IDKPRD(3,I)-120)/2
43511 DO 54 K=1,2
43512 I3DRTP(K,N3MODE) = 10
43513 I3DRCF(K,N3MODE) = 1
43514 I3MODE(K,N3MODE) = 423+2*KKK+12*(K-1)
43515 B3MODE(1,K,N3MODE) = 0.0D0
43516 B3MODE(2,K,N3MODE)=LAMDA1(III,JJJ,KKK)*LMIXSS(2*KKK-1,2,K)
43517 DO 54 J=1,2
43518 54 A3MODE(J,K,N3MODE) = AFC(J,5+2*KKK,K,L1)
43519C--neutrino neutrino lepton
43520 ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
43521 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
43522 N3MODE = N3MODE+1
43523 IF(N3MODE.GT.NMODE3) THEN
43524 CALL HWWARN('HWISP3',119)
43525 GOTO 999
43526 ENDIF
43527 ID3PRT(N3MODE) = I
43528 NME(I) = 10000+N3MODE
43529 NDI3BY(N3MODE) = 4
43530 P3MODE(N3MODE) = ONE
43531 N3NCFL(N3MODE) = 1
43532 SPN3CF(1,1,N3MODE) = ONE
43533 III = (IDKPRD(1,I)-120)/2
43534 JJJ = (IDKPRD(2,I)-120)/2
43535 KKK = (IDKPRD(3,I)-125)/2
43536 DO 55 K=1,2
43537 I3DRTP(K ,N3MODE) = 2
43538 I3DRTP(K+2,N3MODE) = 3
43539 I3DRCF(K ,N3MODE) = 1
43540 I3DRCF(K+2,N3MODE) = 1
43541 I3MODE(K ,N3MODE) = 423+2*III+12*(K-1)
43542 I3MODE(K+2,N3MODE) = 423+2*JJJ+12*(K-1)
43543 B3MODE(1,K,N3MODE) = LAMDA1(III,JJJ,KKK)*
43544 & LMIXSS(2*III-1,1,K)
43545 B3MODE(2,K,N3MODE) = 0.0D0
43546 B3MODE(1,K+2,N3MODE) =-LAMDA1(III,JJJ,KKK)*
43547 & LMIXSS(2*JJJ-1,1,K)
43548 B3MODE(2,K+2,N3MODE) = 0.0D0
43549 DO 55 J=1,2
43550 A3MODE(J,K,N3MODE) = AFC(J,5+2*III,K,L1)
43551 55 A3MODE(J,K+2,N3MODE) = AFC(J,5+2*JJJ,K,L1)
43552C--lepton lepton lepton
43553 ELSEIF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1
43554 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
43555 N3MODE = N3MODE+1
43556 IF(N3MODE.GT.NMODE3) THEN
43557 CALL HWWARN('HWISP3',120)
43558 GOTO 999
43559 ENDIF
43560 ID3PRT(N3MODE) = I
43561 NME(I) = 10000+N3MODE
43562 NDI3BY(N3MODE) = 2
43563 P3MODE(N3MODE) = ONE
43564 N3NCFL(N3MODE) = 1
43565 SPN3CF(1,1,N3MODE) = ONE
43566 III = (IDKPRD(1,I)-125)/2
43567 JJJ = (IDKPRD(2,I)-125)/2
43568 KKK = (IDKPRD(3,I)-119)/2
43569 I3DRTP(1,N3MODE) = 8
43570 I3DRTP(2,N3MODE) = 9
43571 I3DRCF(1,N3MODE) = 1
43572 I3DRCF(2,N3MODE) = 1
43573 I3MODE(1,N3MODE) = 424+2*III
43574 I3MODE(2,N3MODE) = 424+2*JJJ
43575 B3MODE(1,1,N3MODE) = 0.0D0
43576 B3MODE(2,1,N3MODE) = LAMDA1(III,JJJ,KKK)
43577 B3MODE(1,2,N3MODE) = 0.0D0
43578 B3MODE(2,2,N3MODE) =-LAMDA1(III,JJJ,KKK)
43579 DO 56 J=1,2
43580 A3MODE(J,1,N3MODE) = AFC(O(J),6+2*III,1,L1)
43581 56 A3MODE(J,2,N3MODE) = AFC(O(J),6+2*JJJ,1,L1)
43582 ELSE
43583 CALL HWWARN('HWISP3',3)
43584 ENDIF
43585C--LQD decays
43586 ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
43587 & IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE. 12) THEN
43588 L1 = IDK(I)-453
43589C--nubar dbar u
43590 IF(IDKPRD(1,I).GE.128.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
43591 N3MODE = N3MODE+1
43592 IF(N3MODE.GT.NMODE3) THEN
43593 CALL HWWARN('HWISP3',121)
43594 GOTO 999
43595 ENDIF
43596 ID3PRT(N3MODE) = I
43597 NME(I) = 10000+N3MODE
43598 NDI3BY(N3MODE) = 2
43599 P3MODE(N3MODE) = THREE
43600 N3NCFL(N3MODE) = 1
43601 SPN3CF(1,1,N3MODE) = ONE
43602 III = (IDKPRD(1,I)-126)/2
43603 JJJ = (IDKPRD(2,I)-5)/2
43604 KKK = IDKPRD(3,I)/2
43605 DO 88 K=1,2
43606 I3DRTP(K,N3MODE) = 10
43607 I3DRCF(K,N3MODE) = 1
43608 I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
43609 B3MODE(1,K,N3MODE) = 0.0D0
43610 B3MODE(2,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
43611 & LAMDA2(III,JJJ,KKK)
43612 DO 88 J=1,2
43613 88 A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1)
43614C--l+ ubar u
43615 ELSEIF(IDKPRD(1,I).GE.127.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
43616 & MOD(IDKPRD(2,I),2).EQ.0) THEN
43617 N3MODE = N3MODE+1
43618 IF(N3MODE.GT.NMODE3) THEN
43619 CALL HWWARN('HWISP3',122)
43620 GOTO 999
43621 ENDIF
43622 ID3PRT(N3MODE) = I
43623 NME(I) = 10000+N3MODE
43624 NDI3BY(N3MODE) = 2
43625 P3MODE(N3MODE) = THREE
43626 N3NCFL(N3MODE) = 1
43627 SPN3CF(1,1,N3MODE) = ONE
43628 III = (IDKPRD(1,I)-125)/2
43629 JJJ = (IDKPRD(2,I)-6)/2
43630 KKK = IDKPRD(3,I)/2
43631 DO 89 K=1,2
43632 I3DRTP(K,N3MODE) = 10
43633 I3DRCF(K,N3MODE) = 1
43634 I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
43635 B3MODE(1,K,N3MODE) = 0.0D0
43636 B3MODE(2,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
43637 & LAMDA2(III,JJJ,KKK)
43638 DO 89 J=1,2
43639 89 A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1)
43640C--l+ dbar d
43641 ELSEIF(IDKPRD(1,I).GE.127.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
43642 & MOD(IDKPRD(2,I),2).EQ.1) THEN
43643 N3MODE = N3MODE+1
43644 IF(N3MODE.GT.NMODE3) THEN
43645 CALL HWWARN('HWISP3',123)
43646 GOTO 999
43647 ENDIF
43648 ID3PRT(N3MODE) = I
43649 NME(I) = 10000+N3MODE
43650 NDI3BY(N3MODE) = 3
43651 P3MODE(N3MODE) = THREE
43652 N3NCFL(N3MODE) = 1
43653 SPN3CF(1,1,N3MODE) = ONE
43654 III = (IDKPRD(1,I)-125)/2
43655 JJJ = (IDKPRD(2,I)-5)/2
43656 KKK = (IDKPRD(3,I)+1)/2
43657 I3DRTP(1,N3MODE) = 8
43658 I3DRCF(1,N3MODE) = 1
43659 I3MODE(1,N3MODE) = 424+2*III
43660 B3MODE(1,1,N3MODE) = 0.0D0
43661 B3MODE(2,1,N3MODE) = -LAMDA2(III,JJJ,KKK)
43662 DO 91 J=1,2
43663 91 A3MODE(J,1,N3MODE) = AFC(O(J),2*III+6,1,L1)
43664 DO 92 K=1,2
43665 I3DRTP(K+1,N3MODE) = 9
43666 I3DRCF(K+1,N3MODE) = 1
43667 I3MODE(K+1,N3MODE) = 400+2*JJJ+12*(K-1)
43668 B3MODE(1,K+1,N3MODE) = 0.0D0
43669 B3MODE(2,K+1,N3MODE) = QMIXSS(2*JJJ,1,K)*
43670 & LAMDA2(III,JJJ,KKK)
43671 DO 92 J=1,2
43672 92 A3MODE(J,K+1,N3MODE) = AFC(O(J),2*JJJ,K,L1)
43673C--nu u dbar
43674 ELSEIF(IDKPRD(1,I).LE.126.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
43675 N3MODE = N3MODE+1
43676 IF(N3MODE.GT.NMODE3) THEN
43677 CALL HWWARN('HWISP3',124)
43678 GOTO 999
43679 ENDIF
43680 ID3PRT(N3MODE) = I
43681 NME(I) = 10000+N3MODE
43682 NDI3BY(N3MODE) = 4
43683 P3MODE(N3MODE) = THREE
43684 N3NCFL(N3MODE) = 1
43685 SPN3CF(1,1,N3MODE) = ONE
43686 III = (IDKPRD(1,I)-120)/2
43687 JJJ = IDKPRD(2,I)/2
43688 KKK = (IDKPRD(3,I)-5)/2
43689 DO 90 K=1,2
43690 I3DRTP(K ,N3MODE) = 2
43691 I3DRTP(K+2,N3MODE) = 3
43692 I3DRCF(K ,N3MODE) = 1
43693 I3DRCF(K+2,N3MODE) = 1
43694 I3MODE(K ,N3MODE) = 423+2*III+12*(K-1)
43695 I3MODE(K+2,N3MODE) = 399+2*JJJ+12*(K-1)
43696 B3MODE(1,K ,N3MODE) = LMIXSS(2*III-1,1,K)*
43697 & LAMDA2(III,JJJ,KKK)
43698 B3MODE(2,K ,N3MODE) = 0.0D0
43699 B3MODE(1,K+2,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
43700 & LAMDA2(III,JJJ,KKK)
43701 B3MODE(2,K+2,N3MODE) = 0.0D0
43702 DO 90 J=1,2
43703 A3MODE(J,K ,N3MODE) = AFC(J,2*III+5,K,L1)
43704 90 A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ-1,K,L1)
43705C--unrecognised
43706 ELSE
43707 CALL HWWARN('HWISP3',4)
43708 ENDIF
43709C--UDD decays
43710 ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
43711 & IDKPRD(3,I).LE.12) THEN
43712 L1 = IDK(I)-453
43713C--dbar dbar dbar mode
43714 IF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
43715 & MOD(IDKPRD(3,I),2).EQ.1) THEN
43716 N3MODE = N3MODE+1
43717 IF(N3MODE.GT.NMODE3) THEN
43718 CALL HWWARN('HWISP3',125)
43719 GOTO 999
43720 ENDIF
43721 ID3PRT(N3MODE) = I
43722 NME(I) = 10000+N3MODE
43723 NDI3BY(N3MODE) = 6
43724 N3NCFL(N3MODE) = 1
43725 SPN3CF(1,1,N3MODE) = ONE
43726 III = (IDKPRD(1,I)-5)/2
43727 JJJ = (IDKPRD(2,I)-5)/2
43728 KKK = (IDKPRD(3,I)-5)/2
43729 P3MODE(N3MODE) = ONE
43730 IF(III.EQ.JJJ) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
43731 IF(JJJ.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
43732 IF(III.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
43733 P3MODE(N3MODE) = 6.0D0/P3MODE(N3MODE)
43734 DO 66 K=1,6
43735 66 I3DRCF(K,N3MODE) = 1
43736 DO 65 K=1,2
43737 I3DRTP(K ,N3MODE) = 14
43738 I3DRTP(K+2,N3MODE) = 15
43739 I3DRTP(K+4,N3MODE) = 16
43740 I3MODE(K ,N3MODE) = 400+2*III+(K-1)*12
43741 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
43742 I3MODE(K+4,N3MODE) = 400+2*KKK+(K-1)*12
43743 B3MODE(1,K ,N3MODE) = QMIXSS(2*III,2,K)*
43744 & LAMDA3(III,JJJ,KKK)
43745 B3MODE(2,K ,N3MODE) = 0.0D0
43746 B3MODE(1,K+2,N3MODE) =-QMIXSS(2*JJJ,2,K)*
43747 & LAMDA3(JJJ,III,KKK)
43748 B3MODE(2,K+2,N3MODE) = 0.0D0
43749 B3MODE(1,K+4,N3MODE) = QMIXSS(2*KKK,2,K)*
43750 & LAMDA3(KKK,III,JJJ)
43751 B3MODE(2,K+4,N3MODE) = 0.0D0
43752 DO 65 J=1,2
43753 A3MODE(J,K ,N3MODE) = AFC(O(J),2*III,K,L1)
43754 A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ,K,L1)
43755 65 A3MODE(J,K+4,N3MODE) = AFC(O(J),2*KKK,K,L1)
43756C--u u d mode
43757 ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
43758 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
43759 N3MODE = N3MODE+1
43760 IF(N3MODE.GT.NMODE3) THEN
43761 CALL HWWARN('HWISP3',126)
43762 GOTO 999
43763 ENDIF
43764 ID3PRT(N3MODE) = I
43765 NME(I) = 10000+N3MODE
43766 NDI3BY(N3MODE) = 4
43767 P3MODE(N3MODE) = 6.0D0
43768 N3NCFL(N3MODE) = 1
43769 SPN3CF(1,1,N3MODE) = ONE
43770 III = IDKPRD(1,I)/2
43771 JJJ = IDKPRD(2,I)/2
43772 KKK = (IDKPRD(3,I)+1)/2
43773 IF(III.EQ.JJJ) P3MODE(N3MODE) = HALF*P3MODE(N3MODE)
43774 DO 64 K=1,2
43775 I3DRTP(K ,N3MODE) = 11
43776 I3DRTP(K+2,N3MODE) = 12
43777 I3DRCF(K ,N3MODE) = 1
43778 I3DRCF(K+2,N3MODE) = 1
43779 I3MODE(K ,N3MODE) = 399+2*III+(K-1)*12
43780 I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
43781 B3MODE(1,K ,N3MODE) = 0.0D0
43782 B3MODE(2,K ,N3MODE) = QMIXSS(2*III-1,2,K)*
43783 & LAMDA3(JJJ,III,KKK)
43784c B3MODE(2,K,N3MODE) = 0.0D0
43785 B3MODE(1,K+2,N3MODE) = 0.0D0
43786 B3MODE(2,K+2,N3MODE) =-QMIXSS(2*JJJ-1,2,K)*
43787 & LAMDA3(III,JJJ,KKK)
43788 DO 64 J=1,2
43789 A3MODE(J,K ,N3MODE) = AFC(J,2*III-1,K,L1)
43790 64 A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ-1,K,L1)
43791C--unrecognized decay issue warning
43792 ELSE
43793 CALL HWWARN('HWISP3',5)
43794 ENDIF
43795C--unrecognized decay issue warning
43796 ELSE
43797 CALL HWWARN('HWISP3',6)
43798 ENDIF
43799 ELSEIF(IDK(I).GE.456.AND.IDK(I).LE.457) THEN
43800C-- -ve chargino modes last
43801C--first the chargino modes to fermion-antifermion neutralino
43802 IF(L.GE.1.AND.L.LE.4.AND.(IDKPRD(2,I).LE.12.OR.
43803 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
43804 IFR = IDKPRD(2,I)
43805 IFR = IFR+MOD(IFR,2)
43806 J = INT((IFR-1)/120)
43807 IFR = IFR-6*INT((IFR-1)/6)+6*J
43808 IL = IFR+4*J
43809 SIFR = IFR+18*J
43810 L1 = IDK(I)-455
43811 N3MODE = N3MODE+1
43812 IF(N3MODE.GT.NMODE3) THEN
43813 CALL HWWARN('HWISP3',127)
43814 GOTO 999
43815 ENDIF
43816 ID3PRT(N3MODE) = I
43817 NME(I) = 10000+N3MODE
43818 NDI3BY(N3MODE) = 4
43819 P3MODE(N3MODE) = ONE
43820 IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
43821 SPN3CF(1,1,N3MODE) = ONE
43822 N3NCFL(N3MODE) = 1
43823C--sfermion exchange diagrams
43824 DO 15 K=1,2
43825 I3DRTP(K ,N3MODE) = 3
43826 I3DRCF(K ,N3MODE) = 1
43827 I3DRTP(K+2,N3MODE) = 4
43828 I3DRCF(K+2,N3MODE) = 1
43829 I3MODE(K ,N3MODE) = 12*(K-1)+406+SIFR
43830 I3MODE(K+2,N3MODE) = 12*(K-1)+399+SIFR
43831 DO 15 J=1,2
43832 A3MODE(J,K ,N3MODE) = AFC( J ,IFR ,K,L1)
43833 B3MODE(J,K ,N3MODE) = AFN(O(J),IFR ,K,L )
43834 A3MODE(J,K+2,N3MODE) = AFC(O(J),IFR-1,K,L1)
43835 15 B3MODE(J,K+2,N3MODE) = AFN( J ,IFR-1,K,L )
43836C--gauge boson diagram
43837 IF(RMASS(IDK(I)).LT.MW+RMASS(IDKPRD(1,I))) THEN
43838 NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
43839 I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
43840 I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
43841 I3MODE(NDI3BY(N3MODE),N3MODE) = 199
43842 DO 16 J=1,2
43843 16 A3MODE(J,NDI3BY(N3MODE),N3MODE) =-OIJ(O(J),L,L1)
43844 B3MODE(1,NDI3BY(N3MODE),N3MODE) = ZERO
43845 B3MODE(2,NDI3BY(N3MODE),N3MODE) = -G*ORT
43846 ENDIF
43847C--then the chargino modes to fermion-antifermion chargino
43848 ELSEIF(L.GE.5.AND.L.LE.8.AND.(IDKPRD(2,I).LE.12.OR.
43849 & (IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132))) THEN
43850 L = L-6
43851 IFR = IDKPRD(2,I)
43852 J = INT((IFR-1)/120)
43853 IFR = IFR-6*INT((IFR-1)/6)+6*J
43854 IL = IFR+4*J
43855 SIFR = IFR+18*J
43856 IF(MOD(IFR,2).EQ.0) THEN
43857 IFR = IFR-1
43858 SIFR = SIFR-1
43859 ELSE
43860 IFR = IFR+1
43861 SIFR = SIFR+1
43862 ENDIF
43863 L1 = IDK(I)-455
43864 N3MODE = N3MODE+1
43865 IF(N3MODE.GT.NMODE3) THEN
43866 CALL HWWARN('HWISP3',128)
43867 GOTO 999
43868 ENDIF
43869 ID3PRT(N3MODE) = I
43870 NME(I) = 10000+N3MODE
43871 NDI3BY(N3MODE) = 2
43872 P3MODE(N3MODE) = ONE
43873 IF(IDKPRD(2,I).LE.12) P3MODE(N3MODE) = THREE
43874 SPN3CF(1,1,N3MODE) = ONE
43875 N3NCFL(N3MODE) = 1
43876C--sfermion exchange diagrams
43877 IF(MOD(IL,2).EQ.0) THEN
43878 DO 17 K=1,2
43879 I3DRTP(K,N3MODE) = 4
43880 I3DRCF(K,N3MODE) = 1
43881 I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
43882 DO 17 J=1,2
43883 A3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L1)
43884 17 B3MODE(J,K,N3MODE) = AFC( J ,IFR,K,L )
43885 ELSE
43886 DO 18 K=1,2
43887 I3DRTP(K,N3MODE) = 3
43888 I3DRCF(K,N3MODE) = 1
43889 I3MODE(K,N3MODE) = 12*(K-1)+400+SIFR
43890 DO 18 J=1,2
43891 A3MODE(J,K,N3MODE) = AFC( J ,IFR,K,L1)
43892 18 B3MODE(J,K,N3MODE) = AFC(O(J),IFR,K,L )
43893 ENDIF
43894C--gauge boson diagram
43895 IF(RMASS(IDK(I)).LT.MZ+RMASS(IDKPRD(1,I))) THEN
43896 NDI3BY(N3MODE) = NDI3BY(N3MODE)+1
43897 I3DRTP(NDI3BY(N3MODE),N3MODE) = 1
43898 I3DRCF(NDI3BY(N3MODE),N3MODE) = 1
43899 I3MODE(NDI3BY(N3MODE),N3MODE) = 200
43900 DO 19 J=1,2
43901 19 A3MODE(J,NDI3BY(N3MODE),N3MODE) =-OIJP(O(J),L,L1)
43902 B3MODE(1,NDI3BY(N3MODE),N3MODE) = -E*RFCH(IL)
43903 B3MODE(2,NDI3BY(N3MODE),N3MODE) = -E*LFCH(IL)
43904 ENDIF
43905C--R-parity violating decays
43906C--LLE first
43907 ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
43908 & IDKPRD(2,I).GE.121.AND.IDKPRD(2,I).LE.132.AND.
43909 & IDKPRD(1,I).GE.121.AND.IDKPRD(3,I).LE.132) THEN
43910 L1 = IDK(I)-455
43911C--neutrino lepton neutrino
43912 IF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
43913 & MOD(IDKPRD(3,I),2).EQ.0) THEN
43914 N3MODE = N3MODE+1
43915 IF(N3MODE.GT.NMODE3) THEN
43916 CALL HWWARN('HWISP3',129)
43917 GOTO 999
43918 ENDIF
43919 ID3PRT(N3MODE) = I
43920 NME(I) = 10000+N3MODE
43921 NDI3BY(N3MODE) = 2
43922 P3MODE(N3MODE) = ONE
43923 N3NCFL(N3MODE) = 1
43924 SPN3CF(1,1,N3MODE) = ONE
43925 III = (IDKPRD(1,I)-120)/2
43926 JJJ = (IDKPRD(2,I)-119)/2
43927 KKK = (IDKPRD(3,I)-126)/2
43928 DO 57 K=1,2
43929 I3DRTP(K,N3MODE) = 4
43930 I3DRCF(K,N3MODE) = 1
43931 I3MODE(K,N3MODE) = 423+2*KKK+12*(K-1)
43932 B3MODE(2,K,N3MODE) = 0.0D0
43933 B3MODE(1,K,N3MODE)=LAMDA1(III,JJJ,KKK)*LMIXSS(2*KKK-1,2,K)
43934 DO 57 J=1,2
43935 57 A3MODE(J,K,N3MODE) = AFC(O(J),5+2*KKK,K,L1)
43936C--neutrino neutrino lepton
43937 ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
43938 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
43939 N3MODE = N3MODE+1
43940 IF(N3MODE.GT.NMODE3) THEN
43941 CALL HWWARN('HWISP3',130)
43942 GOTO 999
43943 ENDIF
43944 ID3PRT(N3MODE) = I
43945 NME(I) = 10000+N3MODE
43946 NDI3BY(N3MODE) = 4
43947 P3MODE(N3MODE) = ONE
43948 N3NCFL(N3MODE) = 1
43949 SPN3CF(1,1,N3MODE) = ONE
43950 III = (IDKPRD(1,I)-126)/2
43951 JJJ = (IDKPRD(2,I)-126)/2
43952 KKK = (IDKPRD(3,I)-119)/2
43953 DO 58 K=1,2
43954 I3DRTP(K ,N3MODE) = 8
43955 I3DRTP(K+2,N3MODE) = 9
43956 I3DRCF(K ,N3MODE) = 1
43957 I3DRCF(K+2,N3MODE) = 1
43958 I3MODE(K ,N3MODE) = 423+2*III+12*(K-1)
43959 I3MODE(K+2,N3MODE) = 423+2*JJJ+12*(K-1)
43960 B3MODE(2,K,N3MODE) = LAMDA1(III,JJJ,KKK)*
43961 & LMIXSS(2*III-1,1,K)
43962 B3MODE(1,K,N3MODE) = 0.0D0
43963 B3MODE(2,K+2,N3MODE) =-LAMDA1(III,JJJ,KKK)*
43964 & LMIXSS(2*JJJ-1,1,K)
43965 B3MODE(1,K+2,N3MODE) = 0.0D0
43966 DO 58 J=1,2
43967 A3MODE(J,K,N3MODE) = AFC(O(J),5+2*III,K,L1)
43968 58 A3MODE(J,K+2,N3MODE) = AFC(O(J),5+2*JJJ,K,L1)
43969C--lepton lepton lepton
43970 ELSEIF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1
43971 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
43972 N3MODE = N3MODE+1
43973 IF(N3MODE.GT.NMODE3) THEN
43974 CALL HWWARN('HWISP3',131)
43975 GOTO 999
43976 ENDIF
43977 ID3PRT(N3MODE) = I
43978 NME(I) = 10000+N3MODE
43979 NDI3BY(N3MODE) = 2
43980 P3MODE(N3MODE) = ONE
43981 N3NCFL(N3MODE) = 1
43982 SPN3CF(1,1,N3MODE) = ONE
43983 III = (IDKPRD(1,I)-119)/2
43984 JJJ = (IDKPRD(2,I)-119)/2
43985 KKK = (IDKPRD(3,I)-125)/2
43986 I3DRTP(1,N3MODE) = 2
43987 I3DRTP(2,N3MODE) = 3
43988 I3DRCF(1,N3MODE) = 1
43989 I3DRCF(2,N3MODE) = 1
43990 I3MODE(1,N3MODE) = 424+2*III
43991 I3MODE(2,N3MODE) = 424+2*JJJ
43992 B3MODE(1,1,N3MODE) = LAMDA1(III,JJJ,KKK)
43993 B3MODE(2,1,N3MODE) = 0.0D0
43994 B3MODE(1,2,N3MODE) =-LAMDA1(III,JJJ,KKK)
43995 B3MODE(2,2,N3MODE) = 0.0D0
43996 DO 59 J=1,2
43997 A3MODE(J,1,N3MODE) = AFC(J,6+2*III,1,L1)
43998 59 A3MODE(J,2,N3MODE) = AFC(J,6+2*JJJ,1,L1)
43999 ELSE
44000 CALL HWWARN('HWISP3',7)
44001 ENDIF
44002C--LQD decays
44003 ELSEIF(IDKPRD(1,I).GE.121.AND.IDKPRD(1,I).LE.132.AND.
44004 & IDKPRD(2,I).LE.12 .AND.IDKPRD(3,I).LE. 12) THEN
44005 L1 = IDK(I)-455
44006C--nu d ubar
44007 IF(IDKPRD(1,I).LE.126.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
44008 N3MODE = N3MODE+1
44009 IF(N3MODE.GT.NMODE3) THEN
44010 CALL HWWARN('HWISP3',132)
44011 GOTO 999
44012 ENDIF
44013 ID3PRT(N3MODE) = I
44014 NME(I) = 10000+N3MODE
44015 NDI3BY(N3MODE) = 2
44016 P3MODE(N3MODE) = THREE
44017 N3NCFL(N3MODE) = 1
44018 SPN3CF(1,1,N3MODE) = ONE
44019 III = (IDKPRD(1,I)-120)/2
44020 JJJ = (IDKPRD(2,I)+1)/2
44021 KKK = (IDKPRD(3,I)-6)/2
44022 DO 93 K=1,2
44023 I3DRTP(K,N3MODE) = 4
44024 I3DRCF(K,N3MODE) = 1
44025 I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
44026 B3MODE(2,K,N3MODE) = 0.0D0
44027 B3MODE(1,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
44028 & LAMDA2(III,JJJ,KKK)
44029 DO 93 J=1,2
44030 93 A3MODE(J,K,N3MODE) = AFC(O(J),2*KKK-1,K,L1)
44031C--l- u ubar
44032 ELSEIF(IDKPRD(1,I).LE.125.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
44033 & MOD(IDKPRD(2,I),2).EQ.0) THEN
44034 N3MODE = N3MODE+1
44035 IF(N3MODE.GT.NMODE3) THEN
44036 CALL HWWARN('HWISP3',133)
44037 GOTO 999
44038 ENDIF
44039 ID3PRT(N3MODE) = I
44040 NME(I) = 10000+N3MODE
44041 NDI3BY(N3MODE) = 2
44042 P3MODE(N3MODE) = THREE
44043 N3NCFL(N3MODE) = 1
44044 SPN3CF(1,1,N3MODE) = ONE
44045 III = (IDKPRD(1,I)-119)/2
44046 JJJ = IDKPRD(2,I)/2
44047 KKK = (IDKPRD(3,I)-6)/2
44048 DO 94 K=1,2
44049 I3DRTP(K,N3MODE) = 4
44050 I3DRCF(K,N3MODE) = 1
44051 I3MODE(K,N3MODE) = 399+2*KKK+12*(K-1)
44052 B3MODE(2,K,N3MODE) = 0.0D0
44053 B3MODE(1,K,N3MODE) = QMIXSS(2*KKK-1,2,K)*
44054 & LAMDA2(III,JJJ,KKK)
44055 DO 94 J=1,2
44056 94 A3MODE(J,K,N3MODE) = AFC(J,2*KKK-1,K,L1)
44057C--l- d dbar
44058 ELSEIF(IDKPRD(1,I).LE.125.AND.MOD(IDKPRD(1,I),2).EQ.1.AND.
44059 & MOD(IDKPRD(2,I),2).EQ.1) THEN
44060 N3MODE = N3MODE+1
44061 IF(N3MODE.GT.NMODE3) THEN
44062 CALL HWWARN('HWISP3',134)
44063 GOTO 999
44064 ENDIF
44065 ID3PRT(N3MODE) = I
44066 NME(I) = 10000+N3MODE
44067 NDI3BY(N3MODE) = 3
44068 P3MODE(N3MODE) = THREE
44069 N3NCFL(N3MODE) = 1
44070 SPN3CF(1,1,N3MODE) = ONE
44071 III = (IDKPRD(1,I)-119)/2
44072 JJJ = (IDKPRD(2,I)+1)/2
44073 KKK = (IDKPRD(3,I)-5)/2
44074 I3DRTP(1,N3MODE) = 2
44075 I3DRCF(1,N3MODE) = 1
44076 I3MODE(1,N3MODE) = 424+2*III
44077 B3MODE(2,1,N3MODE) = 0.0D0
44078 B3MODE(1,1,N3MODE) = -LAMDA2(III,JJJ,KKK)
44079 DO 95 J=1,2
44080 95 A3MODE(J,1,N3MODE) = AFC(J,2*III+6,1,L1)
44081 DO 96 K=1,2
44082 I3DRTP(K+1,N3MODE) = 3
44083 I3DRCF(K+1,N3MODE) = 1
44084 I3MODE(K+1,N3MODE) = 400+2*JJJ+12*(K-1)
44085 B3MODE(2,K+1,N3MODE) = 0.0D0
44086 B3MODE(1,K+1,N3MODE) = QMIXSS(2*JJJ,1,K)*
44087 & LAMDA2(III,JJJ,KKK)
44088 DO 96 J=1,2
44089 96 A3MODE(J,K+1,N3MODE) = AFC(J,2*JJJ,K,L1)
44090C--nubar ubar d
44091 ELSEIF(IDKPRD(1,I).GE.128.AND.MOD(IDKPRD(1,I),2).EQ.0) THEN
44092 N3MODE = N3MODE+1
44093 IF(N3MODE.GT.NMODE3) THEN
44094 CALL HWWARN('HWISP3',135)
44095 GOTO 999
44096 ENDIF
44097 ID3PRT(N3MODE) = I
44098 NME(I) = 10000+N3MODE
44099 NDI3BY(N3MODE) = 4
44100 P3MODE(N3MODE) = THREE
44101 N3NCFL(N3MODE) = 1
44102 SPN3CF(1,1,N3MODE) = ONE
44103 III = (IDKPRD(1,I)-126)/2
44104 JJJ = (IDKPRD(2,I)-6)/2
44105 KKK = (IDKPRD(3,I)+1)/2
44106 DO 97 K=1,2
44107 I3DRTP(K ,N3MODE) = 8
44108 I3DRTP(K+2,N3MODE) = 9
44109 I3DRCF(K ,N3MODE) = 1
44110 I3DRCF(K+2,N3MODE) = 1
44111 I3MODE(K ,N3MODE) = 423+2*III+12*(K-1)
44112 I3MODE(K+2,N3MODE) = 399+2*JJJ+12*(K-1)
44113 B3MODE(2,K ,N3MODE) = LMIXSS(2*III-1,1,K)*
44114 & LAMDA2(III,JJJ,KKK)
44115 B3MODE(1,K ,N3MODE) = 0.0D0
44116 B3MODE(2,K+2,N3MODE) = -QMIXSS(2*JJJ-1,1,K)*
44117 & LAMDA2(III,JJJ,KKK)
44118 B3MODE(1,K+2,N3MODE) = 0.0D0
44119 DO 97 J=1,2
44120 A3MODE(J,K ,N3MODE) = AFC(O(J),2*III+5,K,L1)
44121 97 A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ-1,K,L1)
44122C--unrecognised
44123 ELSE
44124 CALL HWWARN('HWISP3',8)
44125 ENDIF
44126C-- UDD modes
44127 ELSEIF(IDKPRD(1,I).LE.12.AND.IDKPRD(2,I).LE.12.AND.
44128 & IDKPRD(3,I).LE.12) THEN
44129 L1 = IDK(I)-455
44130C-- d d d mode
44131 IF(MOD(IDKPRD(1,I),2).EQ.1.AND.MOD(IDKPRD(2,I),2).EQ.1.AND.
44132 & MOD(IDKPRD(3,I),2).EQ.1) THEN
44133 N3MODE = N3MODE+1
44134 IF(N3MODE.GT.NMODE3) THEN
44135 CALL HWWARN('HWISP3',136)
44136 GOTO 999
44137 ENDIF
44138 ID3PRT(N3MODE) = I
44139 NME(I) = 10000+N3MODE
44140 NDI3BY(N3MODE) = 6
44141 N3NCFL(N3MODE) = 1
44142 SPN3CF(1,1,N3MODE) = ONE
44143 III = (IDKPRD(1,I)+1)/2
44144 JJJ = (IDKPRD(2,I)+1)/2
44145 KKK = (IDKPRD(3,I)+1)/2
44146 P3MODE(N3MODE) = ONE
44147 IF(III.EQ.JJJ) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
44148 IF(JJJ.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
44149 IF(III.EQ.KKK) P3MODE(N3MODE) = P3MODE(N3MODE)+ONE
44150 P3MODE(N3MODE) = 6.0D0/P3MODE(N3MODE)
44151 DO 68 K=1,6
44152 68 I3DRCF(K,N3MODE) = 1
44153 DO 67 K=1,2
44154 I3DRTP(K ,N3MODE) = 12
44155 I3DRTP(K+2,N3MODE) = 13
44156 I3DRTP(K+4,N3MODE) = 14
44157 I3MODE(K ,N3MODE) = 400+2*III+(K-1)*12
44158 I3MODE(K+2,N3MODE) = 400+2*JJJ+(K-1)*12
44159 I3MODE(K+4,N3MODE) = 400+2*KKK+(K-1)*12
44160 B3MODE(1,K ,N3MODE) = 0.0D0
44161 B3MODE(1,K+2,N3MODE) = 0.0D0
44162 B3MODE(1,K+4,N3MODE) = 0.0D0
44163 B3MODE(2,K ,N3MODE) = QMIXSS(2*III,2,K)*
44164 & LAMDA3(III,JJJ,KKK)
44165 B3MODE(2,K+2,N3MODE) =-QMIXSS(2*JJJ,2,K)*
44166 & LAMDA3(JJJ,III,KKK)
44167 B3MODE(2,K+4,N3MODE) = QMIXSS(2*KKK,2,K)*
44168 & LAMDA3(KKK,III,JJJ)
44169 DO 67 J=1,2
44170 A3MODE(J,K ,N3MODE) = AFC(J,2*III,K,L1)
44171 A3MODE(J,K+2,N3MODE) = AFC(J,2*JJJ,K,L1)
44172 67 A3MODE(J,K+4,N3MODE) = AFC(J,2*KKK,K,L1)
44173C--u u d mode
44174 ELSEIF(MOD(IDKPRD(1,I),2).EQ.0.AND.MOD(IDKPRD(2,I),2).EQ.0
44175 & .AND.MOD(IDKPRD(3,I),2).EQ.1) THEN
44176 N3MODE = N3MODE+1
44177 IF(N3MODE.GT.NMODE3) THEN
44178 CALL HWWARN('HWISP3',137)
44179 GOTO 999
44180 ENDIF
44181 ID3PRT(N3MODE) = I
44182 NME(I) = 10000+N3MODE
44183 NDI3BY(N3MODE) = 4
44184 P3MODE(N3MODE) = 6.0D0
44185 N3NCFL(N3MODE) = 1
44186 SPN3CF(1,1,N3MODE) = ONE
44187 III = (IDKPRD(1,I)-6)/2
44188 JJJ = (IDKPRD(2,I)-6)/2
44189 KKK = (IDKPRD(3,I)-5)/2
44190 IF(III.EQ.JJJ) P3MODE(N3MODE) = HALF*P3MODE(N3MODE)
44191 DO 69 K=1,2
44192 I3DRTP(K ,N3MODE) = 11
44193 I3DRTP(K+2,N3MODE) = 12
44194 I3DRCF(K ,N3MODE) = 1
44195 I3DRCF(K+2,N3MODE) = 1
44196 I3MODE(K ,N3MODE) = 399+2*III+(K-1)*12
44197 I3MODE(K+2,N3MODE) = 399+2*JJJ+(K-1)*12
44198 B3MODE(1,K ,N3MODE) = QMIXSS(2*III-1,2,K)*
44199 & LAMDA3(JJJ,III,KKK)
44200 B3MODE(1,K+2,N3MODE) =-QMIXSS(2*JJJ-1,2,K)*
44201 & LAMDA3(III,JJJ,KKK)
44202 B3MODE(2,K+2,N3MODE) = 0.0D0
44203 B3MODE(2,K+2,N3MODE) = 0.0D0
44204 DO 69 J=1,2
44205 A3MODE(J,K ,N3MODE) = AFC(O(J),2*III-1,K,L1)
44206 69 A3MODE(J,K+2,N3MODE) = AFC(O(J),2*JJJ-1,K,L1)
44207C--unrecognized decay issue warning
44208 ELSE
44209 CALL HWWARN('HWISP3',9)
44210 ENDIF
44211C--unrecognized decay issue warning
44212 ELSE
44213 CALL HWWARN('HWISP3',10)
44214 ENDIF
44215 ENDIF
44216C--NOW FIND THE TWO BODY MODES WE WILL TREAT AS THREE BODY
44217 2500 IF(IDKPRD(2,I).EQ.0.OR.IDKPRD(3,I).NE.0) GOTO 2000
44218 L1 = IDK(I)-449
44219 IH1 = IDK(I)-202
44220 IH = IDKPRD(1,I)-202
44221C--first the neutralino decay modes
44222 IF(L1.GE.1.AND.L1.LE.4.AND.
44223 & IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
44224C--neutralino --> neutralino Z
44225 IF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.200) THEN
44226 NBMODE = NBMODE+1
44227 IF(NBMODE.GT.NMODEB) THEN
44228 CALL HWWARN('HWISP3',138)
44229 GOTO 999
44230 ENDIF
44231 NME(I) = 20000+NBMODE
44232 IDBPRT(NBMODE) = I
44233 IBMODE(NBMODE) = 200
44234 IBDRTP(NBMODE) = 1
44235 DO 20 J=1,2
44236 20 ABMODE(J,NBMODE) = OIJPP(J,L,L1)
44237 DO 21 K=1,12
44238 IF(K.LE.6) THEN
44239 IL = K
44240 PBMODE(K,NBMODE) = THREE
44241 ELSE
44242 IL=K+4
44243 PBMODE(K,NBMODE) = ONE
44244 ENDIF
44245 BBMODE(1,K,NBMODE) = -E*RFCH(IL)
44246 21 BBMODE(2,K,NBMODE) = -E*LFCH(IL)
44247C--neutralino --> chargino+ W-
44248 ELSEIF((L.EQ.5.OR.L.EQ.6).AND.IDKPRD(2,I).EQ.199) THEN
44249 L = L-4
44250 NBMODE = NBMODE+1
44251 IF(NBMODE.GT.NMODEB) THEN
44252 CALL HWWARN('HWISP3',139)
44253 GOTO 999
44254 ENDIF
44255 NME(I) = 20000+NBMODE
44256 IDBPRT(NBMODE) = I
44257 IBMODE(NBMODE) = 199
44258 IBDRTP(NBMODE) = 1
44259 DO 22 J=1,2
44260 22 ABMODE(J,NBMODE) = OIJ(J,L1,L)
44261 DO 23 K=1,6
44262 PBMODE(K,NBMODE) = ONE
44263 IF(K.LE.3) PBMODE(K,NBMODE) = THREE
44264 BBMODE(1,K,NBMODE) = ZERO
44265 23 BBMODE(2,K,NBMODE) = -G*ORT
44266C--neutralino --> chargino- W+
44267 ELSEIF((L.EQ.7.OR.L.EQ.8).AND.IDKPRD(2,I).EQ.198) THEN
44268 L = L-6
44269 NBMODE = NBMODE+1
44270 IF(NBMODE.GT.NMODEB) THEN
44271 CALL HWWARN('HWISP3',140)
44272 GOTO 999
44273 ENDIF
44274 NME(I) = 20000+NBMODE
44275 IDBPRT(NBMODE) = I
44276 IBMODE(NBMODE) = 198
44277 IBDRTP(NBMODE) = 1
44278 DO 24 J=1,2
44279 24 ABMODE(J,NBMODE) =-OIJ(O(J),L1,L)
44280 DO 25 K=1,6
44281 PBMODE(K,NBMODE) = ONE
44282 IF(K.LE.3) PBMODE(K,NBMODE) = THREE
44283 BBMODE(1,K,NBMODE) = ZERO
44284 25 BBMODE(2,K,NBMODE) = -G*ORT
44285C--gravitino Z modes
44286 ELSEIF(L.EQ.9.AND.IDKPRD(2,I).EQ.200) THEN
44287 NBMODE = NBMODE+1
44288 IF(NBMODE.GT.NMODEB) THEN
44289 CALL HWWARN('HWISP3',141)
44290 GOTO 999
44291 ENDIF
44292 NME(I) = 20000+NBMODE
44293 IDBPRT(NBMODE) = I
44294 IBMODE(NBMODE) = 200
44295 IBDRTP(NBMODE) = 7
44296 ABMODE(1,NBMODE) = 2.0D0/SQRT(6.0D0)*ZMIXSS(L1,2)
44297 ABMODE(2,NBMODE) = 2.0D0/SQRT(6.0D0)*RMASS(200)*
44298 & (ZMIXSS(L1,3)*COSB-ZMIXSS(L1,4)*SINB)
44299 DO 41 K=1,12
44300 IF(K.LE.6) THEN
44301 IL = K
44302 PBMODE(K,NBMODE) = THREE
44303 ELSE
44304 IL=K+4
44305 PBMODE(K,NBMODE) = ONE
44306 ENDIF
44307 BBMODE(1,K,NBMODE) = -E*RFCH(IL)
44308 41 BBMODE(2,K,NBMODE) = -E*LFCH(IL)
44309C--unrecognized decay issue warning
44310 ELSE
44311 CALL HWWARN('HWISP3',11)
44312 ENDIF
44313C--then the +ve chargino decay modes
44314 ELSEIF((L1.EQ.5.OR.L1.EQ.6)
44315 & .AND.IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
44316 L1 = L1-4
44317C--chargino --> chargino Z
44318 IF((L.EQ.5.OR.L.EQ.6).AND.IDKPRD(2,I).EQ.200) THEN
44319 L = L-4
44320 NBMODE = NBMODE+1
44321 IF(NBMODE.GT.NMODEB) THEN
44322 CALL HWWARN('HWISP3',142)
44323 GOTO 999
44324 ENDIF
44325 NME(I) = 20000+NBMODE
44326 IDBPRT(NBMODE) = I
44327 IBMODE(NBMODE) = 200
44328 IBDRTP(NBMODE) = 1
44329 DO 26 J=1,2
44330 26 ABMODE(J,NBMODE) = OIJP(J,L,L1)
44331 DO 27 K=1,12
44332 IF(K.LE.6) THEN
44333 IL = K
44334 PBMODE(K,NBMODE) = THREE
44335 ELSE
44336 IL=K+4
44337 PBMODE(K,NBMODE) = ONE
44338 ENDIF
44339 BBMODE(1,K,NBMODE) = -E*RFCH(IL)
44340 27 BBMODE(2,K,NBMODE) = -E*LFCH(IL)
44341C--chargino --> neutralino W+
44342 ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.198) THEN
44343 NBMODE = NBMODE+1
44344 IF(NBMODE.GT.NMODEB) THEN
44345 CALL HWWARN('HWISP3',143)
44346 GOTO 999
44347 ENDIF
44348 NME(I) = 20000+NBMODE
44349 IDBPRT(NBMODE) = I
44350 IBMODE(NBMODE) = 198
44351 IBDRTP(NBMODE) = 1
44352 DO 28 J=1,2
44353 28 ABMODE(J,NBMODE) = OIJ(J,L,L1)
44354 DO 29 K=1,6
44355 PBMODE(K,NBMODE) = ONE
44356 IF(K.LE.3) PBMODE(K,NBMODE) = THREE
44357 BBMODE(1,K,NBMODE) = ZERO
44358 29 BBMODE(2,K,NBMODE) = -G*ORT
44359C--unrecognised decay issue warning
44360 ELSE
44361 CALL HWWARN('HWISP3',12)
44362 ENDIF
44363C--then the -ve chargino decay modes
44364 ELSEIF((L1.EQ.7.OR.L1.EQ.8)
44365 & .AND.IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
44366 L1 = L1-6
44367C--chargino --> chargino Z
44368 IF((L.EQ.7.OR.L.EQ.8).AND.IDKPRD(2,I).EQ.200) THEN
44369 L = L-6
44370 NBMODE = NBMODE+1
44371 IF(NBMODE.GT.NMODEB) THEN
44372 CALL HWWARN('HWISP3',144)
44373 GOTO 999
44374 ENDIF
44375 NME(I) = 20000+NBMODE
44376 IDBPRT(NBMODE) = I
44377 IBMODE(NBMODE) = 200
44378 IBDRTP(NBMODE) = 1
44379 DO 30 J=1,2
44380 30 ABMODE(J,NBMODE) =-OIJP(O(J),L,L1)
44381 DO 31 K=1,12
44382 IF(K.LE.6) THEN
44383 IL = K
44384 PBMODE(K,NBMODE) = THREE
44385 ELSE
44386 IL=K+4
44387 PBMODE(K,NBMODE) = ONE
44388 ENDIF
44389 BBMODE(1,K,NBMODE) = -E*RFCH(IL)
44390 31 BBMODE(2,K,NBMODE) = -E*LFCH(IL)
44391C--chargino --> neutralino W-
44392 ELSEIF(L.GE.1.AND.L.LE.4.AND.IDKPRD(2,I).EQ.199) THEN
44393 NBMODE = NBMODE+1
44394 IF(NBMODE.GT.NMODEB) THEN
44395 CALL HWWARN('HWISP3',145)
44396 GOTO 999
44397 ENDIF
44398 NME(I) = 20000+NBMODE
44399 IDBPRT(NBMODE) = I
44400 IBMODE(NBMODE) = 199
44401 IBDRTP(NBMODE) = 1
44402 DO 32 J=1,2
44403 32 ABMODE(J,NBMODE) =-OIJ(O(J),L,L1)
44404 DO 33 K=1,6
44405 PBMODE(K,NBMODE) = ONE
44406 IF(K.LE.3) PBMODE(K,NBMODE) = THREE
44407 BBMODE(1,K,NBMODE) = ZERO
44408 33 BBMODE(2,K,NBMODE) = -G*ORT
44409C--unrecognised decay issue warning
44410 ELSE
44411 CALL HWWARN('HWISP3',13)
44412 ENDIF
44413C--gauge boson decay modes of the Higgs
44414 ELSEIF(IH.GE.1.AND.IH.LE.5.AND.IH1.GE.1.AND.IH1.LE.5.AND.
44415 & IDKPRD(1,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
44416C--decay of the A0 to scalar Higgs and Z boson
44417 IF(IH1.EQ.3.AND.IH.LE.2) THEN
44418 NBMODE = NBMODE+1
44419 IF(NBMODE.GT.NMODEB) THEN
44420 CALL HWWARN('HWISP3',146)
44421 GOTO 999
44422 ENDIF
44423 NME(I) = 20000+NBMODE
44424 IDBPRT(NBMODE) = I
44425 IBMODE(NBMODE) = 200
44426 IBDRTP(NBMODE) = 6
44427 ABMODE(1,NBMODE) =-HHB(2,IH)
44428 ABMODE(2,NBMODE) = ZERO
44429 DO 34 K=1,12
44430 IF(K.LE.6) THEN
44431 IL = K
44432 PBMODE(K,NBMODE) = 3.0D0
44433 ELSE
44434 IL=K+4
44435 PBMODE(K,NBMODE) = 1.0D0
44436 ENDIF
44437 BBMODE(1,K,NBMODE) = -E*RFCH(IL)
44438 34 BBMODE(2,K,NBMODE) = -E*LFCH(IL)
44439C--decay of scalar Higgs to A0 and Z
44440 ELSEIF(IH.EQ.3.AND.IH1.LE.3) THEN
44441 NBMODE = NBMODE+1
44442 IF(NBMODE.GT.NMODEB) THEN
44443 CALL HWWARN('HWISP3',147)
44444 GOTO 999
44445 ENDIF
44446 NME(I) = 20000+NBMODE
44447 IDBPRT(NBMODE) = I
44448 IBMODE(NBMODE) = 200
44449 IBDRTP(NBMODE) = 6
44450 ABMODE(1,NBMODE) = HHB(2,IH1)
44451 ABMODE(2,NBMODE) = ZERO
44452 DO 35 K=1,12
44453 IF(K.LE.6) THEN
44454 IL = K
44455 PBMODE(K,NBMODE) = 3.0D0
44456 ELSE
44457 IL=K+4
44458 PBMODE(K,NBMODE) = 1.0D0
44459 ENDIF
44460 BBMODE(1,K,NBMODE) = -E*RFCH(IL)
44461 35 BBMODE(2,K,NBMODE) = -E*LFCH(IL)
44462C--decay of the positively charged Higgs
44463 ELSEIF(IH1.EQ.4.AND.IH.LE.3) THEN
44464 NBMODE = NBMODE+1
44465 IF(NBMODE.GT.NMODEB) THEN
44466 CALL HWWARN('HWISP3',148)
44467 GOTO 999
44468 ENDIF
44469 NME(I) = 20000+NBMODE
44470 IDBPRT(NBMODE) = I
44471 IBMODE(NBMODE) = 198
44472 IBDRTP(NBMODE) = 6
44473 ABMODE(1,NBMODE) =-HHB(1,IH)
44474 ABMODE(2,NBMODE) = ZERO
44475 DO 36 K=1,6
44476 PBMODE(K,NBMODE) = 1.0D0
44477 IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
44478 BBMODE(1,K,NBMODE) = ZERO
44479 36 BBMODE(2,K,NBMODE) = -G*ORT
44480C--decay of the negatively charged Higgs
44481 ELSEIF(IH1.EQ.5.AND.IH.LE.3) THEN
44482 NBMODE = NBMODE+1
44483 IF(NBMODE.GT.NMODEB) THEN
44484 CALL HWWARN('HWISP3',149)
44485 GOTO 999
44486 ENDIF
44487 NME(I) = 20000+NBMODE
44488 IDBPRT(NBMODE) = I
44489 IBMODE(NBMODE) = 199
44490 IBDRTP(NBMODE) = 6
44491 ABMODE(1,NBMODE) =-HHB(1,IH)
44492 ABMODE(2,NBMODE) = ZERO
44493 DO 37 K=1,6
44494 PBMODE(K,NBMODE) = 1.0D0
44495 IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
44496 BBMODE(1,K,NBMODE) = ZERO
44497 37 BBMODE(2,K,NBMODE) = -G*ORT
44498 ENDIF
44499C--finally sfermion modes to gauge bosons
44500 ELSEIF(IDK(I).GE.401.AND.IDK(I).LE.448.AND.
44501 & IDKPRD(2,I).GE.401.AND.IDKPRD(2,I).LE.448.AND.
44502 & IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200) THEN
44503C--change the order of the decay products
44504 IM = MOD(INT((IDK(I)-389)/12)+1,2)+1
44505 IL = 6*INT((IDK(I)-401)/24)+MOD(IDK(I)-401,6)+1
44506 IH = MOD(INT((IDKPRD(2,I)-389)/12)+1,2)+1
44507 IQ = 6*INT((IDKPRD(2,I)-401)/24)+MOD(IDKPRD(2,I)-401,6)+1
44508C--first the Z decay modes
44509 IF(IDKPRD(1,I).EQ.200) THEN
44510 NBMODE = NBMODE+1
44511 IF(NBMODE.GT.NMODEB) THEN
44512 CALL HWWARN('HWISP3',150)
44513 GOTO 999
44514 ENDIF
44515 NME(I) = 20000+NBMODE
44516 IDBPRT(NBMODE) = I
44517 IBMODE(NBMODE) = 200
44518 IBDRTP(NBMODE) = 6
44519 ABMODE(1,NBMODE) = ZAB(IL,IM,IH)
44520 ABMODE(2,NBMODE) = ZERO
44521 DO 38 K=1,12
44522 IF(K.LE.6) THEN
44523 IL = K
44524 PBMODE(K,NBMODE) = 3.0D0
44525 ELSE
44526 IL=K+4
44527 PBMODE(K,NBMODE) = 1.0D0
44528 ENDIF
44529 BBMODE(1,K,NBMODE) = -E*RFCH(IL)
44530 38 BBMODE(2,K,NBMODE) = -E*LFCH(IL)
44531C--then the W+ decay modes
44532 ELSEIF(IDKPRD(1,I).EQ.198) THEN
44533 NBMODE = NBMODE+1
44534 IF(NBMODE.GT.NMODEB) THEN
44535 CALL HWWARN('HWISP3',151)
44536 GOTO 999
44537 ENDIF
44538 NME(I) = 20000+NBMODE
44539 IDBPRT(NBMODE) = I
44540 IBMODE(NBMODE) = 198
44541 IBDRTP(NBMODE) = 6
44542 IF(IL.LE.6) THEN
44543 ABMODE(1,NBMODE) = -G*ORT*QMIXSS(IL,1,IM)*QMIXSS(IQ,1,IH)
44544 ELSE
44545 ABMODE(1,NBMODE) = -G*ORT*LMIXSS(IL-6,1,IM)*
44546 & LMIXSS(IQ-6,1,IH)
44547 ENDIF
44548 ABMODE(2,NBMODE) = ZERO
44549 DO 39 K=1,6
44550 PBMODE(K,NBMODE) = 1.0D0
44551 IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
44552 BBMODE(1,K,NBMODE) = ZERO
44553 39 BBMODE(2,K,NBMODE) = -G*ORT
44554 ELSEIF(IDKPRD(1,I).EQ.199) THEN
44555 NBMODE = NBMODE+1
44556 IF(NBMODE.GT.NMODEB) THEN
44557 CALL HWWARN('HWISP3',152)
44558 GOTO 999
44559 ENDIF
44560 NME(I) = 20000+NBMODE
44561 IDBPRT(NBMODE) = I
44562 IBMODE(NBMODE) = 199
44563 IBDRTP(NBMODE) = 6
44564 IF(IL.LE.6) THEN
44565 ABMODE(1,NBMODE) = -G*ORT*QMIXSS(IL,1,IM)*QMIXSS(IQ,1,IH)
44566 ELSE
44567 ABMODE(1,NBMODE) = -G*ORT*LMIXSS(IL-6,1,IM)*
44568 & LMIXSS(IQ-6,1,IH)
44569 ENDIF
44570 ABMODE(2,NBMODE) = ZERO
44571 DO 40 K=1,6
44572 PBMODE(K,NBMODE) = 1.0D0
44573 IF(K.LE.3) PBMODE(K,NBMODE) = 3.0D0
44574 BBMODE(1,K,NBMODE) = ZERO
44575 40 BBMODE(2,K,NBMODE) = -G*ORT
44576 ENDIF
44577 ENDIF
44578 2000 CONTINUE
44579C--now compute the maximum weights for the three body decays found
44580 2999 CONTINUE
44581 DO 3000 I=1,N3MODE
44582 IF(RSPIN(IDK(ID3PRT(I))).EQ.ZERO) THEN
44583 RHOIN(1,1) = ONE
44584 RHOIN(1,2) = ZERO
44585 RHOIN(2,1) = ZERO
44586 RHOIN(2,2) = ZERO
44587 ELSE
44588 RHOIN(1,1) = HALF
44589 RHOIN(1,2) = ZERO
44590 RHOIN(2,1) = ZERO
44591 RHOIN(2,2) = HALF
44592 ENDIF
44593 PHEP(5,1) = RMASS(IDK(ID3PRT(I)))
44594 PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2)
44595 PHEP(1,1) = 100.0D0
44596 PHEP(2,1) = 0.0D0
44597 PHEP(3,1) = 0.0D0
44598 IF(IPRINT.EQ.2) WRITE(6,5000) RNAME(IDK(ID3PRT(I))),
44599 & RNAME(IDKPRD(1,ID3PRT(I))),RNAME(IDKPRD(2,ID3PRT(I))),
44600 & RNAME(IDKPRD(3,ID3PRT(I)))
44601 3000 CALL HWD3ME(1,0,I,RHOIN,1)
44602 IF(.NOT.SUSYIN) RETURN
44603C--and for the two body gauge boson modes
44604 DO 4000 I=1,NBMODE
44605 IF(RSPIN(IDK(IDBPRT(I))).EQ.ZERO) THEN
44606 RHOIN(1,1) = ONE
44607 RHOIN(1,2) = ZERO
44608 RHOIN(2,1) = ZERO
44609 RHOIN(2,2) = ZERO
44610 ELSE
44611 RHOIN(1,1) = HALF
44612 RHOIN(1,2) = ZERO
44613 RHOIN(2,1) = ZERO
44614 RHOIN(2,2) = HALF
44615 ENDIF
44616 PHEP(5,1) = RMASS(IDK(IDBPRT(I)))
44617 PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2)
44618 PHEP(1,1) = 100.0D0
44619 PHEP(2,1) = 0.0D0
44620 PHEP(3,1) = 0.0D0
44621 IF(IPRINT.EQ.2) WRITE(6,5010) RNAME(IDK(IDBPRT(I))),
44622 & RNAME(IDKPRD(1,IDBPRT(I))),RNAME(IDKPRD(2,IDBPRT(I)))
44623 IL = 12
44624 IF(IBMODE(I).NE.200) IL = 6
44625 DO 4000 J=1,IL
44626 4000 CALL HWD3ME(1,J,I,RHOIN,1)
44627 RETURN
44628 5000 FORMAT(/'CALCULATING THREE BODY DECAY ',
44629 & A8,' --> ',A8,' ',A8,' ',A8/)
44630 5010 FORMAT(/'CALCULATING TWO BODY DECAY ',
44631 & A8,' --> ',A8,' ',A8/)
44632 999 RETURN
44633 END
44634CDECK ID>, HWISP4.
44635*CMZ :- -12/10/01 12.04.54 by Peter Richardson
44636*-- Author : Peter Richardson
44637C-----------------------------------------------------------------------
44638 SUBROUTINE HWISP4
44639C-----------------------------------------------------------------------
44640C Initialise the Higgs four body modes
44641C-----------------------------------------------------------------------
c63d70bc 44642 INCLUDE 'herwig65.inc'
65767955 44643 INTEGER I,J,K,IL,IH,II,JJ
44644 DOUBLE PRECISION COL(2),SW,CW,TW,E,G,RT,ORT,MW,MZ,AFN(2,12,2,4),
44645 & AFG(2,6,2),AFC(2,12,2,2),OIJ(2,4,2),OIJP(2,2,2),OIJPP(2,4,4),
44646 & HNN(2,3,4,4),HCC(2,3,2,2),HNC(2,4,2),HFF(2,4,12),HWW(2),
44647 & HZZ(2),ZAB(12,2,2),HHB(2,3),GS
44648 COMMON /HWSPNC/ SW,CW,TW,E,G,RT,ORT,MW,MZ,GS,AFN,AFG,AFC,OIJ,OIJP,
44649 & OIJPP,HNN,HCC,HNC,HFF,HWW,HZZ,ZAB,HHB
44650 IF(IERROR.NE.0.OR..NOT.SUSYIN) RETURN
44651C--four body Higgs modes via virtual WW and ZZ
44652 DO 1000 JJ=1,NRES
44653 DO 1000 II=1,NMODES(JJ)
44654 IF(II.EQ.1) THEN
44655 I = LSTRT(JJ)
44656 ELSE
44657 I = LNEXT(I)
44658 ENDIF
44659 IH=IDK(I)-202
44660 IF((IH.EQ.1.OR.IH.EQ.2).AND.IDKPRD(3,I).EQ.0.AND.
44661 & IDKPRD(1,I).GE.198.AND.IDKPRD(1,I).LE.200.AND.
44662 & IDKPRD(2,I).GE.198.AND.IDKPRD(2,I).LE.200) THEN
44663C--first the WW modes
44664 IF(IDKPRD(1,I).NE.200) THEN
44665 N4MODE = N4MODE+1
44666 IF(N4MODE.GT.NMODE4) THEN
44667 CALL HWWARN('HWISP4',100)
44668 GOTO 999
44669 ENDIF
44670 NME(I) = 40000+N4MODE
44671 ID4PRT(N4MODE) = I
44672 I4MODE(1,N4MODE) = 198
44673 I4MODE(2,N4MODE) = 199
44674 DO 1 K=1,6
44675 A4MODE(1,K,N4MODE) = ZERO
44676 A4MODE(2,K,N4MODE) =-G*ORT
44677 B4MODE(1,K,N4MODE) = ZERO
44678 1 B4MODE(2,K,N4MODE) =-G*ORT
44679C--now the prefactors
44680 DO 2 J=1,6
44681 COL(1) = HWW(IH)**2
44682 IF(J.LE.3) COL(1) = THREE*COL(1)
44683 DO 2 K=1,6
44684 COL(2) = ONE
44685 IF(K.LE.3) COL(2) = THREE*COL(2)
44686 2 P4MODE(J,K,N4MODE) = COL(1)*COL(2)
44687C--then the ZZ modes
44688 ELSE
44689 N4MODE = N4MODE+1
44690 IF(N4MODE.GT.NMODE4) THEN
44691 CALL HWWARN('HWISP4',101)
44692 GOTO 999
44693 ENDIF
44694 NME(I) = 40000+N4MODE
44695 ID4PRT(N4MODE) = I
44696 I4MODE(1,N4MODE) = 200
44697 I4MODE(2,N4MODE) = 200
44698 DO 3 K=1,12
44699 IL = K
44700 IF(K.GT.6) IL=K+4
44701 A4MODE(1,K,N4MODE) =-E*RFCH(IL)
44702 A4MODE(2,K,N4MODE) =-E*LFCH(IL)
44703 B4MODE(1,K,N4MODE) =-E*RFCH(IL)
44704 3 B4MODE(2,K,N4MODE) =-E*LFCH(IL)
44705 DO 4 J=1,12
44706 COL(1) = HALF*HZZ(IH)**2
44707 IF(J.LE.6) COL(1)=THREE*COL(1)
44708 DO 4 K=1,12
44709 COL(2) = ONE
44710 IF(K.LE.6) COL(2) = THREE
44711 4 P4MODE(J,K,N4MODE) = COL(1)*COL(2)
44712 ENDIF
44713 ENDIF
44714 1000 CONTINUE
44715C--compute the maximum weights
44716 IF(N4MODE.EQ.0) RETURN
44717 DO 2000 I=1,N4MODE
44718 PHEP(5,1) = RMASS(IDK(ID4PRT(I)))
44719 PHEP(4,1) = SQRT(100.0D0**2+PHEP(5,1)**2)
44720 PHEP(1,1) = 100.0D0
44721 PHEP(2,1) = 0.0D0
44722 PHEP(3,1) = 0.0D0
44723 IF(IPRINT.EQ.2) WRITE(6,5010) RNAME(IDK(ID4PRT(I))),
44724 & RNAME(IDKPRD(1,ID4PRT(I))),RNAME(IDKPRD(2,ID4PRT(I)))
44725 IL = 12
44726 IF(I4MODE(1,I).NE.200) IL = 6
44727 DO 2000 J=1,IL
44728 DO 2000 K=1,IL
44729 2000 CALL HWD4ME(1,J,K,I)
44730 RETURN
44731 5010 FORMAT(/'CALCULATING TWO BODY DECAY ',
44732 & A8,' --> ',A8,' ',A8/)
44733 999 RETURN
44734 END
44735CDECK ID>, HWISSP.
44736*CMZ :- -12/10/01 09:41:43 by Peter Richardson
44737*-- Author : Bryan Webber, modified by Kosuke Odagiri
44738C-----------------------------------------------------------------------
44739 SUBROUTINE HWISSP
44740C-----------------------------------------------------------------------
44741C Reads in SUSY particle properties and decays,
44742C in format generated by ISAWIG
44743C-----------------------------------------------------------------------
c63d70bc 44744 INCLUDE 'herwig65.inc'
65767955 44745 INTEGER I,J,K,IH,IHW,NSSP,NDEC,MDKYS
44746 DOUBLE PRECISION BETAH, WEINCOS,WEINSIN, MW,MZ, RMMAX
44747 DOUBLE PRECISION FTM,FTMUU(4),FTMDD(4),FTMTT(4),FTMBB(4),FTMU,FTMD
44748 DOUBLE PRECISION YTM,YTM1,DTERM(4), SQHF,SNBCSB,MZSW2
44749 LOGICAL FIRST
44750 EQUIVALENCE (MW,RMASS(198)), (MZ,RMASS(200))
44751 SAVE MDKYS
44752 SAVE FIRST
44753 DATA FIRST/.TRUE./
44754 IF (FIRST) THEN
44755 MDKYS=NDKYS
44756 FIRST=.FALSE.
44757 ELSE
44758 NDKYS=MDKYS
44759 ENDIF
44760C--reset susy input flag
44761 IF (LRSUSY.LT.0) CALL HWWARN('HWISSP',500)
44762 SUSYIN = .TRUE.
44763C
44764C Input SUSY particle + top quark table
44765C
44766 WRITE (6,9) ' '
44767 9 FORMAT(//10X,A28//,
44768 & 10X,'Since SUSY processes are called,'
44769 & ,/, 10X,'please also reference: S.Moretti, K.Odagiri,'
44770 & ,/, 10X,'P.Richardson, M.H.Seymour & B.R.Webber,'
44771 & ,/, 10X,'JHEP 0204 (2002) 028')
44772 WRITE (6,10) LRSUSY
44773 10 FORMAT (/10X,'Reading in SUSY data from unit',I3)
44774 READ (LRSUSY,'(I4)') NSSP
44775 IF (NSSP.LE.0) RETURN
44776 RMMAX=SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
44777 RMMNSS=RMMAX
44778 DO I=1,NSSP
44779 READ (LRSUSY,1) IHW,RMASS(IHW),RLTIM(IHW)
44780C Negative gaugino mass means physical field is gamma_5*psi
44781C Store the signs
44782 IF ((IHW.GE.450).AND.(IHW.LE.457)) THEN
44783 IF (IHW.LE.453) THEN
44784 J=IHW-449
44785 ZSGNSS(J)=RMASS(IHW)/ABS(RMASS(IHW))
44786 ELSEIF (IHW.LE.455) THEN
44787 J=IHW-453
44788 WSGNSS(J)=RMASS(IHW)/ABS(RMASS(IHW))
44789 ENDIF
44790 RMASS(IHW)=ABS(RMASS(IHW))
44791 ENDIF
44792 IF (ABS(IDPDG(IHW)).GT.1000000.AND.(RMASS(IHW).NE.ZERO))
44793 & RMMNSS=MIN(RMMNSS,RMASS(IHW))
44794 IF (IHW.GT.NRES) THEN
44795 IF (IHW.GT.NMXRES) CALL HWWARN('HWISSP',501)
44796 NRES=IHW
44797 ENDIF
44798 ENDDO
44799 XLMNSS=TWO*LOG(RMMNSS/RMMAX)
44800 1 FORMAT(I5,F12.4,E15.5)
44801C
44802C Input decay modes
44803C
44804 NDECSY = NDKYS+1
44805 DO I=1,NSSP
44806 READ (LRSUSY,'(I4)') NDEC
44807 IF (NDEC.GT.0) THEN
44808 DO J=1,NDEC
44809 NDKYS=NDKYS+1
44810 IF (NDKYS.GT.NMXDKS) THEN
44811 CALL HWWARN('HWISSP',100)
44812 GOTO 999
44813 ENDIF
44814 READ (LRSUSY,11) IDK(NDKYS),BRFRAC(NDKYS),NME(NDKYS),
44815 & (IDKPRD(K,NDKYS),K=1,5)
44816 11 FORMAT(I6,F16.8,6I6)
44817 ENDDO
44818 ENDIF
44819 ENDDO
44820C
44821C Mixings and other SUSY parameters
44822C
44823 READ (LRSUSY,'(2F16.8)') TANB,ALPHAH
44824 DO I=1,4
44825 READ (LRSUSY,13) ZMXNSS(I,1),ZMXNSS(I,2),ZMXNSS(I,3),ZMXNSS(I,4)
44826 END DO
44827 WEINSIN = SQRT(SWEIN)
44828 WEINCOS = SQRT(1.-SWEIN)
44829 DO I=1,4
44830 ZMIXSS(I,1) = WEINCOS*ZMXNSS(I,1)+WEINSIN*ZMXNSS(I,2)
44831 ZMIXSS(I,2) = -WEINSIN*ZMXNSS(I,1)+WEINCOS*ZMXNSS(I,2)
44832 ZMIXSS(I,3) = ZMXNSS(I,3)
44833 ZMIXSS(I,4) = ZMXNSS(I,4)
44834 END DO
44835 DO J=1,16
44836 IF ((J.LE.6).OR.(J.GE.11)) THEN
44837C--left and right couplings now computed in HWIGIN
44838 DO I=1,4
44839 SLFCH(J,I)= ZMIXSS(I,1)*QFCH(J)+ZMIXSS(I,2)*LFCH(J)
44840 SRFCH(J,I)=-ZMIXSS(I,1)*QFCH(J)-ZMIXSS(I,2)*RFCH(J)
44841 END DO
44842 ENDIF
44843 END DO
44844 READ (LRSUSY,13) WMXVSS(1,1),WMXVSS(1,2), WMXVSS(2,1),WMXVSS(2,2)
44845 READ (LRSUSY,13) WMXUSS(1,1),WMXUSS(1,2), WMXUSS(2,1),WMXUSS(2,2)
44846 READ (LRSUSY,'(3F16.8)') THETAT,THETAB,THETAL
44847 READ (LRSUSY,'(3F16.8)') ATSS,ABSS,ALSS
44848 READ (LRSUSY,'( F16.8)') MUSS
44849 DO I=1,6
44850 QMIXSS(I,1,1)=1.
44851 QMIXSS(I,1,2)=0.
44852 QMIXSS(I,2,1)=0.
44853 QMIXSS(I,2,2)=1.
44854 LMIXSS(I,1,1)=1.
44855 LMIXSS(I,1,2)=0.
44856 LMIXSS(I,2,1)=0.
44857 LMIXSS(I,2,2)=1.
44858 END DO
44859 QMIXSS(6,1,1)= COS(THETAT)
44860 QMIXSS(6,1,2)= SIN(THETAT)
44861 QMIXSS(6,2,1)=-QMIXSS(6,1,2)
44862 QMIXSS(6,2,2)= QMIXSS(6,1,1)
44863 QMIXSS(5,1,1)= COS(THETAB)
44864 QMIXSS(5,1,2)= SIN(THETAB)
44865 QMIXSS(5,2,1)=-QMIXSS(5,1,2)
44866 QMIXSS(5,2,2)= QMIXSS(5,1,1)
44867 LMIXSS(5,1,1)= COS(THETAL)
44868 LMIXSS(5,1,2)= SIN(THETAL)
44869 LMIXSS(5,2,1)=-LMIXSS(5,1,2)
44870 LMIXSS(5,2,2)= LMIXSS(5,1,1)
44871C--Evaluating Higgs parameters and couplings
44872 BETAH=ATAN(TANB)
44873 COTB=ONE/TANB
44874 COSBPA=COS(BETAH+ALPHAH)
44875 SINBPA=SIN(BETAH+ALPHAH)
44876 COSBMA=COS(BETAH-ALPHAH)
44877 SINBMA=SIN(BETAH-ALPHAH)
44878 COSA=COS(ALPHAH)
44879 SINA=SIN(ALPHAH)
44880 COSB=COS(BETAH)
44881 SINB=SIN(BETAH)
44882 GHWWSS(1)=SINBMA
44883 GHWWSS(2)=COSBMA
44884 GHWWSS(3)=ZERO
44885 DO 30 I=1,3
44886 GHZZSS(I)=GHWWSS(I)
44887 30 CONTINUE
44888 GHDDSS(1)=-SINA/COSB
44889 GHDDSS(2)= COSA/COSB
44890 GHDDSS(3)= TANB
44891 GHUUSS(1)= COSA/SINB
44892 GHUUSS(2)= SINA/SINB
44893 GHUUSS(3)= COTB
44894 GHWHSS(1)= COSBMA
44895 GHWHSS(2)= SINBMA
44896 GHWHSS(3)= ONE
44897 MZSW2 = MZ**2 * SQRT(SWEIN*(ONE-SWEIN))
44898 DTERM(1) =-SINBPA*MZSW2
44899 DTERM(2) = COSBPA*MZSW2
44900 DTERM(3) = ZERO
44901 FTMUU(1) = MUSS*SINA/SINB
44902 FTMUU(2) =-MUSS*COSA/SINB
44903 FTMUU(3) =-MUSS
44904 FTMUU(4) =-MUSS
44905 FTMTT(1) = ATSS*COSA/SINB
44906 FTMTT(2) = ATSS*SINA/SINB
44907 FTMTT(3) =-ATSS*COTB
44908 FTMTT(4) =-ATSS*COTB
44909 FTMDD(1) =-MUSS*COSA/COSB
44910 FTMDD(2) =-MUSS*SINA/COSB
44911 FTMDD(3) =-MUSS
44912 FTMDD(4) =-MUSS
44913 FTMBB(1) =-ABSS*SINA/COSB
44914 FTMBB(2) = ABSS*COSA/COSB
44915 FTMBB(3) =-ABSS*TANB
44916 FTMBB(4) =-ABSS*TANB
44917 DO 40 IH=1,4
44918 FTMU=FTMUU(IH)
44919 FTMD=FTMDD(IH)
44920 DO 50 I=1,6
44921 IF (I.EQ.5) FTMU=FTMU+FTMTT(IH)
44922 IF (I.EQ.5) FTMD=FTMD+FTMBB(IH)
44923 IF (MOD(I,2).EQ.0) THEN
44924 YTM = GHUUSS(IH)
44925 FTM = FTMU
44926 ELSE
44927 YTM = GHDDSS(IH)
44928 FTM = FTMD
44929 END IF
44930 IF (IH.EQ.3) THEN
44931 GHSQSS(IH,I,1,1) = ZERO
44932 GHSQSS(IH,I,2,2) = ZERO
44933 GHSQSS(IH,I,1,2) = FTM*HALF*RMASS(I)/MW
44934 GHSQSS(IH,I,2,1) = - GHSQSS(IH,I,1,2)
44935 GOTO 50
44936 ELSEIF (IH.EQ.4) THEN
44937 SQHF=SQRT(HALF)
44938 SNBCSB=SINB*COSB
44939 DO 60 J=1,2
44940 DO 70 K=1,2
44941 IF (MOD(I,2).EQ.1) THEN
44942 GHSQSS(IH,I,J,K)=SQHF*(
44943 & RMASS(I )*FTMD*QMIXSS(I,2,J)*QMIXSS(I+1,1,K)
44944 & +RMASS(I+1)*FTMU*QMIXSS(I,1,J)*QMIXSS(I+1,2,K)
44945 & +( MW**2*TWO*SNBCSB-RMASS(I+1)**2*COTB
44946 & -RMASS(I )**2*TANB )*QMIXSS(I,1,J)*QMIXSS(I+1,1,K)
44947 & -RMASS(I)*RMASS(I+1)/SNBCSB
44948 & *QMIXSS(I,2,J)*QMIXSS(I+1,2,K) ) / MW
44949 ELSE
44950 GHSQSS(IH,I,J,K)=GHSQSS(IH,I-1,K,J)
44951 END IF
44952 70 END DO
44953 60 END DO
44954 ELSE
44955 DO 80 J=1,2
44956 DO 90 K=1,2
44957 YTM1=ZERO
44958 IF (J.EQ.K) YTM1=YTM*RMASS(I)**2
44959 GHSQSS(IH,I,J,K)=( YTM1
44960 & +( LFCH(I)*QMIXSS(I,1,J)*QMIXSS(I,1,K)
44961 & -RFCH(I)*QMIXSS(I,2,J)*QMIXSS(I,2,K) )*DTERM(IH)
44962 & +FTM*HALF*RMASS(I)*(QMIXSS(I,1,J)*QMIXSS(I,2,K)
44963 & +QMIXSS(I,2,J)*QMIXSS(I,1,K)) ) / MW
44964 90 CONTINUE
44965 80 CONTINUE
44966 END IF
44967 50 CONTINUE
44968 40 CONTINUE
44969C--Rparity violation
44970 READ (LRSUSY,'(L5)') RPARTY
44971 IF(.NOT.RPARTY) THEN
44972 READ(LRSUSY,20) (((LAMDA1(I,J,K),K=1,3),J=1,3),I=1,3)
44973 READ(LRSUSY,20) (((LAMDA2(I,J,K),K=1,3),J=1,3),I=1,3)
44974 READ(LRSUSY,20) (((LAMDA3(I,J,K),K=1,3),J=1,3),I=1,3)
44975 ENDIF
44976 13 FORMAT(4F16.8)
44977 20 FORMAT(27E16.8)
44978 CLOSE(LRSUSY)
44979 IF(FOURB) CALL HWIMDE
44980 999 RETURN
44981 END
44982CDECK ID>, HWMEVT.
44983*CMZ :- -04/05/99 14.28.59 by Bryan Webber
44984*-- Author : Bryan Webber
44985C-----------------------------------------------------------------------
44986 SUBROUTINE HWMEVT
44987C-----------------------------------------------------------------------
44988C IPROC = 1000,... ADDS SOFT UNDERLYING EVENT
44989C = 8000: CREATES MINIMUM-BIAS EVENT
44990C SUPPRESSED BY ADDING 10000 TO IPROC
44991C-----------------------------------------------------------------------
c63d70bc 44992 INCLUDE 'herwig65.inc'
65767955 44993 DOUBLE PRECISION HWREXP,ENFAC,TECM,SECM,SUMM,EMCL,BMP(5),BMR(3,3)
44994 INTEGER HWRINT,NETC,IBT,IDBT,ID1,ID2,ID3,KHEP,LHEP,NTRY,ICMS,
44995 & NPPBAR,MCHT,JCL,JD1,JD2,JD3,ICH,MODC,NCHT,INHEP(2),
44996 & INID(2,2),JBT
44997C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE
44998C--RMS CLUSTER COORDINATES (GAUSSIAN) AND C*LIFETIME (IN MM)
44999 DOUBLE PRECISION VCLX,VCLY,VCLZ,VCLT,HWRGAU,HWRGEN
45000 EXTERNAL HWREXP,HWRINT,HWRGAU,HWRGEN
45001 SAVE VCLX,VCLY,VCLZ,VCLT
45002 DATA VCLX,VCLY,VCLZ,VCLT/4*1D-12/
45003C--END FIX
45004 IF (IERROR.NE.0) RETURN
45005 IF (.NOT.GENSOF) GOTO 990
45006 IF (IPROC.EQ.8000) THEN
45007C---SET UP BEAM AND TARGET CLUSTERS
45008 5 NETC=0
45009 DO 10 IBT=1,2
45010 JBT=IBT
45011 IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT)
45012 IDBT=IDHW(JBT)
45013 IF (IDBT.EQ.73.OR.IDBT.EQ.75) THEN
45014 INID(1,IBT)=HWRINT(1,2)
45015 INID(2,IBT)=110
45016 ELSEIF (IDBT.EQ.91.OR.IDBT.EQ.93) THEN
45017 INID(1,IBT)=116
45018 INID(2,IBT)=HWRINT(7,8)
45019 ELSEIF (IDBT.EQ.30) THEN
45020 INID(1,IBT)=HWRINT(1,2)
45021 INID(2,IBT)=8
45022 ELSEIF (IDBT.EQ.38) THEN
45023 INID(1,IBT)=2
45024 INID(2,IBT)=HWRINT(7,8)
45025 ELSEIF (IDBT.EQ.34) THEN
45026 INID(1,IBT)=3
45027 INID(2,IBT)=HWRINT(7,8)
45028 ELSEIF (IDBT.EQ.46) THEN
45029 INID(1,IBT)=HWRINT(1,2)
45030 INID(2,IBT)=9
45031 ELSEIF (IDBT.EQ.59) THEN
45032 INID(1,IBT)=HWRINT(1,2)
45033 INID(2,IBT)=HWRINT(7,8)
45034 ELSE
45035 CALL HWWARN('HWMEVT',100)
45036 GOTO 999
45037 ENDIF
45038 NETC=NETC+ICHRG(IDBT)
45039 & -(ICHRG(INID(1,IBT))+ICHRG(INID(2,IBT)))/3
45040 ENFAC=1.
45041 IDHW(NHEP+IBT)=19
45042 IDHEP(NHEP+IBT)=91
45043 ISTHEP(NHEP+IBT)=163+IBT
45044 JMOHEP(1,NHEP+IBT)=JBT
45045 10 CONTINUE
45046 IF (NETC.EQ.0) THEN
45047 ID3=HWRINT(1,2)
45048 ELSEIF (NETC.EQ.-1) THEN
45049 ID3=1
45050 ELSEIF (NETC.EQ.1) THEN
45051 ID3=2
45052 ELSE
45053 GOTO 5
45054 ENDIF
45055 DO 12 IBT=1,2
45056 NHEP=NHEP+1
45057 JBT=IBT
45058 IF (JDAHEP(1,IBT).NE.0) JBT=JDAHEP(1,IBT)
45059 CALL HWVEQU(5,PHEP(1,JBT),PHEP(1,NHEP))
45060 12 INHEP(IBT)=NHEP
45061 ELSE
45062C---FIND BEAM AND TARGET CLUSTERS
45063 DO 20 IBT=1,2
45064 DO 15 KHEP=1,NHEP
45065 IF (ISTHEP(KHEP).EQ.163+IBT) THEN
45066 INHEP(IBT)=KHEP
45067 INID(1,IBT)=IDHW(JMOHEP(1,KHEP))
45068 INID(2,IBT)=IDHW(JMOHEP(2,KHEP))
45069 GOTO 20
45070 ENDIF
45071 15 CONTINUE
45072C---COULDN'T FIND ONE
45073 INHEP(IBT)=0
45074 20 CONTINUE
45075 JCL=-1
45076C---TEST FOR BOTH FOUND
45077 IF (INHEP(1).EQ.0) JCL=INHEP(2)
45078 IF (INHEP(2).EQ.0) JCL=INHEP(1)
45079 IF (JCL.EQ.0) THEN
45080 CALL HWWARN('HWMEVT',101)
45081 GOTO 999
45082 ENDIF
45083 IF (JCL.GT.0) THEN
45084 ISTHEP(JCL)=163
45085 CALL HWCFOR
45086 CALL HWCDEC
45087 CALL HWDHAD
45088 CALL HWDHVY
45089 GOTO 90
45090 ENDIF
45091 ID3=HWRINT(1,2)
45092 ENFAC=ENSOF
45093 NETC=0
45094 ENDIF
45095C---FIND SOFT CM MOMENTUM AND MULTIPLICITY
45096 NTRY=0
45097 NHEP=NHEP+1
45098 IF (NHEP.GT.NMXHEP) THEN
45099 CALL HWWARN('HWMEVT',102)
45100 GOTO 999
45101 ENDIF
45102 ICMS=NHEP
45103 IDHW(NHEP)=16
45104 IDHEP(NHEP)=0
45105C--Bug Fix 31/03/00 PR
45106 JMOHEP(1,ICMS)=INHEP(1)
45107 JMOHEP(2,ICMS)=INHEP(2)
45108C--End of Fix
45109 ISTHEP(NHEP)=170
45110 CALL HWVSUM(4,PHEP(1,INHEP(1)),PHEP(1,INHEP(2)),PHEP(1,NHEP))
45111 CALL HWUMAS(PHEP(1,NHEP))
45112 TECM=PHEP(5,NHEP)
45113 IF (IPRO/10.EQ.9.OR.IPRO/10.EQ.5) THEN
45114 SECM=TECM*ENFAC
45115 ELSE
45116 SECM=PHEP(5,3)*ENFAC
45117 ENDIF
45118C---CHOOSE MULTIPLICITY
45119 25 CALL HWMULT(SECM,NPPBAR)
45120 30 NCL=0
45121 MCHT=0
45122 IERROR=0
45123 NHEP =ICMS
45124 SUMM=0.
45125 NTRY=NTRY+1
45126C---CREATE CLUSTERS
45127 35 NCL=NCL+1
45128 NHEP=NHEP+1
45129 IF (NHEP.GT.NMXHEP) THEN
45130 CALL HWWARN('HWMEVT',103)
45131 GOTO 999
45132 ENDIF
45133 JCL=NHEP
45134 IDHW(JCL)=19
45135 IDHEP(JCL)=91
45136 IF (NCL.LT.3) THEN
45137 ISTHEP(JCL)=170+NCL
45138 ID1=INID(1,NCL)
45139 ID2=INID(2,NCL)
45140 ELSE
45141 ID1=ID2-6
45142 IF (NCL.EQ.3) ID1=ID3
45143 ID2=HWRINT(7,8)
45144 ISTHEP(JCL)=173
45145 ENDIF
45146 JMOHEP(1,JCL)=ICMS
45147 JMOHEP(2,JCL)=0
45148 CALL HWVZRO(3,PHEP(1,JCL))
45149 PHEP(4,JCL)=RMASS(ID1)+RMASS(ID2)+PMBM1+HWREXP(TWO/PMBM2)
45150 PHEP(5,JCL)=PHEP(4,JCL)
45151C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE
45152C--VERTEX POSITION FOR CLUSTER FORMATION
45153 VHEP(1,JCL)=HWRGAU(1,ZERO,VCLX)
45154 VHEP(2,JCL)=HWRGAU(2,ZERO,VCLY)
45155 VHEP(3,JCL)=HWRGAU(3,ZERO,VCLZ)
45156 VHEP(4,JCL)=SQRT(VHEP(1,JCL)**2+VHEP(2,JCL)**2+VHEP(3,JCL)**2)
45157 & -VCLT*LOG(HWRGEN(0))
45158C--MHS FIX 07/03/05 - MEASURE DISPLACEMENTS RELATIVE TO SOFT CM
45159 CALL HWVZRO(4,VTXPIP)
45160C--END FIXES
45161C---HADRONIZE AND DECAY CLUSTERS
45162 CALL HWCFLA(ID1,ID2,JD1,JD2)
45163 CALL HWCHAD(JCL,JD1,JD2,JD3)
45164 IF (IERROR.NE.0) RETURN
45165 IF (JD3.EQ.0) THEN
45166 EMCL=RMASS(IDHW(NHEP))
45167 IF (PHEP(4,JCL).NE.EMCL) THEN
45168 PHEP(4,JCL)=EMCL
45169 PHEP(5,JCL)=EMCL
45170 PHEP(4,NHEP)=EMCL
45171 PHEP(5,NHEP)=EMCL
45172 ENDIF
45173 ELSE
45174 EMCL=PHEP(5,JCL)
45175 ENDIF
45176 IDCL(NCL)=JD3
45177 PPCL(5,NCL)=EMCL
45178 SUMM=SUMM +EMCL
45179 CALL HWDHAD
45180 CALL HWDHVY
45181 IF (IERROR.NE.0) RETURN
45182C---CHECK CHARGED MULTIPLICITY
45183 MODC=0
45184 DO 50 KHEP=JCL,NHEP
45185 IF (ISTHEP(KHEP).EQ.1) THEN
45186 ICH=ICHRG(IDHW(KHEP))
45187 IF (ICH.NE.0) THEN
45188 MCHT=MCHT+ABS(ICH)
45189 MODC=MODC+ICH
45190 ENDIF
45191 ENDIF
45192 50 CONTINUE
45193 IF (NCL.EQ.1) THEN
45194 NCHT=NPPBAR+NETC+ABS(MODC)
45195 GOTO 35
45196 ELSEIF (NCL.EQ.2) THEN
45197 NCHT=NCHT+ABS(MODC)
45198 IF (NCHT.LT.0) NCHT=NCHT+2
45199 ENDIF
45200 IF (MCHT.LT.NCHT) THEN
45201 GOTO 35
45202 ELSEIF (MCHT.GT.NCHT) THEN
45203 IF (MOD(NTRY,50).EQ.0) GOTO 25
45204 IF (NTRY.LT.NSTRY) GOTO 30
45205C---NO PHASE SPACE FOR SOFT EVENT
45206 NHEP=ICMS-1
45207 IF (IPROC.EQ.8000) THEN
45208C---MINIMUM BIAS: RELABEL BEAM AND TARGET CLUSTERS
45209 DO 60 IBT=1,2
45210 KHEP=INHEP(IBT)
45211 LHEP=JMOHEP(1,KHEP)
45212 ISTHEP(KHEP)=1
45213 IDHEP(KHEP)=IDHEP(LHEP)
45214 IDHW(KHEP)=IDHW(LHEP)
45215 60 CONTINUE
45216 ELSE
45217C---UNDERLYING EVENT: DECAY THEM
45218 ISTHEP(INHEP(1))=163
45219 ISTHEP(INHEP(2))=163
45220 CALL HWCFOR
45221 CALL HWCDEC
45222 CALL HWDHAD
45223 CALL HWDHVY
45224 ENDIF
45225 GOTO 90
45226 ENDIF
45227C---GENERATE CLUSTER MOMENTA IN CLUSTER CM
45228C FRAME. N.B. SECOND CLUSTER IS TARGET
45229 IF (SUMM.GT.TECM) GOTO 25
45230 CALL HWMLPS(TECM)
45231 IF (NCL.EQ.0) GOTO 25
45232 JCL=0
45233C---ROTATE & BOOST CLUSTERS & DECAY PRODUCTS
45234 CALL HWULOF(PHEP(1,ICMS),PHEP(1,INHEP(1)),BMP)
45235 CALL HWUROT(BMP, ONE,ZERO,BMR)
45236C---BMR PUTS BEAM ALONG Z AXIS (WE WANT INVERSE)
45237 DO 70 KHEP=ICMS+1,NHEP
45238 IF (ISTHEP(KHEP).GT.180.AND.ISTHEP(KHEP).LT.190
45239 $ .AND.JMOHEP(1,KHEP).EQ.ICMS) THEN
45240 ISTHEP(KHEP)=ISTHEP(KHEP)+3
45241 LHEP=KHEP
45242 JCL=JCL+1
45243 CALL HWUROB(BMR,PPCL(1,JCL),PPCL(1,JCL))
45244 CALL HWULOB(PHEP(1,ICMS),PPCL(1,JCL),PPCL(1,JCL))
45245C---NOW PPCL(*,JCL) IS LAB MOMENTUM OF JTH CLUSTER
45246 ENDIF
45247 CALL HWULOB(PPCL(1,JCL),PHEP(1,KHEP),PHEP(1,KHEP))
45248C--BRW FIX 30/12/04 FOR SPACE-TIME STRUCTURE
45249 CALL HWULOB(PPCL(1,JCL),VHEP(1,KHEP),VHEP(1,KHEP))
45250C--MHS FIX 07/03/05 - ASSUME THAT SOFT CM COINCIDES WITH PRIMARY IP
45251 IF (.NOT.(ISTHEP(KHEP).GT.180.AND.ISTHEP(KHEP).LT.190
45252 $ .AND.JMOHEP(1,KHEP).EQ.ICMS))
45253 $ CALL HWVSUM(4,VHEP(1,3),VHEP(1,KHEP),VHEP(1,KHEP))
45254C--END FIXES
45255 70 CONTINUE
45256 ISTHEP(INHEP(1))=167
45257 ISTHEP(INHEP(2))=168
45258 JDAHEP(1,INHEP(1))=ICMS
45259 JDAHEP(2,INHEP(1))=0
45260 JDAHEP(1,INHEP(2))=ICMS
45261 JDAHEP(2,INHEP(2))=0
45262 JDAHEP(1,ICMS)=ICMS+1
45263 JDAHEP(2,ICMS)=LHEP
45264 90 CONTINUE
45265 990 ISTAT=100
45266 999 RETURN
45267 END
45268CDECK ID>, HWMLPS.
45269*CMZ :- -04/05/99 14.17.04 by Bryan Webber
45270*-- Author : David Ward, modified by Bryan Webber
45271C-----------------------------------------------------------------------
45272 SUBROUTINE HWMLPS(TECM)
45273C-----------------------------------------------------------------------
45274C GENERATES CYLINDRICAL PHASE SPACE USING THE METHOD OF JADACH
45275C RETURNS WITH NCL=0 IF UNSUCCESSFUL
45276C-----------------------------------------------------------------------
c63d70bc 45277 INCLUDE 'herwig65.inc'
65767955 45278 DOUBLE PRECISION HWREXT,HWRUNG,HWUSQR,TECM,ESS,ALOGS,EPS,SUMX,
45279 & SUMY,PT,PX,PY,PT2,SUMPT2,SUMTM,XIMIN,XIMAX,YY,SUM1,SUM2,SUM3,
45280 & SUM4,EX,FY,DD,DYY,ZZ,E1,TM,SLOP,XI(NMXCL)
45281 INTEGER NTRY,I,NIT,IY(NMXCL),IDP
45282 EXTERNAL HWREXT,HWRUNG,HWUSQR
45283 IF (NCL.GT.NMXCL) THEN
45284 CALL HWWARN('HWMLPS',1)
45285 NCL=NMXCL
45286 ENDIF
45287 ESS=TECM**2
45288 ALOGS=LOG(ESS)
45289 EPS=1D-10/NCL
45290 NTRY=0
45291 11 NTRY=NTRY+1
45292 IF (NTRY.GT.NSTRY) THEN
45293 NCL=0
45294 RETURN
45295 ENDIF
45296 SUMX=0.
45297 SUMY=0.
45298 DO 12 I=1,NCL
45299C---Pt distribution of form exp(-b*Mt)
45300C---Factors for pt slopes to fit data. IDCL contains the type of
45301C q-qbar pair produced in this cluster (0 if 1-particle cluster).
45302 IDP=IDCL(I)
45303 IF (IDP.LE.2) THEN
45304 SLOP=PMBP1
45305 ELSEIF(IDP.EQ.3.OR.IDP.EQ.10) THEN
45306 SLOP=PMBP2
45307 ELSEIF(IDP.GT.3.AND.IDP.LE.9) THEN
45308 SLOP=PMBP3
45309 ELSE
45310 CALL HWWARN('HWMLPS',IDP)
45311 IF(IDP.LT.0.OR.IDP.GT.49) GOTO 999
45312 SLOP=PMBP2
45313 ENDIF
45314 PT=HWREXT(PPCL(5,I),SLOP)
45315 PT=HWUSQR(PT**2-PPCL(5,I)**2)
45316 CALL HWRAZM(PT,PX,PY)
45317 PPCL(1,I)=PX
45318 PPCL(2,I)=PY
45319 SUMX=SUMX+PPCL(1,I)
45320 12 SUMY=SUMY+PPCL(2,I)
45321 SUMX=SUMX/NCL
45322 SUMY=SUMY/NCL
45323 SUMPT2=0.
45324 SUMTM=0.
45325 DO 13 I=1,NCL
45326 PPCL(1,I)=PPCL(1,I)-SUMX
45327 PPCL(2,I)=PPCL(2,I)-SUMY
45328 PT2=PPCL(1,I)**2+PPCL(2,I)**2
45329 SUMPT2=SUMPT2+PT2
45330C---STORE TRANSVERSE MASS IN PPCL(3,I) TEMPORARILY
45331 PPCL(3,I)=SQRT(PT2+PPCL(5,I)**2)
45332 13 SUMTM=SUMTM+PPCL(3,I)
45333 IF (SUMTM.GT.TECM) GOTO 11
45334 DO 14 I=1,NCL
45335C---Form of "reduced rapidity" distribution
45336 XI(I)=HWRUNG(0.6*ONE,ONE)
45337 14 CONTINUE
45338 CALL HWUSOR(XI,NCL,IY,1)
45339 XIMIN=XI(1)
45340 XIMAX=XI(NCL)-XI(1)
45341C---N.B. TARGET CLUSTER IS SECOND
45342 XI(1)=0.
45343 DO 16 I=NCL-1,2,-1
45344 XI(I+1)=(XI(I)-XIMIN)/XIMAX
45345 16 CONTINUE
45346 XI(2)=1.
45347 YY=LOG(ESS/(PPCL(3,1)*PPCL(3,2)))
45348 DO 18 NIT=1,10
45349 SUM1=0.
45350 SUM2=0.
45351 SUM3=0.
45352 SUM4=0.
45353 DO 19 I=1,NCL
45354 TM=PPCL(3,I)
45355 EX=EXP(YY*XI(I))
45356 SUM1=SUM1+(TM*EX)
45357 SUM2=SUM2+(TM/EX)
45358 SUM3=SUM3+(TM*EX)*XI(I)
45359 19 SUM4=SUM4+(TM/EX)*XI(I)
45360 FY=ALOGS-LOG(SUM1*SUM2)
45361 DD=(SUM3*SUM2-SUM1*SUM4)/(SUM1*SUM2)
45362 DYY=FY/DD
45363 IF(ABS(DYY/YY).LT.EPS) GOTO 20
45364 18 YY=YY+DYY
45365C---Y ITERATIONS EXCEEDED - TRY AGAIN
45366 IF (NTRY.LT.100) GOTO 11
45367 EPS=10.*EPS
45368 IF (EPS.GT.ONE) THEN
45369 CALL HWWARN('HWMLPS',100)
45370 GOTO 999
45371 ENDIF
45372 CALL HWWARN('HWMLPS',50)
45373 GOTO 11
45374 20 YY=YY+DYY
45375 ZZ=LOG(TECM/SUM1)
45376 DO 22 I=1,NCL
45377 TM=PPCL(3,I)
45378 E1=EXP(ZZ+YY*XI(I))
45379 PPCL(3,I)=(0.5*TM)*((1./E1)-E1)
45380 PPCL(4,I)=(0.5*TM)*((1./E1)+E1)
45381 22 CONTINUE
45382 999 RETURN
45383 END
45384CDECK ID>, HWMNBI.
45385*CMZ :- -26/04/91 11.11.55 by Bryan Webber
45386*-- Author : David Ward, modified by Bryan Webber
45387C-----------------------------------------------------------------------
45388 FUNCTION HWMNBI(N,AVNCH,EK)
45389C-----------------------------------------------------------------------
45390C---Computes negative binomial probability
45391C-----------------------------------------------------------------------
45392 IMPLICIT NONE
45393 DOUBLE PRECISION HWMNBI,AVNCH,EK,R
45394 INTEGER N,I
45395 IF(N.LE.0) THEN
45396 HWMNBI=0
45397 ELSE
45398 R=AVNCH/EK
45399 HWMNBI=(1.+R)**(-EK)
45400 R=R/(1.+R)
45401 DO 1 I=1,N
45402 HWMNBI=HWMNBI*R*(EK+I-1)/I
45403 1 CONTINUE
45404 ENDIF
45405 END
45406CDECK ID>, HWMODK.
45407*CMZ :- -27/07/99 13.33.03 by Mike Seymour
45408*-- Author : Ian Knowles
45409C-----------------------------------------------------------------------
45410 SUBROUTINE HWMODK(IDKTMP,BRTMP,IMETMP,
45411 & IATMP,IBTMP,ICTMP,IDTMP,IETMP)
45412C-----------------------------------------------------------------------
45413C Takes the decay, IDKTMP -> I-(A+B+C+D+E)-TMP, and simply stores it
45414C if internal pointers not set up (.NOT.DKPSET) else if pre-existing
45415C mode updates branching ratio BRTMP and matrix element code IMETMP,
45416C if -ve leaves as is. If a new mode adds to table and if consistent
45417C adjusts pointers, sets CMMOM (for two-body mode) and resets RSTAB
45418C if necessary. The branching ratios of any other IDKTMP decays are
45419C scaled by (1.-BRTMP)/(1.-BR_OLD)
45420C-----------------------------------------------------------------------
c63d70bc 45421 INCLUDE 'herwig65.inc'
65767955 45422 DOUBLE PRECISION HWUPCM,BRTMP,SCALE,EPS
45423 INTEGER IDKTMP,IMETMP,IATMP,IBTMP,ICTMP,IDTMP,IETMP,IDKY,ITMP(5),
45424 & L,I,J,K,JPREV
45425 LOGICAL MATCH(5),IFGO
45426 CHARACTER*8 CDUM
45427 EXTERNAL HWUPCM
45428 PARAMETER (EPS=1.D-6)
45429C Convert to internal format
45430 CALL HWUIDT(1,IDKTMP,IDKY,CDUM)
45431 IF (IDKY.EQ.20) THEN
45432 WRITE(6,10) IDKTMP
45433 10 FORMAT(1X,'Particle decaying,',I7,', is not recognised')
45434 RETURN
45435 ENDIF
45436 CALL HWUIDT(1,IATMP,ITMP(1),CDUM)
45437 CALL HWUIDT(1,IBTMP,ITMP(2),CDUM)
45438 CALL HWUIDT(1,ICTMP,ITMP(3),CDUM)
45439 CALL HWUIDT(1,IDTMP,ITMP(4),CDUM)
45440 CALL HWUIDT(1,IETMP,ITMP(5),CDUM)
45441C If internal pointers not yet set up simply store decay
45442 IF (.NOT.DKPSET) THEN
45443 NDKYS=NDKYS+1
45444 IF (NDKYS.GT.NMXDKS) THEN
45445 CALL HWWARN('HWMODK',100)
45446 GOTO 999
45447 ENDIF
45448 IDK(NDKYS)=IDKY
45449 BRFRAC(NDKYS)=BRTMP
45450 NME(NDKYS)=IMETMP
45451 DO 20 I=1,5
45452 20 IDKPRD(I,NDKYS)=ITMP(I)
45453 ELSE
45454 IF (NMODES(IDKY).GT.0) THEN
45455C First search to see if mode pre-exists
45456 IF ((ITMP(2).GE.1.AND.ITMP(2).LE.13).OR.
45457 & (ITMP(3).GE.1.AND.ITMP(3).LE.13)) THEN
45458C Partonic respect order
45459 L=LSTRT(IDKY)
45460 DO 30 K=1,NMODES(IDKY)
45461 IF (ITMP(1).EQ.IDKPRD(1,L).AND.
45462 & ITMP(2).EQ.IDKPRD(2,L).AND.
45463 & ITMP(3).EQ.IDKPRD(3,L).AND.
45464 & ITMP(4).EQ.IDKPRD(4,L).AND.
45465 & ITMP(5).EQ.IDKPRD(5,L)) GOTO 90
45466 30 L=LNEXT(L)
45467 ELSE
45468C Allow for different order in matching
45469 L=LSTRT(IDKY)
45470 DO 70 I=1,NMODES(IDKY)
45471 DO 40 J=1,5
45472 40 MATCH(J)=.FALSE.
45473 DO 60 J=1,5
45474 DO 50 K=1,5
45475 IF (.NOT.MATCH(K).AND.ITMP(K).EQ.IDKPRD(J,L)) THEN
45476 MATCH(K)=.TRUE.
45477 GOTO 60
45478 ENDIF
45479 50 CONTINUE
45480 60 CONTINUE
45481 IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
45482 & MATCH(4).AND.MATCH(5)) GOTO 90
45483 70 L=LNEXT(L)
45484 ENDIF
45485 ENDIF
45486C A new mode put decay products in table
45487 NDKYS=NDKYS+1
45488 IF (NDKYS.GT.NMXDKS) THEN
45489 CALL HWWARN('HWMODK',101)
45490 GOTO 999
45491 ENDIF
45492 DO 80 I=1,5
45493 80 IDKPRD(I,NDKYS)=ITMP(I)
45494C If decay consistent set up new pointers
45495 CALL HWDCHK(IDKY,NDKYS,IFGO)
45496 IF(IFGO) GOTO 980
45497 IF (NMODES(IDKY).EQ.0) THEN
45498 LSTRT(IDKY)=NDKYS
45499 IF (RLTIM(IDKY).LT.PLTCUT.AND.RMASS(IDKY).NE.ZERO) THEN
45500 RSTAB(IDKY)=.FALSE.
45501 DKLTM(IDKY)=RLTIM(IDKY)*RMASS(IDKY)/HBAR
45502 ELSE
45503 RSTAB(IDKY)=.TRUE.
45504 ENDIF
45505 ELSE
45506 LNEXT(L)=NDKYS
45507 ENDIF
45508 NMODES(IDKY)=NMODES(IDKY)+1
45509 LNEXT(NDKYS)=NDKYS
45510 L=NDKYS
45511C Set CMMOM if two body decay
45512 IF (NPRODS(L).EQ.2) CMMOM(L)=
45513 & HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,L)),RMASS(IDKPRD(2,L)))
45514C A Pre-existing mode, line L, add/update ME code and BR, scaling all
45515C other branching fractions
45516 90 IF (IMETMP.GT.0) NME(L)=IMETMP
45517 IF (ABS(BRTMP-1.).LT.EPS) THEN
45518C This modes dominant: eliminate others
45519 NMODES(IDKY)=1
45520 LSTRT(IDKY)=L
45521 BRFRAC(L)=ONE
45522 LNEXT(L)=L
45523 ELSEIF (ABS(BRTMP).LT.EPS) THEN
45524C This mode insignificant: eliminate it
45525 IF (NMODES(IDKY).EQ.1) THEN
45526 RSTAB(IDKY)=.TRUE.
45527 ELSE
45528 J=LSTRT(IDKY)
45529 IF (J.EQ.L) THEN
45530 LSTRT(IDKY)=LNEXT(J)
45531 ELSE
45532 JPREV=J
45533 DO 100 I=2,NMODES(IDKY)
45534 J=LNEXT(J)
45535 IF (J.EQ.L) LNEXT(JPREV)=LNEXT(J)
45536 100 JPREV=J
45537 ENDIF
45538C Rescale other modes
45539 SCALE=ONE/(ONE-BRFRAC(L))
45540 J=LSTRT(IDKY)
45541 DO 110 I=1,NMODES(IDKY)-1
45542 BRFRAC(J)=SCALE*BRFRAC(J)
45543 110 J=LNEXT(J)
45544 ENDIF
45545 NMODES(IDKY)=NMODES(IDKY)-1
45546 ELSE
45547C Rescale all other modes
45548 IF (NMODES(IDKY).EQ.1) THEN
45549 BRFRAC(L)=ONE
45550 ELSE
45551 IF (L.EQ.NDKYS) THEN
45552 SCALE=ONE-BRTMP
45553 ELSE
45554 SCALE=(ONE-BRTMP)/(ONE-BRFRAC(L))
45555 ENDIF
45556 J=LSTRT(IDKY)
45557 DO 120 I=1,NMODES(IDKY)
45558 IF (J.NE.L) BRFRAC(J)=SCALE*BRFRAC(J)
45559 120 J=LNEXT(J)
45560 BRFRAC(L)=BRTMP
45561 ENDIF
45562 ENDIF
45563 ENDIF
45564 GOTO 999
45565 980 WRITE(6,990)
45566 990 FORMAT(1X,'Decay mode inconsistent, no modifications made')
45567 999 RETURN
45568 END
45569CDECK ID>, HWMULT.
45570*CMZ :- -04/05/99 11.11.55 by Bryan Webber
45571*-- Author : David Ward, modified by Bryan Webber
45572C-----------------------------------------------------------------------
45573 SUBROUTINE HWMULT(EPPBAR,NCHT)
45574C-----------------------------------------------------------------------
45575C Chooses charged multiplicity NCHT at the p-pbar c.m. energy EPPBAR
45576C-----------------------------------------------------------------------
c63d70bc 45577 INCLUDE 'herwig65.inc'
65767955 45578 DOUBLE PRECISION HWMNBI,HWRGEN,EPPBAR,E0,ALOGS,RK,EK,AVN,SUM,R,
45579 & CUM(500)
45580 INTEGER NCHT,IMAX,I,N
45581 SAVE E0,CUM,IMAX
45582 EXTERNAL HWMNBI,HWRGEN
45583 DATA E0/0/
45584 IF (EPPBAR.NE.E0) THEN
45585 E0=EPPBAR
45586C---Initialize
45587 ALOGS=2.*LOG(EPPBAR)
45588 RK=PMBK1*ALOGS+PMBK2
45589 IF (ABS(RK).GT.1000.) RK=1000.
45590 EK=1./RK
45591 AVN=PMBN1*EXP(PMBN2*ALOGS)+PMBN3
45592 IF (AVN.LT.ONE) AVN=1.
45593 SUM=0.
45594 IMAX=1
45595 DO 10 I=1,500
45596 N=2*I
45597 CUM(I)=HWMNBI(N,AVN,EK)
45598 IF (CUM(I).LT.1D-7*SUM) GOTO 11
45599 IMAX=I
45600 SUM=SUM+CUM(I)
45601 CUM(I)=SUM
45602 10 CONTINUE
45603 11 CONTINUE
45604 IF (IMAX.LE.1) THEN
45605 IMAX=1
45606 CUM(1)=1
45607 ELSEIF (IMAX.EQ.500) THEN
45608 E0=0
45609 CALL HWWARN('HWMULT',101)
45610 GOTO 999
45611 ELSE
45612 DO 12 I=1,IMAX
45613 12 CUM(I)=CUM(I)/SUM
45614 ENDIF
45615 ENDIF
45616C --- Select NCHT
45617 R=HWRGEN(0)
45618 DO 20 I=1,IMAX
45619 IF(R.GT.CUM(I)) GOTO 20
45620 NCHT=2*I
45621 RETURN
45622 20 CONTINUE
45623 CALL HWWARN('HWMULT',100)
45624 999 RETURN
45625 END
45626CDECK ID>, HWMWGT.
45627*CMZ :- -02/11/93 11.11.55 by Bryan Webber
45628*-- Author : Bryan Webber
45629C-----------------------------------------------------------------------
45630 SUBROUTINE HWMWGT
45631C-----------------------------------------------------------------------
45632C COMPUTES WEIGHT FOR MINIMUM-BIAS EVENT
45633C-----------------------------------------------------------------------
c63d70bc 45634 INCLUDE 'herwig65.inc'
65767955 45635 DOUBLE PRECISION S,X,Y
45636 INTEGER IDB,IDT,IDBT
45637 IF (IERROR.NE.0) RETURN
45638 IDB=IDHW(1)
45639 IF (JDAHEP(1,1).NE.0) IDB=IDHW(JDAHEP(1,1))
45640 IDT=IDHW(2)
45641 IF (JDAHEP(1,2).NE.0) IDT=IDHW(JDAHEP(1,2))
45642 IDBT=100*IDB+IDT
45643 IF (IDT.GT.IDB) IDBT=100*IDT+IDB
45644C---USE TOTAL CROSS SECTION FITS OF DONNACHIE & LANDSHOFF
45645C CERN-TH.6635/92
45646 IF (IDBT.EQ.9173) THEN
45647 X=21.70
45648 Y=98.39
45649 ELSEIF (IDBT.EQ.7373) THEN
45650 X=21.70
45651 Y=56.08
45652 ELSEIF (IDBT.EQ.7330) THEN
45653 X=13.63
45654 Y=36.02
45655 ELSEIF (IDBT.EQ.7338) THEN
45656 X=13.63
45657 Y=27.56
45658 ELSEIF (IDBT.EQ.7334) THEN
45659 X=11.82
45660 Y=26.36
45661 ELSEIF (IDBT.EQ.7346) THEN
45662 X=11.82
45663 Y= 8.15
45664 ELSEIF (IDBT.EQ.7359) THEN
45665 X=.0677
45666 Y=.1290
45667 ELSEIF (IDBT.EQ.9175) THEN
45668 X=21.70
45669 Y=92.71
45670 ELSEIF (IDBT.EQ.7573) THEN
45671 X=21.70
45672 Y=54.77
45673 ELSEIF (IDBT.EQ.5959) THEN
45674C---FOR GAMMA-GAMMA ASSUME X AND Y FACTORIZE
45675 X=2.1E-4
45676 Y=3.0E-4
45677 ELSE
45678 PRINT *,' IDBT=',IDBT
45679 CALL HWWARN('HWMWGT',100)
45680 GOTO 999
45681 ENDIF
45682 S=PHEP(5,3)**2
45683C---EVWGT IS NON-DIFFRACTIVE CROSS SECTION IN NANOBARNS
45684C ASSUMING NON-DIFFRACTIVE = TOTAL*0.7
45685 EVWGT=.7E6*(X*S**.0808 + Y*S**(-.4525))
45686 999 RETURN
45687 END
45688CDECK ID>, HWPHTP.
45689*CMZ :- -11/08/03 15:30:25 by Peter Richardson
45690*-- Author : Peter Richardson and Zbigniew Was
45691C-----------------------------------------------------------------------
45692 SUBROUTINE HWPHTP(IHEP)
45693C-----------------------------------------------------------------------
45694C subroutine for radiation in top decays
45695C-----------------------------------------------------------------------
c63d70bc 45696 INCLUDE 'herwig65.inc'
65767955 45697 INTEGER IHEP,KK,IPOS,NN,NHEP0,KK1,KK2,JMOH(NMXHEP)
45698 DOUBLE PRECISION HWDPWT
45699 EXTERNAL HWDPWT
45700C--add an extra photon for top or W
45701 IF(IERROR.NE.0) RETURN
45702 IF(ABS(IDHEP(IHEP)).EQ.6.OR.ABS(IDHEP(IHEP)).EQ.24) THEN
45703 NHEP0=NHEP
45704 KK1=JDAHEP(1,IHEP)
45705 KK2=JDAHEP(2,IHEP)
45706C--copy the colour mother infomation
45707 DO KK=KK1,KK2
45708 JMOH(KK)=JMOHEP(2,KK)
45709 JMOHEP(2,KK)=0
45710 ENDDO
45711C--call photos
45712 IPOS=-IHEP
45713 CALL PHOTOS(IPOS)
45714C--reset the colour mother infomation
45715 DO KK=KK1,KK2
45716 JMOHEP(2,KK)=JMOH(KK)
45717 ENDDO
45718C--update the decaying particle
45719 JDAHEP(2,IHEP) = NHEP
45720C--set up the additions photons in the record
45721 NN=NHEP-NHEP0
45722 NHEP=NHEP0
45723 IF(NN.GT.0) THEN
45724 DO KK=1,NN
45725C--photon mass probably not needed
45726 PHEP(5,NHEP+1) = ZERO
45727C--info on the photon
45728 ISTHEP(NHEP+1) = 114
45729 IDHW(NHEP+1) = 59
45730 IDHEP(NHEP+1) = 22
45731 JMOHEP(1,NHEP+1) = IHEP
45732 JMOHEP(2,NHEP+1) = NHEP+1
45733 JDAHEP(2,NHEP+1) = NHEP+1
45734 NHEP = NHEP+1
45735 ENDDO
45736 ENDIF
45737 ENDIF
45738 END
45739CDECK ID>, HWPHTT.
45740*CMZ :- -11/08/03 15:30:25 by Peter Richardson
45741*-- Author : Peter Richardson and Zbigniew Was
45742C-----------------------------------------------------------------------
45743 SUBROUTINE HWPHTT
45744C-----------------------------------------------------------------------
45745C subroutine for radiation in top production
45746C-----------------------------------------------------------------------
c63d70bc 45747 INCLUDE 'herwig65.inc'
65767955 45748C--local variables
45749 INTEGER IMO(10),IFOUND,JMO(2),I,J,K,L,NSTART,NHEPX
45750C--initialisation
45751 IF(IERROR.NE.0) RETURN
45752 IFOUND=0
45753 DO K=1,10
45754 IMO(K)=0
45755 ENDDO
45756C--loop to find mothers of any tops
45757 NSTART=1
45758 DO I=NSTART,NHEP
45759 IF (ABS(IDHEP(I)).EQ.6) THEN
45760 DO K=1,IFOUND
45761 IF(IMO(K).EQ.JMOHEP(1,I)) GOTO 10
45762 ENDDO
45763 IFOUND=IFOUND+1
45764 IMO(IFOUND)=JMOHEP(1,I)
45765 ENDIF
45766 10 CONTINUE
45767 ENDDO
45768C--generate the radiation
45769 DO K=1,IFOUND
45770C--save the colour mother pointers
45771 JMO(1)=JMOHEP(2,JDAHEP(1,IMO(K)))
45772 JMO(2)=JMOHEP(2,1+JDAHEP(1,IMO(K)))
45773C--zero the second mothers
45774 JMOHEP(2,JDAHEP(1,IMO(K)))=0
45775 JMOHEP(2,JDAHEP(2,IMO(K)))=0
45776C--call photos to generate radiation
45777 CALL PHOTOS(IMO(K))
45778 NHEPX=NHEP
45779 DO 11 J=NHEP,1,-1
45780 IF(IDHEP(J).EQ.22) THEN
45781 NHEPX=NHEPX-1
45782 ELSE
45783 GOTO 11
45784 ENDIF
45785 11 CONTINUE
45786C--reset the colour pointers
45787 JMOHEP(2, JDAHEP(1,IMO(K)))=JMO(1)
45788 JMOHEP(2,1+JDAHEP(1,IMO(K)))=JMO(2)
45789C--setup the photons
45790 DO L=NHEPX+1,NHEP
45791 ISTHEP(L)=114
45792 JMOHEP(2,L) = L
45793 JDAHEP(2,L) = L
45794 IDHW(L) = 59
45795 ENDDO
45796 ENDDO
45797 END
45798CDECK ID>, HWRAZM.
45799*CMZ :- -26/04/91 11.11.55 by Bryan Webber
45800*-- Author : Bryan Webber
45801C-----------------------------------------------------------------------
45802 SUBROUTINE HWRAZM(PT,PX,PY)
45803C-----------------------------------------------------------------------
45804C RANDOMLY ROTATED 2-VECTOR (PX,PY) OF LENGTH PT
45805C-----------------------------------------------------------------------
45806 IMPLICIT NONE
45807 DOUBLE PRECISION HWRGEN,PT,PX,PY,C,S,CS,QT,ONE,ZERO
45808 PARAMETER(ONE=1.0D0, ZERO=0.0D0)
45809 EXTERNAL HWRGEN
45810 10 C=2.*HWRGEN(1)-1.
45811 S=2.*HWRGEN(2)-1.
45812 CS=C*C+S*S
45813 IF (CS.GT.ONE .OR. CS.EQ.ZERO) GOTO 10
45814 QT=PT/CS
45815 PX=(C*C-S*S)*QT
45816 PY=2.*C*S*QT
45817 END
45818CDECK ID>, HWREXP.
45819*CMZ :- -26/04/91 11.11.55 by Bryan Webber
45820*-- Author : David Ward, modified by Bryan Webber
45821C-----------------------------------------------------------------------
45822 FUNCTION HWREXP(AV)
45823C-----------------------------------------------------------------------
45824C Random number from dN/d(x**2)=exp(-b*x) with mean AV
45825C-----------------------------------------------------------------------
45826 IMPLICIT NONE
45827 DOUBLE PRECISION HWREXP,HWRGEN,AV,B,R1,R2
45828 EXTERNAL HWRGEN
45829 B=2./AV
45830 R1=HWRGEN(0)
45831 R2=HWRGEN(1)
45832 HWREXP=-LOG(R1*R2)/B
45833 END
45834CDECK ID>, HWREXQ.
45835*CMZ :- -02/06/94 11.02.47 by Mike Seymour
45836*-- Author : David Ward, modified by Bryan Webber and Mike Seymour
45837C-----------------------------------------------------------------------
45838 FUNCTION HWREXQ(AV,XMAX)
45839C-----------------------------------------------------------------------
45840C Random number from dN/d(x**2)=EXQ(-b*x) with mean AV,
45841C But truncated at XMAX
45842C-----------------------------------------------------------------------
45843 IMPLICIT NONE
45844 DOUBLE PRECISION HWREXQ,HWRGEN,AV,B,BXMAX,R1,R2,XMAX,R,RMIN
45845 EXTERNAL HWRGEN
45846 B=2./AV
45847 BXMAX=B*XMAX
45848 IF (BXMAX.LT.50) THEN
45849 RMIN=EXP(-BXMAX)
45850 ELSE
45851 RMIN=0
45852 ENDIF
45853 10 R1=HWRGEN(0)*(1-RMIN)+RMIN
45854 R2=HWRGEN(1)*(1-RMIN)+RMIN
45855 R=R1*R2
45856 IF (R.LT.RMIN) GOTO 10
45857 HWREXQ=-LOG(R)/B
45858 END
45859CDECK ID>, HWREXT.
45860*CMZ :- -26/04/91 11.11.55 by Bryan Webber
45861*-- Author : David Ward, modified by Bryan Webber
45862C-----------------------------------------------------------------------
45863 FUNCTION HWREXT(AM0,B)
45864C-----------------------------------------------------------------------
45865C Random number from dN/d(x**2)=exp(-B*TM) distribution, where
45866C TM = SQRT(X**2+AM0**2). Uses Newton's method to solve F-R=0
45867C-----------------------------------------------------------------------
45868 IMPLICIT NONE
45869 DOUBLE PRECISION HWREXT,HWRGEN,AM0,B,R,A,F,DF,DAM,AM
45870 INTEGER NIT
45871 EXTERNAL HWRGEN
45872 R=HWRGEN(0)
45873C --- Starting value
45874 AM=AM0-LOG(R)/B
45875 DO 1 NIT=1,20
45876 A=EXP(-B*(AM-AM0))/(1.+B*AM0)
45877 F=(1.+B*AM)*A-R
45878 DF=-B**2*AM*A
45879 DAM=-F/DF
45880 AM=AM+DAM
45881 IF(AM.LT.AM0) AM=AM0+.001
45882 IF(ABS(DAM).LT..001) GOTO 2
45883 1 CONTINUE
45884 CALL HWWARN('HWREXT',1)
45885 2 HWREXT=AM
45886 END
45887CDECK ID>, HWRGAU.
45888*CMZ :- -19/05/99 11.11.56 by Mike Seymour
45889*-- Author : Mike Seymour
45890C-----------------------------------------------------------------------
45891 FUNCTION HWRGAU(J,A,B)
45892C-----------------------------------------------------------------------
45893C Gaussian random number, mean A, standard deviation B.
45894C Generates uncorrelated pairs and throws one of them away.
45895C-----------------------------------------------------------------------
c63d70bc 45896 INCLUDE 'herwig65.inc'
65767955 45897 DOUBLE PRECISION HWRGAU,HWRGEN,A,B,X,TRASH
45898 INTEGER J
45899 EXTERNAL HWRGEN
45900 10 X=HWRGEN(J)
45901 IF (X.LE.ZERO.OR.X.GT.ONE) GOTO 10
45902 X=SQRT(-TWO*LOG(X))
45903 CALL HWRAZM(X,X,TRASH)
45904 HWRGAU=A+B*X
45905 END
45906CDECK ID>, HWRGEN.
45907*CMZ :- -26/04/91 12.42.30 by Federico Carminati
45908*-- Author : F. James, modified by Mike Seymour
45909*- Split in 3 files by M. Kirsanov. Initial seeds ISEED set in HWUDAT
45910C-----------------------------------------------------------------------
64e370da 45911
45912C FUNCTION HWRGEN(I)
65767955 45913C-----------------------------------------------------------------------
45914C MAIN RANDOM NUMBER GENERATOR
45915C USES METHOD OF l'Ecuyer, (VIA F.JAMES, COMP PHYS COMM 60(1990)329)
45916C-----------------------------------------------------------------------
64e370da 45917C IMPLICIT NONE
45918C DOUBLE PRECISION HWRGEN
45919C COMMON/HWSEED/ISEED(2)
45920C INTEGER ISEED
45921C INTEGER I,K,IZ
65767955 45922C
64e370da 45923C K=ISEED(1)/53668
45924C ISEED(1)=40014*(ISEED(1)-K*53668)-K*12211
45925C IF (ISEED(1).LT.0) ISEED(1)=ISEED(1)+2147483563
45926C K=ISEED(2)/52774
45927C ISEED(2)=40692*(ISEED(2)-K*52774)-K*3791
45928C IF (ISEED(2).LT.0) ISEED(2)=ISEED(2)+2147483399
45929C IZ=ISEED(1)-ISEED(2)
45930C IF (IZ.LT.1) IZ=IZ+2147483562
45931C HWRGEN=DBLE(IZ)*4.656613001013252D-10
65767955 45932C---> (4.656613001013252D-10 = 1.D0/2147483589)
64e370da 45933c END
65767955 45934CDECK ID>, HWRSET.
45935*CMZ :- -26/04/91 12.42.30 by Federico Carminati
45936*-- Author : F. James, modified by Mike Seymour
45937C-----------------------------------------------------------------------
45938 FUNCTION HWRSET(JSEED)
45939C-----------------------------------------------------------------------
45940C MAIN RANDOM NUMBER GENERATOR
45941C SETTING SEEDS
45942C-----------------------------------------------------------------------
45943 IMPLICIT NONE
45944 DOUBLE PRECISION HWRSET
45945 COMMON/HWSEED/ISEED(2)
45946 INTEGER ISEED
45947 INTEGER JSEED(2)
45948 HWRSET=0.0D0
45949 IF (JSEED(1).EQ.0.OR.JSEED(2).EQ.0) THEN
45950 CALL HWWARN('HWRSET',99)
45951 GOTO 999
45952 ENDIF
45953 ISEED(1)=JSEED(1)
45954 ISEED(2)=JSEED(2)
45955 999 RETURN
45956 END
45957CDECK ID>, HWRGET.
45958*CMZ :- -26/04/91 12.42.30 by Federico Carminati
45959*-- Author : F. James, modified by Mike Seymour
45960C-----------------------------------------------------------------------
45961 FUNCTION HWRGET(JSEED)
45962C-----------------------------------------------------------------------
45963C MAIN RANDOM NUMBER GENERATOR
45964C GET SEEDS
45965C-----------------------------------------------------------------------
45966 IMPLICIT NONE
45967 DOUBLE PRECISION HWRGET
45968 COMMON/HWSEED/ISEED(2)
45969 INTEGER ISEED
45970 INTEGER JSEED(2)
45971C
45972 JSEED(1)=ISEED(1)
45973 JSEED(2)=ISEED(2)
45974 HWRGET=0.0D0
45975 END
45976CDECK ID>, HWRINT.
45977*CMZ :- -26/04/91 11.11.56 by Bryan Webber
45978*-- Author : Bryan Webber
45979C-----------------------------------------------------------------------
45980 FUNCTION HWRINT(IMIN,IMAX)
45981C-----------------------------------------------------------------------
45982C RANDOM INTEGER IN [IMIN,IMAX]. N.B. ASSUMES IMAX.GE.IMIN
45983C-----------------------------------------------------------------------
45984 IMPLICIT NONE
45985 DOUBLE PRECISION HWRGEN,RN,ONE
45986 INTEGER HWRINT,IMIN,IMAX
45987 EXTERNAL HWRGEN
45988 PARAMETER (ONE=1.0D0)
45989 1 RN=HWRGEN(0)
45990 IF (RN.EQ.ONE) GOTO 1
45991 RN=RN*(IMAX-IMIN+1)
45992 HWRINT=IMIN+INT(RN)
45993 END
45994CDECK ID>, HWRLOG.
45995*CMZ :- -26/04/91 14.15.56 by Federico Carminati
45996*-- Author : Bryan Webber
45997C-----------------------------------------------------------------------
45998 FUNCTION HWRLOG(A)
45999C-----------------------------------------------------------------------
46000C Returns .TRUE. with probability A
46001C-----------------------------------------------------------------------
46002 IMPLICIT NONE
46003 DOUBLE PRECISION HWRGEN,A,R
46004 LOGICAL HWRLOG
46005 EXTERNAL HWRGEN
46006 HWRLOG=.TRUE.
46007 R=HWRGEN(0)
46008 IF(R.GT.A) HWRLOG=.FALSE.
46009 END
46010CDECK ID>, HWRPIP.
46011*CMZ :- -07/09/00 10:06:23 by Peter Richardson
46012*-- Author : Ian Knowles
46013C-----------------------------------------------------------------------
46014 SUBROUTINE HWRPIP
46015C-----------------------------------------------------------------------
46016C Generates a random primary IP using a triple Gaussian distribution
46017C-----------------------------------------------------------------------
c63d70bc 46018 INCLUDE 'herwig65.inc'
65767955 46019 DOUBLE PRECISION HWRGAU
46020 INTEGER I
46021 EXTERNAL HWRGAU
46022 DO 10 I=1,3
46023 10 VTXPIP(I)=HWRGAU(I,ZERO,VIPWID(I))
46024 VTXPIP(4)=ZERO
46025 END
46026CDECK ID>, HWRPOW.
46027*CMZ :- -26/04/91 11.11.56 by Bryan Webber
46028*-- Author : Bryan Webber
46029C-----------------------------------------------------------------------
46030 SUBROUTINE HWRPOW(XVAL,XJAC)
46031C-----------------------------------------------------------------------
46032C RETURNS XVAL DISTRIBUTED ON (XMIN,XMAX) LIKE XVAL**XPOW
46033C AND CORRESPONDING JACOBIAN FACTOR XJAC
46034C SET FIRST=.TRUE. IF NEW XMIN,XMAX OR XPOW
46035C-----------------------------------------------------------------------
46036 IMPLICIT NONE
46037 DOUBLE PRECISION HWRGEN,XVAL,XJAC,XMIN,XMAX,XPOW,P,Q,A,B,C,Z,ZERO
46038 LOGICAL FIRST
46039 PARAMETER(ZERO=0.0D0)
46040 EXTERNAL HWRGEN
46041 SAVE Q,A,B,C
46042 COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
46043 IF (FIRST) THEN
46044 P=XPOW+1.
46045 IF (P.EQ.ZERO) CALL HWWARN('HWRPOW',500)
46046 Q=1./P
46047 A=XMIN**P
46048 B=XMAX**P-A
46049 C=B*Q
46050 FIRST=.FALSE.
46051 ENDIF
46052 Z=A+B*HWRGEN(0)
46053 XVAL=Z**Q
46054 XJAC=XVAL*C/Z
46055 END
46056CDECK ID>, HWRUNG.
46057*CMZ :- -26/04/91 14.55.45 by Federico Carminati
46058*-- Author : David Ward, modified by Bryan Webber
46059C-----------------------------------------------------------------------
46060 FUNCTION HWRUNG(A,B)
46061C-----------------------------------------------------------------------
46062C Random number from distribution having flat top [-A,A] & gaussian
46063C tail of s.d. B
46064C-----------------------------------------------------------------------
46065 IMPLICIT NONE
46066 DOUBLE PRECISION HWRUNG,HWRGAU,HWRUNI,A,B,PRUN,ZERO
46067 LOGICAL HWRLOG
46068 EXTERNAL HWRGAU,HWRUNI,HWRLOG
46069 PARAMETER (ZERO=0.D0)
46070 IF (A.EQ.ZERO) THEN
46071 PRUN=0
46072 ELSE
46073 PRUN=1./(1.+B*1.2533/A)
46074 ENDIF
46075 IF(HWRLOG(PRUN)) THEN
46076 HWRUNG=HWRUNI(0,-A,A)
46077 ELSE
46078 HWRUNG=HWRGAU(0,ZERO,B)
46079 HWRUNG=HWRUNG+SIGN(A,HWRUNG)
46080 ENDIF
46081 END
46082CDECK ID>, HWRUNI.
46083*CMZ :- -26/04/91 14.55.45 by Federico Carminati
46084*-- Author : Bryan Webber
46085C-----------------------------------------------------------------------
46086 FUNCTION HWRUNI(I,A,B)
46087C-----------------------------------------------------------------------
46088C Uniform random random number in range [A,B]
46089C-----------------------------------------------------------------------
46090 IMPLICIT NONE
46091 DOUBLE PRECISION HWRUNI,HWRGEN,A,B,RN
46092 INTEGER I
46093 EXTERNAL HWRGEN
46094 RN=HWRGEN(I)
46095 HWRUNI=A+RN*(B-A)
46096 END
46097CDECK ID>, HWSBRN.
46098*CMZ :- -18/10/99 19.08.45 by Mike Seymour
46099*-- Author : Bryan Webber
46100C-----------------------------------------------------------------------
46101 SUBROUTINE HWSBRN(KPAR)
46102C-----------------------------------------------------------------------
46103C DOES BRANCHING OF SPACELIKE PARTON KPAR
46104C-----------------------------------------------------------------------
c63d70bc 46105 INCLUDE 'herwig65.inc'
65767955 46106 DOUBLE PRECISION HWBVMC,HWRGEN,HWRUNI,HWSTAB,HWUALF,HWUTAB,HWSGQQ,
46107 & HWSSUD,XLAST,QNOW,QLST,QP,QMIN,QLAM,QSAV,SMAX,SLST,SNOW,RN,SUDA,
46108 & SUDB,ZZ,ENOW,XI,PMOM,DIST(13),DMIN,X1,X2,REJFAC,OTHXI,OTHZ,QTMP,
46109 & PTMP(2),JAC,OTHJAC,S,T,U,EMB2,PTMX
46110 INTEGER N0,IS,ID,ID1,ID2,IDHAD,N1,I,MQ,NTRY,NDEL,NA,NB,IW1,IW2,
46111 & KPAR,LPAR,MPAR,ISUD(13),IREJ,NREJ
46112 LOGICAL HWSVAL,FORCE,VALPAR,FTMP
46113 EXTERNAL HWBVMC,HWRGEN,HWRUNI,HWSTAB,HWUALF,HWUTAB,HWSGQQ,HWSSUD,
46114 & HWSVAL
46115 COMMON/HWTABC/XLAST,N0,IS,ID
46116 SAVE ISUD,DMIN
46117 DATA ISUD,DMIN/2,2,3,4,5,6,2,2,3,4,5,6,1,1.D-15/
46118 IF (IERROR.NE.0) RETURN
46119 ID=IDPAR(KPAR)
46120C--TEST FOR PARTON TYPE
46121 IF (ID.LE.13) THEN
46122 IS=ISUD(ID)
46123 ELSEIF (ID.GE.208) THEN
46124 IS=7
46125 ELSE
46126 IS=0
46127 END IF
46128 QNOW=-1.
46129 IF (IS.NE.0) THEN
46130C--SPACELIKE PARTON BRANCHING
46131 QLST=PPAR(1,KPAR)
46132 IDHAD=IDHW(INHAD)
46133 VALPAR=HWSVAL(ID)
46134 QP=HWBVMC(ID)
46135 XLAST=XFACT*PPAR(4,KPAR)
46136 IF (XLAST.GE.ONE) THEN
46137 CALL HWWARN('HWSBRN',107)
46138 GOTO 999
46139 ENDIF
46140C--SET UP Q BOUNDARY
46141 IF (VALPAR) THEN
46142 QMIN=QG/(1.-XLAST)
46143 ELSEIF (ID.EQ.13) THEN
46144 QMIN=QV/(1.-XLAST)
46145 ELSE
46146 QMIN=.5*(QP+QV+SQRT((QP-QV)**2+4.*QP*QV*XLAST))/(1.-XLAST)
46147 ENDIF
46148 QSAV=QMIN
46149 IF (QMIN.LE.QSPAC.AND.ISPAC.LT.2) THEN
46150 QMIN=QSPAC
46151 N1=NSPAC(IS)
46152 ELSEIF (QMIN.LE.QEV(1,IS)) THEN
46153 QMIN=QEV(1,IS)
46154 N1=1
46155 ELSE
46156 DO 110 I=2,NQEV
46157 IF (QEV(I,IS).GT.QMIN) GOTO 120
46158 110 CONTINUE
46159 120 N1=I-1
46160 ENDIF
46161 N0=N1-1
46162 MQ=NQEV-N0
46163 NTRY=0
46164 125 NTRY=NTRY+1
46165 NREJ=1
46166 IF (QLST.GT.QMIN.AND..NOT.NOSPAC.OR..NOT.VALPAR) THEN
46167 IF (QLST.LE.QMIN) THEN
46168C--CHECK PHASE SPACE FOR FORCED SPLITTING OF NON-VALENCE PARTON
46169 IF (QLST.LT.QSAV) THEN
46170 CALL HWWARN('HWSBRN',ISLENT*105)
46171 GOTO 999
46172 ENDIF
46173 FORCE=.TRUE.
46174 QNOW=(QLST/QSAV)**HWRGEN(0)*QSAV
46175 ELSE
46176C--ENHANCE EMISSION BY A FACTOR OF TWO IF THIS BRANCH
46177C IS CAPABLE OF BEING THE HARDEST SO FAR
46178 IF (QLST.GT.HARDST) NREJ=2
46179 QTMP=-1
46180 DO 300 IREJ=1,NREJ
46181C--FIND NEW VALUE OF SUD/DIST
46182 CALL HWSFUN(XLAST,QMIN,IDHAD,NSTRU,DIST,JNHAD)
46183 IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QMIN)
46184 IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
46185 SMAX=HWUTAB(SUD(N1,IS),QEV(N1,IS),MQ,QMIN,INTER)/DIST(ID)
46186 CALL HWSFUN(XLAST,QLST,IDHAD,NSTRU,DIST,JNHAD)
46187 IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QLST)
46188 IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
46189 SLST=HWUTAB(SUD(N1,IS),QEV(N1,IS),MQ,QLST,INTER)/DIST(ID)
46190 RN=HWRGEN(0)
46191 IF (RN.EQ.ZERO) THEN
46192 SNOW=SLST*2.
46193 ELSE
46194 SNOW=SLST/RN
46195 ENDIF
46196 IF (VALPAR.AND.SNOW.GE.SMAX) GOTO 200
46197 IF (SNOW.LT.SMAX.AND..NOT.NOSPAC) THEN
46198 FORCE=.FALSE.
46199 ELSE
46200C--FORCE SPLITTING OF NON-VALENCE PARTON
46201 FORCE=.TRUE.
46202 QNOW=(MIN(QLST,1.1*QMIN)/QSAV)**HWRGEN(0)*QSAV
46203 ENDIF
46204 IF (QNOW.LT.ZERO) THEN
46205C--BRANCHING OCCURS. FIRST CHECK FOR MONOTONIC FORM FACTOR
46206 SUDA=SMAX
46207 NDEL=32
46208 NA=N1
46209 130 NB=NA+NDEL
46210 IF (NB.GT.NQEV) THEN
46211 CALL HWWARN('HWSBRN',103)
46212 GOTO 999
46213 ENDIF
46214 CALL HWSFUN(XLAST,QEV(NB,IS),IDHAD,NSTRU,DIST,JNHAD)
46215 IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QEV(NB,IS))
46216 IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
46217 SUDB=SUD(NB,IS)/DIST(ID)
46218 IF (SUDB.GT.SUDA) THEN
46219 SUDA=SUDB
46220 NA=NB
46221 GOTO 130
46222 ELSEIF (NA.NE.N1) THEN
46223 IF (SUDB.LT.SNOW) THEN
46224 NDEL=NDEL/2
46225 IF (NDEL.EQ.0) THEN
46226 CALL HWWARN('HWSBRN',100)
46227 GOTO 999
46228 ENDIF
46229 GOTO 130
46230 ENDIF
46231 N1=NB
46232 N0=N1-1
46233 MQ=NQEV-N0
46234 ENDIF
46235C--NOW FIND NEW Q
46236 QNOW=HWSTAB(QEV(N1,IS),HWSSUD,MQ,SNOW,INTER)
46237 IF (QNOW.LE.QMIN.OR.QNOW.GT.QLST) THEN
46238C--INTERPOLATION PROBLEM: USE LINEAR INSTEAD
46239C CALL HWWARN('HWSBRN',1)
46240 QNOW=HWRUNI(0,QMIN,QLST)
46241 ENDIF
46242 ENDIF
46243 200 CONTINUE
46244 IF (QNOW.GT.QTMP) THEN
46245 QTMP=QNOW
46246 FTMP=FORCE
46247 ENDIF
46248 QNOW=-1
46249 300 CONTINUE
46250 QNOW=QTMP
46251 FORCE=FTMP
46252 ENDIF
46253 IF (QNOW.LT.ZERO) GOTO 210
46254C--NOW FIND NEW X
46255 CALL HWSFBR(XLAST,QNOW,FORCE,ID,1,ID1,ID2,IW1,IW2,ZZ)
46256 IF (ID1.LT.0) THEN
46257C--NO PHASE SPACE FOR BRANCHING
46258 FROST=.TRUE.
46259 RETURN
46260 ELSEIF (ID1.EQ.0) THEN
46261C--BRANCHING REJECTED: REDUCE Q AND REPEAT
46262 IF (NTRY.GT.NBTRY.OR.IERROR.NE.0) THEN
46263 CALL HWWARN('HWSBRN',102)
46264 GOTO 999
46265 ENDIF
46266 QLST=QNOW
46267 QNOW=-1.
46268 GOTO 125
46269 ELSEIF (ID1.EQ.59) THEN
46270C--ANOMALOUS PHOTON SPLITTING: ADD PT TO INTRINSIC PT AND STOP BRANCHING
46271 IF (IDHAD.NE.59) THEN
46272 CALL HWWARN('HWSBRN',109)
46273 GOTO 999
46274 ENDIF
46275 ENOW=PPAR(4,KPAR)/XLAST
46276 XI=(QNOW/ENOW)**2
46277 QLAM=QNOW*(1.-XLAST)
46278 IF ((2.-XI)*QLAM**2.GT.EMSCA**2) THEN
46279C--BRANCHING REJECTED: REDUCE Q AND REPEAT
46280 IF (NTRY.GT.NBTRY) THEN
46281 CALL HWWARN('HWSBRN',110)
46282 GOTO 999
46283 ENDIF
46284 QLST=QNOW
46285 QNOW=-1.
46286 GOTO 125
46287 ENDIF
46288 CALL HWRAZM(QNOW*(1.-XLAST),PTMP(1),PTMP(2))
46289 CALL HWVSUM(2,PTMP,PTINT(1,JNHAD),PTINT(1,JNHAD))
46290 PTINT(3,JNHAD)=PTINT(1,JNHAD)**2+PTINT(2,JNHAD)**2
46291 ANOMSC(1,JNHAD)=QNOW
46292 ANOMSC(2,JNHAD)=QNOW*(1.-XLAST)
46293 QNOW=-1.
46294 QLST=QNOW
46295 GOTO 125
46296 ELSEIF (FORCE.AND..NOT.HWSVAL(ID1).AND.ID1.NE.13) THEN
46297C--FORCED BRANCHING PRODUCED A NON-VALENCE PARTON: TRY AGAIN
46298 IF (NTRY.GT.NBTRY) THEN
46299 CALL HWWARN('HWSBRN',108)
46300 GOTO 999
46301 ENDIF
46302 QLST=QNOW
46303 QNOW=-1.
46304 GOTO 125
46305 ENDIF
46306 ENDIF
46307 210 CONTINUE
46308 IF (QNOW.GT.ZERO) THEN
46309C--BRANCHING HAS OCCURRED
46310 ENOW=PPAR(4,KPAR)/ZZ
46311 XI=(QNOW/ENOW)**2
46312 QLAM=QNOW*(1.-ZZ)
46313 IF ((SUDORD.EQ.1.AND.HWUALF(2,QLAM).LT.HWRGEN(0) .OR.
46314 & (2.-XI)*QLAM**2.GT.EMSCA**2).AND..NOT.FORCE) THEN
46315C--BRANCHING REJECTED: REDUCE Q AND REPEAT
46316 IF (NTRY.GT.NBTRY) THEN
46317 CALL HWWARN('HWSBRN',104)
46318 GOTO 999
46319 ENDIF
46320 QLST=QNOW
46321 QNOW=-1.
46322 GOTO 125
46323 ENDIF
46324C--IF THIS IS HARDEST EMISSION SO FAR, APPLY MATRIX-ELEMENT CORRECTION
46325 IF (.NOT.FORCE) THEN
46326 REJFAC=1
46327 IF (QLAM.GT.HARDST .AND. ID.NE.13) THEN
46328 IF (MOD(ISTHEP(JCOPAR(1,1)),10).GE.3) THEN
46329C---COLOUR PARTNER IS OUTGOING (X1=XP, X2=ZP)
46330 X2=SQRT((ZZ**2-(1-ZZ)*XI)**2+2*(ZZ*(1-ZZ))**2*XI*(2-XI))
46331 X1=(ZZ**2+(1-ZZ)*XI-X2)/(2*(1-ZZ)*XI)
46332 X2=(ZZ**2-(1-ZZ)*XI+X2)/(2*ZZ**2)
46333 IF (ID2.EQ.13) THEN
46334C---GLUON EMISSION
46335 REJFAC=ZZ**3*(1-X1-X2+2*X1*X2)
46336 $ /(X1**2*(1-ZZ)*(ZZ+XI*(1-ZZ)))
46337 $ *(1+ZZ**2)/((1-ZZ)*XI)
46338 $ *(1-X1)*(1-X2)/
46339 $ (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
46340C---CHECK WHETHER IT IS IN THE OVERLAP REGION
46341 OTHXI=2*(1-X1)/(1-X1+2*(3*X1-2)*X2*(1-X2))
46342 IF (OTHXI.LT.ONE) THEN
46343 OTHZ=(1-(2*X2-1)*SQRT((3*X1-2)/X1))/2
46344 REJFAC=REJFAC+SQRT(3-2/X1)/(X1**2*OTHZ*(1-OTHZ))
46345 $ *(1+(1-OTHZ)**2)/(OTHZ*OTHXI)
46346 $ *(1-X1)*(1-X2)/
46347 $ (1+(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
46348 ENDIF
46349 ELSEIF (ID1.EQ.13) THEN
46350C---GLUON SPLITTING
46351 REJFAC=ZZ**3*(1-X1-X2+2*X1*X2)
46352 $ /(X1**2*(1-ZZ)*(ZZ+XI*(1-ZZ)))
46353 $ *(ZZ**2+(1-ZZ)**2)/XI
46354 $ *(1-X2)/
46355 $ (( X1+X2-2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2
46356 $ +(1-X1-X2+2*X1*X2)**2+2*(1-X1)*(1-X2)*X1*X2)
46357 ENDIF
46358 ELSE
46359C---COLOUR PARTNER IS ALSO INCOMING
46360 T=-(1-ZZ)*XI/ZZ**2
46361 S=2*(ZZ**2+(1-ZZ)*XI)/(ZZ**2*(2*ZZ+XI*(1-ZZ)))
46362 U=1-S-T
46363 JAC=-T*(1-T)/S**2*ZZ**5/(XI*(1-ZZ)**2*(ZZ+XI*(1-ZZ)))
46364 IF (ID2.EQ.13) THEN
46365C---GLUON EMISSION
46366 REJFAC=(1+ZZ**2)/((1-ZZ)*ZZ*XI)
46367 & *JAC*S**2*T*U/((1-U)**2+(1-T)**2)
46368C---CHECK WHETHER IT IS IN THE OVERLAPPING REGION
46369 OTHZ=(1+SQRT(1-2*U*(1-U)/S))/U
46370 OTHXI=2*(1-OTHZ+T/S)/(1-OTHZ)
46371 IF (OTHXI.LT.OTHZ**2) THEN
46372 OTHJAC=-U*(1-U)/S**2*OTHZ**5/(OTHXI*
46373 & (1-OTHZ)**2*(OTHZ+OTHXI*(1-OTHZ)))
46374 REJFAC=REJFAC+(1+OTHZ**2)/((1-OTHZ)*OTHZ*OTHXI)
46375 & *OTHJAC*S**2*T*U/((1-U)**2+(1-T)**2)
46376 ENDIF
46377 ELSEIF (ID1.EQ.13) THEN
46378C---GLUON SPLITTING
46379 REJFAC=-((1-ZZ)**2+ZZ**2)/(ZZ*XI)
46380 & *JAC*S**3*T/((1-S)**2+(1-T)**2)
46381 ENDIF
46382 ENDIF
46383 ENDIF
46384 IF (NREJ*REJFAC*HWRGEN(NREJ).GT.ONE) THEN
46385 QLST=QNOW
46386 QNOW=-1.
46387 GOTO 125
46388 ENDIF
46389 IF (QLAM.GT.HARDST) HARDST=QLAM
46390 ENDIF
46391 IF (IW2.GT.IW1) THEN
46392 LPAR=NPAR+1
46393 MPAR=NPAR+2
46394C---NEW MOTHER-DAUGHTER RELATIONS
46395C N.B. DEFINED MOVING AWAY FROM HARD PROCESS
46396 JDAPAR(1,KPAR)=LPAR
46397 JDAPAR(2,KPAR)=MPAR
46398C---NEW COLOUR CONNECTIONS
46399 JCOPAR(3,KPAR)=MPAR
46400 JCOPAR(4,KPAR)=LPAR
46401 JCOPAR(1,MPAR)=KPAR
46402 JCOPAR(2,MPAR)=LPAR
46403 JCOPAR(1,LPAR)=MPAR
46404 JCOPAR(2,LPAR)=KPAR
46405 ELSE
46406 MPAR=NPAR+1
46407 LPAR=NPAR+2
46408 JDAPAR(1,KPAR)=MPAR
46409 JDAPAR(2,KPAR)=LPAR
46410 JCOPAR(3,KPAR)=LPAR
46411 JCOPAR(4,KPAR)=MPAR
46412 JCOPAR(1,MPAR)=LPAR
46413 JCOPAR(2,MPAR)=KPAR
46414 JCOPAR(1,LPAR)=KPAR
46415 JCOPAR(2,LPAR)=MPAR
46416 ENDIF
46417 JMOPAR(1,LPAR)=KPAR
46418 JMOPAR(1,MPAR)=KPAR
46419 IDPAR(LPAR)=ID1
46420 IDPAR(MPAR)=ID2
46421 TMPAR(LPAR)=.FALSE.
46422 TMPAR(MPAR)=.TRUE.
46423 PPAR(1,LPAR)=QNOW
46424 PPAR(2,LPAR)=XI
46425 PPAR(4,LPAR)=ENOW
46426 PPAR(1,MPAR)=QNOW*(1.-ZZ)
46427 PPAR(2,MPAR)=XI
46428 PPAR(4,MPAR)=ENOW*(1.-ZZ)
46429 NPAR=NPAR+2
46430 ENDIF
46431 ENDIF
46432 IF (QNOW.LT.ZERO) THEN
46433C--BRANCHING STOPS
46434 JDAPAR(1,KPAR)=0
46435 JDAPAR(2,KPAR)=0
46436 JCOPAR(3,KPAR)=0
46437 JCOPAR(4,KPAR)=0
46438 IF (ID.LE.13) THEN
46439C---PUT SPECTATOR (APPROXIMATELY) ON-SHELL
46440 XLAST=XFACT*PPAR(4,KPAR)
46441 IF ((1-XLAST)**2.LT.(RMASS(ID)**2+PTINT(3,JNHAD))*XFACT**2)
46442 & THEN
46443 FROST=.TRUE.
46444 RETURN
46445 ENDIF
46446C---BRW MOD: INCLUDE HIGHER ORDER CORRECTION IN MASS CALCULATION
46447c$$$ PPAR(5,KPAR)=-(RMASS(ID)**2*XLAST+PTINT(3,JNHAD))/(1.-XLAST)
46448c$$$ & +XLAST*SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
46449 PTMX=(RMASS(ID)**2+PTINT(3,JNHAD))/(ONE-XLAST)
46450 EMB2=SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
46451 PPAR(5,KPAR)=-PTINT(3,JNHAD)-XLAST*(PTMX-EMB2)-0.25D0*
46452 $ ((PTMX-EMB2)**2+XLAST*(PTMX**2/(ONE-XLAST)-EMB2**2))*XFACT**2
46453C---END BRW MOD
46454 ELSEIF (ID.EQ.IDHW(INHAD)) THEN
46455C---IF INCOMING PARTON IS INCOMING BEAM, ALLOW IT TO BE OFF-SHELL
46456 PPAR(5,KPAR)=SIGN(PHEP(5,INHAD)**2,PHEP(5,INHAD))
46457 ELSE
46458 PPAR(5,KPAR)=RMASS(ID)**2
46459 ENDIF
46460 PMOM=PPAR(4,KPAR)**2-PPAR(5,KPAR)
46461 IF (PMOM.LT.ZERO) THEN
46462 FROST=.TRUE.
46463 RETURN
46464 ENDIF
46465 PPAR(3,KPAR)=SQRT(PMOM)
46466 ENDIF
46467 999 RETURN
46468 END
46469CDECK ID>, HWSDGG.
46470*CMZ := =26/04/91 12.47.48 by Federico Carminati
46471*-- Author : Drees, Grassie, Charchula, modified by Bryan Webber
46472C ===============================================================
46473C DREES & GRASSIE PARAMETRIZATION OF PHOTON STRUCTURE FUNCTION
46474C
46475C HWSDGQ(X,Q2,NFL,NCH) - X*QUARK_IN_PHOTON/ALPHA (!)
46476C HWSDGG(X,Q2,NFL) - X*GLUON_IN_PHOTON/ALPHA (!)
46477C WHERE:
46478C (INTEGER) NCH - QUARK CHARGE: 1 FOR 1/3
46479C 2 FOR 2/3
46480C (INTEGER) NFL - NUMBER OF QUARK FLAVOURS /3 OR 4/
46481C Q2 - SQUARE OF MOMENTUM Q /IN GEV2/
46482C X - LONGITUDINAL FRACTION
46483C LAMBDA=0.4 GEV
46484C
46485C NFL=3: 1 < Q2 < 50 GEV^2
46486C NFL=4: 20 < Q2 < 500 GEV^2
46487C NFL=5: 200 < Q2 < 10^4 GEV^2
46488C
46489C
46490C KRZYSZTOF CHARCHULA /14.02.1989/
46491C================================================================
46492C
46493C PS. Note that for the case of three flavors, one has to add
46494C the QPM charm contribution for getting F2.
46495C
46496C================================================================
46497C MODIFIED FOR HERWIG BY BRW 19/4/91
46498C--- -----------------------------------------------
46499C GLUON PART OF THE PHOTON SF
46500C--- -----------------------------------------------
46501 FUNCTION HWSDGG(X,Q2,NFL)
46502 IMPLICIT REAL (A-H,P-Z)
46503 INTEGER NFL
46504 DIMENSION A(3,4,3),AT(3)
46505 ALAM2=0.160
46506 T=LOG(Q2/ALAM2)
46507C- --- CHECK WHETHER NFL HAVE RIGHT VALUES -----
46508 IF (.NOT.((NFL.EQ.3).OR.(NFL.EQ.4).OR.(NFL.EQ.5)))THEN
46509 WRITE(6,131)
46510 131 FORMAT(' NUMBER OF FLAVOURS(NFL) HAS NOT BEEN SET TO: 3,4 OR 5;'/
46511 *' NFL=3 IS ASSUMED')
46512 NFL=3
46513 ELSEIF (T.LE.0) THEN
46514 WRITE(6,132)
46515 132 FORMAT(' HWSDGG CALLED WITH SCALE < LAMBDA. RETURNING ZERO.')
46516 HWSDGG=0
46517 RETURN
46518 ENDIF
46519C ------ INITIALIZATION OF PARAMETERS ARRAY -----
46520 DATA(((A(I,J,K),I=1,3),J=1,4),K=1,3)/
46521 + -0.20700,-0.19870, 5.11900,
46522 + 0.61580, 0.62570,-0.27520,
46523 + 1.07400, 8.35200,-6.99300,
46524 + 0.00000, 5.02400, 2.29800,
46525 + 0.8926E-2, 0.05090,-0.23130,
46526 + 0.659400, 0.27740, 0.13820,
46527 + 0.476600,-0.39060, 6.54200,
46528 + 0.019750,-0.32120, 0.51620,
46529 + 0.031970, -0.618E-2, -0.1216,
46530 + 1.0180, 0.94760, 0.90470,
46531 + 0.24610, -0.60940, 2.6530,
46532 + 0.027070, -0.010670, 0.2003E-2/
46533C ------ Q2 DEPENDENCE -----------
46534 LF=NFL-2
46535 DO 20 I=1,3
46536 AT(I)=A(I,1,LF)*T**A(I,2,LF)+A(I,3,LF)*T**(-A(I,4,LF))
46537 20 CONTINUE
46538C ------ GLUON DISTRIBUTION -------------
46539 HWSDGG=AT(1)*X**AT(2)*(1.0-X)**AT(3)/137.
46540 END
46541CDECK ID>, HWSDGQ.
46542*CMZ :- -26/04/91 13.04.45 by Federico Carminati
46543*-- Author : Drees, Grassie, Charchula, modified by Bryan Webber
46544C --------------------------------------
46545C QUARK PART OF THE PHOTON SF
46546C --------------------------------------
46547 FUNCTION HWSDGQ(X,Q2,NFL,NCH)
46548 IMPLICIT REAL (A-H,P-Z)
46549 INTEGER NFL,NCH
46550 DIMENSION A(5,4,2,3),AT(5,2),XQPOM(2),E(2)
46551 COMMON/DG/F2
46552C SQUARE OF LAMBDA=0.4 GEV
46553 ALAM2=0.160
46554 T=LOG(Q2/ALAM2)
46555C
46556C CHECK WHETHER NFL AND NCH HAVE RIGHT VALUES
46557C
46558 IF(.NOT.((NFL.EQ.3).OR.(NFL.EQ.4).OR.(NFL.EQ.5))) THEN
46559 WRITE(6,111)
46560 111 FORMAT('NUMBER OF FLAVOURS (NFL) HAS NOT BEEN SET TO: 3,4 OR 5'/
46561 *' NFL=3 IS ASSUMED')
46562 NFL=3
46563 ELSEIF (T.LE.0) THEN
46564 WRITE(6,132)
46565 132 FORMAT(' HWSDGQ CALLED WITH SCALE < LAMBDA. RETURNING ZERO.')
46566 HWSDGQ=0
46567 RETURN
46568 ENDIF
46569 IF (.NOT.((NCH.EQ.1).OR.(NCH.EQ.2))) THEN
46570 WRITE(6,121)
46571 121 FORMAT(' QUARK CHARGE NUMBER (NCH) HAS NOT BEEN SET',
46572 *' TO 1 OR 2;'/
46573 *' NCH=1 IS ASSUMED')
46574 NCH=1
46575 ENDIF
46576C ------ INITIALIZATION ------
46577 DATA(((A(I,J,K,1),I=1,5),J=1,4),K=1,2)/
46578 + 2.28500, 6.07300, -0.42020,-0.08080, 0.05530,
46579 +-0.01530, -0.81320, 0.01780, 0.63460, 1.13600,
46580 + 1.3300E3,-41.3100, 0.92160, 1.20800, 0.95120,
46581 + 4.21900, 3.16500, 0.18000, 0.20300, 0.01160,
46582 +16.6900, 0.17600, -0.02080,-0.01680,-0.19860,
46583 +-0.79160, 0.04790, 0.3386E-2,1.35300, 1.10000,
46584 + 1.0990E3, 1.04700, 4.85300, 1.42600, 1.13600,
46585 + 4.42800, 0.02500, 0.84040, 1.23900,-0.27790/
46586 DATA(((A(I,J,K,2),I=1,5),J=1,4),K=1,2)/
46587 +-0.37110,-0.17170, 0.087660,-0.89150,-0.18160,
46588 + 1.06100, 0.78150, 0.021970, 0.28570, 0.58660,
46589 + 4.75800, 1.53500, 0.109600, 2.97300, 2.42100,
46590 +-0.01500, 0.7067E-2,0.204000, 0.11850, 0.40590,
46591 +-0.12070,25.00000,-0.012300,-0.09190, 0.020150,
46592 + 1.07100,-1.64800, 1.162000, 0.79120, 0.98690,
46593 + 1.97700,-0.015630,0.482400, 0.63970,-0.070360,
46594 +-0.8625E-2,6.43800,-0.011000, 2.32700, 0.016940/
46595 DATA(((A(I,J,K,3),I=1,5),J=1,4),K=1,2)/
46596 +15.80, 2.7420, 0.029170,-0.03420, -0.023020,
46597 +-0.94640, -0.73320, 0.046570, 0.71960, 0.92290,
46598 +-0.50, 0.71480, 0.17850, 0.73380, 0.58730,
46599 +-0.21180, 3.2870, 0.048110, 0.081390,-0.79E-4,
46600 + 6.7340, 59.880, -0.3226E-2,-0.03321, 0.10590,
46601 +-1.0080, -2.9830, 0.84320, 0.94750, 0.69540,
46602 +-0.085940, 4.480, 0.36160, -0.31980, -0.66630,
46603 + 0.076250, 0.96860, 0.1383E-2, 0.021320, 0.36830/
46604C ------- EVALUATION OF PARAMETERS IN Q2 ---------
46605 E(1)=1.0
46606 IF (NFL.EQ.3) THEN
46607 E(2)=9.0
46608 LF=1
46609 ELSEIF (NFL.EQ.4) THEN
46610 E(2)=10.0
46611 LF=2
46612 ELSEIF (NFL.EQ.5) THEN
46613 E(2)=55.0/6.0
46614 LF=3
46615 ENDIF
46616 DO 10 J=1,2
46617 DO 20 I=1,5
46618 ATP=A(I,1,J,LF)*T**A(I,2,J,LF)
46619 AT(I,J)=ATP+A(I,3,J,LF)*T**(-A(I,4,J,LF))
46620 20 CONTINUE
46621 10 CONTINUE
46622 DO 30 J=1,2
46623 POM1=X*(X*X+(1.0-X)**2)/(AT(1,J)-AT(2,J)*ALOG(1.0-X))
46624 POM2=AT(3,J)*X**AT(4,J)*(1.0-X)**AT(5,J)
46625 XQPOM(J)=E(J)*POM1+POM2
46626 30 CONTINUE
46627C ------- QUARK DISTRIBUTIONS ----------
46628 HWSDGQ=0
46629 IF (NFL.EQ.3) THEN
46630 IF (NCH.EQ.2) THEN
46631 HWSDGQ=1.0/6.0*(XQPOM(2)+9.0*XQPOM(1))
46632 ELSEIF(NCH.EQ.1) THEN
46633 HWSDGQ=1.0/6.0*(XQPOM(2)-9.0/2.0*XQPOM(1))
46634 ENDIF
46635 F2=2.0/9.0*XQPOM(2)+XQPOM(1)
46636 ELSEIF (NFL.EQ.4) THEN
46637 IF (NCH.EQ.2) THEN
46638 HWSDGQ=1.0/8.0*(XQPOM(2)+6.0*XQPOM(1))
46639 ELSEIF(NCH.EQ.1) THEN
46640 HWSDGQ=1.0/8.0*(XQPOM(2)-6.0*XQPOM(1))
46641 ENDIF
46642 F2=5.0/18.0*XQPOM(2)+XQPOM(1)
46643 ELSEIF (NFL.EQ.5) THEN
46644 IF (NCH.EQ.2) THEN
46645 HWSDGQ=1.0/10.0*(XQPOM(2)+15.0/2.0*XQPOM(1))
46646 ELSEIF(NCH.EQ.1) THEN
46647 HWSDGQ=1.0/10.0*(XQPOM(2)-5.0*XQPOM(1))
46648 ENDIF
46649 F2=11.0/45.0*XQPOM(2)+XQPOM(1)
46650 ENDIF
46651 HWSDGQ=HWSDGQ/137.
46652 END
46653CDECK ID>, HWSFBR.
46654*CMZ :- -15/07/92 14.08.45 by Mike Seymour
46655*-- Author : Bryan Webber
46656C-----------------------------------------------------------------------
46657 SUBROUTINE HWSFBR(X,QQ,FORCED,ID,IW,ID1,ID2,IW1,IW2,Z)
46658C-----------------------------------------------------------------------
46659C FINDS BRANCHING (ID1->ID+ID2) AND Z=X/X1 IN BACKWARD
46660C EVOLUTION AT ENERGY FRACTION X AND SCALE QQ
46661C
46662C FORCED=.TRUE. FORCES SPLITTING OF NON-VALENCE PARTON
46663C
46664C IW,IW1,IW2 ARE COLOUR CONNECTION WORDS
46665C
46666C ID1.LT.0 ON RETURN MEANS NO PHASE SPACE
46667C ID1.EQ.0 ON RETURN FLAGS REJECTED BRANCHINGS
46668C-----------------------------------------------------------------------
c63d70bc 46669 INCLUDE 'herwig65.inc'
65767955 46670 DOUBLE PRECISION HWBVMC,HWRGEN,HWUALF,HWUAEM,QP,X,QQ,Z,WQG,WQV,
46671 & WQP,XQV,ZMIN,ZMAX,YMIN,YMAX,DELY,YY,PSUM,EZ,WQN,WR,ZR,WZ,ZZ,AZ,
46672 & PVAL,EY,DIST(13),PROB(13,100),PPHO
46673 INTEGER ID,IW,ID1,ID2,IW1,IW2,NZ,IDHAD,IP,IZ
46674 LOGICAL HWRLOG,HWSVAL,FORCED,NONF,NONV,PHOTPR
46675 EXTERNAL HWBVMC,HWRGEN,HWUALF,HWUAEM,HWRLOG,HWSVAL
46676 ID1=-1
46677 QP=HWBVMC(ID)
46678 WQG=1.-QG/QQ
46679 WQV=1.-QV/QQ
46680 WQP=1.-QP/QQ
46681 XQV=X/WQV
46682 NONV=.NOT.HWSVAL(ID)
46683 NONF=.NOT.FORCED
46684 IF (ID.EQ.13) THEN
46685 ZMIN=X
46686 IF (NONF) THEN
46687 ZMAX=WQG
46688 ELSE
46689 ZMAX=WQV
46690 ENDIF
46691 ELSE
46692 IF (NONV) THEN
46693 ZMIN=XQV
46694 IF (NONF) THEN
46695 ZMAX=WQG
46696 ELSE
46697 ZMAX=WQP
46698 ENDIF
46699 ELSE
46700 ZMIN=X
46701 ZMAX=MAX(WQG,WQP)
46702 ENDIF
46703 ENDIF
46704 IF (ZMIN.GE.ZMAX) RETURN
46705 ID1=0
46706C---INTERPOLATION VARIABLE IS Y=LN(Z/(1-Z))
46707 YMIN=LOG(ZMIN/(1.-ZMIN))
46708 YMAX=LOG(ZMAX/(1.-ZMAX))
46709 DELY=YMAX-YMIN
46710 NZ=MIN(INT(ZBINM*DELY)+1,NZBIN)
46711 DELY=(YMAX-YMIN)/FLOAT(NZ)
46712 YY=YMIN+0.5*DELY
46713 PSUM=0.
46714 IDHAD=IDHW(INHAD)
46715C---SET UP TABLES FOR CHOOSING BRANCHING
46716 DO 40 IZ=1,NZ
46717 EZ=EXP(YY)
46718 WR=1.+EZ
46719 ZR=WR/EZ
46720 WZ=1./WR
46721 ZZ=WZ*EZ
46722 AZ=WZ*ZZ*HWUALF(5-2*SUDORD,MAX(WZ*QQ,QG))
46723 CALL HWSFUN(X*ZR,QQ,IDHAD,NSTRU,DIST,JNHAD)
46724 IF (ID.NE.13) THEN
46725C---SPLITTING INTO QUARK
46726 DO 10 IP=1,ID-1
46727 10 PROB(IP,IZ)=PSUM
46728 IF (NONF) PSUM=PSUM+DIST(ID)*AZ*CFFAC*(1.+ZZ*ZZ)*WR
46729 DO 20 IP=ID,12
46730 20 PROB(IP,IZ)=PSUM
46731 PSUM=PSUM+DIST(13)*AZ*0.5*(ZZ*ZZ+WZ*WZ)
46732 PROB(13,IZ)=PSUM
46733 ELSE
46734C---SPLITTING INTO GLUON
46735 DO 30 IP=1,12
46736 PSUM=PSUM+DIST(IP)*AZ*CFFAC*(1.+WZ*WZ)*ZR
46737 30 PROB(IP,IZ)=PSUM
46738 IF (NONF) PSUM=PSUM+DIST(13)*AZ*2.*CAFAC*(WZ*ZR+ZZ*WR+WZ*ZZ)
46739 PROB(13,IZ)=PSUM
46740 ENDIF
46741 40 YY=YY+DELY
46742 50 PHOTPR=IDHAD.EQ.59.AND.ID.NE.13
46743 IF (PHOTPR) THEN
46744C---ALLOW ANOMALOUS PHOTON SPLITTING
46745 PPHO=ZMIN*HWUAEM(-QQ*QQ)*CAFAC*(ZMIN**2+(1.-ZMIN)**2)
46746 & *ICHRG(ID)**2/9D0
46747 IF (PPHO.GT.(PPHO+PSUM*DELY)*HWRGEN(2)) THEN
46748C---ANOMALOUS PHOTON SPLITTING OCCURRED
46749 ID1=59
46750 RETURN
46751 ENDIF
46752 ENDIF
46753 IF (PSUM.LE.ZERO) RETURN
46754C---CHOOSE Z
46755 PVAL=PSUM*HWRGEN(0)
46756 DO 60 IZ=1,NZ
46757 IF (PROB(13,IZ).GT.PVAL) GOTO 70
46758 60 CONTINUE
46759 IZ=NZ
46760 70 EY=EXP(YMIN+DELY*(FLOAT(IZ)-HWRGEN(1)))
46761 ZZ=EY/(1.+EY)
46762C---CHOOSE BRANCHING
46763 DO 80 IP=1,13
46764 IF (PROB(IP,IZ).GT.PVAL) GOTO 90
46765 80 CONTINUE
46766 IP=13
46767C---CHECK THAT Z IS INSIDE PHASE SPACE (RETURN IF NOT)
46768 90 CONTINUE
46769 IF (ID.NE.13) THEN
46770 IF (IP.EQ.ID) THEN
46771 IF ((NONV.AND.ZZ*WQP.LT.XQV).OR.ZZ.GT.WQG) THEN
46772 IF (PHOTPR) GOTO 50
46773 RETURN
46774 ENDIF
46775 ELSE
46776 IF (ZZ.LT.XQV.OR.ZZ.GT.WQP) THEN
46777 IF (PHOTPR) GOTO 50
46778 RETURN
46779 ENDIF
46780 ENDIF
46781 ELSE
46782 IF (IP.EQ.ID) THEN
46783 IF (ZZ.LT.XQV.OR.ZZ.GT.WQG) RETURN
46784 ELSEIF (.NOT.HWSVAL(IP)) THEN
46785 WQN=1.-HWBVMC(IP)/QQ
46786 IF (ZZ*WQN.LT.XQV.OR.ZZ.GT.WQN) RETURN
46787 ENDIF
46788 ENDIF
46789C---EVERYTHING OK: LABEL NEW BRANCHES
46790 Z=ZZ
46791 ID1=IP
46792 IW1=IW*2
46793 IW2=IW1+1
46794 IF (ID.LE.6) THEN
46795 IF (ID1.EQ.13) THEN
46796 ID2=ID+6
46797 ELSE
46798 ID2=13
46799 IW2=IW1
46800 ENDIF
46801 ELSE IF (ID.NE.13) THEN
46802 IF (ID1.EQ.13) THEN
46803 ID2=ID-6
46804 IW2=IW1
46805 ELSE
46806 ID2=13
46807 ENDIF
46808 ELSE
46809 ID2=ID1
46810 IF (ID1.EQ.13) THEN
46811 IF (HWRLOG(HALF)) IW2=IW1
46812 ELSE IF (ID1.GT.6) THEN
46813 IW2=IW1
46814 END IF
46815 END IF
46816 IF (IW2.EQ.IW1) IW1=IW1+1
46817 END
46818CDECK ID>, HWSFUN.
46819*CMZ :- -02/05/91 11.30.51 by Federico Carminati
46820*-- Author : Miscellaneous, combined by Bryan Webber
46821C-----------------------------------------------------------------------
46822 SUBROUTINE HWSFUN(XIN,SCALE,IDHAD,NSET,DIST,IBEAM)
46823C-----------------------------------------------------------------------
46824C NUCLEON AND PION STRUCTURE FUNCTIONS DIST=X*QRK(X,Q=SCALE)
46825C
46826C IDHAD = TYPE OF HADRON:
46827C 73=P 91=PBAR 75=N 93=NBAR 38=PI+ 30=PI- 59=PHOTON
46828C
46829C NEW SPECIAL CODES:
46830C 71=`REMNANT PHOTON' 72=`REMNANT NUCLEON'
46831C
46832C NSET = STRUCTURE FUNCTION SET
46833C = 1,2 FOR DUKE+OWENS SETS 1,2 (SOFT/HARD GLUE)
46834C = 3,4 FOR EICHTEN ET AL SETS 1,2 (NUCLEON ONLY)
46835C = 5 FOR OWENS SET 1.1 (PREPRINT FSU-HEP-910606)
46836C
46837C FOR PHOTON DREES+GRASSIE IS USED
46838C
46839C N.B. IF IBEAM.GT.0.AND.MODPDF(IBEAM).GE.0 THEN NSET IS
46840C IGNORED AND CERN PDFLIB WITH AUTHOR GROUP=AUTPDF(IBEAM) AND
46841C SET=MODPDF(IBEAM) IS USED. FOR COMPATABILITY WITH VERSIONS 3
46842C AND EARLIER, AUTPDF SHOULD BE SET TO 'MODE'
46843C NOTE THAT NO CONSISTENCY CHECK IS MADE, FOR EXAMPLE THAT THE
46844C REQUESTED SET FOR A PHOTON IS ACTUALLY A PHOTON SET
46845C
46846C IF (ISPAC.GT.0) SCALE IS REPLACED BY MAX(SCALE,QSPAC)
46847C
46848C IF (X.LT.PDFX0) REPLACE X*F(X) BY PDFX0*F(PDFX0)*(X/PDFX0)**PDFPOW
46849C
46850C FOR PHOTON, IF (PHOMAS.GT.0) THEN QUARK DISTRIBUTIONS ARE
46851C SUPPRESSED BY LOG((Q**2+PHOMAS**2)/(P**2+PHOMAS**2))
46852C L = -------------------------------------- ,
46853C LOG((Q**2+PHOMAS**2)/( PHOMAS**2))
46854C WHILE GLUON DISTRIBUTIONS ARE SUPPRESSED BY L**2,
46855C WHERE Q=SCALE AND P=VIRTUALITY OF THE PHOTON
46856C
46857C DUKE+OWENS = D.W.DUKE AND J.F.OWENS, PHYS. REV. D30 (1984) 49 (P/N)
46858C + J.F.OWENS, PHYS. REV. D30 (1984) 943 (PI+/-)
46859C WITH EXTRA SIGNIFICANT FIGURES VIA ED BERGER
46860C WARNING....MOMENTUM SUM RULE BADLY VIOLATED ABOVE 1 TEV
46861C DUKE+OWENS SETS 1,2 OBSOLETE. SET 1 UPDATED TO OWENS 1.1 (1991)
46862C PION NOT RELIABLE ABOVE SCALE = 50 GEV
46863C
46864C EICHTEN ET AL = E.EICHTEN,I.HINCHLIFFE,K.LANE AND C.QUIGG,
46865C REV. MOD. PHYS. 56 (1984) 579
46866C REVISED AS IN REV. MOD. PHYS. 58 (1986) 1065
46867C RELIABLE RANGE : SQRT(5)GEV < SCALE < 10TEV, 1E-4 < X < 1
46868C
46869C DREES+GRASSIE = M.DREES & K.GRASSIE, ZEIT. PHYS. C28 (1985) 451
46870C MODIFIED IN M.DREES & C.S.KIM, DESY 91-039
46871C AND C.S.KIM, DTP/91/16 FOR HEAVY QUARKS
46872C
46873C FOR CERN PDFLIB DETAILS SEE PDFLIB DOC Q ON CERNVM OR
46874C CERN_ROOT:[DOC]PDFLIB.TXT ON VXCERN
46875C-----------------------------------------------------------------------
46876C---BRW change 27/8/04: include Frixione's fix to reduce PDFSET calls
46877C-----------------------------------------------------------------------
c63d70bc 46878 INCLUDE 'herwig65.inc'
65767955 46879 DOUBLE PRECISION HWSGAM,X,SCALE,XOLD,QOLD,XMWN,QSCA,SS,SMIN,S,T,
46880 & TMIN,TMAX,VX,AA,VT,WT,UPV,DNV,SEA,STR,CHM,BTM,TOP,GLU,WX,XQSUM,
46881 & DMIN,TPMIN,TPMAX,DIST(13),G(2),Q0(5),QL(5),F(5),A(6,5),
46882 & B(3,6,5,4),XQ(6),TX(6),TT(6),TB(6),NEHLQ(8,2),CEHLQ(6,6,2,8,2),
46883 & BB(4,6,5),VAL(20),USEA,DSEA,TOTAL,SCALEF,FAC,TBMIN(2),TTMIN(2)
46884 DOUBLE PRECISION XIN,PDFFAC
46885 REAL HWSDGG,HWSDGQ,XSP,Q2,P2,W2,EMB2,EMC2,ALAM2,XPGA(-6:6),F2GM,
46886 & XPVMD,XPANL,XPANH,XPBEH,XPDIR
46887 COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
46888 & XPDIR(-6:6)
46889 LOGICAL PDFWRX(2,2),PDFWRQ(2,2)
46890 DOUBLE PRECISION PDFXMN,PDFXMX,PDFQMN,PDFQMX
46891 COMMON /W50513/PDFXMN,PDFXMX,PDFQMN,PDFQMX
46892 INTEGER IDHAD,NSET,IBEAM,IOLD,NOLD,IP,I,J,K,NX,IT,IX,IFL,NFL,
46893 & MPDF,IHAD,ISET,IOP1,IOP2,IP2
46894 CHARACTER*20 PARM(20)
46895 CHARACTER*20 PARMSAVE
46896 DOUBLE PRECISION VALSAVE
46897 COMMON/HWSFSA/PARMSAVE
46898 COMMON/HWSFSB/VALSAVE
46899 EXTERNAL HWSGAM,HWSDGG,HWSDGQ
46900 SAVE QOLD,IOLD,NOLD,XOLD,SS,S,T,TMIN,TMAX,G,A,TX,TT,TB,IP,NX
46901 SAVE PDFWRX,PDFWRQ,B,BB,NEHLQ,CEHLQ,TBMIN,TTMIN,DMIN,Q0,QL
46902 DATA PDFWRX,PDFWRQ/8*.TRUE./
46903 DATA (((B(I,J,K,1),I=1,3),J=1,6),K=1,5)/
46904 &3.D0,0.D0,0.D0,.419D0,.004383D0,-.007412D0,
46905 &3.46D0,.72432D0,-.065998D0,4.4D0,-4.8644D0,1.3274D0,
46906 &6*0.D0,1.D0,
46907 &0.D0,0.D0,.763D0,-.23696D0,.025836D0,4.D0,.62664D0,-.019163D0,
46908 &0.D0,-.42068D0,.032809D0,6*0.D0,1.265D0,-1.1323D0,.29268D0,
46909 &0.D0,-.37162D0,-.028977D0,8.05D0,1.5877D0,-.15291D0,
46910 &0.D0,6.3059D0,-.27342D0,0.D0,-10.543D0,-3.1674D0,
46911 &0.D0,14.698D0,9.798D0,0.D0,.13479D0,-.074693D0,
46912 &-.0355D0,-.22237D0,-.057685D0,6.3494D0,3.2649D0,-.90945D0,
46913 &0.D0,-3.0331D0,1.5042D0,0.D0,17.431D0,-11.255D0,
46914 &0.D0,-17.861D0,15.571D0,1.564D0,-1.7112D0,.63751D0,
46915 &0.D0,-.94892D0,.32505D0,6.D0,1.4345D0,-1.0485D0,
46916 &9.D0,-7.1858D0,.25494D0,0.D0,-16.457D0,10.947D0,
46917 &0.D0,15.261D0,-10.085D0/
46918 DATA (((B(I,J,K,2),I=1,3),J=1,6),K=1,5)/
46919 &3.D0,0.D0,0.D0,.3743D0,.013946D0,-.00031695D0,
46920 &3.329D0,.75343D0,-.076125D0,6.032D0,-6.2153D0,1.5561D0,
46921 &6*0.D0,1.D0,0.D0,
46922 &0.D0,.7608D0,-.2317D0,.023232D0,3.83D0,.62746D0,-.019155D0,
46923 &0.D0,-.41843D0,.035972D0,6*0.D0,1.6714D0,-1.9168D0,.58175D0,
46924 &0.D0,-.27307D0,-.16392D0,9.145D0,.53045D0,-.76271D0,
46925 &0.D0,15.665D0,-2.8341D0,0.D0,-100.63D0,44.658D0,
46926 &0.D0,223.24D0,-116.76D0,0.D0,.067368D0,-.030574D0,
46927 &-.11989D0,-.23293D0,-.023273D0,3.5087D0,3.6554D0,-.45313D0,
46928 &0.D0,-.47369D0,.35793D0,0.D0,9.5041D0,-5.4303D0,
46929 &0.D0,-16.563D0,15.524D0,.8789D0,-.97093D0,.43388D0,
46930 &0.D0,-1.1612D0,.4759D0,4.D0,1.2271D0,-.25369D0,
46931 &9.D0,-5.6354D0,-.81747D0,0.D0,-7.5438D0,5.5034D0,
46932 &0.D0,-.59649D0,.12611D0/
46933 DATA (((B(I,J,K,3),I=1,3),J=1,6),K=1,5)/
46934 &1.D0,0.D0,0.D0,0.4D0,-0.06212D0,-0.007109D0,0.7D0,0.6478D0,
46935 &0.01335D0,27*0.D0,0.9D0,-0.2428D0,0.1386D0,0.D0,-0.2120D0,
46936 &0.003671D0,5.0D0,0.8673D0,0.04747D0,
46937 &0.D0,1.266D0,-2.215D0,0.D0,2.382D0,0.3482D0,3*0.D0,
46938 &0.D0,0.07928D0,-0.06134D0,-0.02212D0,-0.3785D0,-0.1088D0,2.894D0,
46939 &9.433D0,
46940 &-10.852D0,0.D0,5.248D0,-7.187D0,0.D0,8.388D0,-11.61D0,3*0.D0,
46941 &0.888D0,-1.802D0,1.812D0,0.D0,-1.576D0,1.20D0,3.11D0,-0.1317D0,
46942 &0.5068D0,6.0D0,2.801D0,-12.16D0,0.D0,-17.28D0,20.49D0,3*0.D0/
46943 DATA (((B(I,J,K,4),I=1,3),J=1,6),K=1,5)/
46944 &1.D0,0.D0,0.D0,0.4D0,-0.05909D0,-0.006524D0,0.628D0,0.6436D0,
46945 &0.01451D0,27*0.D0,
46946 &0.90D0,-0.1417D0,-0.1740D0,0.D0,-0.1697D0,-0.09623D0,5.0D0,
46947 &-2.474D0,1.575D0,
46948 &0.D0,-2.534D0,1.378D0,0.D0,0.5621D0,-0.2701D0,3*0.D0,
46949 &0.D0,0.06229D0,-0.04099D0,-0.0882D0,-0.2892D0,-0.1082D0,1.924D0,
46950 &0.2424D0,
46951 &2.036D0,0.D0,-4.463D0,5.209D0,0.D0,-0.8367D0,-0.04840D0,3*0.D0,
46952 &0.794D0,-0.9144D0,0.5966D0,0.D0,-1.237D0,0.6582D0,2.89D0,0.5966D0,
46953 &-0.2550D0,
46954 &6.0D0,-3.671D0,-2.304D0,0.D0,-8.191D0,7.758D0,3*0.D0/
46955C---COEFFTS FOR NEW OWENS 1.1 SET
46956 DATA BB/3.D0,3*0.D0,.665D0,-.1097D0,-.002442D0,0.D0,
46957 &3.614D0,.8395D0,-.02186D0,0.D0,.8673D0,-1.6637D0,.342D0,0.D0,
46958 &0.D0,1.1049D0,-.2369D0,5*0.D0,1.D0,3*0.D0,
46959 &.8388D0,-.2092D0,.02657D0,0.D0,4.667D0,.7951D0,.1081D0,0.D0,
46960 &0.D0,-1.0232D0,.05799D0,0.D0,0.D0,.8616D0,.153D0,5*0.D0,
46961 &.909D0,-.4023D0,.006305D0,0.D0,
46962 &0.D0,-.3823D0,.02766D0,0.D0,7.278D0,-.7904D0,.8108D0,0.D0,
46963 &0.D0,-1.6629D0,.5719D0,0.D0,0.D0,-.01333D0,.5299D0,0.D0,
46964 &0.D0,.1211D0,-.1739D0,0.D0,0.D0,.09469D0,-.07066D0,.01236D0,
46965 &-.1447D0,-.402D0,.1533D0,-.06479D0,6.7599D0,1.6596D0,.6798D0,
46966 &-.8525D0,0.D0,-4.4559D0,3.3756D0,-.9468D0,
46967 &0.D0,7.862D0,-3.6591D0,.03672D0,0.D0,-.2472D0,-.751D0,.0487D0,
46968 &3.017D0,-4.7347D0,3.3594D0,-.9443D0,0.D0,-.9342D0,.5454D0,
46969 &-.1668D0,
46970 &5.304D0,1.4654D0,-1.4292D0,.7569D0,0.D0,-3.9141D0,2.8445D0,
46971 &-.8411D0,
46972 &0.D0,9.0176D0,-10.426D0,4.0983D0,0.D0,-5.9602D0,7.515D0,-2.7329D0/
46973C...THE FOLLOWING DATA LINES ARE COEFFICIENTS NEEDED IN THE
46974C...EICHTEN, HINCHLIFFE, LANE, QUIGG PROTON STRUCTURE FUNCTION
46975C...POWERS OF 1-X IN DIFFERENT CASES
46976 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
46977C...EXPANSION COEFFICIENTS FOR UP VALENCE QUARK DISTRIBUTION
46978 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
46979 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
46980 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
46981 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
46982 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
46983 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
46984 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
46985 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
46986 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
46987 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
46988 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
46989 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
46990 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
46991 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
46992 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
46993 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
46994 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
46995 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
46996 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
46997 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
46998 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
46999 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
47000 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
47001 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
47002 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
47003 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
47004C...EXPANSION COEFFICIENTS FOR DOWN VALENCE QUARK DISTRIBUTION
47005 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
47006 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
47007 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
47008 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
47009 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
47010 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
47011 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
47012 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
47013 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
47014 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
47015 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
47016 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
47017 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
47018 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
47019 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
47020 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
47021 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
47022 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
47023 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
47024 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
47025 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
47026 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
47027 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
47028 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
47029 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
47030 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
47031C...EXPANSION COEFFICIENTS FOR UP AND DOWN SEA QUARK DISTRIBUTIONS
47032 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
47033 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
47034 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
47035 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
47036 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
47037 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
47038 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
47039 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
47040 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
47041 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
47042 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
47043 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
47044 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
47045 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
47046 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
47047 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
47048 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
47049 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
47050 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
47051 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
47052 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
47053 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
47054 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
47055 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
47056 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
47057 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
47058C...EXPANSION COEFFICIENTS FOR GLUON DISTRIBUTION
47059 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
47060 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
47061 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
47062 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
47063 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
47064 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
47065 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
47066 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
47067 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
47068 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
47069 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
47070 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
47071 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
47072 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
47073 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
47074 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
47075 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
47076 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
47077 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
47078 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
47079 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
47080 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
47081 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
47082 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
47083 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
47084 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
47085C...EXPANSION COEFFICIENTS FOR STRANGE SEA QUARK DISTRIBUTION
47086 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
47087 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
47088 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
47089 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
47090 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
47091 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
47092 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
47093 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
47094 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
47095 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
47096 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
47097 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
47098 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
47099 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
47100 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
47101 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
47102 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
47103 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
47104 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
47105 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
47106 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
47107 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
47108 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
47109 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
47110 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
47111 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
47112C...EXPANSION COEFFICIENTS FOR CHARM SEA QUARK DISTRIBUTION
47113 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
47114 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
47115 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
47116 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
47117 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
47118 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
47119 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
47120 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
47121 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
47122 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
47123 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
47124 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
47125 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
47126 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
47127 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
47128 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
47129 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
47130 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
47131 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
47132 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
47133 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
47134 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
47135 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
47136 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
47137 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
47138 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
47139C...EXPANSION COEFFICIENTS FOR BOTTOM SEA QUARK DISTRIBUTION
47140 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
47141 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
47142 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
47143 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
47144 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
47145 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
47146 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
47147 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
47148 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
47149 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
47150 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
47151 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
47152 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
47153 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
47154 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
47155 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
47156 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
47157 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
47158 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
47159 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
47160 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
47161 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
47162 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
47163 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
47164 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
47165 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
47166C...EXPANSION COEFFICIENTS FOR TOP SEA QUARK DISTRIBUTION
47167 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
47168 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
47169 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
47170 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
47171 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
47172 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
47173 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
47174 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
47175 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
47176 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
47177 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
47178 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
47179 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
47180 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
47181 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
47182 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
47183 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
47184 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
47185 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
47186 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
47187 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
47188 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
47189 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
47190 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
47191 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
47192 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
47193 DATA TBMIN,TTMIN/8.1905D0,7.4474D0,11.5528D0,10.8097D0/
47194 DATA XOLD,QOLD,IOLD,NOLD/-1.D0,0.D0,0,0/
47195 DATA DMIN,Q0,QL/0.D0,2*2.D0,2*2.236D0,2.D0,.2D0,
47196 & .4D0,.2D0,.29D0,.177D0/
47197C---X IS EQUAL TO XIN, UNLESS IT IS LESS THAN PDFX0
47198 X=MAX(XIN,PDFX0)
47199 IF (X.LE.ZERO) THEN
47200 CALL HWWARN('HWSFUN',100)
47201 GOTO 999
47202 ENDIF
47203 XMWN=ONE-X
47204 IF (XMWN.LE.ZERO) THEN
47205 DO 1 I=1,13
47206 DIST(I)=0
47207 1 CONTINUE
47208 RETURN
47209 ENDIF
47210C---FREEZE THE SCALE IF REQUIRED
47211 SCALEF=SCALE
47212 IF (ISPAC.GT.0) SCALEF=MAX(SCALEF,QSPAC)
47213C---CHECK IF PDFLIB REQUESTED
47214 IF (IBEAM.EQ.1.OR.IBEAM.EQ.2) THEN
47215 MPDF=MODPDF(IBEAM)
47216 ELSE
47217 MPDF=-1
47218 ENDIF
47219 QSCA=ABS(SCALEF)
47220 IF (IDHAD.EQ.59.OR.IDHAD.EQ.71) THEN
47221 IF (MPDF.GE.0) THEN
47222C---USE PDFLIB PHOTON STRUCTURE FUNCTIONS
47223 PARM(1)=AUTPDF(IBEAM)
47224 VAL(1)=FLOAT(MPDF)
47225C---FIX TO CALL SCHULER-SJOSTRAND CODE
47226 IF (AUTPDF(IBEAM).EQ.'SaSph') THEN
47227 XSP=SNGL(X)
47228 IF ( XSP.LE.ZERO) THEN
47229 CALL HWWARN('HWSFUN',102)
47230 GOTO 999
47231 ENDIF
47232 IF (ONE-XSP.LE.ZERO) THEN
47233 CALL HWWARN('HWSFUN',103)
47234 GOTO 999
47235 ENDIF
47236 Q2=SNGL(QSCA**2)
47237 ISET=MOD(MODPDF(IBEAM),10)
47238 IOP1=MOD(MODPDF(IBEAM)/10,2)
47239 IOP2=MOD(MODPDF(IBEAM)/20,2)
47240 IP2=MODPDF(IBEAM)/100
47241 IF (IOP2.EQ.0) THEN
47242 P2=0.
47243 ELSE
47244 IHAD=IBEAM
47245 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
47246 P2=SNGL(PHEP(5,IHAD)**2)
47247 ENDIF
47248 CALL SASGAM(ISET,XSP,Q2,P2,IP2,F2GM,XPGA)
47249 IF (IOP1.EQ.1 .AND. ISTAT.LT.10) THEN
47250 DO 5 I=-6,6
47251 5 XPGA(I)=XPVMD(I)+XPANL(I)+XPBEH(I)+XPDIR(I)
47252 ENDIF
47253 UPV=XPGA(2)
47254 DNV=XPGA(1)
47255 USEA=XPGA(2)
47256 DSEA=XPGA(1)
47257 STR=XPGA(3)
47258 CHM=XPGA(4)
47259 BTM=XPGA(5)
47260 TOP=XPGA(6)
47261 GLU=XPGA(0)
47262 ELSE
47263 IF(PARM(1).NE.PARMSAVE.OR.VAL(1).NE.VALSAVE)THEN
47264 PARMSAVE=PARM(1)
47265 VALSAVE=VAL(1)
d08a7832 47266 CALL PDFSET_HERWIG(PARM,VAL)
65767955 47267 ENDIF
47268 IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR.
47269 & X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN
47270 CALL HWWARN('HWSFUN',2)
47271 WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X',
47272 & ' OUTSIDE ALLOWED RANGE!'
47273 WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
47274 & ', MINIMUM=',PDFXMN,', MAXIMUM=',PDFXMX
47275 WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
47276 IF (X.LT.PDFXMN) PDFWRX(IBEAM,1)=.FALSE.
47277 IF (X.GT.PDFXMX) PDFWRX(IBEAM,2)=.FALSE.
47278 ENDIF
47279 IF (QSCA**2.LT.PDFQMN.AND.PDFWRQ(IBEAM,1) .OR.
47280 & QSCA**2.GT.PDFQMX.AND.PDFWRQ(IBEAM,2)) THEN
47281 CALL HWWARN('HWSFUN',3)
47282 WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q',
47283 & ' OUTSIDE ALLOWED RANGE!'
47284 WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',QSCA,
47285 & ', MINIMUM=',SQRT(PDFQMN),', MAXIMUM=',SQRT(PDFQMX)
47286 WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
47287 IF (QSCA**2.LT.PDFQMN) PDFWRQ(IBEAM,1)=.FALSE.
47288 IF (QSCA**2.GT.PDFQMN) PDFWRQ(IBEAM,2)=.FALSE.
47289 ENDIF
47290 CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
47291 ENDIF
47292 DIST(1)=DSEA
47293 DIST(2)=USEA
47294 DIST(7)=DSEA
47295 DIST(8)=USEA
47296 ELSE
47297 XSP=SNGL(X)
47298 IF ( XSP.LE.ZERO) THEN
47299 CALL HWWARN('HWSFUN',102)
47300 GOTO 999
47301 ENDIF
47302 IF (ONE-XSP.LE.ZERO) THEN
47303 CALL HWWARN('HWSFUN',103)
47304 GOTO 999
47305 ENDIF
47306 Q2=SNGL(SCALEF**2)
47307 W2=Q2*(1-XSP)/XSP
47308 EMC2=SNGL(4*RMASS(4)**2)
47309 EMB2=SNGL(4*RMASS(5)**2)
47310 ALAM2=0.160
47311 NFL=3
47312 IF (Q2.GT.50.) NFL=4
47313 IF (Q2.GT.500.) NFL=5
47314 STR=HWSDGQ(XSP,Q2,NFL,1)
47315 CHM=HWSDGQ(XSP,Q2,NFL,2)
47316 GLU=HWSDGG(XSP,Q2,NFL)
47317 DIST(1)=STR
47318 DIST(2)=CHM
47319 DIST(7)=STR
47320 DIST(8)=CHM
47321 IF (W2.GT.EMB2) THEN
47322 BTM=STR
47323 IF (W2*ALAM2.LT.Q2*EMB2)
47324 & BTM=BTM*LOG(W2/EMB2)/LOG(Q2/ALAM2)
47325 ELSE
47326 BTM=0.
47327 ENDIF
47328 IF (W2.GT.EMC2) THEN
47329 IF (W2*ALAM2.LT.Q2*EMC2)
47330 & CHM=CHM*LOG(W2/EMC2)/LOG(Q2/ALAM2)
47331 ELSE
47332 CHM=0.
47333 ENDIF
47334 TOP=0.
47335 ENDIF
47336C---INCLUDE SUPPRESSION FROM PHOTON VIRTUALITY IF NECESSARY
47337 IF (PHOMAS.GT.ZERO.AND.(IBEAM.EQ.1.OR.IBEAM.EQ.2)) THEN
47338 IHAD=IBEAM
47339 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
47340 IF (IDHW(IHAD).EQ.59) THEN
47341 FAC=LOG((QSCA**2+PHOMAS**2)/(PHEP(5,IHAD)**2+PHOMAS**2))/
47342 $ LOG((QSCA**2+PHOMAS**2)/( PHOMAS**2))
47343 IF (FAC.LT.ZERO) FAC=ZERO
47344 DIST(1)=DIST(1)*FAC
47345 DIST(2)=DIST(2)*FAC
47346 DIST(7)=DIST(7)*FAC
47347 DIST(8)=DIST(8)*FAC
47348 STR=STR*FAC
47349 CHM=CHM*FAC
47350 BTM=BTM*FAC
47351 TOP=TOP*FAC
47352 GLU=GLU*FAC**2
47353 ELSE
47354 CALL HWWARN('HWSFUN',1)
47355 ENDIF
47356 ENDIF
47357 GOTO 900
47358 ENDIF
47359 IF (MPDF.GE.0) THEN
47360C---USE PDFLIB NUCLEON STRUCTURE FUNCTIONS
47361 PARM(1)=AUTPDF(IBEAM)
47362 VAL(1)=FLOAT(MPDF)
47363 IF(PARM(1).NE.PARMSAVE.OR.VAL(1).NE.VALSAVE)THEN
47364 PARMSAVE=PARM(1)
47365 VALSAVE=VAL(1)
d08a7832 47366 CALL PDFSET_HERWIG(PARM,VAL)
65767955 47367 ENDIF
47368 IF (X.LT.PDFXMN.AND.PDFWRX(IBEAM,1) .OR.
47369 & X.GT.PDFXMX.AND.PDFWRX(IBEAM,2)) THEN
47370 CALL HWWARN('HWSFUN',4)
47371 WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH X',
47372 & ' OUTSIDE ALLOWED RANGE!'
47373 WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
47374 & ', MINIMUM=',PDFXMN,', MAXIMUM=',PDFXMX
47375 WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
47376 IF (X.LT.PDFXMN) PDFWRX(IBEAM,1)=.FALSE.
47377 IF (X.GT.PDFXMX) PDFWRX(IBEAM,2)=.FALSE.
47378 ENDIF
47379 IF (QSCA**2.LT.PDFQMN.AND.PDFWRQ(IBEAM,1) .OR.
47380 & QSCA**2.GT.PDFQMX.AND.PDFWRQ(IBEAM,2)) THEN
47381 CALL HWWARN('HWSFUN',5)
47382 WRITE (6,'(2A)') ' WARNING: PDFLIB CALLED WITH Q',
47383 & ' OUTSIDE ALLOWED RANGE!'
47384 WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',QSCA,
47385 & ', MINIMUM=',SQRT(PDFQMN),', MAXIMUM=',SQRT(PDFQMX)
47386 WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
47387 IF (QSCA**2.LT.PDFQMN) PDFWRQ(IBEAM,1)=.FALSE.
47388 IF (QSCA**2.GT.PDFQMN) PDFWRQ(IBEAM,2)=.FALSE.
47389 ENDIF
47390 CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
47391C--new MRST98 LO PDF's
47392 ELSEIF(NSET.GE.6.AND.NSET.LE.8) THEN
47393 CALL HWSMRS(X,SCALEF,NSET-5,UPV,DNV,USEA,DSEA,STR,CHM,BTM,GLU)
47394 TOP=ZERO
47395 ELSE
47396 IF (NSET.LT.1.OR.NSET.GT.5) CALL HWWARN('HWSFUN',400)
47397 IF (QSCA.LT.Q0(NSET)) QSCA=Q0(NSET)
47398 IF (QSCA.NE.QOLD.OR.IDHAD.NE.IOLD.OR.NSET.NE.NOLD) THEN
47399C---INITIALIZE
47400 QOLD=QSCA
47401 IOLD=IDHAD
47402 NOLD=NSET
47403 SS=LOG(QSCA/QL(NSET))
47404 SMIN=LOG(Q0(NSET)/QL(NSET))
47405 IF (NSET.LT.3.OR.NSET.EQ.5) THEN
47406 S=LOG(SS/SMIN)
47407 ELSE
47408 T=2.*SS
47409 TMIN=2.*SMIN
47410 TMAX=2.*LOG(1.E4/QL(NSET))
47411 ENDIF
47412 IF (IDHAD.GE.72) THEN
47413 IF (NSET.LT.3) THEN
47414 IP=NSET
47415 DO 10 I=1,5
47416 DO 10 J=1,6
47417 10 A(J,I)=B(1,J,I,IP)+S*(B(2,J,I,IP)+S*B(3,J,I,IP))
47418 DO 20 K=1,2
47419 AA=ONE+A(2,K)+A(3,K)
47420 20 G(K)=HWSGAM(AA)/((ONE+A(2,K)*A(4,K)/AA)*HWSGAM(A(2,K))
47421 & *HWSGAM(ONE+A(3,K)))
47422 ELSEIF (NSET.EQ.5) THEN
47423 DO 21 I=1,5
47424 DO 21 J=1,6
47425 21 A(J,I)=BB(1,J,I)+S*(BB(2,J,I)+S*(BB(3,J,I)+S*BB(4,J,I)))
47426 DO 22 K=1,2
47427 AA=ONE+A(2,K)+A(3,K)
47428 22 G(K)=HWSGAM(AA)/((ONE+A(2,K)/AA*(A(4,K)+
47429 & (ONE+A(2,K))/(ONE+AA)*A(5,K)))*HWSGAM(A(2,K))
47430 & *HWSGAM(ONE+A(3,K)))
47431 ELSE
47432 IP=NSET-2
47433 VT=MAX(-ONE,MIN(ONE,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
47434 WT=VT*VT
47435C...CHEBYSHEV POLYNOMIALS FOR T EXPANSION
47436 TT(1)=1.
47437 TT(2)=VT
47438 TT(3)= 2.*WT- 1.
47439 TT(4)= (4.*WT- 3.)*VT
47440 TT(5)= (8.*WT- 8.)*WT+1.
47441 TT(6)=((16.*WT-20.)*WT+5.)*VT
47442 ENDIF
47443 ELSEIF (NSET.LT.3) THEN
47444 IP=NSET+2
47445 DO 30 I=1,5
47446 DO 30 J=1,6
47447 30 A(J,I)=B(1,J,I,IP)+S*(B(2,J,I,IP)+S*B(3,J,I,IP))
47448 AA=ONE+A(2,1)+A(3,1)
47449 G(1)=HWSGAM(AA)/(HWSGAM(A(2,1))*HWSGAM(ONE+A(3,1)))
47450 G(2)=0.
47451 ENDIF
47452 ENDIF
47453C
47454 IF (NSET.LT.3.OR.NSET.EQ.5) THEN
47455 DO 50 I=1,5
47456 50 F(I)=A(1,I)*X**A(2,I)*XMWN**A(3,I)*(ONE+X*
47457 & (A(4,I)+X*(A(5,I) + X*A(6,I))))
47458 F(1)=F(1)*G(1)
47459 F(2)=F(2)*G(2)
47460 UPV=F(1)-F(2)
47461 DNV=F(2)
47462 SEA=F(3)/6.
47463 STR=SEA
47464 CHM=F(4)
47465 BTM=ZERO
47466 TOP=ZERO
47467 GLU=F(5)
47468 ELSE
47469 IF (X.NE.XOLD) THEN
47470 XOLD=X
47471 IF (X.GT.0.1) THEN
47472 NX=1
47473 VX=(2.*X-1.1)/0.9
47474 ELSE
47475 NX=2
47476 VX=MAX(-ONE,(2.*LOG(X)+11.51293)/6.90776)
47477 ENDIF
47478 WX=VX*VX
47479 TX(1)=1.
47480 TX(2)=VX
47481 TX(3)= 2.*WX- 1.
47482 TX(4)= (4.*WX- 3.)*VX
47483 TX(5)= (8.*WX- 8.)*WX+1.
47484 TX(6)=((16.*WX-20.)*WX+5.)*VX
47485 ENDIF
47486C...CALCULATE STRUCTURE FUNCTIONS
47487 DO 120 IFL=1,6
47488 XQSUM=0.
47489 DO 110 IT=1,6
47490 DO 110 IX=1,6
47491 110 XQSUM=XQSUM+CEHLQ(IX,IT,NX,IFL,IP)*TX(IX)*TT(IT)
47492 120 XQ(IFL)=XQSUM*XMWN**NEHLQ(IFL,IP)
47493 UPV=XQ(1)
47494 DNV=XQ(2)
47495 STR=XQ(5)
47496 CHM=XQ(6)
47497 SEA=XQ(3)
47498 GLU=XQ(4)
47499C...SPECIAL EXPANSION FOR BOTTOM (THRESHOLD EFFECTS)
47500 IF (NFLAV.LT.5.OR.T.LE.TBMIN(IP)) THEN
47501 BTM=0.
47502 ELSE
47503 VT=MAX(-ONE,MIN(ONE,(2.*T-TMAX-TBMIN(IP))/(TMAX-TBMIN(IP))))
47504 WT=VT*VT
47505 TB(1)=1.
47506 TB(2)=VT
47507 TB(3)= 2.*WT- 1.
47508 TB(4)= (4.*WT- 3.)*VT
47509 TB(5)= (8.*WT- 8.)*WT+1.
47510 TB(6)=((16.*WT-20.)*WT+5.)*VT
47511 XQSUM=0.
47512 DO 130 IT=1,6
47513 DO 130 IX=1,6
47514 130 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,IP)*TX(IX)*TB(IT)
47515 BTM=XQSUM*XMWN**NEHLQ(7,IP)
47516 ENDIF
47517C...SPECIAL EXPANSION FOR TOP (THRESHOLD EFFECTS)
47518 TPMIN=TTMIN(IP)+TMTOP
47519C---TMTOP=2.*LOG(TOPMAS/30.)
47520 TPMAX=TMAX+TMTOP
47521 IF (NFLAV.LT.6.OR.T.LE.TPMIN) THEN
47522 TOP=0.
47523 ELSE
47524 VT=MAX(-ONE,MIN(ONE,(2.*T-TPMAX-TPMIN)/(TPMAX-TPMIN)))
47525 WT=VT*VT
47526 TB(1)=1.
47527 TB(2)=VT
47528 TB(3)= 2.*WT- 1.
47529 TB(4)= (4.*WT- 3.)*VT
47530 TB(5)= (8.*WT- 8.)*WT+1.
47531 TB(6)=((16.*WT-20.)*WT+5.)*VT
47532 XQSUM=0.
47533 DO 150 IT=1,6
47534 DO 150 IX=1,6
47535 150 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,IP)*TX(IX)*TB(IT)
47536 TOP=XQSUM*XMWN**NEHLQ(8,IP)
47537 ENDIF
47538 ENDIF
47539 ENDIF
47540 IF (MPDF.LT.0.AND.NSET.LE.5) THEN
47541 USEA=SEA
47542 DSEA=USEA
47543 ENDIF
47544 IF(MPDF.LT.0.AND.NSET.GT.2.AND.(IDHAD.EQ.38.OR.IDHAD.EQ.30)) THEN
47545 WRITE(6,*) ' THIS SET OF PDFS DOES NOT SUPPORT PIONS'
47546 WRITE(6,*) 'EITHER USE SET NSTRU=1,2 OR A PION SET FROM PDFLIB'
47547 STOP
47548 ENDIF
47549 IF (IDHAD.EQ.73.OR.IDHAD.EQ.72) THEN
47550 DIST(1)=DSEA+DNV
47551 DIST(2)=USEA+UPV
47552 DIST(7)=DSEA
47553 DIST(8)=USEA
47554 ELSEIF (IDHAD.EQ.91) THEN
47555 DIST(1)=DSEA
47556 DIST(2)=USEA
47557 DIST(7)=DSEA+DNV
47558 DIST(8)=USEA+UPV
47559 ELSEIF (IDHAD.EQ.75) THEN
47560 DIST(1)=USEA+UPV
47561 DIST(2)=DSEA+DNV
47562 DIST(7)=USEA
47563 DIST(8)=DSEA
47564 ELSEIF (IDHAD.EQ.93) THEN
47565 DIST(1)=USEA
47566 DIST(2)=DSEA
47567 DIST(7)=USEA+UPV
47568 DIST(8)=DSEA+DNV
47569 ELSEIF (IDHAD.EQ.38) THEN
47570 DIST(1)=USEA
47571 DIST(2)=USEA+UPV
47572 DIST(7)=USEA+UPV
47573 DIST(8)=USEA
47574 ELSEIF (IDHAD.EQ.30) THEN
47575 DIST(1)=USEA+UPV
47576 DIST(2)=USEA
47577 DIST(7)=USEA
47578 DIST(8)=USEA+UPV
47579 ELSE
47580 PRINT *,' CALLED HWSFUN FOR IDHAD =',IDHAD
47581 CALL HWWARN('HWSFUN',401)
47582 ENDIF
47583 900 DIST(3)=STR
47584 DIST(4)=CHM
47585 DIST(5)=BTM
47586 DIST(6)=TOP
47587 DIST(9)=STR
47588 DIST(10)=CHM
47589 DIST(11)=BTM
47590 DIST(12)=TOP
47591 DIST(13)=GLU
47592 DO 901 I=1,13
47593 IF (DIST(I).LT.DMIN) DIST(I)=DMIN
47594 901 CONTINUE
47595C---FOR REMNANT NUCLEONS SWITCH OFF VALENCE QUARKS,
47596C WHILE MAINTAINING MOMENTUM SUM RULE
47597 IF (IDHAD.EQ.72) THEN
47598 TOTAL=0
47599 DO 910 I=1,13
47600 TOTAL=TOTAL+DIST(I)
47601 910 CONTINUE
47602 DIST(1)=DIST(1)-DNV
47603 DIST(2)=DIST(2)-UPV
47604 IF (TOTAL.GT.DNV+UPV) THEN
47605 DO 920 I=1,13
47606 DIST(I)=DIST(I)*TOTAL/(TOTAL-DNV-UPV)
47607 920 CONTINUE
47608 ENDIF
47609 ENDIF
47610C---IF X HAS BEEN FROZEN USE A POWER LAW
47611 IF (XIN.LT.PDFX0) THEN
47612 PDFFAC=(XIN/PDFX0)**PDFPOW
47613 DO 930 I=1,13
47614 DIST(I)=DIST(I)*PDFFAC
47615 930 CONTINUE
47616 ENDIF
47617 999 RETURN
47618 END
47619CDECK ID>, HWSGAM.
47620*CMZ :- -26/04/91 11.11.56 by Bryan Webber
47621*-- Author : Adapted by Bryan Webber
47622C-----------------------------------------------------------------------
47623 FUNCTION HWSGAM(ZINPUT)
47624C-----------------------------------------------------------------------
47625C Gamma function computed by eq. 6.1.40, Abramowitz.
47626C B(M) = B2m/(2m *(2m-1)) where B2m is the 2m'th Bernoulli number.
47627C HLNTPI = .5*LOG(2.*PI)
47628C-----------------------------------------------------------------------
47629 IMPLICIT NONE
47630 DOUBLE PRECISION HWSGAM,ZINPUT,B(10),HLNTPI,Z,SHIFT,G,T,RECZSQ
47631 INTEGER I
47632 SAVE B,HLNTPI
47633 DATA B/
47634 1 0.83333333333333333333D-01, -0.27777777777777777778D-02,
47635 1 0.79365079365079365079D-03, -0.59523809523809523810D-03,
47636 1 0.84175084175084175084D-03, -0.19175269175269175269D-02,
47637 1 0.64102564102564102564D-02, -0.29550653594771241830D-01,
47638 1 0.17964437236883057316D0 , -1.3924322169059011164D0 /
47639 DATA HLNTPI/0.91893853320467274178D0/
47640C
47641C Shift argument to large value ( > 20 )
47642C
47643 Z=ZINPUT
47644 SHIFT=1.
47645 10 IF (Z.LT.20.D0) THEN
47646 SHIFT = SHIFT*Z
47647 Z = Z + 1.D0
47648 GOTO 10
47649 ENDIF
47650C
47651C Compute asymptotic formula
47652C
47653 G = (Z-.5D0)*LOG(Z) - Z + HLNTPI
47654 T = 1.D0/Z
47655 RECZSQ = T**2
47656 DO 20 I = 1,10
47657 G = G + B(I)*T
47658 T = T*RECZSQ
47659 20 CONTINUE
47660 HWSGAM = EXP(G)/SHIFT
47661 END
47662CDECK ID>, HWSGEN.
47663*CMZ :- -26/04/91 14.55.45 by Federico Carminati
47664*-- Author : Bryan Webber
47665C-----------------------------------------------------------------------
47666 SUBROUTINE HWSGEN(GENEX)
47667C-----------------------------------------------------------------------
47668C GENERATES X VALUES (IF GENEX)
47669C EVALUATES STRUCTURE FUNCTIONS AND ENFORCES CUTOFFS ON X
47670C-----------------------------------------------------------------------
c63d70bc 47671 INCLUDE 'herwig65.inc'
65767955 47672 DOUBLE PRECISION HWBVMC,HWRUNI,X,QL
47673 INTEGER I,J
47674 LOGICAL GENEX
47675 EXTERNAL HWBVMC,HWRUNI
47676 IF (GENEX) THEN
47677 XX(1)=EXP(HWRUNI(0,ZERO,XLMIN))
47678 XX(2)=XXMIN/XX(1)
47679 ENDIF
47680 DO 10 I=1,2
47681 J=I
47682 IF (JDAHEP(1,I).NE.0) J=JDAHEP(1,I)
47683 X=XX(I)
47684 QL=(1.-X)*EMSCA
47685 CALL HWSFUN(X,EMSCA,IDHW(J),NSTRU,DISF(1,I),I)
47686 DO 10 J=1,13
47687 IF (QL.LT.HWBVMC(J)) DISF(J,I)=0.
47688 10 CONTINUE
47689 END
47690CDECK ID>, HWSGQQ.
47691*CMZ :- -26/04/91 11.11.56 by Bryan Webber
47692*-- Author : Bryan Webber
47693C-----------------------------------------------------------------------
47694 FUNCTION HWSGQQ(QSCA)
47695C-----------------------------------------------------------------------
47696C CORRECTION TO GLUON STRUCTURE FUNCTION FOR BACKWARD EVOLUTION:
47697C G->Q-QBAR PART OF FORM FACTOR
47698C-----------------------------------------------------------------------
c63d70bc 47699 INCLUDE 'herwig65.inc'
65767955 47700 DOUBLE PRECISION HWSGQQ,HWUALF,QSCA,GG
47701 EXTERNAL HWUALF
47702 GG=HWUALF(1,QSCA)**(-ONE/BETAF)
47703 IF (GG.LT.ONE) GG=ONE
47704 IF (QSCA.GT.RMASS(6)) THEN
47705 HWSGQQ=GG**6
47706 ELSEIF (QSCA.GT.RMASS(5)) THEN
47707 HWSGQQ=GG**5
47708 ELSEIF (QSCA.GT.RMASS(4)) THEN
47709 HWSGQQ=GG**4
47710 ELSE
47711 HWSGQQ=GG**3
47712 ENDIF
47713 END
47714CDECK ID>, HWSMRS.
47715*CMZ :- -26/04/01 10.00.16 by Peter Richardson
47716*-- Author : Dick Roberts, modified by Peter Richardson
47717C-----------------------------------------------------------------------
47718 SUBROUTINE HWSMRS(X,Q,MODE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,GLU)
47719C-----------------------------------------------------------------------
47720C MRST98 Leading order PDF's central and higher gluon + average
47721C-----------------------------------------------------------------------
c63d70bc 47722 INCLUDE 'herwig65.inc'
65767955 47723 DOUBLE PRECISION X,Q,UPV,DNV,USEA,DSEA,STR,CHM,BOT,GLU,XMIN,XMAX,
47724 & QSQMIN,QSQMAX,Q2,QQ(NQMRS),XXMRS(NXMRS),G(NPMRS),N0(NPMRS),
47725 & XSAVE,Q2SAVE,XXX,A,B,FAC
47726 INTEGER MODE,INIT,NTENTH,N,M,I,J,K,ML,WARN(2)
47727 PARAMETER(NTENTH=23)
47728 SAVE INIT,WARN,XMIN,XMAX,QSQMIN,QSQMAX,XXMRS,QQ,N0
47729 DATA XMIN,XMAX,QSQMIN,QSQMAX/1D-5,1D0,1.25D0,1D7/
47730 DATA XXMRS/1d-5,2d-5,4d-5,6d-5,8d-5,
47731 & 1d-4,2d-4,4d-4,6d-4,8d-4,
47732 & 1d-3,2d-3,4d-3,6d-3,8d-3,
47733 & 1d-2,1.4d-2,2d-2,3d-2,4d-2,6d-2,8d-2,
47734 & .1d0,.125d0,.15d0,.175d0,.2d0,.225d0,.25d0,.275d0,
47735 & .3d0,.325d0,.35d0,.375d0,.4d0,.425d0,.45d0,.475d0,
47736 & .5d0,.525d0,.55d0,.575d0,.6d0,.65d0,.7d0,.75d0,
47737 & .8d0,.9d0,1d0/
47738 DATA QQ/1.25d0,1.5d0,2d0,2.5d0,3.2d0,4d0,5d0,6.4d0,8d0,1d1,
47739 & 1.2d1,1.8d1,2.6d1,4d1,6.4d1,1d2,
47740 & 1.6d2,2.4d2,4d2,6.4d2,1d3,1.8d3,3.2d3,5.6d3,1d4,
47741 & 1.8d4,3.2d4,5.6d4,1d5,1.8d5,3.2d5,5.6d5,1d6,
47742 & 1.8d6,3.2d6,5.6d6,1d7/
47743 DATA N0/3,4,5,9,9,9,9,9/
47744 DATA INIT,WARN/0,0,0/
47745 Q2=Q*Q
47746C--issue warning if x or q out of range
47747 IF((Q2.LT.QSQMIN.OR.Q2.GT.QSQMAX).AND.WARN(1).EQ.0) THEN
47748 CALL HWWARN('HWSMRS',5)
47749 WRITE (6,'(2A)') ' WARNING: MRST98 CALLED WITH Q',
47750 & ' OUTSIDE ALLOWED RANGE!'
47751 WRITE (6,'(1P,3(A,E9.3))') ' Q VALUE=',Q,
47752 & ', MINIMUM=',SQRT(QSQMIN),', MAXIMUM=',SQRT(QSQMAX)
47753 WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
47754 WARN(1) = 1
47755 ENDIF
47756 IF((X.LT.XMIN.OR.X.GT.XMAX).AND.WARN(2).EQ.0) THEN
47757 CALL HWWARN('HWSMRS',4)
47758 WRITE (6,'(2A)') ' WARNING: MRST98 CALLED WITH X',
47759 & ' OUTSIDE ALLOWED RANGE!'
47760 WRITE (6,'(1P,3(A,E9.3))') ' X VALUE=',X,
47761 & ', MINIMUM=',XMIN,', MAXIMUM=',XMAX
47762 WRITE (6,'(A)') ' NO FURTHER WARNINGS WILL BE ISSUED'
47763 WARN(2) = 1
47764 ENDIF
47765C--now the evaluation
47766 XSAVE = X
47767 Q2SAVE = Q2
47768C--first the initialisation
47769 IF(INIT.NE.0) GOTO 10
47770 DO 15 ML=3,1,-1
47771 DO 20 N=1,NXMRS-1
47772 DO 20 M=1,NQMRS
47773 DO 20 I=1,NPMRS
47774c notation: 1=uval 2=val 3=glue 4=usea 5=chm 6=str 7=btm 8=dsea
47775 IF(ML.LE.2) THEN
47776 FMRS(ML,I,N,M) = FMRS(ML,I,N,M)/(1.0D0-XXMRS(N))**N0(I)
47777 ELSE
47778 FMRS(ML,I,N,M) = 0.5D0*(FMRS(1,I,N,M)+FMRS(2,I,N,M))/
47779 & (1.0D0-XXMRS(N))**N0(I)
47780 ENDIF
47781 20 CONTINUE
47782 DO 31 J=1,NTENTH-1
47783 DO 31 I=1,8
47784 IF(I.EQ.5.OR.I.EQ.7) GOTO 31
47785 DO 30 K=1,NQMRS
47786 30 FMRS(ML,I,J,K)=DLOG10(FMRS(ML,I,J,K)/FMRS(ML,I,NTENTH,K))
47787 & +FMRS(ML,I,NTENTH,K)
47788 31 CONTINUE
47789 DO 40 I=1,NPMRS
47790 DO 40 M=1,NQMRS
47791 40 FMRS(ML,I,NXMRS,M)=0.0D0
47792 15 CONTINUE
47793 DO 32 J=1,NTENTH-1
47794 32 XXMRS(J)=DLOG10(XXMRS(J)/XXMRS(NTENTH))+XXMRS(NTENTH)
47795 INIT=1
47796 10 CONTINUE
47797C--check x and q within range of set
47798 IF(X.LT.XMIN) X=XMIN
47799 IF(X.GT.XMAX) X=XMAX
47800 IF(Q2.LT.QSQMIN) Q2=QSQMIN
47801 IF(Q2.GT.QSQMAX) Q2=QSQMAX
47802C--find X and Q
47803 XXX=X
47804 IF(X.LT.XXMRS(NTENTH)) XXX=DLOG10(X/XXMRS(NTENTH))+XXMRS(NTENTH)
47805 N = 0
47806 70 N=N+1
47807 IF(XXX.GT.XXMRS(N+1)) GOTO 70
47808 A=(XXX-XXMRS(N))/(XXMRS(N+1)-XXMRS(N))
47809 M=0
47810 80 M=M+1
47811 IF(Q2.GT.QQ(M+1)) GOTO 80
47812 B=(Q2-QQ(M))/(QQ(M+1)-QQ(M))
47813 DO 60 I=1,NPMRS
47814 G(I)= (1.0D0-A)*(1.0D0-B)*FMRS(MODE,I,N ,M )
47815 & +(1.0D0-A)* B *FMRS(MODE,I,N ,M+1)
47816 & + A *(1.0D0-B)*FMRS(MODE,I,N+1,M )
47817 & + A * B *FMRS(MODE,I,N+1,M+1)
47818 IF(N.GE.NTENTH) GOTO 65
47819 IF(I.EQ.5.OR.I.EQ.7) GOTO 65
47820 FAC = (1.0D0-B)*FMRS(MODE,I,NTENTH,M)+B*FMRS(MODE,I,NTENTH,M+1)
47821 G(I) = FAC*10.0d0**(G(I)-FAC)
47822 65 continue
47823 G(I)=G(I)*(1.0d0-X)**N0(I)
47824 60 continue
47825 UPV = G(1)
47826 DNV = G(2)
47827 USEA = G(4)
47828 DSEA = G(8)
47829 STR = G(6)
47830 CHM = G(5)
47831 GLU = G(3)
47832 BOT = G(7)
47833 X = XSAVE
47834 Q2 = Q2SAVE
47835 END
47836CDECK ID>, HWSSPC.
47837*CMZ :- -26/04/91 11.11.56 by Bryan Webber
47838*-- Author : Bryan Webber
47839C-----------------------------------------------------------------------
47840 SUBROUTINE HWSSPC
47841C-----------------------------------------------------------------------
47842C REPLACES SPACELIKE PARTONS BY SPECTATORS
47843C-----------------------------------------------------------------------
c63d70bc 47844 INCLUDE 'herwig65.inc'
65767955 47845 DOUBLE PRECISION HWUSQR,EMSQ,EMTR,EPAR,XPAR,QSQ,PCL(5)
47846 INTEGER KHEP,IP,JP,IDH,IDP,ISP,IDSPC,JHEP
47847 EXTERNAL HWUSQR
47848 IF (IERROR.NE.0) RETURN
47849 DO 50 KHEP=1,NHEP
47850 IF (ISTHEP(KHEP).EQ.145.OR.ISTHEP(KHEP).EQ.146) THEN
47851 IP=ISTHEP(KHEP)-144
47852 JP=IP
47853 IF (JDAHEP(1,IP).NE.0) JP=JDAHEP(1,IP)
47854 IDH=IDHW(JP)
47855 IDP=IDHW(KHEP)
47856 IF (IDH.NE.IDP) THEN
47857 IF (IDH.EQ.59) THEN
47858C---PHOTON CASE
47859 IF (IDP.LT.7) THEN
47860 IDSPC=IDP+6
47861 ELSEIF (IDP.LT.13) THEN
47862 IDSPC=IDP-6
47863 ELSE
47864 CALL HWWARN('HWSSPC',100)
47865 GOTO 999
47866 ENDIF
47867C---IDENTIFY SPECTATOR
47868C (1) QUARK CASE
47869 ELSEIF (IDP.LE.3) THEN
47870 DO 10 ISP=1,12
47871 10 IF (IDH.EQ.NCLDK(LOCN(IDP,ISP))) GOTO 20
47872 CALL HWWARN('HWSSPC',101)
47873 GOTO 999
47874 20 IF (ISP.LE.3) THEN
47875 IDSPC=ISP+6
47876 ELSEIF (ISP.LE.9) THEN
47877 IDSPC=ISP+105
47878 ELSE
47879 IDSPC=ISP
47880 ENDIF
47881C---(2) ANTIQUARK CASE
47882 ELSEIF (IDP.GT.6.AND.IDP.LE.9) THEN
47883 IDP=IDP-6
47884 DO 30 ISP=1,12
47885 30 IF (IDH.EQ.NCLDK(LOCN(ISP,IDP))) GOTO 40
47886 CALL HWWARN('HWSSPC',103)
47887 GOTO 999
47888 40 IF (ISP.LE.3) THEN
47889 IDSPC=ISP
47890 ELSEIF (ISP.LE.9) THEN
47891 IDSPC=ISP+111
47892 ELSE
47893 IDSPC=ISP-6
47894 ENDIF
47895C---SPECIAL CASE FOR REMNANT HADRON
47896 ELSEIF (IDH.EQ.71.OR.IDH.EQ.72) THEN
47897 IF (IDP.EQ.13) THEN
47898 IDSPC=IDP
47899 ELSE
47900 CALL HWWARN('HWSSPC',106)
47901 GOTO 999
47902 ENDIF
47903 ELSE
47904 CALL HWWARN('HWSSPC',105)
47905 GOTO 999
47906 ENDIF
47907C---REPLACE PARTON BY SPECTATOR
47908 IDHW(KHEP)=IDSPC
47909 IDHEP(KHEP)=IDPDG(IDSPC)
47910 ISTHEP(KHEP)=146+IP
47911 EMSQ=SIGN(PHEP(5,KHEP)**2,PHEP(5,KHEP))
47912 EMTR=EMSQ+PHEP(1,KHEP)**2+PHEP(2,KHEP)**2
47913 EPAR=PHEP(4,KHEP)
47914 CALL HWVDIF(4,PHEP(1,JP),PHEP(1,KHEP),PHEP(1,KHEP))
47915 IF (EPAR**2.LT.10000.*ABS(EMTR)) THEN
47916 CALL HWUMAS(PHEP(1,KHEP))
47917 ELSE
47918C---COMPUTE SPECTATOR MASS ELIMINATING ROUNDING ERRORS
47919 XPAR=EPAR/PHEP(4,JP)
47920 QSQ=SIGN(PHEP(5,JP)**2,PHEP(5,JP))
47921 PHEP(5,KHEP)=HWUSQR((1.-XPAR)*QSQ+EMSQ-EMTR/XPAR
47922 & -((QSQ*XPAR**2-EMTR)/(2*EPAR*XPAR**2))**2*XPAR)
47923 ENDIF
47924C---CHECK FOR UNPHYSICAL SPECTATOR
47925 IF (PHEP(4,KHEP).LT.ZERO) FROST=.TRUE.
47926C---FIND MASS OF CORRESPONDING CLUSTER, IF PARTNER IS IN THE SAME JET
47927 IF (QORQQB(IDHW(KHEP))) THEN
47928 JHEP=JMOHEP(2,KHEP)
47929 ELSEIF (QBORQQ(IDHW(KHEP))) THEN
47930 JHEP=JDAHEP(2,KHEP)
47931 ELSE
47932 JHEP=0
47933 ENDIF
47934 IF (JHEP.GT.0) THEN
47935 CALL HWVSUM(4,PHEP(1,KHEP),PHEP(1,JHEP),PCL)
47936 CALL HWUMAS(PCL)
47937C---IF IT IS NEGATIVE, REJECT
47938 IF (PCL(5).LT.ZERO) FROST=.TRUE.
47939 ENDIF
47940 ENDIF
47941 ENDIF
47942 50 CONTINUE
47943 999 RETURN
47944 END
47945CDECK ID>, HWSSUD.
47946*CMZ :- -26/04/91 11.11.56 by Bryan Webber
47947*-- Author : Bryan Webber
47948C-----------------------------------------------------------------------
47949 FUNCTION HWSSUD(I)
47950C-----------------------------------------------------------------------
c63d70bc 47951 INCLUDE 'herwig65.inc'
65767955 47952 DOUBLE PRECISION HWSSUD,HWSGQQ,DMIN,QSCA,XLAST,DIST(13)
47953 INTEGER I,N0,IS,ID
47954 EXTERNAL HWSGQQ
47955 COMMON/HWTABC/XLAST,N0,IS,ID
47956 SAVE DMIN
47957 DATA DMIN/1.D-15/
47958 QSCA=QEV(N0+I,IS)
47959 CALL HWSFUN(XLAST,QSCA,IDHW(INHAD),NSTRU,DIST,JNHAD)
47960 IF (ID.EQ.13) DIST(ID)=DIST(ID)*HWSGQQ(QSCA)
47961 IF (DIST(ID).LT.DMIN) DIST(ID)=DMIN
47962 HWSSUD=SUD(N0+I,IS)/DIST(ID)
47963 END
47964CDECK ID>, HWSTAB.
47965*CMZ :- -26/04/91 11.11.56 by Bryan Webber
47966*-- Author : Adapted by Bryan Webber
47967C-----------------------------------------------------------------------
47968 FUNCTION HWSTAB(F,AFUN,NN,X,MM)
47969C-----------------------------------------------------------------------
47970C MODIFIED CERN INTERPOLATION ROUTINE DIVDIF
47971C LIKE HWUTAB BUT USES FUNCTION AFUN IN PLACE OF ARRAY A
47972C-----------------------------------------------------------------------
47973 IMPLICIT NONE
47974 INTEGER NN,MM,MMAX,N,M,MPLUS,IX,IY,MID,NPTS,IP,I,J,L,ISUB
47975 DOUBLE PRECISION HWSTAB,AFUN,SUM,X,F(NN),T(20),D(20)
47976 LOGICAL EXTRA
47977 EXTERNAL AFUN
47978 SAVE MMAX
47979 DATA MMAX/10/
47980 N=NN
47981 M=MIN(MM,MMAX,N-1)
47982 MPLUS=M+1
47983 IX=0
47984 IY=N+1
47985 IF (AFUN(1).GT.AFUN(N)) GOTO 94
47986 91 MID=(IX+IY)/2
47987 IF (X.GE.AFUN(MID)) GOTO 92
47988 IY=MID
47989 GOTO 93
47990 92 IX=MID
47991 93 IF (IY-IX.GT.1) GOTO 91
47992 GOTO 97
47993 94 MID=(IX+IY)/2
47994 IF (X.LE.AFUN(MID)) GOTO 95
47995 IY=MID
47996 GOTO 96
47997 95 IX=MID
47998 96 IF (IY-IX.GT.1) GOTO 94
47999 97 NPTS=M+2-MOD(M,2)
48000 IP=0
48001 L=0
48002 GOTO 99
48003 98 L=-L
48004 IF (L.GE.0) L=L+1
48005 99 ISUB=IX+L
48006 IF ((1.LE.ISUB).AND.(ISUB.LE.N)) GOTO 100
48007 NPTS=MPLUS
48008 GOTO 101
48009 100 IP=IP+1
48010 T(IP)=AFUN(ISUB)
48011 D(IP)=F(ISUB)
48012 101 IF (IP.LT.NPTS) GOTO 98
48013 EXTRA=NPTS.NE.MPLUS
48014 DO 14 L=1,M
48015 IF (.NOT.EXTRA) GOTO 12
48016 ISUB=MPLUS-L
48017 D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB))
48018 12 I=MPLUS
48019 DO 13 J=L,M
48020 ISUB=I-L
48021 D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB))
48022 I=I-1
48023 13 CONTINUE
48024 14 CONTINUE
48025 SUM=D(MPLUS)
48026 IF (EXTRA) SUM=0.5*(SUM+D(M+2))
48027 J=M
48028 DO 15 L=1,M
48029 SUM=D(J)+(X-T(J))*SUM
48030 J=J-1
48031 15 CONTINUE
48032 HWSTAB=SUM
48033 END
48034CDECK ID>, HWSVAL.
48035*CMZ :- -26/04/91 10.18.58 by Bryan Webber
48036*-- Author : Bryan Webber
48037C-----------------------------------------------------------------------
48038 FUNCTION HWSVAL(ID)
48039C-----------------------------------------------------------------------
48040C TRUE FOR VALENCE PARTON ID IN INCOMING HADRON INHAD
48041C-----------------------------------------------------------------------
c63d70bc 48042 INCLUDE 'herwig65.inc'
65767955 48043 INTEGER ID,IDHAD
48044 LOGICAL HWSVAL
48045 HWSVAL=.FALSE.
48046 IDHAD=IDHW(INHAD)
48047 IF (IDHAD.EQ.73.OR.IDHAD.EQ.75) THEN
48048 IF (ID.EQ.1.OR.ID.EQ.2) HWSVAL=.TRUE.
48049 ELSEIF (IDHAD.EQ.91.OR.IDHAD.EQ.93) THEN
48050 IF (ID.EQ.7.OR.ID.EQ.8) HWSVAL=.TRUE.
48051 ELSEIF (IDHAD.EQ.30) THEN
48052 IF (ID.EQ.1.OR.ID.EQ.8) HWSVAL=.TRUE.
48053 ELSEIF (IDHAD.EQ.38) THEN
48054 IF (ID.EQ.2.OR.ID.EQ.7) HWSVAL=.TRUE.
48055 ELSEIF (IDHAD.EQ.59) THEN
48056 IF (ID.LT.6.OR.(ID.GT.6.AND.ID.LT.12)) HWSVAL=.TRUE.
48057 ELSEIF (IDHAD.EQ.71.OR.IDHAD.EQ.72) THEN
48058 IF (ID.EQ.13) HWSVAL=.TRUE.
48059 ELSE
48060 CALL HWWARN('HWSVAL',100)
48061 ENDIF
48062 END
48063CDECK ID>, HWUAEM.
48064*CMZ :- -23/08/94 13.22.29 by Mike Seymour
48065*-- Author : Ian Knowles
48066C-----------------------------------------------------------------------
48067 FUNCTION HWUAEM(Q2)
48068C-----------------------------------------------------------------------
48069C Running electromagnetic coupling constant.
48070C See R. Kleiss et al.: CERN yellow report 89-08, vol.3 p.129
48071C Hadronic component from: H. Burkhardt et al.: Z. Phys C43 (89) 497
48072C-----------------------------------------------------------------------
c63d70bc 48073 INCLUDE 'herwig65.inc'
65767955 48074 DOUBLE PRECISION HWUAEM,HWUAER,Q2,EPS,A1,B1,C1,A2,B2,C2,A3,B3,C3,
48075 & A4,B4,C4,AEMPI,EEL2,EMU2,ETAU2,ETOP2,REPIGG,X
48076 LOGICAL FIRST
48077 EXTERNAL HWUAER
48078 SAVE FIRST,AEMPI,EEL2,EMU2,ETAU2,ETOP2
48079 PARAMETER (EPS=1.D-6)
48080 SAVE A1,B1,C1,A2,B2,C2,A3,B3,C3,A4,B4,C4
48081 DATA A1,B1,C1/0.0 D0,0.00835D0,1.000D0/
48082 DATA A2,B2,C2/0.0 D0,0.00238D0,3.927D0/
48083 DATA A3,B3,C3/0.00165D0,0.00299D0,1.000D0/
48084 DATA A4,B4,C4/0.00221D0,0.00293D0,1.000D0/
48085 DATA FIRST/.TRUE./
48086 IF (FIRST) THEN
48087 AEMPI=ALPHEM/(THREE*PIFAC)
48088 EEL2 =RMASS(121)**2
48089 EMU2 =RMASS(123)**2
48090 ETAU2=RMASS(125)**2
48091 ETOP2=RMASS(6)**2
48092 FIRST=.FALSE.
48093 ENDIF
48094 IF (ABS(Q2).LT.EPS) THEN
48095 HWUAEM=ALPHEM
48096 RETURN
48097 ENDIF
48098C Leptonic component
48099 REPIGG=AEMPI*(HWUAER(EEL2/Q2)+HWUAER(EMU2/Q2)+HWUAER(ETAU2/Q2))
48100C Hadronic component from light quarks
48101 X=ABS(Q2)
48102 IF (X.LT.9.D-2) THEN
48103 REPIGG=REPIGG+A1+B1*LOG(ONE+C1*X)
48104 ELSEIF (X.LT.9.D0) THEN
48105 REPIGG=REPIGG+A2+B2*LOG(ONE+C2*X)
48106 ELSEIF (X.LT.1.D4) THEN
48107 REPIGG=REPIGG+A3+B3*LOG(ONE+C3*X)
48108 ELSE
48109 REPIGG=REPIGG+A4+B4*LOG(ONE+C4*X)
48110 ENDIF
48111C Top Contribution
48112 REPIGG=REPIGG+AEMPI*HWUAER(ETOP2/Q2)
48113 HWUAEM=ALPHEM/(ONE-REPIGG)
48114 END
48115CDECK ID>, HWUAER.
48116*CMZ :- -23/08/94 13.22.29 by Mike Seymour
48117*-- Author : Ian Knowles
48118C-----------------------------------------------------------------------
48119 FUNCTION HWUAER(R)
48120C-----------------------------------------------------------------------
48121C Real part of photon self-energy: Pi_{gg}(R=M^2/Q^2)
48122C-----------------------------------------------------------------------
48123 IMPLICIT NONE
48124 DOUBLE PRECISION HWUAER,R,ZERO,ONE,TWO,FOUR,FVTHR,THIRD,RMAX,BETA
48125 PARAMETER (ZERO=0.D0, ONE=1.D0, TWO=2.D0, FOUR=4.D0,
48126 & FVTHR=1.666666666666667D0, THIRD=.3333333333333333D0)
48127 PARAMETER (RMAX=1.D6)
48128 IF (ABS(R).LT.1.D-3) THEN
48129C Use assymptotic formula
48130 HWUAER=-FVTHR-LOG(ABS(R))
48131 ELSEIF (ABS(R).GT.RMAX) THEN
48132 HWUAER=ZERO
48133 ELSEIF (FOUR*R.GT.ONE) THEN
48134 BETA=SQRT(FOUR*R-ONE)
48135 HWUAER=THIRD
48136 & -(ONE+TWO*R)*(TWO-BETA*ACOS(ONE-ONE/(TWO*R)))
48137 ELSE
48138 BETA=SQRT(ONE-FOUR*R)
48139 HWUAER=THIRD
48140 & -(ONE+TWO*R)*(TWO+BETA*LOG(ABS((BETA-ONE)/(BETA+ONE))))
48141 ENDIF
48142 END
48143CDECK ID>, HWUALF.
48144*CMZ :- -15/07/92 14.08.45 by Mike Seymour
48145*-- Author : Bryan Webber
48146C-----------------------------------------------------------------------
48147 FUNCTION HWUALF(IOPT,SCALE)
48148C-----------------------------------------------------------------------
48149C STRONG COUPLING CONSTANT
48150C IOPT.EQ.0 INITIALIZES
48151C .EQ.1 TWO-LOOP, FLAVOUR THRESHOLDS
48152C .EQ.2 RATIO OF ABOVE TO ONE-LOOP
48153C WITH 5-FLAVOUR BETA, LAMBDA=QCDL3
48154C .EQ.3 ONE-LOOP WITH 5-FLAVOUR BETA, LAMBDA=QCDL3
48155C-----------------------------------------------------------------------
c63d70bc 48156 INCLUDE 'herwig65.inc'
65767955 48157 DOUBLE PRECISION HWUALF,SCALE,KAFAC,B3,B4,B5,B6,C3,C4,C5,C6,C35,
48158 & C45,C65,D35,RHO,RAT,RLF,DRH,EPS
48159 INTEGER IOPT,ITN
48160 SAVE B3,B4,B5,B6,C3,C4,C5,C6,C35,C45,C65,D35
48161 SAVE EPS
48162 DATA EPS/1.D-6/
48163 IF (IOPT.EQ.0) THEN
48164C---INITIALIZE CONSTANTS
48165 CAFAC=FLOAT(NCOLO)
48166 CFFAC=FLOAT(NCOLO**2-1)/(2.*CAFAC)
48167 B3=((11.*CAFAC)- 6.)/(12.*PIFAC)
48168 B4=((11.*CAFAC)- 8.)/(12.*PIFAC)
48169 B5=((11.*CAFAC)-10.)/(12.*PIFAC)
48170 B6=((11.*CAFAC)-12.)/(12.*PIFAC)
48171 BETAF=6.*PIFAC*B5
48172 C3=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*3.)/(24.*PIFAC**2)/B3**2
48173 C4=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*4.)/(24.*PIFAC**2)/B4**2
48174 C5=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*5.)/(24.*PIFAC**2)/B5**2
48175 C6=((17.*CAFAC**2)-(5.*CAFAC+3.*CFFAC)*6.)/(24.*PIFAC**2)/B6**2
48176 KAFAC=CAFAC*(67./18.-PIFAC**2/6.)-25./9.
48177C---QCDLAM IS 5-FLAVOUR LAMBDA-MS-BAR AT LARGE X OR Z
48178C---QCDL5 IS 5-FLAVOUR LAMBDA-MC
48179 QCDL5=QCDLAM*EXP(KAFAC/(4.*PIFAC*B5))/SQRT(2.D0)
48180C---COMPUTE THRESHOLD MATCHING
48181 RHO=2.*LOG(RMASS(6)/QCDL5)
48182 RAT=LOG(RHO)/RHO
48183 C65=(B5/(1.-C5*RAT)-B6/(1.-C6*RAT))*RHO
48184 RHO=2.*LOG(RMASS(5)/QCDL5)
48185 RAT=LOG(RHO)/RHO
48186 C45=(B5/(1.-C5*RAT)-B4/(1.-C4*RAT))*RHO
48187 RHO=2.*LOG(RMASS(4)/QCDL5)
48188 RAT=LOG(RHO)/RHO
48189 C35=(B4/(1.-C4*RAT)-B3/(1.-C3*RAT))*RHO+C45
48190C---FIND QCDL3
48191 D35=-1./(B3*C35)
48192 DO 10 ITN=1,100
48193 RAT=LOG(D35)/D35
48194 RLF=B3*D35/(1.-C3*RAT)
48195 DRH=B3*(RLF+C35)*D35**2/((1.-2.*C3*RAT+C3/D35)*RLF**2)
48196 D35=D35-DRH
48197 IF (ABS(DRH).LT.EPS*D35) GOTO 20
48198 10 CONTINUE
48199 20 QCDL3=QCDL5*EXP(0.5*D35)
48200 ENDIF
48201 IF (SCALE.LE.QCDL5) THEN
48202 CALL HWWARN('HWUALF',51)
48203 GOTO 999
48204 ENDIF
48205 RHO=2.*LOG(SCALE/QCDL5)
48206 IF (IOPT.EQ.3) THEN
48207 IF (RHO.LE.D35) THEN
48208 CALL HWWARN('HWUALF',52)
48209 GOTO 999
48210 ENDIF
48211 HWUALF=1./(B5*(RHO-D35))
48212 RETURN
48213 ENDIF
48214 RAT=LOG(RHO)/RHO
48215 IF (SCALE.GT.RMASS(6)) THEN
48216 RLF=B6*RHO/(1.-C6*RAT)+C65
48217 ELSEIF (SCALE.GT.RMASS(5)) THEN
48218 RLF=B5*RHO/(1.-C5*RAT)
48219 ELSEIF (SCALE.GT.RMASS(4)) THEN
48220 RLF=B4*RHO/(1.-C4*RAT)+C45
48221 ELSE
48222 RLF=B3*RHO/(1.-C3*RAT)+C35
48223 ENDIF
48224 IF (RLF.LE.ZERO) THEN
48225 CALL HWWARN('HWUALF',53)
48226 GOTO 999
48227 ENDIF
48228 IF (IOPT.EQ.1) THEN
48229 HWUALF=1./RLF
48230 ELSE
48231 HWUALF=B5*(RHO-D35)/RLF
48232 IF (HWUALF.GT.ONE) THEN
48233 CALL HWWARN('HWUALF',54)
48234 GOTO 999
48235 ENDIF
48236 ENDIF
48237 RETURN
48238 999 HWUALF=ZERO
48239 END
48240CDECK ID>, HWUANT.
48241*CMZ :- -27/07/99 13.33.03 by Mike Seymour
48242*-- Author : Ian Knowles
48243C-----------------------------------------------------------------------
48244 FUNCTION HWUANT(IPART)
48245C-----------------------------------------------------------------------
48246C Returns the antiparticle of IPART; uses HERWIG numbering
48247C-----------------------------------------------------------------------
c63d70bc 48248 INCLUDE 'herwig65.inc'
65767955 48249 INTEGER HWUANT,IPART,IPDG,IANTI,OLDERR
48250 CHARACTER*8 CDUM
48251 OLDERR=IERROR
48252 IPDG=IDPDG(IPART)
48253 IF (IPDG.EQ. 9.OR.IPDG.EQ.21.OR.IPDG.EQ.22.OR.IPDG.EQ.23.OR.
48254 & IPDG.EQ.25.OR.IPDG.EQ.26.OR.IPDG.EQ.32.OR.IPDG.EQ.35.OR.
48255 & IPDG.EQ.36.OR.IPDG.EQ.39.OR.IPDG.EQ.91.OR.IPDG.EQ.98.OR.
48256 & IPDG.EQ.99.OR.IPDG.EQ.130.OR.IPDG.EQ.310.OR.
48257 & IPDG.EQ.1000021.OR.IPDG.EQ.1000022.OR.IPDG.EQ.1000023.OR.
48258 & IPDG.EQ.1000025.OR.IPDG.EQ.1000035.OR.IPDG.EQ.1000039.OR.
48259 & (FLOAT(INT(RSPIN(IPART))).EQ.RSPIN(IPART).AND.
48260 & MOD(IPDG/100,10).EQ.MOD(IPDG/10,10).AND.
48261 & MOD(IPDG/10,10).NE.0)) THEN
48262C Self-conjugate boson
48263 IANTI=IPART
48264 ELSEIF(IPART.EQ.211.OR.IPART.EQ.212) THEN
48265C Fourth generation (anti-)quarks
48266 IANTI=IPART+6
48267 ELSEIF(IPART.EQ.217.OR.IPART.EQ.218) THEN
48268 IANTI=IPART-6
48269 ELSE
48270C Non-zero charge particle
48271 CALL HWUIDT(1,-IPDG,IANTI,CDUM)
48272 ENDIF
48273 IF (IANTI.EQ.20) WRITE(6,10) RNAME(IPART)
48274 10 FORMAT(1X,A8,' has no antiparticle'/)
48275 HWUANT=IANTI
48276 IERROR=OLDERR
48277 END
48278CDECK ID>, HWUATS.
48279*CMZ :- -07/07/99 17.42.00 by Kosuke Odagiri
48280*-- Author : Kosuke Odagiri
48281C-----------------------------------------------------------------------
48282 SUBROUTINE HWUATS
48283C-----------------------------------------------------------------------
48284C Replaces all &'s in TXNAME by backslashes
48285C-----------------------------------------------------------------------
c63d70bc 48286 INCLUDE 'herwig65.inc'
65767955 48287 INTEGER I,J,L
48288 CHARACTER*1 Z
48289 Z=CHAR(92)
48290 L=LEN(TXNAME(1,1))
48291 DO 1 I=0,NMXRES
48292 DO 2 J=1,L
48293 IF (TXNAME(1,I)(J:J).EQ.'&') TXNAME(1,I)(J:J)=Z
48294 2 CONTINUE
48295 1 CONTINUE
48296 END
48297CDECK ID>, HWUBPR.
48298*CMZ :- -26/04/91 10.18.58 by Bryan Webber
48299*-- Author : Bryan Webber
48300C-----------------------------------------------------------------------
48301 SUBROUTINE HWUBPR
48302C-----------------------------------------------------------------------
48303C PRINTS OUT DATA ON PARTON SHOWER
48304C-----------------------------------------------------------------------
c63d70bc 48305 INCLUDE 'herwig65.inc'
65767955 48306 INTEGER I,J
48307 IF (PRVTX) THEN
48308 WRITE(6,10) INHAD,XFACT
48309 10 FORMAT(///10X,'DATA ON LAST PARTON SHOWER: INHAD =',I3,
48310 & ' XFACT =',E11.3//' IPAR ID TM DA1 CMO AMO CDA',
48311 & ' ADA P-X P-Y P-Z ENERGY MASS',
48312 & ' V-X V-Y V-Z V-C*T')
48313 DO 20 J=1,NPAR
48314 20 WRITE(6,30) J,RNAME(ABS(IDPAR(J))),TMPAR(J),JDAPAR(1,J),
48315 & (JCOPAR(I,J),I=1,4),(PPAR(I,J),I=1,5),(VPAR(I,J),I=1,4)
48316 30 FORMAT(I5,1X,A8,L2,5I4,F7.2,4F8.2,4E11.4)
48317 ELSE
48318 WRITE(6,40) INHAD,XFACT
48319 40 FORMAT(///10X,'DATA ON LAST PARTON SHOWER: INHAD =',I3,
48320 & ' XFACT =',E11.3//' IPAR ID TM DA1 CMO AMO CDA',
48321 & ' ADA P-X P-Y P-Z ENERGY MASS')
48322 DO 50 J=1,NPAR
48323 50 WRITE(6,60) J,RNAME(ABS(IDPAR(J))),TMPAR(J),JDAPAR(1,J),
48324 & (JCOPAR(I,J),I=1,4),(PPAR(I,J),I=1,5)
48325 60 FORMAT(I5,1X,A8,L2,5I4,F7.2,4F8.2)
48326 ENDIF
48327 END
48328CDECK ID>, HWUBST.
48329*CMZ :- -18/10/93 10.21.56 by Mike Seymour
48330*-- Author : Mike Seymour
48331C-----------------------------------------------------------------------
48332 SUBROUTINE HWUBST(IOPT)
48333C-----------------------------------------------------------------------
48334C BOOST THE ENTIRE EVENT RECORD TO (IOPT=1) OR FROM (IOPT=0) ITS
48335C CENTRE-OF-MASS FRAME, WITH INCOMING HADRONS ON Z-AXIS
48336C-----------------------------------------------------------------------
c63d70bc 48337 INCLUDE 'herwig65.inc'
65767955 48338 DOUBLE PRECISION PBOOST(5),RBOOST(3,3)
48339 INTEGER IOPT,IHEP,BOOSTD,IHAD
48340 SAVE BOOSTD,PBOOST,RBOOST
48341 DATA BOOSTD/-1/
48342 IF (IERROR.NE.0) RETURN
48343 IF (IOPT.EQ.1) THEN
48344C---FIND FIRST INCOMING HADRON
48345 IHAD=1
48346 IF (JDAHEP(1,IHAD).NE.0) IHAD=JDAHEP(1,IHAD)
48347C---IF WE'RE ALREADY IN THE RIGHT FRAME, DON'T DO ANYTHING
48348 IF (PHEP(1,3)**2+PHEP(2,3)**2+PHEP(3,3)**2.EQ.ZERO .AND.
48349 & PHEP(1,IHAD)**2+PHEP(2,IHAD)**2.EQ.ZERO) RETURN
48350C---FIND AND APPLY BOOST
48351 CALL HWVEQU(5,PHEP(1,3),PBOOST)
48352 DO 100 IHEP=1,NHEP
48353 CALL HWULOF(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
48354 CALL HWULOF(PBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
48355 100 CONTINUE
48356 CALL HWULOF(PBOOST,VTXPIP,VTXPIP)
48357C---FIND AND APPLY ROTATION TO PUT IT ON Z-AXIS
48358 CALL HWUROT(PHEP(1,IHAD),ONE,ZERO,RBOOST)
48359 DO 110 IHEP=1,NHEP
48360 CALL HWUROF(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
48361 CALL HWUROF(RBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
48362 110 CONTINUE
48363 CALL HWUROF(RBOOST,VTXPIP,VTXPIP)
48364C---ENSURE THAT WE ONLY EVER UNBOOST THE SAME EVENT THAT WE BOOSTED
48365C (BEARING IN MIND THAT NWGTS IS UPDATED AFTER GENERATING THE WEIGHT)
48366 BOOSTD=NWGTS+1
48367 ELSEIF (IOPT.EQ.0) THEN
48368 IF (BOOSTD.NE.NWGTS) RETURN
48369C---UNDO ROTATION AND BOOST
48370 DO 200 IHEP=1,NHEP
48371 CALL HWUROB(RBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
48372 CALL HWULOB(PBOOST,PHEP(1,IHEP),PHEP(1,IHEP))
48373 CALL HWUROB(RBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
48374 CALL HWULB4(PBOOST,VHEP(1,IHEP),VHEP(1,IHEP))
48375 200 CONTINUE
48376 ENDIF
48377 END
48378CDECK ID>, HWUCFF.
48379*CMZ :- -23/08/94 13.22.29 by Mike Seymour
48380*-- Author : Bryan Webber and Ian Knowles
48381C-----------------------------------------------------------------------
48382 SUBROUTINE HWUCFF(I,J,QSQ,CLF)
48383C-----------------------------------------------------------------------
48384C Calculates basic coefficients in cross-section formula for
48385C ffbar --> f'fbar', at virtuality QSQ, I labels initial, J
48386C labels final fermion; type given as:
48387C I,J= 1- 6: d,u,s,c,b,t
48388C =11-16: e,nu_e,mu,nu_mu,tau,nu_tau
48389C-----------------------------------------------------------------------
c63d70bc 48390 INCLUDE 'herwig65.inc'
65767955 48391 DOUBLE PRECISION QSQ,CLF(7),POL1,POL2,QIF,VI,AI,VF,AF,PG,DQM,PMW,
48392 & DEN,XRE,XIM,XSQ,VI2,AI2,VF2,AF2,PG2,PG12,DQM2,PMW2,DEN2,XRE2,
48393 & XIM2,XSQ2,XRE12,XIM12
48394 INTEGER I,J
48395C Longitudinal Polarisation factors
48396 POL1=1.-EPOLN(3)*PPOLN(3)
48397 POL2=PPOLN(3)-EPOLN(3)
48398C Standard model couplings
48399 QIF=QFCH(I)*QFCH(J)
48400 VI=VFCH(I,1)
48401 AI=AFCH(I,1)
48402 VF=VFCH(J,1)
48403 AF=AFCH(J,1)
48404 PG=POL1*(VI**2+AI**2)+POL2*2.*VI*AI
48405C Z propagator factors
48406 DQM=QSQ-RMASS(200)**2
48407 PMW=GAMZ*RMASS(200)
48408 DEN=QSQ/(DQM**2+PMW**2)
48409 XRE=DEN*DQM
48410 XIM=DEN*PMW
48411 XSQ=DEN*QSQ
48412C Calculate cross-section coefficients
48413 CLF(1)=POL1*QIF**2+XRE*2.*QIF*(POL1*VI+POL2*AI)*VF
48414 & +XSQ*PG*(VF**2+AF**2)
48415 CLF(2)=CLF(1)-2.*XSQ*PG*AF**2
48416 CLF(3)=2.*(XRE*QIF*(POL1*AI+POL2*VI)*AF
48417 & +XSQ*(POL1*2.*VI*AI+POL2*(VI**2+AI**2))*VF*AF)
48418 IF (TPOL) THEN
48419 CLF(4)=QIF**2+XRE*2.*QIF*VI*VF+XSQ*(VI**2-AI**2)*(VF**2+AF**2)
48420 CLF(5)=CLF(4)-2.*XSQ*(VI**2-AI**2)*AF**2
48421 CLF(6)=XIM*2.*QIF*AI*VF
48422 CLF(7)=CLF(6)
48423 ENDIF
48424 IF (ZPRIME) THEN
48425C Z' couplings:
48426 VI2=VFCH(I,2)
48427 AI2=AFCH(I,2)
48428 VF2=VFCH(J,2)
48429 AF2=AFCH(J,2)
48430 PG2=POL1*(VI2**2+AI2**2)+POL2*2.*VI2*AI2
48431 PG12=POL1*(VI*VI2+AI*AI2)+POL2*(VI*AI2+AI+VI2)
48432C Z' propagator factors
48433 DQM2=QSQ-RMASS(202)**2
48434 PMW2=RMASS(202)*GAMZP
48435 DEN2=QSQ/(DQM2**2+PMW2**2)
48436 XRE2=DEN2*DQM2
48437 XIM2=DEN2*PMW2
48438 XSQ2=DEN2*QSQ
48439 XRE12=DEN*DEN2*(DQM*DQM2+PMW*PMW2)
48440 XIM12=DEN*DEN2*(DQM*PMW2-DQM2*PMW)
48441C Additional contributions to cross-section coefficients
48442 CLF(1)=CLF(1)+XRE2*2.*QIF*(POL1*VI2+POL2*AI2)*VF2
48443 & +XSQ2*PG2*(VF2**2+AF2**2)+XRE12*2.*PG12*(VF*VF2+AF*AF2)
48444 CLF(2)=CLF(1)-2.*(XSQ2*PG2*AF2**2+XRE12*2.*PG12*AF*AF2)
48445 CLF(3)=CLF(3)+2.*(XRE2*QIF*(POL1*AI2+POL2*VI2)*AF2
48446 & +XSQ2*(POL1*2.*VI2*AI2+POL2*(VI2**2+AI2**2))*VF2*AF2
48447 & +XRE12*(POL1*(VI*AI2+AI*VI2)+POL1*(VI*VI2+AI*AI2))
48448 & *(VF*VF2+AF*AF2))
48449 IF (TPOL) THEN
48450 CLF(4)=CLF(4)+XRE2*2.*QIF*VI2*VF2
48451 & +XSQ2*(VI2**2-AI2**2)*(VF2**2+AF2**2)
48452 & +XRE12*2.*(VI*VI2-AI*AI2)*(VF*VF2+AF*AF2)
48453 CLF(5)=CLF(4)-2*(XSQ2*(VI2**2-AI2**2)*AF2**2
48454 & +XRE12*2.*(VI*VI2-AI*AI2)*AF*AF2)
48455 CLF(6)=CLF(6)+2.*(XIM2*QIF*AI2*VF2
48456 & -XIM12*(VI*AI2-AI*VI2)*(VF*VF2+AF*AF2))
48457 CLF(7)=CLF(6)+4.*XIM12*(VI*AI2-AI*AI2)*AF*AF2
48458 ENDIF
48459 ENDIF
48460 END
48461CDECK ID>, HWUCI2.
48462*CMZ :- -23/08/94 13.22.29 by Mike Seymour
48463*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
48464C-----------------------------------------------------------------------
48465 FUNCTION HWUCI2(A,B,Y0)
48466C-----------------------------------------------------------------------
48467C Integral LOG(A-EPSI-BY(1-Y))/(Y-Y0)
48468C-----------------------------------------------------------------------
48469 IMPLICIT NONE
48470 DOUBLE COMPLEX HWUCI2,HWULI2,EPSI,Y1,Y2,Z1,Z2,Z3,Z4
48471 DOUBLE PRECISION A,B,Y0,ZERO,ONE,FOUR,HALF
48472 EXTERNAL HWULI2
48473 COMMON/SMALL/EPSI
48474 PARAMETER (ZERO=0.D0, ONE =1.D0, FOUR= 4.D0, HALF=0.5D0)
48475 IF(B.EQ.ZERO)THEN
48476 HWUCI2=DCMPLX(ZERO,ZERO)
48477 ELSE
48478 Y1=HALF*(ONE+SQRT(ONE-FOUR*(A+EPSI)/B))
48479 Y2=ONE-Y1
48480 Z1=Y0/(Y0-Y1)
48481 Z2=(Y0-ONE)/(Y0-Y1)
48482 Z3=Y0/(Y0-Y2)
48483 Z4=(Y0-ONE)/(Y0-Y2)
48484 HWUCI2=HWULI2(Z1)-HWULI2(Z2)+HWULI2(Z3)-HWULI2(Z4)
48485 ENDIF
48486 END
48487CDECK ID>, HWUDAT.
48488*CMZ :- -26/04/91 10.18.58 by Bryan Webber
48489*-- Author : Ian Knowles & Bryan Webber
48490C-----------------------------------------------------------------------
48491 BLOCK DATA HWUDAT
48492C-----------------------------------------------------------------------
48493C Loads common blocks with particle properties data; for particle I:
48494C RNAME(I) = Name
48495C IDPDG(I) = PDG code
48496C IFLAV(I) = HERWIG flavour code
48497C ICHRG(I) = Electric charge (|e-|) (*3 for (di-)quarks)
48498C RMASS(I) = Mass (GeV/c^2)
48499C RLTIM(I) = Proper life time (s)
48500C RSPIN(I) = Spin
48501C QORQQB(I) = .TRUE. if it is a quark or an antidiquark
48502C QBORQQ(I) = .TRUE. if it is an antiquark or a diquark
48503C And stores the particle decay tables: call HWUDPR to print them
48504C-----------------------------------------------------------------------
c63d70bc 48505 INCLUDE 'herwig65.inc'
65767955 48506 COMMON/HWSEED/ISEED(2)
48507 INTEGER ISEED
48508 INTEGER NLAST,NNEXT,NLEFT,NREST,I,J,MMWIDE,MMLONG,MMHOFF,MMVOFF
48509 COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
48510c PARAMETER (NLAST=458,NNEXT=458+1,NLEFT=NMXRES-458)
48511c PARAMETER (NREST=NMXRES-120)
48512c DATA NRES/458/
48513 PARAMETER (NLAST=458,NNEXT=NLAST+1,NLEFT=NMXRES-NLAST)
48514 PARAMETER (NREST=NMXRES-120)
48515 DATA NRES/NLAST/
48516C Don't forget to change the three occurances above as well
48517 DATA MMWIDE,MMLONG,MMHOFF,MMVOFF/190,280,-39,-35/
48518 DATA ISEED/12345,67890/
48519 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48520 & RSPIN(I),I=0,16)/
48521 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48522 & 'DQRK ', 1, 0,-1,0.3200D0,0.000D+00,0.5D0,
48523 & 'UQRK ', 2, 0,+2,0.3200D0,0.000D+00,0.5D0,
48524 & 'SQRK ', 3, 0,-1,0.5000D0,0.000D+00,0.5D0,
48525 & 'CQRK ', 4, 0,+2,1.5500D0,0.000D+00,0.5D0,
48526 & 'BQRK ', 5, 0,-1,4.9500D0,0.000D+00,0.5D0,
48527 & 'TQRK ', 6, 0,+2,174.30D0,4.000D-25,0.5D0,
48528 & 'DBAR ', -1, 0,+1,0.3200D0,0.000D+00,0.5D0,
48529 & 'UBAR ', -2, 0,-2,0.3200D0,0.000D+00,0.5D0,
48530 & 'SBAR ', -3, 0,+1,0.5000D0,0.000D+00,0.5D0,
48531 & 'CBAR ', -4, 0,-2,1.5500D0,0.000D+00,0.5D0,
48532 & 'BBAR ', -5, 0,+1,4.9500D0,0.000D+00,0.5D0,
48533 & 'TBAR ', -6, 0,-2,174.30D0,4.000D-25,0.5D0,
48534 & 'GLUON ', 21, 0, 0,0.7500D0,0.000D+00,1.0D0,
48535 & 'CMF ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48536 & 'HARD ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48537 & 'SOFT ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0/
48538 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48539 & RSPIN(I),I=17,32)/
48540 & 'CONE ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48541 & 'HEAVY ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48542 & 'CLUS ', 91, 0, 0,0.0000D0,0.000D+00,0.0D0,
48543 & '**** ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48544 & 'PI0 ', 111, 11, 0,.13498D0,8.400D-17,0.0D0,
48545 & 'ETA ', 221, 33, 0,.54730D0,0.000D+00,0.0D0,
48546 & 'RHO0 ', 113, 11, 0,.77000D0,0.000D+00,1.0D0,
48547 & 'OMEGA ', 223, 33, 0,.78194D0,0.000D+00,1.0D0,
48548 & 'ETAP ', 331, 33, 0,.95778D0,0.000D+00,0.0D0,
48549 & 'F_2 ', 225, 33, 0,1.2750D0,0.000D+00,2.0D0,
48550 & 'A_10 ', 20113, 11, 0,1.2300D0,0.000D+00,1.0D0,
48551 & 'FL_1 ', 20223, 33, 0,1.2819D0,0.000D+00,1.0D0,
48552 & 'A_20 ', 115, 11, 0,1.3181D0,0.000D+00,2.0D0,
48553 & 'PI- ', -211, 12,-1,.13957D0,2.603D-08,0.0D0,
48554 & 'RHO- ', -213, 12,-1,.77000D0,0.000D+00,1.0D0,
48555 & 'A_1- ', -20213, 12,-1,1.2300D0,0.000D+00,1.0D0/
48556 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48557 & RSPIN(I),I=33,48)/
48558 & 'A_2- ', -215, 12,-1,1.3181D0,0.000D+00,2.0D0,
48559 & 'K- ', -321, 32,-1,.49368D0,1.237D-08,0.0D0,
48560 & 'K*- ', -323, 32,-1,.89166D0,0.000D+00,1.0D0,
48561 & 'KH_1- ', -20323, 32,-1,1.8500D0,0.000D+00,1.0D0,
48562 & 'K*_2- ', -325, 32,-1,1.4256D0,0.000D+00,2.0D0,
48563 & 'PI+ ', 211, 21,+1,.13957D0,2.603D-08,0.0D0,
48564 & 'RHO+ ', 213, 21,+1,.77000D0,0.000D+00,1.0D0,
48565 & 'A_1+ ', 20213, 21,+1,1.2300D0,0.000D+00,1.0D0,
48566 & 'A_2+ ', 215, 21,+1,1.3181D0,0.000D+00,2.0D0,
48567 & 'KBAR0 ', -311, 31, 0,.49767D0,0.000D+00,0.0D0,
48568 & 'K*BAR0 ', -313, 31, 0,.89610D0,0.000D+00,1.0D0,
48569 & 'KH_1BAR0', -20313, 31, 0,1.8500D0,0.000D+00,1.0D0,
48570 & 'K*_2BAR0', -315, 31, 0,1.4324D0,0.000D+00,2.0D0,
48571 & 'K+ ', 321, 23,+1,.49368D0,1.237D-08,0.0D0,
48572 & 'K*+ ', 323, 23,+1,.89166D0,0.000D+00,1.0D0,
48573 & 'KH_1+ ', 20323, 23,+1,1.8500D0,0.000D+00,1.0D0/
48574 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48575 & RSPIN(I),I=49,64)/
48576 & 'K*_2+ ', 325, 23,+1,1.4256D0,0.000D+00,2.0D0,
48577 & 'K0 ', 311, 13, 0,.49767D0,0.000D+00,0.0D0,
48578 & 'K*0 ', 313, 13, 0,.89610D0,0.000D+00,1.0D0,
48579 & 'KH_10 ', 20313, 13, 0,1.8500D0,0.000D+00,1.0D0,
48580 & 'K*_20 ', 315, 13, 0,1.4324D0,0.000D+00,2.0D0,
48581 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48582 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48583 & 'PHI ', 333, 33, 0,1.0194D0,0.000D+00,1.0D0,
48584 & 'FH_1 ', 20333, 33, 0,1.4262D0,0.000D+00,1.0D0,
48585 & 'FP_2 ', 335, 33, 0,1.5250D0,0.000D+00,2.0D0,
48586 & 'GAMMA ', 22, 0, 0,0.0000D0,1.000D+30,1.0D0,
48587 & 'K_S0 ', 310, 0, 0,.49767D0,8.926D-11,0.0D0,
48588 & 'K_L0 ', 130, 0, 0,.49767D0,5.170D-08,0.0D0,
48589 & 'A_0(H)0 ', 10111, 11, 0,1.4740D0,0.000D+00,0.0D0,
48590 & 'A_0(H)+ ', 10211, 21,+1,1.4740D0,0.000D+00,0.0D0,
48591 & 'A_0(H)- ', -10211, 12,-1,1.4740D0,0.000D+00,0.0D0/
48592 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48593 & RSPIN(I),I=65,80)/
48594 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48595 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48596 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48597 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48598 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48599 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48600 & 'REMG ', 98, 0, 0,0.0000D0,0.000D+00,0.0D0,
48601 & 'REMN ', 99, 0, 0,0.0000D0,0.000D+00,0.0D0,
48602 & 'P ', 2212, 122,+1,.93827D0,1.000D+30,0.5D0,
48603 & 'DELTA+ ', 2214, 122,+1,1.2320D0,0.000D+00,1.5D0,
48604 & 'N ', 2112, 112, 0,.93957D0,8.870D+02,0.5D0,
48605 & 'DELTA0 ', 2114, 112, 0,1.2320D0,0.000D+00,1.5D0,
48606 & 'DELTA- ', 1114, 111,-1,1.2320D0,0.000D+00,1.5D0,
48607 & 'LAMBDA ', 3122, 123, 0,1.1157D0,2.632D-10,0.5D0,
48608 & 'SIGMA0 ', 3212, 123, 0,1.1926D0,7.400D-20,0.5D0,
48609 & 'SIGMA*0 ', 3214, 123, 0,1.3837D0,0.000D+00,1.5D0/
48610 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48611 & RSPIN(I),I=81,96)/
48612 & 'SIGMA- ', 3112, 113,-1,1.1974D0,1.479D-10,0.5D0,
48613 & 'SIGMA*- ', 3114, 113,-1,1.3872D0,0.000D+00,1.5D0,
48614 & 'XI- ', 3312, 133,-1,1.3213D0,1.639D-10,0.5D0,
48615 & 'XI*- ', 3314, 133,-1,1.5350D0,0.000D+00,1.5D0,
48616 & 'DELTA++ ', 2224, 222,+2,1.2320D0,0.000D+00,1.5D0,
48617 & 'SIGMA+ ', 3222, 223,+1,1.1894D0,7.990D-11,0.5D0,
48618 & 'SIGMA*+ ', 3224, 223,+1,1.3828D0,0.000D+00,1.5D0,
48619 & 'XI0 ', 3322, 233, 0,1.3149D0,2.900D-10,0.5D0,
48620 & 'XI*0 ', 3324, 233, 0,1.5318D0,0.000D+00,1.5D0,
48621 & 'OMEGA- ', 3334, 333,-1,1.6725D0,8.220D-11,1.5D0,
48622 & 'PBAR ', -2212,-122,-1,.93827D0,1.000D+30,0.5D0,
48623 & 'DELTABR-', -2214,-122,-1,1.2320D0,0.000D+00,1.5D0,
48624 & 'NBAR ', -2112,-112, 0,.93957D0,8.870D+02,0.5D0,
48625 & 'DELTABR0', -2114,-112, 0,1.2320D0,0.000D+00,1.5D0,
48626 & 'DELTABR+', -1114,-111,+1,1.2320D0,0.000D+00,1.5D0,
48627 & 'LAMBDABR', -3122,-123, 0,1.1157D0,2.632D-10,0.5D0/
48628 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48629 & RSPIN(I),I=97,112)/
48630 & 'SIGMABR0', -3212,-123, 0,1.1926D0,7.400D-20,0.5D0,
48631 & 'SGMA*BR0', -3214,-123, 0,1.3837D0,0.000D+00,1.5D0,
48632 & 'SIGMABR+', -3112,-113,+1,1.1974D0,1.479D-10,0.5D0,
48633 & 'SGMA*BR+', -3114,-113,+1,1.3872D0,0.000D+00,1.5D0,
48634 & 'XIBAR+ ', -3312,-133,+1,1.3213D0,1.639D-10,0.5D0,
48635 & 'XI*BAR+ ', -3314,-133,+1,1.5350D0,0.000D+00,1.5D0,
48636 & 'DLTABR--', -2224,-222,-2,1.2320D0,0.000D+00,1.5D0,
48637 & 'SIGMABR-', -3222,-223,-1,1.1894D0,7.990D-11,0.5D0,
48638 & 'SGMA*BR-', -3224,-223,-1,1.3828D0,0.000D+00,1.5D0,
48639 & 'XIBAR0 ', -3322,-233, 0,1.3149D0,2.900D-10,0.5D0,
48640 & 'XI*BAR ', -3324,-233, 0,1.5318D0,0.000D+00,1.5D0,
48641 & 'OMEGABR+', -3334,-333,+1,1.6725D0,8.220D-11,1.5D0,
48642 & 'UU ', 2203, 0,+4,0.6400D0,0.000D+00,0.0D0,
48643 & 'UD ', 2101, 0,+1,0.6400D0,0.000D+00,0.0D0,
48644 & 'DD ', 1103, 0,-2,0.6400D0,0.000D+00,0.0D0,
48645 & 'US ', 3201, 0,+1,0.8200D0,0.000D+00,0.0D0/
48646 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48647 & RSPIN(I),I=113,128)/
48648 & 'DS ', 3101, 0,-2,0.8200D0,0.000D+00,0.0D0,
48649 & 'SS ', 3303, 0,-2,1.0000D0,0.000D+00,0.0D0,
48650 & 'UBARUBAR', -2203, 0,-4,0.6400D0,0.000D+00,0.0D0,
48651 & 'UBARDBAR', -2101, 0,-1,0.6400D0,0.000D+00,0.0D0,
48652 & 'DBARDBAR', -1103, 0,+2,0.6400D0,0.000D+00,0.0D0,
48653 & 'UBARSBAR', -3201, 0,-1,0.8200D0,0.000D+00,0.0D0,
48654 & 'DBARSBAR', -3101, 0,+2,0.8200D0,0.000D+00,0.0D0,
48655 & 'SBARSBAR', -3303, 0,+2,1.0000D0,0.000D+00,0.0D0,
48656 & 'E- ', 11, 0,-1,5.11D-04,1.000D+30,0.5D0,
48657 & 'NU_E ', 12, 0, 0,0.0000D0,1.000D+30,0.5D0,
48658 & 'MU- ', 13, 0,-1,.10566D0,2.197D-06,0.5D0,
48659 & 'NU_MU ', 14, 0, 0,0.0000D0,1.000D+30,0.5D0,
48660 & 'TAU- ', 15, 0,-1,1.7771D0,2.916D-13,0.5D0,
48661 & 'NU_TAU ', 16, 0, 0,0.0000D0,1.000D+30,0.5D0,
48662 & 'E+ ', -11, 0,+1,5.11D-04,1.000D+30,0.5D0,
48663 & 'NU_EBAR ', -12, 0, 0,0.0000D0,1.000D+30,0.5D0/
48664 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48665 & RSPIN(I),I=129,144)/
48666 & 'MU+ ', -13, 0,+1,.10566D0,2.197D-06,0.5D0,
48667 & 'NU_MUBAR', -14, 0, 0,0.0000D0,1.000D+30,0.5D0,
48668 & 'TAU+ ', -15, 0,+1,1.7771D0,2.916D-13,0.5D0,
48669 & 'NU_TAUBR', -16, 0, 0,0.0000D0,1.000D+30,0.5D0,
48670 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48671 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48672 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48673 & 'D+ ', 411, 41,+1,1.8693D0,1.057D-12,0.0D0,
48674 & 'D*+ ', 413, 41,+1,2.0100D0,0.000D+00,1.0D0,
48675 & 'DH_1+ ', 20413, 41,+1,2.4270D0,0.000D+00,1.0D0,
48676 & 'D*_2+ ', 415, 41,+1,2.4590D0,0.000D+00,2.0D0,
48677 & 'D0 ', 421, 42, 0,1.8646D0,4.150D-13,0.0D0,
48678 & 'D*0 ', 423, 42, 0,2.0067D0,0.000D+00,1.0D0,
48679 & 'DH_10 ', 20423, 42, 0,2.4222D0,0.000D+00,1.0D0,
48680 & 'D*_20 ', 425, 42, 0,2.4589D0,0.000D+00,2.0D0,
48681 & 'D_S+ ', 431, 43,+1,1.9685D0,4.670D-13,0.0D0/
48682 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48683 & RSPIN(I),I=145,160)/
48684 & 'D*_S+ ', 433, 43,+1,2.1124D0,0.000D+00,1.0D0,
48685 & 'DH_S1+ ', 20433, 43,+1,2.5354D0,0.000D+00,1.0D0,
48686 & 'D*_S2+ ', 435, 43,+1,2.5735D0,0.000D+00,2.0D0,
48687 & 'SGMA_C++', 4222, 224,+2,2.4528D0,0.000D+00,0.5D0,
48688 & 'SGM*_C++', 4224, 224,+2,2.5194D0,0.000D+00,1.5D0,
48689 & 'LMBDA_C+', 4122, 124,+1,2.2849D0,2.060D-13,0.5D0,
48690 & 'SIGMA_C+', 4212, 124,+1,2.4536D0,0.000D+00,0.5D0,
48691 & 'SGMA*_C+', 4214, 124,+1,2.5185D0,0.000D+00,1.5D0,
48692 & 'SIGMA_C0', 4112, 114, 0,2.4522D0,0.000D+00,0.5D0,
48693 & 'SGMA*_C0', 4114, 114, 0,2.5175D0,0.000D+00,1.5D0,
48694 & 'XI_C+ ', 4232, 234,+1,2.4656D0,3.500D-13,0.5D0,
48695 & 'XIP_C+ ', 4322, 234,+1,2.5750D0,0.000D+00,0.5D0,
48696 & 'XI*_C+ ', 4324, 234,+1,2.6446D0,0.000D+00,1.5D0,
48697 & 'XI_C0 ', 4132, 134, 0,2.4703D0,9.800D-14,0.5D0,
48698 & 'XIP_C0 ', 4312, 134, 0,2.5800D0,0.000D+00,0.5D0,
48699 & 'XI*_C0 ', 4314, 134, 0,2.6438D0,0.000D+00,1.5D0/
48700 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48701 & RSPIN(I),I=161,176)/
48702 & 'OMEGA_C0', 4332, 334, 0,2.7040D0,6.400D-14,0.5D0,
48703 & 'OMGA*_C0', 4334, 334, 0,2.7300D0,0.000D+00,1.5D0,
48704 & 'ETA_C ', 441, 44, 0,2.9798D0,0.000D+00,0.0D0,
48705 & 'JPSI ', 443, 44, 0,3.0969D0,0.000D+00,1.0D0,
48706 & 'CHI_C1 ', 10441, 44, 0,3.4173D0,0.000D+00,0.0D0,
48707 & 'PSI2S ', 100443, 44, 0,3.6860D0,0.000D+00,1.0D0,
48708 & 'PSID ', 30443, 44, 0,3.7699D0,0.000D+00,1.0D0,
48709 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48710 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48711 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48712 & 'D- ', -411, 14,-1,1.8693D0,1.057D-12,0.0D0,
48713 & 'D*- ', -413, 14,-1,2.0100D0,0.000D+00,1.0D0,
48714 & 'DH_1- ', -20413, 14,-1,2.4270D0,0.000D+00,1.0D0,
48715 & 'D*_2- ', -415, 14,-1,2.4590D0,0.000D+00,2.0D0,
48716 & 'DBAR0 ', -421, 24, 0,1.8646D0,4.140D-13,0.0D0,
48717 & 'D*BAR0 ', -423, 24, 0,2.0067D0,0.000D+00,1.0D0/
48718 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48719 & RSPIN(I),I=177,192)/
48720 & 'DH_1BAR0', -20423, 24, 0,2.4222D0,0.000D+00,1.0D0,
48721 & 'D*_2BAR0', -425, 24, 0,2.4589D0,0.000D+00,2.0D0,
48722 & 'D_S- ', -431, 34,-1,1.9685D0,4.670D-13,0.0D0,
48723 & 'D*_S- ', -433, 34,-1,2.1124D0,0.000D+00,1.0D0,
48724 & 'DH_S1- ', -20433, 34,-1,2.5354D0,0.000D+00,1.0D0,
48725 & 'D*_S2- ', -435, 34,-1,2.5735D0,0.000D+00,2.0D0,
48726 & 'SGMA_C--', -4222,-224,-2,2.4528D0,0.000D+00,0.5D0,
48727 & 'SGM*_C--', -4224,-224,-2,2.5194D0,0.000D+00,1.5D0,
48728 & 'LMBDA_C-', -4122,-124,-1,2.2849D0,2.060D-13,0.5D0,
48729 & 'SIGMA_C-', -4212,-124,-1,2.4536D0,0.000D+00,0.5D0,
48730 & 'SGMA*_C-', -4214,-124,-1,2.5185D0,0.000D+00,1.5D0,
48731 & 'SGM_CBR0', -4112,-114, 0,2.4522D0,0.000D+00,0.5D0,
48732 & 'SG*_CBR0', -4114,-114, 0,2.5175D0,0.000D+00,1.5D0,
48733 & 'XI_C- ', -4232,-234,-1,2.4656D0,3.500D-13,0.5D0,
48734 & 'XIP_C- ', -4322,-234,-1,2.5750D0,0.000D+00,0.5D0,
48735 & 'XI*_C- ', -4324,-234,-1,2.6446D0,0.000D+00,1.5D0/
48736 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48737 & RSPIN(I),I=193,208)/
48738 & 'XI_CBAR0', -4132,-134, 0,2.4703D0,9.800D-14,0.5D0,
48739 & 'XIP_CBR0', -4312,-134, 0,2.5800D0,0.000D+00,0.5D0,
48740 & 'XI*_CBR0', -4314,-134, 0,2.6438D0,0.000D+00,1.5D0,
48741 & 'OMG_CBR0', -4332,-334, 0,2.7040D0,6.400D-14,0.5D0,
48742 & 'OM*_CBR0', -4334,-334, 0,2.7300D0,0.000D+00,1.5D0,
48743 & 'W+ ', 24, 0,+1,80.420D0,0.000D+00,1.0D0,
48744 & 'W- ', -24, 0,-1,80.420D0,0.000D+00,1.0D0,
48745 & 'Z0/GAMA*', 23, 0, 0,91.188D0,0.000D+00,1.0D0,
48746 & 'HIGGS ', 25, 0, 0,115.00D0,0.000D+00,0.0D0,
48747 & 'Z0P ', 32, 0, 0,500.00D0,0.000D+00,1.0D0,
48748 & 'HIGGSL0 ', 26, 0, 0,0.0000D0,1.000D+30,0.0D0,
48749 & 'HIGGSH0 ', 35, 0, 0,0.0000D0,1.000D+30,0.0D0,
48750 & 'HIGGSA0 ', 36, 0, 0,0.0000D0,1.000D+30,0.0D0,
48751 & 'HIGGS+ ', 37, 0,+1,0.0000D0,1.000D+30,0.0D0,
48752 & 'HIGGS- ', -37, 0,-1,0.0000D0,1.000D+30,0.0D0,
48753 & 'GRAVITON', 39, 0, 0,0.0000D0,1.000D+30,2.0D0/
48754 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48755 & RSPIN(I),I=209,224)/
48756 & 'VQRK ', 7, 0,-1,200.00D0,0.000D+00,0.5D0,
48757 & 'AQRK ', 8, 0,+2,400.00D0,0.000D+00,0.5D0,
48758 & 'HQRK ', 7, 0,-1,400.00D0,0.000D+00,0.5D0,
48759 & 'HPQK ', 8, 0,+2,600.00D0,0.000D+00,0.5D0,
48760 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48761 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48762 & 'VBAR ', -7, 0,+1,200.00D0,0.000D+00,0.5D0,
48763 & 'ABAR ', -8, 0,-2,400.00D0,0.000D+00,0.5D0,
48764 & 'HBAR ', -7, 0,+1,400.00D0,0.000D+00,0.5D0,
48765 & 'HPBR ', -8, 0,-2,600.00D0,0.000D+00,0.5D0,
48766 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48767 & ' ', 0, 0, 0,0.0000D0,0.000D+00,0.0D0,
48768 & 'B_DBAR0 ', -511, 51, 0,5.2792D0,1.614D-12,0.0D0,
48769 & 'B- ', -521, 52,-1,5.2789D0,1.652D-12,0.0D0,
48770 & 'B_SBAR0 ', -531, 53, 0,5.3693D0,1.540D-12,0.0D0,
48771 & 'SIGMA_B+', 5222, 225,+1,5.8200D0,1.070D-12,0.5D0/
48772 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48773 & RSPIN(I),I=225,240)/
48774 & 'LMBDA_B0', 5122, 125, 0,5.6240D0,1.070D-12,0.5D0,
48775 & 'SIGMA_B-', 5112, 115,-1,5.8200D0,1.070D-12,0.5D0,
48776 & 'XI_B0 ', 5232, 235, 0,5.8000D0,1.070D-12,0.5D0,
48777 & 'XI_B- ', 5132, 135,-1,5.8000D0,1.070D-12,0.5D0,
48778 & 'OMEGA_B-', 5332, 335,-1,6.0400D0,1.070D-12,0.5D0,
48779 & 'B_C- ', -541, 54,-1,6.2500D0,1.000D-12,0.5D0,
48780 & 'UPSLON1S', 553, 55, 0,9.4604D0,0.000D+00,1.0D0,
48781 & 'T_B- ', -651, 56,-1,0.0000D0,0.000D+00,0.0D0,
48782 & 'T+ ', 611, 61,+1,0.0000D0,0.000D+00,0.0D0,
48783 & 'T0 ', 621, 62, 0,0.0000D0,0.000D+00,0.0D0,
48784 & 'T_S+ ', 631, 63,+1,0.0000D0,0.000D+00,0.0D0,
48785 & 'SGMA_T++', 6222, 226,+2,0.0000D0,0.000D+00,0.5D0,
48786 & 'LMBDA_T0', 6122, 126,+1,0.0000D0,0.000D+00,0.5D0,
48787 & 'SIGMA_T0', 6112, 116, 0,0.0000D0,0.000D+00,0.5D0,
48788 & 'XI_T+ ', 6232, 236,+1,0.0000D0,0.000D+00,0.5D0,
48789 & 'XI_T0 ', 6132, 136, 0,0.0000D0,0.000D+00,0.5D0/
48790 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48791 & RSPIN(I),I=241,256)/
48792 & 'OMEGA_T0', 6332, 336, 0,0.0000D0,0.000D+00,0.5D0,
48793 & 'T_C0 ', 641, 64, 0,0.0000D0,0.000D+00,0.0D0,
48794 & 'T_B+ ', 651, 65,+1,0.0000D0,0.000D+00,0.0D0,
48795 & 'TOPONIUM', 663, 66, 0,0.0000D0,0.000D+00,1.0D0,
48796 & 'B_D0 ', 511, 15, 0,5.2792D0,1.614D-12,0.0D0,
48797 & 'B+ ', 521, 25,+1,5.2789D0,1.652D-12,0.0D0,
48798 & 'B_S0 ', 531, 35, 0,5.3693D0,1.540D-12,0.0D0,
48799 & 'SGM_BBR-', -5222,-225,-1,5.8200D0,1.070D-12,0.5D0,
48800 & 'LMD_BBR0', -5122,-125, 0,5.6240D0,1.070D-12,0.5D0,
48801 & 'SGM_BBR+', -5112,-115,+1,5.8200D0,1.070D-12,0.5D0,
48802 & 'XI_BBAR0', -5232,-235, 0,5.8000D0,1.070D-12,0.5D0,
48803 & 'XI_B+ ', -5132,-135,+1,5.8000D0,1.070D-12,0.5D0,
48804 & 'OMG_BBR+', -5332,-335,+1,6.0400D0,1.070D-12,0.5D0,
48805 & 'B_C+ ', 541, 45,+1,6.2500D0,1.000D-12,0.5D0,
48806 & 'T- ', -611, 16,-1,0.0000D0,0.000D+00,0.0D0,
48807 & 'TBAR0 ', -621, 26, 0,0.0000D0,0.000D+00,0.0D0/
48808 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48809 & RSPIN(I),I=257,272)/
48810 & 'T_S- ', -631, 36,-1,0.0000D0,0.000D+00,0.0D0,
48811 & 'SGMA_T--', -6222,-226,-2,0.0000D0,0.000D+00,0.5D0,
48812 & 'LAMDA_T-', -6122,-126,-1,0.0000D0,0.000D+00,0.5D0,
48813 & 'SGM_TBR0', -6112,-116, 0,0.0000D0,0.000D+00,0.5D0,
48814 & 'XI_T- ', -6232,-236,-1,0.0000D0,0.000D+00,0.5D0,
48815 & 'XI_TBAR0', -6132,-136, 0,0.0000D0,0.000D+00,0.5D0,
48816 & 'OMG_TBR0', -6332,-336, 0,0.0000D0,0.000D+00,0.5D0,
48817 & 'T_CBAR0 ', -641, 46, 0,0.0000D0,0.000D+00,0.0D0,
48818 & 'B*BAR0 ', -513, 51, 0,5.3249D0,0.000D+00,1.0D0,
48819 & 'B*- ', -523, 52,-1,5.3249D0,0.000D+00,1.0D0,
48820 & 'B*_SBAR0', -533, 53, 0,5.4163D0,0.000D+00,1.0D0,
48821 & 'BH_1BAR0', -20513, 51, 0,5.7600D0,0.000D+00,1.0D0,
48822 & 'BH_1- ', -20523, 52,-1,5.7600D0,0.000D+00,1.0D0,
48823 & 'BH_S1BR0', -20533, 53, 0,5.8550D0,0.000D+00,1.0D0,
48824 & 'B*_2BAR0', -515, 51, 0,5.7700D0,0.000D+00,2.0D0,
48825 & 'B*_2- ', -525, 52,-1,5.7700D0,0.000D+00,2.0D0/
48826 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48827 & RSPIN(I),I=273,288)/
48828 & 'B*_S2BR0', -535, 53, 0,5.8650D0,0.000D+00,2.0D0,
48829 & 'B*0 ', 513, 15, 0,5.3249D0,0.000D+00,1.0D0,
48830 & 'B*+ ', 523, 25,+1,5.3249D0,0.000D+00,1.0D0,
48831 & 'B*_S0 ', 533, 35, 0,5.4163D0,0.000D+00,1.0D0,
48832 & 'BH_10 ', 20513, 15, 0,5.7600D0,0.000D+00,1.0D0,
48833 & 'BH_1+ ', 20523, 25,+1,5.7600D0,0.000D+00,1.0D0,
48834 & 'BH_S10 ', 20533, 35, 0,5.8550D0,0.000D+00,1.0D0,
48835 & 'B*_20 ', 515, 15, 0,5.7700D0,0.000D+00,2.0D0,
48836 & 'B*_2+ ', 525, 25,+1,5.7700D0,0.000D+00,2.0D0,
48837 & 'B*_S20 ', 535, 35, 0,5.8650D0,0.000D+00,2.0D0,
48838 & ' ', 0, 0, 0,0.0000D0,0.000D+00, 0D0,
48839 & ' ', 0, 0, 0,0.0000D0,0.000D+00, 0D0,
48840 & 'B_10 ', 10113, 11, 0,1.2295D0,0.000D+00,1.0D0,
48841 & 'B_1+ ', 10213, 21,+1,1.2295D0,0.000D+00,1.0D0,
48842 & 'B_1- ', -10213, 12,-1,1.2295D0,0.000D+00,1.0D0,
48843 & 'HL_10 ', 10223, 33, 0,1.1700D0,0.000D+00,1.0D0/
48844 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48845 & RSPIN(I),I=289,304)/
48846 & 'HH_10 ', 10333, 33, 0,1.3950D0,0.000D+00,1.0D0,
48847 & 'A_00 ', 9000111, 11, 0,.99600D0,0.000D+00,0.0D0,
48848 & 'A_0+ ', 9000211, 21,+1,.99600D0,0.000D+00,0.0D0,
48849 & 'A_0- ',-9000211, 12,-1,.99600D0,0.000D+00,0.0D0,
48850 & 'F0P0 ', 9010221, 33, 0,.99600D0,0.000D+00,0.0D0,
48851 & 'FH_00 ', 10221, 33, 0,1.3500D0,0.000D+00,0.0D0,
48852 & 'B*_C+ ', 543, 45,+1,6.2950D0,0.000D+00,1.0D0,
48853 & 'B*_C- ', -543, 54,-1,6.2950D0,0.000D+00,1.0D0,
48854 & 'BH_C1+ ', 20543, 45,+1,6.7300D0,0.000D+00,1.0D0,
48855 & 'BH_C1- ', -20543, 54,-1,6.7300D0,0.000D+00,1.0D0,
48856 & 'B*_C2+ ', 545, 45,+1,6.7400D0,0.000D+00,2.0D0,
48857 & 'B*_C2- ', -545, 54,-1,6.7400D0,0.000D+00,2.0D0,
48858 & 'H_C ', 10443, 44, 0,3.5261D0,0.000D+00,1.0D0,
48859 & 'CHI_C0 ', 20443, 44, 0,3.5105D0,0.000D+00,0.0D0,
48860 & 'CHI_C2 ', 445, 44, 0,3.5562D0,0.000D+00,2.0D0,
48861 & 'ETA_B ', 551, 55, 0,9.0000D0,0.000D+00,0.0D0/
48862 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48863 & RSPIN(I),I=305,320)/
48864 & 'H_B ', 10553, 55, 0,9.8880D0,0.000D+00,1.0D0,
48865 & 'CHI_B0 ', 10551, 55, 0,9.8598D0,0.000D+00,0.0D0,
48866 & 'CHI_B1 ', 20553, 55, 0,9.8919D0,0.000D+00,1.0D0,
48867 & 'CHI_B2 ', 555, 55, 0,9.9132D0,0.000D+00,2.0D0,
48868 & 'KL_10 ', 10313, 13, 0,1.5700D0,0.000D+00,1.0D0,
48869 & 'KL_1+ ', 10323, 23,+1,1.5700D0,0.000D+00,1.0D0,
48870 & 'KL_1BAR0', -10313, 31, 0,1.5700D0,0.000D+00,1.0D0,
48871 & 'KL_1- ', -10323, 32,-1,1.5700D0,0.000D+00,1.0D0,
48872 & 'DL_1+ ', 10413, 41,+1,2.4270D0,0.000D+00,1.0D0,
48873 & 'DL_10 ', 10423, 42, 0,2.4222D0,0.000D+00,1.0D0,
48874 & 'DL_S1+ ', 10433, 43,+1,2.5354D0,0.000D+00,1.0D0,
48875 & 'DL_1- ', -10413, 14,-1,2.4270D0,0.000D+00,1.0D0,
48876 & 'DL_1BAR0', -10423, 24, 0,2.4222D0,0.000D+00,1.0D0,
48877 & 'DL_S1- ', -10433, 34,-1,2.5354D0,0.000D+00,1.0D0,
48878 & 'BL_10 ', 10513, 15, 0,5.7600D0,0.000D+00,1.0D0,
48879 & 'BL_1+ ', 10523, 25,+1,5.7600D0,0.000D+00,1.0D0/
48880 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48881 & RSPIN(I),I=321,336)/
48882 & 'BL_S10 ', 10533, 35, 0,5.8530D0,0.000D+00,1.0D0,
48883 & 'BL_C1+ ', 10543, 45,+1,6.7300D0,0.000D+00,1.0D0,
48884 & 'BL_1BAR0', -10513, 51, 0,5.7600D0,0.000D+00,1.0D0,
48885 & 'BL_1- ', -10523, 52,-1,5.7600D0,0.000D+00,1.0D0,
48886 & 'BL_S1BR0', -10533, 53, 0,5.8530D0,0.000D+00,1.0D0,
48887 & 'BL_C1- ', -10543, 54,-1,6.7300D0,0.000D+00,1.0D0,
48888 & 'K*_0+ ', 10321, 23,+1,1.4290D0,0.000D+00,0.0D0,
48889 & 'K*_00 ', 10311, 13, 0,1.4290D0,0.000D+00,0.0D0,
48890 & 'K*_0BAR0', -10311, 31, 0,1.4290D0,0.000D+00,0.0D0,
48891 & 'K*_0- ', -10321, 32,-1,1.4290D0,0.000D+00,0.0D0,
48892 & 'D*_0+ ', 10411, 41,+1,2.4230D0,0.000D+00,0.0D0,
48893 & 'D*_00 ', 10421, 42, 0,2.4230D0,0.000D+00,0.0D0,
48894 & 'D*_S0+ ', 10431, 43,+1,2.5250D0,0.000D+00,0.0D0,
48895 & 'D*_0- ', -10411, 14,-1,2.4230D0,0.000D+00,0.0D0,
48896 & 'D*_0BAR0', -10421, 24, 0,2.4230D0,0.000D+00,0.0D0,
48897 & 'D*_S0- ', -10431, 34,-1,2.5250D0,0.000D+00,0.0D0/
48898 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48899 & RSPIN(I),I=337,352)/
48900 & 'B*_00 ', 10511, 15, 0,5.7600D0,0.000D+00,0.0D0,
48901 & 'B*_0+ ', 10521, 25,+1,5.7600D0,0.000D+00,0.0D0,
48902 & 'B*_S00 ', 10531, 35, 0,5.8550D0,0.000D+00,0.0D0,
48903 & 'B*_C0+ ', 10541, 45,+1,6.7300D0,0.000D+00,0.0D0,
48904 & 'B*_0BAR0', -10511, 51, 0,5.7600D0,0.000D+00,0.0D0,
48905 & 'B*_0- ', -10521, 52,-1,5.7600D0,0.000D+00,0.0D0,
48906 & 'B*_S0BR0', -10531, 53, 0,5.8550D0,0.000D+00,0.0D0,
48907 & 'B*_C0- ', -10541, 54,-1,6.7300D0,0.000D+00,0.0D0,
48908 & 'SGMA*_B-', 5114, 115,-1,5.8400D0,0.000D+00,1.5D0,
48909 & 'SIGMA_B0', 5212, 125, 0,5.8200D0,0.000D+00,0.5D0,
48910 & 'SGMA*_B0', 5214, 125, 0,5.8400D0,0.000D+00,1.5D0,
48911 & 'SGMA*_B+', 5224, 225,+1,5.8400D0,0.000D+00,1.5D0,
48912 & 'XIP_B0 ', 5322, 235, 0,5.9450D0,0.000D+00,0.5D0,
48913 & 'XI*_B0 ', 5324, 235, 0,5.9450D0,0.000D+00,1.5D0,
48914 & 'XIP_B- ', 5312, 135,-1,5.9450D0,0.000D+00,0.5D0,
48915 & 'XI*_B- ', 5314, 135,-1,5.9450D0,0.000D+00,1.5D0/
48916 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48917 & RSPIN(I),I=353,368)/
48918 & '0MGA*_B-', 5334, 335,-1,6.0600D0,0.000D+00,1.5D0,
48919 & 'SG*_BBR+', -5114,-115,+1,5.8400D0,0.000D+00,1.5D0,
48920 & 'SGM_BBR0', -5212,-125, 0,5.8200D0,0.000D+00,0.5D0,
48921 & 'SG*_BBR0', -5214,-125, 0,5.8400D0,0.000D+00,1.5D0,
48922 & 'SG*_BBR-', -5224,-225,-1,5.8400D0,0.000D+00,1.5D0,
48923 & 'XIP_BBR0', -5322,-235, 0,5.9450D0,0.000D+00,0.5D0,
48924 & 'XI*_BBR0', -5324,-235, 0,5.9450D0,0.000D+00,1.5D0,
48925 & 'XIP_B+ ', -5312,-135,+1,5.9450D0,0.000D+00,0.5D0,
48926 & 'XI*_B+ ', -5314,-135,+1,5.9450D0,0.000D+00,1.5D0,
48927 & '0MGA*_B+', -5334,-335,+1,6.0600D0,0.000D+00,1.5D0,
48928 & 'KDL_2+ ', 10325, 23,+1,1.7730D0,0.000D+00,2.0D0,
48929 & 'KDL_20 ', 10315, 13, 0,1.7730D0,0.000D+00,2.0D0,
48930 & 'KDL_2BR0', -10315, 31, 0,1.7730D0,0.000D+00,2.0D0,
48931 & 'KDL_2- ', -10325, 32,-1,1.7730D0,0.000D+00,2.0D0,
48932 & 'KD*+ ', 30323, 23,+1,1.7170D0,0.000D+00,1.0D0,
48933 & 'KD*0 ', 30313, 13, 0,1.7170D0,0.000D+00,1.0D0/
48934 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48935 & RSPIN(I),I=369,384)/
48936 & 'KD*BAR0 ', -30313, 31, 0,1.7170D0,0.000D+00,1.0D0,
48937 & 'KD*- ', -30323, 32,-1,1.7170D0,0.000D+00,1.0D0,
48938 & 'KDH_2+ ', 20325, 23,+1,1.8160D0,0.000D+00,2.0D0,
48939 & 'KDH_20 ', 20315, 13, 0,1.8160D0,0.000D+00,2.0D0,
48940 & 'KDH_2BR0', -20315, 31, 0,1.8160D0,0.000D+00,2.0D0,
48941 & 'KDH_2- ', -20325, 32,-1,1.8160D0,0.000D+00,2.0D0,
48942 & 'KD_3+ ', 327, 23,+1,1.7730D0,0.000D+00,3.0D0,
48943 & 'KD_30 ', 317, 13, 0,1.7730D0,0.000D+00,3.0D0,
48944 & 'KD_3BAR0', -317, 31, 0,1.7730D0,0.000D+00,3.0D0,
48945 & 'KD_3- ', -327, 32,-1,1.7730D0,0.000D+00,3.0D0,
48946 & 'PI_2+ ', 10215, 21,+1,1.6700D0,0.000D+00,2.0D0,
48947 & 'PI_20 ', 10115, 11, 0,1.6700D0,0.000D+00,2.0D0,
48948 & 'PI_2- ', -10215, 12,-1,1.6700D0,0.000D+00,2.0D0,
48949 & 'RHOD+ ', 30213, 21,+1,1.7000D0,0.000D+00,1.0D0,
48950 & 'RHOD0 ', 30113, 11, 0,1.7000D0,0.000D+00,1.0D0,
48951 & 'RHOD- ', -30213, 12,-1,1.7000D0,0.000D+00,1.0D0/
48952 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48953 & RSPIN(I),I=385,400)/
48954 & 'RHO_3+ ', 217, 21,+1,1.6910D0,0.000D+00,3.0D0,
48955 & 'RHO_30 ', 117, 11, 0,1.6910D0,0.000D+00,3.0D0,
48956 & 'RHO_3- ', -217, 12,-1,1.6910D0,0.000D+00,3.0D0,
48957 & 'UPSLON2S', 100553, 55, 0,10.023D0,0.000D+00,1.0D0,
48958 & 'CHI2P_B0', 110551, 55, 0,10.232D0,0.000D+00,0.0D0,
48959 & 'CHI2P_B1', 120553, 55, 0,10.255D0,0.000D+00,1.0D0,
48960 & 'CHI2P_B2', 100555, 55, 0,10.269D0,0.000D+00,2.0D0,
48961 & 'UPSLON3S', 200553, 55, 0,10.355D0,0.000D+00,1.0D0,
48962 & 'UPSLON4S', 300553, 55, 0,10.580D0,0.000D+00,1.0D0,
48963 & ' ', 0, 0, 0,0.0 D0, 0.0D+00, 0D0,
48964 & 'OMEGA_3 ', 227, 33, 0,1.6670D0,0.000D+00,3.0D0,
48965 & 'PHI_3 ', 337, 33, 0,1.8540D0,0.000D+00,3.0D0,
48966 & 'ETA_2(L)', 10225, 33, 0,1.6320D0,0.000D+00,2.0D0,
48967 & 'ETA_2(H)', 10335, 33, 0,1.8540D0,0.000D+00,2.0D0,
48968 & 'OMEGA(H)', 30223, 33, 0,1.6490D0,0.000D+00,1.0D0,
48969 & ' ', 0, 0, 0,0.0 D0,0.0D+00 , 0D0/
48970 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48971 & RSPIN(I),I=401,416)/
48972 & 'SSDL ', 1000001, 0,-1,0.00D0,1.000D+30,0.0D0,
48973 & 'SSUL ', 1000002, 0,+2,0.00D0,1.000D+30,0.0D0,
48974 & 'SSSL ', 1000003, 0,-1,0.00D0,1.000D+30,0.0D0,
48975 & 'SSCL ', 1000004, 0,+2,0.00D0,1.000D+30,0.0D0,
48976 & 'SSB1 ', 1000005, 0,-1,0.00D0,1.000D+30,0.0D0,
48977 & 'SST1 ', 1000006, 0,+2,0.00D0,1.000D+30,0.0D0,
48978 & 'SSDLBR ',-1000001, 0,+1,0.00D0,1.000D+30,0.0D0,
48979 & 'SSULBR ',-1000002, 0,-2,0.00D0,1.000D+30,0.0D0,
48980 & 'SSSLBR ',-1000003, 0,+1,0.00D0,1.000D+30,0.0D0,
48981 & 'SSCLBR ',-1000004, 0,-2,0.00D0,1.000D+30,0.0D0,
48982 & 'SSB1BR ',-1000005, 0,+1,0.00D0,1.000D+30,0.0D0,
48983 & 'SST1BR ',-1000006, 0,-2,0.00D0,1.000D+30,0.0D0,
48984 & 'SSDR ', 2000001, 0,-1,0.00D0,1.000D+30,0.0D0,
48985 & 'SSUR ', 2000002, 0,+2,0.00D0,1.000D+30,0.0D0,
48986 & 'SSSR ', 2000003, 0,-1,0.00D0,1.000D+30,0.0D0,
48987 & 'SSCR ', 2000004, 0,+2,0.00D0,1.000D+30,0.0D0/
48988 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
48989 & RSPIN(I),I=417,432)/
48990 & 'SSB2 ', 2000005, 0,-1,0.00D0,1.000D+30,0.0D0,
48991 & 'SST2 ', 2000006, 0,+2,0.00D0,1.000D+30,0.0D0,
48992 & 'SSDRBR ',-2000001, 0,+1,0.00D0,1.000D+30,0.0D0,
48993 & 'SSURBR ',-2000002, 0,-2,0.00D0,1.000D+30,0.0D0,
48994 & 'SSSRBR ',-2000003, 0,+1,0.00D0,1.000D+30,0.0D0,
48995 & 'SSCRBR ',-2000004, 0,-2,0.00D0,1.000D+30,0.0D0,
48996 & 'SSB2BR ',-2000005, 0,+1,0.00D0,1.000D+30,0.0D0,
48997 & 'SST2BR ',-2000006, 0,-2,0.00D0,1.000D+30,0.0D0,
48998 & 'SSEL- ', 1000011, 0,-1,0.00D0,1.000D+30,0.0D0,
48999 & 'SSNUEL ', 1000012, 0, 0,0.00D0,1.000D+30,0.0D0,
49000 & 'SSMUL- ', 1000013, 0,-1,0.00D0,1.000D+30,0.0D0,
49001 & 'SSNUMUL ', 1000014, 0, 0,0.00D0,1.000D+30,0.0D0,
49002 & 'SSTAU1- ', 1000015, 0,-1,0.00D0,1.000D+30,0.0D0,
49003 & 'SSNUTL ', 1000016, 0, 0,0.00D0,1.000D+30,0.0D0,
49004 & 'SSEL+ ',-1000011, 0,+1,0.00D0,1.000D+30,0.0D0,
49005 & 'SSNUELBR',-1000012, 0, 0,0.00D0,1.000D+30,0.0D0/
49006 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
49007 & RSPIN(I),I=433,448)/
49008 & 'SSMUL+ ',-1000013, 0,+1,0.00D0,1.000D+30,0.0D0,
49009 & 'SSNUMLBR',-1000014, 0, 0,0.00D0,1.000D+30,0.0D0,
49010 & 'SSTAU1+ ',-1000015, 0,+1,0.00D0,1.000D+30,0.0D0,
49011 & 'SSNUTLBR',-1000016, 0, 0,0.00D0,1.000D+30,0.0D0,
49012 & 'SSER- ', 2000011, 0,-1,0.00D0,1.000D+30,0.0D0,
49013 & 'SSNUER ', 2000012, 0, 0,0.00D0,1.000D+30,0.0D0,
49014 & 'SSMUR- ', 2000013, 0,-1,0.00D0,1.000D+30,0.0D0,
49015 & 'SSNUMUR ', 2000014, 0, 0,0.00D0,1.000D+30,0.0D0,
49016 & 'SSTAU2- ', 2000015, 0,-1,0.00D0,1.000D+30,0.0D0,
49017 & 'SSNUTR ', 2000016, 0, 0,0.00D0,1.000D+30,0.0D0,
49018 & 'SSER+ ',-2000011, 0,+1,0.00D0,1.000D+30,0.0D0,
49019 & 'SSNUERBR',-2000012, 0, 0,0.00D0,1.000D+30,0.0D0,
49020 & 'SSMUR+ ',-2000013, 0,+1,0.00D0,1.000D+30,0.0D0,
49021 & 'SSNUMRBR',-2000014, 0, 0,0.00D0,1.000D+30,0.0D0,
49022 & 'SSTAU2+ ',-2000015, 0,+1,0.00D0,1.000D+30,0.0D0,
49023 & 'SSNUTRBR',-2000016, 0, 0,0.00D0,1.000D+30,0.0D0/
49024 DATA (RNAME(I),IDPDG(I),IFLAV(I),ICHRG(I),RMASS(I),RLTIM(I),
49025 & RSPIN(I),I=449,NLAST)/
49026 & 'GLUINO ', 1000021, 0, 0,0.00D0,1.000D+30,0.5D0,
49027 & 'NTLINO1 ', 1000022, 0, 0,0.00D0,1.000D+30,0.5D0,
49028 & 'NTLINO2 ', 1000023, 0, 0,0.00D0,1.000D+30,0.5D0,
49029 & 'NTLINO3 ', 1000025, 0, 0,0.00D0,1.000D+30,0.5D0,
49030 & 'NTLINO4 ', 1000035, 0, 0,0.00D0,1.000D+30,0.5D0,
49031 & 'CHGINO1+', 1000024, 0,+1,0.00D0,1.000D+30,0.5D0,
49032 & 'CHGINO2+', 1000037, 0,+1,0.00D0,1.000D+30,0.5D0,
49033 & 'CHGINO1-',-1000024, 0,-1,0.00D0,1.000D+30,0.5D0,
49034 & 'CHGINO2-',-1000037, 0,-1,0.00D0,1.000D+30,0.5D0,
49035 & 'GRAVTINO', 1000039, 0, 0,0.00D0,1.000D+30,1.5D0/
49036C
49037 DATA QORQQB/.FALSE.,
49038 & 6*.TRUE.,6*.FALSE.,96*.FALSE.,6*.FALSE.,6*.TRUE.,NREST*.FALSE./
49039 DATA QBORQQ/.FALSE.,
49040 & 6*.FALSE.,6*.TRUE.,96*.FALSE.,6*.TRUE.,6*.FALSE.,NREST*.FALSE./
49041C
49042C In the character strings use an ampersand to represent a backslash
49043C to avoid compiler problems with the C escape character
49044 DATA ((TXNAME(J,I),J=1,2),I=0,8)/
49045 & ' ',
49046 & ' ',
49047 & ' d',
49048 & ' d',
49049 & ' u',
49050 & ' u',
49051 & ' s',
49052 & ' s',
49053 & ' c',
49054 & ' c',
49055 & ' b',
49056 & ' b',
49057 & ' t',
49058 & ' t',
49059 & ' $&bar{&rm d}$',
49060 & ' -d',
49061 & ' $&bar{&rm u}$',
49062 & ' -u'/
49063 DATA ((TXNAME(J,I),J=1,2),I=9,16)/
49064 & ' $&bar{&rm s}$',
49065 & ' -s',
49066 & ' $&bar{&rm c}$',
49067 & ' -c',
49068 & ' $&bar{&rm b}$',
49069 & ' -b',
49070 & ' $&bar{&rm t}$',
49071 & ' -t',
49072 & ' $g$',
49073 & ' g',
49074 & ' CoM',
49075 & ' CoM',
49076 & ' Hard',
49077 & ' Hard',
49078 & ' Soft',
49079 & ' Soft'/
49080 DATA ((TXNAME(J,I),J=1,2),I=17,24)/
49081 & ' Cone',
49082 & ' Cone',
49083 & ' Heavy',
49084 & ' Heavy',
49085 & ' Cluster',
49086 & ' Cluster',
49087 & ' $&star&star&star&star$',
49088 & ' ****',
49089 & ' $&pi^0$',
49090 & ' pi<SUP>0</SUP>',
49091 & ' $&eta$',
49092 & ' eta',
49093 & ' $&rho^0$',
49094 & ' rho<SUP>0</SUP>',
49095 & ' $&omega$',
49096 & ' omega'/
49097 DATA ((TXNAME(J,I),J=1,2),I=25,32)/
49098 & ' $&eta^&prime$',
49099 & ' eta<SUP>''</SUP>',
49100 & ' $f_2$',
49101 & ' f<SUB>2</SUB>',
49102 & ' $a^0_1$',
49103 & ' a<SUB>1</SUB><SUP>0</SUP>',
49104 & ' $f_1(L)$',
49105 & ' f<SUB>1</SUB>(L)',
49106 & ' $a^0_2$',
49107 & ' a<SUB>2</SUB><SUP>0</SUP>',
49108 & ' $&pi^-$',
49109 & ' pi<SUP>-</SUP>',
49110 & ' $&rho^-$',
49111 & ' rho<SUP>-</SUP>',
49112 & ' $a^-_1$',
49113 & ' a<SUB>1</SUB><SUP>-</SUP>'/
49114 DATA ((TXNAME(J,I),J=1,2),I=33,40)/
49115 & ' $a^-_2$',
49116 & ' a<SUB>2</SUB><SUP>-</SUP>',
49117 & ' K$^-$',
49118 & ' K<SUP>-</SUP>',
49119 & ' K$^{&star-}$',
49120 & ' K<SUP>*-</SUP>',
49121 & ' K$_1(H)^-$',
49122 & ' K<SUB>1</SUB>(H)<SUP>-</SUP>',
49123 & ' K$^{&star-}_2$',
49124 & ' K<SUB>2</SUB><SUP>*-</SUP>',
49125 & ' $&pi^+$',
49126 & ' pi<SUP>+</SUP>',
49127 & ' $&rho^+$',
49128 & ' rho<SUP>+</SUP>',
49129 & ' $a^+_1$',
49130 & ' a<SUB>1</SUB><SUP>+</SUP>'/
49131 DATA ((TXNAME(J,I),J=1,2),I=41,48)/
49132 & ' $a^+_2$',
49133 & ' a<SUB>2</SUB><SUP>+</SUP>',
49134 & ' $&overline{&rm K}^0$',
49135 & ' -K<SUP>0</SUP>',
49136 & ' $&overline{&rm K}^{&star0}$',
49137 & ' -K<SUP>*0</SUP>',
49138 & ' $&overline{&rm K}_1(H)^0$',
49139 & ' -K<SUB>1</SUB>(H)<SUP>0</SUP>',
49140 & ' $&overline{&rm K}^{&star0}_2$',
49141 & ' -K<SUB>2</SUB><SUP>*0</SUP>',
49142 & ' K$^+$',
49143 & ' K<SUP>+</SUP>',
49144 & ' K$^{&star+}$',
49145 & ' K<SUP>*+</SUP>',
49146 & ' K$_1(H)^+$',
49147 & ' K<SUB>1</SUB>(H)<SUP>+</SUP>'/
49148 DATA ((TXNAME(J,I),J=1,2),I=49,56)/
49149 & ' K$^{&star+}_2$',
49150 & ' K<SUB>2</SUB>(H)<SUP>*+</SUP>',
49151 & ' K$^0$',
49152 & ' K<SUP>0</SUP>',
49153 & ' K$^{&star0}$',
49154 & ' K<SUP>*-</SUP>',
49155 & ' K$_1(H)^0$',
49156 & ' K<SUB>1</SUB>(H)<SUP>0</SUP>',
49157 & ' K$^{&star0}_2$',
49158 & ' K<SUB>2</SUB><SUP>*0</SUP>',
49159 & ' ',
49160 & ' ',
49161 & ' ',
49162 & ' ',
49163 & ' $&phi$',
49164 & ' phi'/
49165 DATA ((TXNAME(J,I),J=1,2),I=57,64)/
49166 & ' $f_1(1420)$',
49167 & ' f<SUB>1</SUB>(1420)',
49168 & ' $f^&prime_2$',
49169 & ' f<SUP>''</SUP><SUB>2</SUB>',
49170 & ' $&gamma$',
49171 & ' gamma',
49172 & ' K$^0_{&rm S}$',
49173 & ' K<SUB>S</SUB><SUP>0</SUP>',
49174 & ' K$^0_{&rm L}$',
49175 & ' K<SUB>L</SUB><SUP>0</SUP>',
49176 & ' $a_0(1450)^0$',
49177 & ' a<SUB>0</SUB>(1450)<SUP>0</SUP>',
49178 & ' $a_0(1450)^+$',
49179 & ' a<SUB>0</SUB>(1450)<SUP>+</SUP>',
49180 & ' $a_0(1450)^-$',
49181 & ' a<SUB>0</SUB>(1450)<SUP>-</SUP>'/
49182 DATA ((TXNAME(J,I),J=1,2),I=65,72)/
49183 & ' ',
49184 & ' ',
49185 & ' ',
49186 & ' ',
49187 & ' ',
49188 & ' ',
49189 & ' ',
49190 & ' ',
49191 & ' ',
49192 & ' ',
49193 & ' ',
49194 & ' ',
49195 & ' $&gamma$-remnant',
49196 & ' gamma-remnant',
49197 & ' $N$-remnant',
49198 & ' N-remnant'/
49199 DATA ((TXNAME(J,I),J=1,2),I=73,80)/
49200 & ' p',
49201 & ' p',
49202 & ' $&Delta^+$',
49203 & ' Delta<SUP>+</SUP>',
49204 & ' n',
49205 & ' n',
49206 & ' $&Delta^0$',
49207 & ' Delta<SUP>0</SUP>',
49208 & ' $&Delta^-$',
49209 & ' Delta<SUP>-</SUP>',
49210 & ' $&Lambda$',
49211 & ' Lambda',
49212 & ' $&Sigma^0$',
49213 & ' Sigma<SUP>0</SUP>',
49214 & ' $&Sigma^{&star0}$',
49215 & ' Sigma<SUP>*0</SUP>'/
49216 DATA ((TXNAME(J,I),J=1,2),I=81,88)/
49217 & ' $&Sigma^-$',
49218 & ' Sigma<SUP>-</SUP>',
49219 & ' $&Sigma^{&star-}$',
49220 & ' Sigma<SUP>*-</SUP>',
49221 & ' $&Xi^-$',
49222 & ' Xi<SUP>-</SUP>',
49223 & ' $&Xi^{&star-}$',
49224 & ' Xi<SUP>*-</SUP>',
49225 & ' $&Delta^{++}$',
49226 & ' Delta<SUP>++</SUP>',
49227 & ' $&Sigma^+$',
49228 & ' Sigma<SUP>+</SUP>',
49229 & ' $&Sigma^{&star+}$',
49230 & ' Sigma<SUP>*+</SUP>',
49231 & ' $&Xi^0$',
49232 & ' Xi<SUP>0</SUP>'/
49233 DATA ((TXNAME(J,I),J=1,2),I=89,96)/
49234 & ' $&Xi^{&star0}$',
49235 & ' Xi<SUP>*0</SUP>',
49236 & ' $&Omega^-$',
49237 & ' Omega<SUP>-</SUP>',
49238 & ' $&bar{&rm p}$',
49239 & ' -p',
49240 & ' $&overline{&Delta}^-$',
49241 & ' -Delta<SUP>-</SUP>',
49242 & ' $&bar{&rm n}$',
49243 & ' -n',
49244 & ' $&overline{&Delta}^0$',
49245 & ' -Delta<SUP>0</SUP>',
49246 & ' $&overline{&Delta}^+$',
49247 & ' -Delta<SUP>+</SUP>',
49248 & ' $&overline{&Lambda}$',
49249 & ' -Lambda'/
49250 DATA ((TXNAME(J,I),J=1,2),I=97,104)/
49251 & ' $&overline{&Sigma}^0$',
49252 & ' -Sigma<SUP>0</SUP>',
49253 & ' $&overline{&Sigma}^{&star0}$',
49254 & ' -Sigma<SUP>*0</SUP>',
49255 & ' $&overline{&Sigma}^+$',
49256 & ' -Sigma<SUP>+</SUP>',
49257 & ' $&overline{&Sigma}^{&star+}$',
49258 & ' -Sigma<SUP>*+</SUP>',
49259 & ' $&overline{&Xi}^+$',
49260 & ' -Xi<SUP>+</SUP>',
49261 & ' $&overline{&Xi}^{&star+}$',
49262 & ' -Xi<SUP>*+</SUP>',
49263 & ' $&overline{&Delta}^{--}$',
49264 & ' -Delta<SUP>--</SUP>',
49265 & ' $&overline{&Sigma}^-$',
49266 & ' -Sigma<SUP>-</SUP>'/
49267 DATA ((TXNAME(J,I),J=1,2),I=105,112)/
49268 & ' $&overline{&Sigma}^{&star-}$',
49269 & ' -Sigma<SUP>*-</SUP>',
49270 & ' $&overline{&Xi}^0$',
49271 & ' -Xi<SUP>0</SUP>',
49272 & ' $&overline&Xi^{&star0}$',
49273 & ' -Xi<SUP>*0</SUP>',
49274 & ' $&overline{&Omega}^+$',
49275 & ' -Omega<SUP>+</SUP>',
49276 & ' uu',
49277 & ' uu',
49278 & ' ud',
49279 & ' ud',
49280 & ' dd',
49281 & ' dd',
49282 & ' us',
49283 & ' us'/
49284 DATA ((TXNAME(J,I),J=1,2),I=113,120)/
49285 & ' ds',
49286 & ' ds',
49287 & ' ss',
49288 & ' ss',
49289 & ' $&bar{&rm u}&bar{&rm u}$',
49290 & ' -uu',
49291 & ' $&bar{&rm u}&bar{&rm d}$',
49292 & ' -ud',
49293 & ' $&bar{&rm d}&bar{&rm d}$',
49294 & ' -dd',
49295 & ' $&bar{&rm u}&bar{&rm s}$',
49296 & ' -us',
49297 & ' $&bar{&rm d}&bar{&rm s}$',
49298 & ' -ds',
49299 & ' $&bar{&rm s}&bar{&rm s}$',
49300 & ' -ss'/
49301 DATA ((TXNAME(J,I),J=1,2),I=121,128)/
49302 & ' e$^-$',
49303 & ' e<SUP>-</SUP>',
49304 & ' $&nu_{&rm e}$',
49305 & ' nu<SUB>e</SUB>',
49306 & ' $&mu^-$',
49307 & ' mu<SUP>-</SUP>',
49308 & ' $&nu_&mu$',
49309 & ' nu<SUB>mu</SUB>',
49310 & ' $&tau^-$',
49311 & ' tau<SUP>-</SUP>',
49312 & ' $&nu_&tau$',
49313 & ' nu<SUB>tau</SUB>',
49314 & ' e$^+$',
49315 & ' e<SUP>+</SUP>',
49316 & ' $&bar{&nu}_{&rm e}$',
49317 & ' -nu<SUB>e</SUB>'/
49318 DATA ((TXNAME(J,I),J=1,2),I=129,136)/
49319 & ' $&mu^+$',
49320 & ' mu<SUP>+</SUP>',
49321 & ' $&bar{&nu}_&mu$',
49322 & ' -nu<SUB>mu</SUB>',
49323 & ' $&tau^+$',
49324 & ' tau<SUP>+</SUP>',
49325 & ' $&bar{&nu}_&tau$',
49326 & ' -nu<SUB>tau</SUB>',
49327 & ' ',
49328 & ' ',
49329 & ' ',
49330 & ' ',
49331 & ' ',
49332 & ' ',
49333 & ' D$^+$',
49334 & ' D<SUP>+</SUP>'/
49335 DATA ((TXNAME(J,I),J=1,2),I=137,144)/
49336 & ' D$^{&star+}$',
49337 & ' D<SUP>*+</SUP>',
49338 & ' D$_1(H)^+$',
49339 & ' D<SUB>1</SUB>(H)<SUP>+</SUP>',
49340 & ' D$_2^{&star+}$',
49341 & ' D<SUB>2</SUB><SUP>*+</SUP>',
49342 & ' D$^0$',
49343 & ' D<SUP>0</SUP>',
49344 & ' D$^{&star0}$',
49345 & ' D<SUP>*0</SUP>',
49346 & ' D$_1(H)^0$',
49347 & ' D<SUB>1</SUB>(H)<SUP>0</SUP>',
49348 & ' D$_2^{&star0}$',
49349 & ' D<SUB>2</SUB><SUP>*0</SUP>',
49350 & ' D$_{&rm s}^+$',
49351 & ' D<SUB>s</SUB><SUP>+</SUP>'/
49352 DATA ((TXNAME(J,I),J=1,2),I=145,152)/
49353 & ' D$_{&rm s}^{&star+}$',
49354 & ' D<SUB>s</SUB><SUP>*+</SUP>',
49355 & ' D$_{&rm s1}(H)^+$',
49356 & ' D<SUB>s1</SUB>(H)<SUP>+</SUP>',
49357 & ' D$^{&star+}_{&rm s2}$',
49358 & ' D<SUB>s1</SUB>(H)<SUP>*+</SUP>',
49359 & ' $&Sigma_{&rm c}^{++}$',
49360 & ' Sigma<SUB>c</SUB><SUP>++</SUP>',
49361 & ' $&Sigma_{&rm c}^{&star++}$',
49362 & ' Sigma<SUB>c</SUB><SUP>*++</SUP>',
49363 & ' $&Lambda_{&rm c}^+$',
49364 & ' Lambda<SUB>c</SUB><SUP>+</SUP>',
49365 & ' $&Sigma_{&rm c}^+$',
49366 & ' Sigma<SUB>c</SUB><SUP>+</SUP>',
49367 & ' $&Sigma_{&rm c}^{&star+}$',
49368 & ' Sigma<SUB>c</SUB><SUP>*+</SUP>'/
49369 DATA ((TXNAME(J,I),J=1,2),I=153,160)/
49370 & ' $&Sigma_{&rm c}^0$',
49371 & ' Sigma<SUB>c</SUB><SUP>0</SUP>',
49372 & ' $&Sigma_{&rm c}^{&star0}$',
49373 & ' Sigma<SUB>c</SUB><SUP>*0</SUP>',
49374 & ' $&Xi_{&rm c}^+$',
49375 & ' Xi<SUB>c</SUB><SUP>+</SUP>',
49376 & ' $&Xi_{&rm c}^{&prime+}$',
49377 & ' Xi<SUB>c</SUB><SUP>''+</SUP>',
49378 & ' $&Xi_{&rm c}^{&star+}$',
49379 & ' Xi<SUB>c</SUB><SUP>*+</SUP>',
49380 & ' $&Xi_{&rm c}^0$',
49381 & ' Xi<SUB>c</SUB><SUP>0</SUP>',
49382 & ' $&Xi_{&rm c}^{&prime0}$',
49383 & ' Xi<SUB>c</SUB><SUP>''0</SUP>',
49384 & ' $&Xi_{&rm c}^{&star0}$',
49385 & ' Xi<SUB>c</SUB><SUP>*0</SUP>'/
49386 DATA ((TXNAME(J,I),J=1,2),I=161,168)/
49387 & ' $&Omega_{&rm c}^0$',
49388 & ' Omega<SUB>c</SUB><SUP>0</SUP>',
49389 & ' $&Omega_{&rm c}^{&star0}$',
49390 & ' Omega<SUB>c</SUB><SUP>*0</SUP>',
49391 & ' $&eta_{&rm c}(1S)$',
49392 & ' eta<SUB>c</SUB>(1S)',
49393 & ' J/$&psi$',
49394 & ' J/psi',
49395 & ' $&chi_{&rm c0}(1P)$',
49396 & ' chi<SUB>c0</SUB>(1P)',
49397 & ' $&psi(2S)$',
49398 & ' psi(2S)',
49399 & ' $&psi(1D)$',
49400 & ' psi(1D)',
49401 & ' ',
49402 & ' '/
49403 DATA ((TXNAME(J,I),J=1,2),I=169,176)/
49404 & ' ',
49405 & ' ',
49406 & ' ',
49407 & ' ',
49408 & ' D$^-$',
49409 & ' D<SUP>-</SUP>',
49410 & ' D$^{&star-}$',
49411 & ' D<SUP>*-</SUP>',
49412 & ' D$_1(H)^-$',
49413 & ' D<SUB>1</SUB>(H)<SUP>-</SUP>',
49414 & ' D$_2^{&star-}$',
49415 & ' D<SUB>2</SUB><SUP>*-</SUP>',
49416 & ' $&overline{&rm D}^0$',
49417 & ' -D<SUP>0</SUP>',
49418 & ' $&overline{&rm D}^{&star0}$',
49419 & ' -D<SUP>*0</SUP>'/
49420 DATA ((TXNAME(J,I),J=1,2),I=177,184)/
49421 & ' $&overline{&rm D}_1(H)^0$',
49422 & ' -D<SUB>1</SUB>(H)<SUP>0</SUP>',
49423 & ' $&overline{&rm D}_2^{&star0}$',
49424 & ' -D<SUB>2</SUB><SUP>*0</SUP>',
49425 & ' D$_{&rm s}^-$',
49426 & ' D<SUB>s</SUB><SUP>-</SUP>',
49427 & ' D$_{&rm s}^{&star-}$',
49428 & ' D<SUB>s</SUB><SUP>*-</SUP>',
49429 & ' D$_{&rm s1}(H)^-$',
49430 & ' D<SUB>s1</SUB>(H)<SUP>-</SUP>',
49431 & ' D$_{&rm s2}^{&star-}$',
49432 & ' D<SUB>s1</SUB>(H)<SUP>*-</SUP>',
49433 & ' $&overline{&Sigma}_{&rm c}^{--}$',
49434 & ' -Sigma<SUB>c</SUB><SUP>--</SUP>',
49435 & '$&overline{&Sigma}_{&rm c}^{&star--}$',
49436 & ' -Sigma<SUB>c</SUB><SUP>*--</SUP>'/
49437 DATA ((TXNAME(J,I),J=1,2),I=185,192)/
49438 & ' $&overline{&Lambda}_{&rm c}^-$',
49439 & ' -Lambda<SUB>c</SUB><SUP>-</SUP>',
49440 & ' $&overline{&Sigma}_{&rm c}^-$',
49441 & ' -Sigma<SUB>c</SUB><SUP>-</SUP>',
49442 & ' $&overline{&Sigma}_{&rm c}^{&star-}$',
49443 & ' -Sigma<SUB>c</SUB><SUP>*-</SUP>',
49444 & ' $&overline{&Sigma}_{&rm c}^0$',
49445 & ' -Sigma<SUB>c</SUB><SUP>0</SUP>',
49446 & ' $&overline{&Sigma}_{&rm c}^{&star0}$',
49447 & ' -Sigma<SUB>c</SUB><SUP>*0</SUP>',
49448 & ' $&overline{&Xi}_{&rm c}^-$',
49449 & ' -Xi<SUB>c</SUB><SUP>-</SUP>',
49450 & ' $&overline{&Xi}_{&rm c}^{&prime-}$',
49451 & ' -Xi<SUB>c</SUB><SUP>''-</SUP>',
49452 & ' $&overline{&Xi}_{&rm c}^{&star-}$',
49453 & ' -Xi<SUB>c</SUB><SUP>*-</SUP>'/
49454 DATA ((TXNAME(J,I),J=1,2),I=193,200)/
49455 & ' $&overline{&Xi}_{&rm c}^0$',
49456 & ' -Xi<SUB>c</SUB><SUP>0</SUP>',
49457 & ' $&overline{&Xi}_{&rm c}^{&prime0}$',
49458 & ' -Xi<SUB>c</SUB><SUP>''0</SUP>',
49459 & ' $&overline{&Xi}_{&rm c}^{&star0}$',
49460 & ' -Xi<SUB>c</SUB><SUP>*0</SUP>',
49461 & ' $&overline{&Omega}_{&rm c}^0$',
49462 & ' -Omega<SUB>c</SUB><SUP>0</SUP>',
49463 & ' $&overline{&Omega}_{&rm c}^{&star0}$',
49464 & ' -Omega<SUB>c</SUB><SUP>*0</SUP>',
49465 & ' W$^+$',
49466 & ' W<SUP>+</SUP>',
49467 & ' W$^-$',
49468 & ' W<SUP>-</SUP>',
49469 & ' Z$^0/&gamma^&star$',
49470 & ' Z<SUP>0</SUP>/gamma<SUP>*</SUP>'/
49471 DATA ((TXNAME(J,I),J=1,2),I=201,208)/
49472 & ' $H^0_{&rm SM}$',
49473 & ' H<SUP>0</SUP><SUB>SM</SUB>',
49474 & ' Z$^{&prime0}$',
49475 & ' Z<SUP>''0</SUP>',
49476 & ' $h^0$',
49477 & ' h<SUP>0</SUP>',
49478 & ' $H^0$',
49479 & ' H<SUP>0</SUP>',
49480 & ' $A^0$',
49481 & ' A<SUP>0</SUP>',
49482 & ' $H^+$',
49483 & ' H<SUP>+</SUP>',
49484 & ' $H^-$',
49485 & ' H<SUP>-</SUP>',
49486 & ' $G$',
49487 & ' G'/
49488 DATA ((TXNAME(J,I),J=1,2),I=209,216)/
49489 & ' V-quark',
49490 & ' V-quark',
49491 & ' A-quark',
49492 & ' A-quark',
49493 & ' H-quark',
49494 & ' H-quark',
49495 & ' H$^&prime$-quark',
49496 & ' H<SUP>''</SUP>-quark',
49497 & ' ',
49498 & ' ',
49499 & ' ',
49500 & ' ',
49501 & ' $&overline{&rm V}$-quark',
49502 & ' -V-quark',
49503 & ' $&overline{&rm A}$-quark',
49504 & ' -A-quark'/
49505 DATA ((TXNAME(J,I),J=1,2),I=217,224)/
49506 & ' $&overline{&rm H}$-quark',
49507 & ' -H-quark',
49508 & ' $&overline{&rm H}^&prime$-quark',
49509 & ' -H<SUP>''</SUP>-quark',
49510 & ' ',
49511 & ' ',
49512 & ' ',
49513 & ' ',
49514 & ' $&overline{&rm B}_{&rm d}^0$',
49515 & ' -B<SUB>d</SUB><SUP>0</SUP>',
49516 & ' B$^-$',
49517 & ' B<SUP>-</SUP>',
49518 & ' $&overline{&rm B}_{&rm s}^0$',
49519 & ' -B<SUB>s</SUB><SUP>0</SUP>',
49520 & ' $&Sigma_{&rm b}^+$',
49521 & ' Sigma<SUB>b</SUB><SUP>+</SUP>'/
49522 DATA ((TXNAME(J,I),J=1,2),I=225,232)/
49523 & ' $&Lambda_{&rm b}^0$',
49524 & ' Lambda<SUB>b</SUB><SUP>0</SUP>',
49525 & ' $&Sigma_{&rm b}^-$',
49526 & ' Sigma<SUB>b</SUB><SUP>-</SUP>',
49527 & ' $&Xi_{&rm b}^0$',
49528 & ' Xi<SUB>b</SUB><SUP>0</SUP>',
49529 & ' $&Xi_{&rm b}^-$',
49530 & ' Xi<SUB>b</SUB><SUP>-</SUP>',
49531 & ' $&Omega_{&rm b}^-$',
49532 & ' Omega<SUB>b</SUB><SUP>-</SUP>',
49533 & ' B$_{&rm c}^-$',
49534 & ' B<SUB>c</SUB><SUP>-</SUP>',
49535 & ' $&Upsilon(1S)$',
49536 & ' Upsilon(1S)',
49537 & ' T$_{&rm b}^-$',
49538 & ' T<SUB>b</SUB><SUP>-</SUP>'/
49539 DATA ((TXNAME(J,I),J=1,2),I=233,240)/
49540 & ' T$^+$',
49541 & ' T<SUP>+</SUP>',
49542 & ' T$^0$',
49543 & ' T<SUP>0</SUP>',
49544 & ' T$_{&rm s}^+$',
49545 & ' T<SUB>s</SUB><SUP>+</SUP>',
49546 & ' $&Sigma_{&rm t}^{++}$',
49547 & ' Sigma<SUB>t</SUB><SUP>++</SUP>',
49548 & ' $&Lambda_{&rm t}^0$',
49549 & ' Lambda<SUB>t</SUB><SUP>0</SUP>',
49550 & ' $&Sigma_{&rm t}^0$',
49551 & ' Sigma<SUB>t</SUB><SUP>0</SUP>',
49552 & ' $&chi_{&rm t}^+$',
49553 & ' Xi<SUB>t</SUB><SUP>+</SUP>',
49554 & ' $&chi_{&rm t}^0$',
49555 & ' Xi<SUB>t</SUB><SUP>0</SUP>'/
49556 DATA ((TXNAME(J,I),J=1,2),I=241,248)/
49557 & ' $&Omega_{&rm t}^0$',
49558 & ' Omega<SUB>t</SUB><SUP>0</SUP>',
49559 & ' T$_{&rm c}^0$',
49560 & ' T<SUB>c</SUB><SUP>0</SUP>',
49561 & ' T$_{&rm b}^+$',
49562 & ' T<SUB>b</SUB><SUP>+</SUP>',
49563 & ' Toponium',
49564 & ' Toponium',
49565 & ' B$_{&rm d}^0$',
49566 & ' B<SUB>d</SUB><SUP>0</SUP>',
49567 & ' B$^+$',
49568 & ' B<SUP>+</SUP>',
49569 & ' B$_{&rm s}^0$',
49570 & ' B<SUB>s</SUB><SUP>0</SUP>',
49571 & ' $&overline{&Sigma}_{&rm b}^-$',
49572 & ' -Sigma<SUB>b</SUB><SUP>-</SUP>'/
49573 DATA ((TXNAME(J,I),J=1,2),I=249,256)/
49574 & ' $&overline{&Lambda}_{&rm b}^-$',
49575 & ' -Lambda<SUB>b</SUB><SUP>-</SUP>',
49576 & ' $&overline{&Sigma}_{&rm b}^+$',
49577 & ' -Sigma<SUB>b</SUB><SUP>+</SUP>',
49578 & ' $&overline{&Xi}_{&rm b}^0$',
49579 & ' -Xi<SUB>b</SUB><SUP>0</SUP>',
49580 & ' $&Xi_{&rm b}^+$',
49581 & ' Xi<SUB>b</SUB><SUP>+</SUP>',
49582 & ' $&overline{&Omega}_{&rm b}^+$',
49583 & ' -Omega<SUB>b</SUB><SUP>+</SUP>',
49584 & ' B$_{&rm c}^+$',
49585 & ' B<SUB>c</SUB><SUP>+</SUP>',
49586 & ' T$^-$',
49587 & ' T<SUP>-</SUP>',
49588 & ' $&overline{&rm T}^0$',
49589 & ' T<SUP>0</SUP>'/
49590 DATA ((TXNAME(J,I),J=1,2),I=257,264)/
49591 & ' T$_{&rm s}^-$',
49592 & ' T<SUB>s</SUB><SUP>-</SUP>',
49593 & ' $&overline{&Sigma}_{&rm t}^{--}$',
49594 & ' Sigma<SUB>t</SUB><SUP>--</SUP>',
49595 & ' $&overline{&Lambda}_{&rm t}^-$',
49596 & ' -Lambda<SUB>t</SUB><SUP>-</SUP>',
49597 & ' $&overline{&Sigma}_{&rm t}^0$',
49598 & ' -Sigma<SUB>t</SUB><SUP>0</SUP>',
49599 & ' $&overline{&Xi}_{&rm t}^-$',
49600 & ' -Xi<SUB>t</SUB><SUP>-</SUP>',
49601 & ' $&overline{&Xi}_{&rm t}^0$',
49602 & ' -Xi<SUB>t</SUB><SUP>0</SUP>',
49603 & ' $&overline{&Omega}_{&rm t}^0$',
49604 & ' -Omega<SUB>t</SUB><SUP>0</SUP>',
49605 & ' $&overline{&rm T}_{&rm c}^0$',
49606 & ' T<SUB>c</SUB><SUP>0</SUP>'/
49607 DATA ((TXNAME(J,I),J=1,2),I=265,272)/
49608 & ' $&overline{&rm B}^{&star0}$',
49609 & ' -B<SUP>*0</SUP>',
49610 & ' B$^{&star-}$',
49611 & ' B<SUP>*-</SUP>',
49612 & ' $&overline{&rm B}_{&rm s}^{&star0}$',
49613 & ' -B<SUB>s</SUB><SUP>*0</SUP>',
49614 & ' $&overline{&rm B}_1(H)^0$',
49615 & ' -B<SUB>1</SUB>(H)<SUP>0</SUP>',
49616 & ' B$_1(H)^-$',
49617 & ' B<SUB>1</SUB>(H)<SUP>-</SUP>',
49618 & ' $&overline{&rm B}_{&rm s1}(H)^0$',
49619 & ' -B<SUB>s1</SUB>(H)<SUP>0</SUP>',
49620 & ' $&overline{&rm B}_2^{&star0}$',
49621 & ' -B<SUB>2</SUB><SUP>*0</SUP>',
49622 & ' B$_2^{&star-}$',
49623 & ' B<SUB>2</SUB><SUP>*-</SUP>'/
49624 DATA ((TXNAME(J,I),J=1,2),I=273,280)/
49625 & ' B$_{&rm s2}^{&star0}$',
49626 & ' B<SUB>s2</SUB><SUP>*0</SUP>',
49627 & ' B$^{&star0}$',
49628 & ' B<SUP>*0</SUP>',
49629 & ' B$^{&star+}$',
49630 & ' B<SUP>*+</SUP>',
49631 & ' B$_{&rm s}^{&star0}$',
49632 & ' B<SUB>s</SUB><SUP>*0</SUP>',
49633 & ' B$_1(H)^0$',
49634 & ' B<SUB>1</SUB>(H)<SUP>0</SUP>',
49635 & ' B$_1(H)^+$',
49636 & ' B<SUB>1</SUB>(H)<SUP>+</SUP>',
49637 & ' B$_{&rm s1}(H)^0$',
49638 & ' B<SUB>s1</SUB>(H)<SUP>0</SUP>',
49639 & ' B$_2^{&star0}$',
49640 & ' B<SUB>2</SUB><SUP>*0</SUP>'/
49641 DATA ((TXNAME(J,I),J=1,2),I=281,288)/
49642 & ' B$_2^{&star+}$',
49643 & ' B<SUB>2</SUB><SUP>*+</SUP>',
49644 & ' B$_{&rm s2}^{&star0}$',
49645 & ' B<SUB>s2</SUB><SUP>*0</SUP>',
49646 & ' ',
49647 & ' ',
49648 & ' ',
49649 & ' ',
49650 & ' b$_1^0$',
49651 & ' b<SUB>1</SUB><SUP>0</SUP>',
49652 & ' b$_1^+$',
49653 & ' b<SUB>1</SUB><SUP>+</SUP>',
49654 & ' b$_1^-$',
49655 & ' b<SUB>1</SUB><SUP>-</SUP>',
49656 & ' h$_1(L)^0$',
49657 & ' h<SUB>1</SUB>(L)<SUP>0</SUP>'/
49658 DATA ((TXNAME(J,I),J=1,2),I=289,296)/
49659 & ' h$_1(H)^0$',
49660 & ' h<SUB>1</SUB>(H)<SUP>0</SUP>',
49661 & ' a$_0(980)^0$',
49662 & ' a<SUB>0</SUB>(980)<SUP>0</SUP>',
49663 & ' a$_0(980)^+$',
49664 & ' a<SUB>0</SUB>(980)<SUP>+</SUP>',
49665 & ' a$_0(980)^-$',
49666 & ' a<SUB>0</SUB>(980)<SUP>-</SUP>',
49667 & ' f$_0(980)$',
49668 & ' f<SUB>0</SUB>(980)',
49669 & ' f$_0(1370)$',
49670 & ' f<SUB>0</SUB>(1370)',
49671 & ' B$_{&rm c}^{&star+}$',
49672 & ' B<SUB>c</SUB><SUP>*+</SUP>',
49673 & ' B$_{&rm c}^{&star-}$',
49674 & ' B<SUB>c</SUB><SUP>*-</SUP>'/
49675 DATA ((TXNAME(J,I),J=1,2),I=297,304)/
49676 & ' B$_{&rm c1}(H)^+$',
49677 & ' B<SUB>c1</SUB>(H)<SUP>+</SUP>',
49678 & ' B$_{&rm c1}(H)^-$',
49679 & ' B<SUB>c1</SUB>(H)<SUP>-</SUP>',
49680 & ' B$_{&rm c2}^{&star+}$',
49681 & ' B<SUB>c2</SUB><SUP>*+</SUP>',
49682 & ' B$_{&rm c2}^{&star-}$',
49683 & ' B<SUB>c2</SUB><SUP>*-</SUP>',
49684 & ' h$_{&rm c}(1P)$',
49685 & ' h<SUB>c</SUB>(1P)',
49686 & ' $&chi_{&rm c0}(1P)$',
49687 & ' chi<SUB>c0</SUB>(1P)',
49688 & ' $&chi_{&rm c2}(1P)$',
49689 & ' chi<SUB>c2</SUB>(1P)',
49690 & ' $&eta_{&rm b}(1S)$',
49691 & ' eta<SUB>b</SUB>(1S)'/
49692 DATA ((TXNAME(J,I),J=1,2),I=305,312)/
49693 & ' h$_{&rm b}(1P)$',
49694 & ' h<SUB>b</SUB>(1P)',
49695 & ' $&chi_{&rm b0}(1P)$',
49696 & ' chi<SUB>b0</SUB>(1P)',
49697 & ' $&chi_{&rm b1}(1P)$',
49698 & ' chi<SUB>b1</SUB>(1P)',
49699 & ' $&chi_{&rm b2}(1P)$',
49700 & ' chi<SUB>b2</SUB>(1P)',
49701 & ' K$_1(L)^0$',
49702 & ' K<SUB>1</SUB>(L)<SUP>0</SUP>',
49703 & ' K$_1(L)^+$',
49704 & ' K<SUB>1</SUB>(L)<SUP>+</SUP>',
49705 & ' $&overline{&rm K}_1(L)^0$',
49706 & ' -K<SUB>1</SUB>(L)<SUP>0</SUP>',
49707 & ' K$_1(L)^-$',
49708 & ' K<SUB>1</SUB>(L)<SUP>-</SUP>'/
49709 DATA ((TXNAME(J,I),J=1,2),I=313,320)/
49710 & ' D$_1(L)^+$',
49711 & ' D<SUB>1</SUB>(L)<SUP>+</SUP>',
49712 & ' D$_1(L)^0$',
49713 & ' D<SUB>1</SUB>(L)<SUP>0</SUP>',
49714 & ' D$_{&rm s1}(L)^+$',
49715 & ' D<SUB>s1</SUB>(L)<SUP>+</SUP>',
49716 & ' D$_1(L)^-$',
49717 & ' D<SUB>1</SUB>(L)<SUP>-</SUP>',
49718 & ' $&overline{&rm D}_1(L)^0$',
49719 & ' D<SUB>1</SUB>(L)<SUP>0</SUP>',
49720 & ' D$_{&rm s1}(L)^-$',
49721 & ' D<SUB>s1</SUB>(L)<SUP>-</SUP>',
49722 & ' B$_1(L)^0$',
49723 & ' B<SUB>1</SUB>(L)<SUP>0</SUP>',
49724 & ' B$_1(L)^+$',
49725 & ' B<SUB>1</SUB>(L)<SUP>+</SUP>'/
49726 DATA ((TXNAME(J,I),J=1,2),I=321,328)/
49727 & ' B$_{&rm s1}(L)^0$',
49728 & ' B<SUB>s1</SUB>(L)<SUP>0</SUP>',
49729 & ' B$_{&rm c1}(L)^+$',
49730 & ' B<SUB>c1</SUB>(L)<SUP>+</SUP>',
49731 & ' $&overline{&rm B}_1(L)^0$',
49732 & ' -B<SUB>1</SUB>(L)<SUP>0</SUP>',
49733 & ' B$_1(L)^-$',
49734 & ' B<SUB>1</SUB>(L)<SUP>-</SUP>',
49735 & ' $&overline{&rm B}_{&rm s1}(L)^0$',
49736 & ' -B<SUB>s1</SUB>(L)<SUP>0</SUP>',
49737 & ' B$_{&rm c1}(L)^-$',
49738 & ' B<SUB>c1</SUB>(L)<SUP>-</SUP>',
49739 & ' K$_0^{&star+}$',
49740 & ' K<SUB>0</SUB><SUP>*+</SUP>',
49741 & ' K$_0^{&star0}$',
49742 & ' K<SUB>0</SUB><SUP>*0</SUP>'/
49743 DATA ((TXNAME(J,I),J=1,2),I=329,336)/
49744 & ' $&overline{&rm K}_0^{&star0}$',
49745 & ' -K<SUB>0</SUB><SUP>*0</SUP>',
49746 & ' K$_0^{&star-}$',
49747 & ' K<SUB>0</SUB><SUP>*-</SUP>',
49748 & ' D$_0^{&star+}$',
49749 & ' D<SUB>0</SUB><SUP>*+</SUP>',
49750 & ' D$_0^{&star0}$',
49751 & ' D<SUB>0</SUB><SUP>*0</SUP>',
49752 & ' D$_{&rm s0}^{&star+}$',
49753 & ' D<SUB>s0</SUB><SUP>*+</SUP>',
49754 & ' D$_0^{&star-}$',
49755 & ' D<SUB>0</SUB><SUP>*-</SUP>',
49756 & ' $&overline{&rm D}_0^{&star0}$',
49757 & ' -D<SUB>0</SUB><SUP>*0</SUP>',
49758 & ' D$_{&rm s0}^{&star-}$',
49759 & ' D<SUB>s0</SUB><SUP>*-</SUP>'/
49760 DATA ((TXNAME(J,I),J=1,2),I=337,344)/
49761 & ' B$_0^{&star0}$',
49762 & ' B<SUB>0</SUB><SUP>*0</SUP>',
49763 & ' B$_0^{&star+}$',
49764 & ' B<SUB>0</SUB><SUP>*+</SUP>',
49765 & ' B$_{&rm s0}^{&star0}$',
49766 & ' B<SUB>s0</SUB><SUP>*0</SUP>',
49767 & ' B$_{&rm c0}^{&star+}$',
49768 & ' B<SUB>c0</SUB><SUP>*+</SUP>',
49769 & ' $&overline{&rm B}_0^{&star0}$',
49770 & ' -B<SUB>0</SUB><SUP>*0</SUP>',
49771 & ' B$_0^{&star-}$',
49772 & ' B<SUB>0</SUB><SUP>*-</SUP>',
49773 & ' $&overline{&rm B}_{&rm s0}^{&star0}$',
49774 & ' -B<SUB>s0</SUB><SUP>*0</SUP>',
49775 & ' B$_{&rm c0}^{&star-}$',
49776 & ' B<SUB>c0</SUB><SUP>*-</SUP>'/
49777 DATA ((TXNAME(J,I),J=1,2),I=345,352)/
49778 & ' $&Sigma_{&rm b}^0$',
49779 & ' Sigma<SUB>b</SUB><SUP>0</SUP>',
49780 & ' $&Sigma_{&rm b}^{&star-}$',
49781 & ' Sigma<SUB>b</SUB><SUP>*-</SUP>',
49782 & ' $&Sigma_{&rm b}^{&star0}$',
49783 & ' Sigma<SUB>b</SUB><SUP>*0</SUP>',
49784 & ' $&Sigma_{&rm b}^{&star+}$',
49785 & ' Sigma<SUB>b</SUB><SUP>*+</SUP>',
49786 & ' $&Xi_{&rm b}^{&prime0}$',
49787 & ' Xi<SUB>b</SUB><SUP>''0</SUP>',
49788 & ' $&Xi_{&rm b}^{&star0}$',
49789 & ' Xi<SUB>b</SUB><SUP>*0</SUP>',
49790 & ' $&Xi_{&rm b}^{&prime-}$',
49791 & ' Xi<SUB>b</SUB><SUP>''-</SUP>',
49792 & ' $&Xi_{&rm b}^{&star-}$',
49793 & ' Xi<SUB>b</SUB><SUP>*-</SUP>'/
49794 DATA ((TXNAME(J,I),J=1,2),I=353,360)/
49795 & ' $&Omega_{&rm b}^{&star-}$',
49796 & ' -Omega<SUB>b</SUB><SUP>*-</SUP>',
49797 & ' $&overline{&Sigma}_{&rm b}^{&star+}$',
49798 & ' Sigma<SUB>b</SUB><SUP>*+</SUP>',
49799 & ' $&overline{&Sigma}_{&rm b}^0$',
49800 & ' -Sigma<SUB>b</SUB><SUP>0</SUP>',
49801 & ' $&overline{&Sigma}_{&rm b}^{&star0}$',
49802 & ' -Sigma<SUB>b</SUB><SUP>*0</SUP>',
49803 & ' $&overline{&Sigma}_{&rm b}^{&star-}$',
49804 & ' -Sigma<SUB>b</SUB><SUP>*-</SUP>',
49805 & ' $&overline{&Xi}_{&rm b}^{&prime0}$',
49806 & ' -Xi<SUB>b</SUB><SUP>''0</SUP>',
49807 & ' $&overline{&Xi}_{&rm b}^{&star0}$',
49808 & ' -Xi<SUB>b</SUB><SUP>*0</SUP>',
49809 & ' $&overline{&Xi}_{&rm b}^{&prime+}$',
49810 & ' -Xi<SUB>b</SUB><SUP>''+</SUP>'/
49811 DATA ((TXNAME(J,I),J=1,2),I=361,368)/
49812 & ' $&overline{&Xi}_{&rm b}^{&star+}$',
49813 & ' -Xi<SUB>b</SUB><SUP>*+</SUP>',
49814 & ' $&Omega_{&rm b}^{&star+}$',
49815 & ' Omega<SUB>b</SUB><SUP>*+</SUP>',
49816 & ' K$(DL)_2^+$',
49817 & ' K(DL)<SUB>2</SUB><SUP>+</SUP>',
49818 & ' K$(DL)_2^0$',
49819 & ' K(DL)<SUB>2</SUB><SUP>0</SUP>',
49820 & ' $&overline{&rm K}(DL)_2^0$',
49821 & ' -K(DL)<SUB>2</SUB><SUP>0</SUP>',
49822 & ' K$(DL)_2^-$',
49823 & ' K(DL)<SUB>2</SUB><SUP>-</SUP>',
49824 & ' K$(D)^{&star+}$',
49825 & ' K(D)<SUP>*+</SUP>',
49826 & ' K$(D)^{&star0}$',
49827 & ' K(D)<SUP>*0</SUP>'/
49828 DATA ((TXNAME(J,I),J=1,2),I=369,376)/
49829 & ' $&overline{&rm K}(D)^{&star0}$',
49830 & ' -K(D)<SUP>*0</SUP>',
49831 & ' K$(D)^{&star-}$',
49832 & ' K(D)<SUP>*-</SUP>',
49833 & ' K$(DH)_2^+$',
49834 & ' K(DH)<SUB>2</SUB><SUP>+</SUP>',
49835 & ' K$(DH)_2^0$',
49836 & ' K(DH)<SUB>2</SUB><SUP>0</SUP>',
49837 & ' $&overline{&rm K}(DH)_2^0$',
49838 & ' -K(DH)<SUB>2</SUB><SUP>0</SUP>',
49839 & ' K$(DH)_2^-$',
49840 & ' K(DH)<SUB>2</SUB><SUP>-</SUP>',
49841 & ' K$(D)_3^+$',
49842 & ' K(D)<SUB>3</SUB><SUP>+</SUP>',
49843 & ' K$(D)_3^0$',
49844 & ' K(D)<SUB>3</SUB><SUP>0</SUP>'/
49845 DATA ((TXNAME(J,I),J=1,2),I=377,384)/
49846 & ' $&overline{&rm K}(D)_3^0$',
49847 & ' -K(D)<SUB>3</SUB><SUP>0</SUP>',
49848 & ' K$(D)_3^-$',
49849 & ' K(D)<SUB>3</SUB><SUP>-</SUP>',
49850 & ' $&pi_2^+$',
49851 & ' pi<SUB>2</SUB><SUP>+</SUP>',
49852 & ' $&pi_2^0$',
49853 & ' pi<SUB>2</SUB><SUP>0</SUP>',
49854 & ' $&pi_2^-$',
49855 & ' pi<SUB>2</SUB><SUP>-</SUP>',
49856 & ' $&rho(D)^+$',
49857 & ' rho(D)<SUP>+</SUP>',
49858 & ' $&rho(D)^0$',
49859 & ' rho(D)<SUP>0</SUP>',
49860 & ' $&rho(D)^-$',
49861 & ' rho(D)<SUP>-</SUP>'/
49862 DATA ((TXNAME(J,I),J=1,2),I=385,392)/
49863 & ' $&rho_3^+$',
49864 & ' rho<SUB>3</SUB><SUP>+</SUP>',
49865 & ' $&rho_3^0$',
49866 & ' rho<SUB>3</SUB><SUP>0</SUP>',
49867 & ' $&rho_3^-$',
49868 & ' rho<SUB>3</SUB><SUP>-</SUP>',
49869 & ' $&Upsilon(2S)$',
49870 & ' Upsilon(2S)',
49871 & ' $&chi_{&rm b0}(2P)$',
49872 & ' Chi<SUB>b0</SUB>(2P)',
49873 & ' $&chi_{&rm b1}(2P)$',
49874 & ' Chi<SUB>b1</SUB>(2P)',
49875 & ' $&chi_{&rm b2}(2P)$',
49876 & ' Chi<SUB>b2</SUB>(2P)',
49877 & ' $&Upsilon(3S)$',
49878 & ' Upsilon(3S)'/
49879 DATA ((TXNAME(J,I),J=1,2),I=393,400)/
49880 & ' $&Upsilon(4S)$',
49881 & ' Upsilon(4S)',
49882 & ' ',
49883 & ' ',
49884 & ' $&omega_3$',
49885 & ' omega<SUB>3</SUB>',
49886 & ' $&phi_3$',
49887 & ' phi<SUB>3</SUB>',
49888 & ' $&eta_2(L)$',
49889 & ' eta<SUB>2</SUB>(L)',
49890 & ' $&eta_2(H)$',
49891 & ' eta<SUB>2</SUB>(H)',
49892 & ' $&omega(H)$',
49893 & ' omega(H)',
49894 & ' ',
49895 & ' '/
49896 DATA ((TXNAME(J,I),J=1,2),I=401,408)/
49897 & ' $&tilde{&rm d}_{&rm L}$',
49898 & ' ~d<SUB>L</SUB>',
49899 & ' $&tilde{&rm u}_{&rm L}$',
49900 & ' ~u<SUB>L</SUB>',
49901 & ' $&tilde{&rm s}_{&rm L}$',
49902 & ' ~s<SUB>L</SUB>',
49903 & ' $&tilde{&rm c}_{&rm L}$',
49904 & ' ~c<SUB>L</SUB>',
49905 & ' $&tilde{&rm b}_1$',
49906 & ' ~b<SUB>1</SUB>',
49907 & ' $&tilde{&rm t}_1$',
49908 & ' ~t<SUB>1</SUB>',
49909 & ' $&overline{&tilde{&rm d}}_{&rm L}$',
49910 & ' -~d<SUB>L</SUB>',
49911 & ' $&overline{&tilde{&rm u}}_{&rm L}$',
49912 & ' -~u<SUB>L</SUB>'/
49913 DATA ((TXNAME(J,I),J=1,2),I=409,416)/
49914 & ' $&overline{&tilde{&rm s}}_{&rm L}$',
49915 & ' -~s<SUB>L</SUB>',
49916 & ' $&overline{&tilde{&rm c}}_{&rm L}$',
49917 & ' -~c<SUB>L</SUB>',
49918 & ' $&overline{&tilde{&rm b}}_1$',
49919 & ' -~b<SUB>1</SUB>',
49920 & ' $&overline{&tilde{&rm t}}_1$',
49921 & ' -~t<SUB>1</SUB>',
49922 & ' $&tilde{&rm d}_{&rm R}$',
49923 & ' ~d<SUB>R</SUB>',
49924 & ' $&tilde{&rm u}_{&rm R}$',
49925 & ' ~u<SUB>R</SUB>',
49926 & ' $&tilde{&rm s}_{&rm R}$',
49927 & ' ~s<SUB>R</SUB>',
49928 & ' $&tilde{&rm c}_{&rm R}$',
49929 & ' ~c<SUB>R</SUB>'/
49930 DATA ((TXNAME(J,I),J=1,2),I=417,424)/
49931 & ' $&tilde{&rm b}_2$',
49932 & ' ~b<SUB>2</SUB>',
49933 & ' $&tilde{&rm t}_2$',
49934 & ' ~t<SUB>2</SUB>',
49935 & ' $&overline{&tilde{&rm d}}_{&rm R}$',
49936 & ' -~d<SUB>R</SUB>',
49937 & ' $&overline{&tilde{&rm u}}_{&rm R}$',
49938 & ' -~u<SUB>R</SUB>',
49939 & ' $&overline{&tilde{&rm s}}_{&rm R}$',
49940 & ' -~s<SUB>R</SUB>',
49941 & ' $&overline{&tilde{&rm c}}_{&rm R}$',
49942 & ' -~c<SUB>R</SUB>',
49943 & ' $&overline{&tilde{&rm b}}_2$',
49944 & ' -~b<SUB>2</SUB>',
49945 & ' $&overline{&tilde{&rm t}}_2$',
49946 & ' -~t<SUB>2</SUB>'/
49947 DATA ((TXNAME(J,I),J=1,2),I=425,432)/
49948 & ' $&tilde{&rm e}^-_{&rm L}$',
49949 & ' ~e<SUP>-</SUP><SUB>L</SUB>',
49950 & ' $&tilde{&nu}_{&rm e}$',
49951 & ' ~nu<SUB>e L</SUB>',
49952 & ' $&tilde{&mu}^-_{&rm L}$',
49953 & ' ~mu<SUP>-</SUP><SUB>L</SUB>',
49954 & ' $&tilde{&nu}_&mu$',
49955 & ' ~nu<SUB>mu L</SUB>',
49956 & ' $&tilde{&tau}^-_1$',
49957 & ' ~tau<SUP>-</SUP><SUB>1</SUB>',
49958 & ' $&tilde{&nu}_&tau$',
49959 & ' ~nu<SUB>tau L</SUB>',
49960 & ' $&tilde{&rm e}^+_{&rm L}$',
49961 & ' ~e<SUP>+</SUP><SUB>L</SUB>',
49962 & ' $&overline{&tilde{&nu}}_{&rm eL}$',
49963 & ' -~nu<SUB>eL</SUB>'/
49964 DATA ((TXNAME(J,I),J=1,2),I=433,440)/
49965 & ' $&tilde{&mu}^+_{&rm L}$',
49966 & ' ~mu<SUP>+</SUP><SUB>L</SUB>',
49967 & ' $&overline{&tilde{&nu}}_{&rm&mu L}$',
49968 & ' -~nu<SUB>mu L</SUB>',
49969 & ' $&tilde{&tau}^+_1$',
49970 & ' ~tau<SUP>+</SUP><SUB>1</SUB>',
49971 & ' $&overline{&tilde{&nu}}_{&rm&tau L}$',
49972 & ' -~nu<SUB>tau L</SUB>',
49973 & ' $&tilde{&rm e}^-_{&rm R}$',
49974 & ' ~e<SUP>-</SUP><SUB>R</SUB>',
49975 & ' $&tilde{&nu}_{&rm eR}$',
49976 & ' ~nu<SUB>e R</SUB>',
49977 & ' $&tilde{&mu}^-_{&rm R}$',
49978 & ' ~mu<SUP>-</SUP><SUB>R</SUB>',
49979 & ' $&tilde{&nu}_{&mu{&rm R}}$',
49980 & ' ~nu<SUB>mu R</SUB>'/
49981 DATA ((TXNAME(J,I),J=1,2),I=441,448)/
49982 & ' $&tilde{&tau}^-_2$',
49983 & ' ~tau<SUP>-</SUP><SUB>2</SUB>',
49984 & ' $&tilde{&nu}_{&tau{&rm R}}$',
49985 & ' ~nu<SUB>tau R</SUB>',
49986 & ' $&tilde{&rm e}^+_{&rm R}$',
49987 & ' ~e<SUP>+</SUP><SUB>R</SUB>',
49988 & ' $&overline{&tilde{&nu}}_{&rm eR}$',
49989 & ' -~nu<SUB>e R</SUB>',
49990 & ' $&tilde{&mu}^+_{&rm R}$',
49991 & ' ~mu<SUP>+</SUP><SUB>R</SUB>',
49992 & ' $&overline{&tilde{&nu}}_{&rm&mu R}$',
49993 & ' -~nu<SUB>mu R</SUB>',
49994 & ' $&tilde{&tau}^+_2$',
49995 & ' ~tau<SUP>+</SUP><SUB>2</SUB>',
49996 & ' $&overline{&tilde{&nu}}_{&rm&tau R}$',
49997 & ' -~nu<SUB>tau R</SUB>'/
49998 DATA ((TXNAME(J,I),J=1,2),I=449,456)/
49999 & ' $&tilde{g}$',
50000 & ' ~g',
50001 & ' $&tilde{&chi}^0_1$',
50002 & ' ~chi<SUP>0</SUP><SUB>1</SUB>',
50003 & ' $&tilde{&chi}^0_2$',
50004 & ' ~chi<SUP>0</SUP><SUB>2</SUB>',
50005 & ' $&tilde{&chi}^0_3$',
50006 & ' ~chi<SUP>0</SUP><SUB>3</SUB>',
50007 & ' $&tilde{&chi}^0_4$',
50008 & ' ~chi<SUP>0</SUP><SUB>4</SUB>',
50009 & ' $&tilde{&chi}^+_1$',
50010 & ' ~chi<SUP>+</SUP><SUB>1</SUB>',
50011 & ' $&tilde{&chi}^+_2$',
50012 & ' ~chi<SUP>+</SUP><SUB>2</SUB>',
50013 & ' $&tilde{&chi}^-_1$',
50014 & ' ~chi<SUP>-</SUP><SUB>1</SUB>'/
50015 DATA ((TXNAME(J,I),J=1,2),I=457,NLAST)/
50016 & ' $&tilde{&chi}^-_2$',
50017 & ' ~chi<SUP>-</SUP><SUB>2</SUB>',
50018 & ' $&tilde{G}$',
50019 & ' ~G'/
50020C
50021 DATA (RNAME(I),I=NNEXT,NMXRES)/NLEFT*' '/
50022 DATA (IDPDG(I),I=NNEXT,NMXRES)/NLEFT*0/
50023 DATA (IFLAV(I),I=NNEXT,NMXRES)/NLEFT*0/
50024 DATA (RMASS(I),I=NNEXT,NMXRES)/NLEFT*0.0000D0/
50025 DATA (RLTIM(I),I=NNEXT,NMXRES)/NLEFT*0.000D+00/
50026 DATA (RSPIN(I),I=NNEXT,NMXRES)/NLEFT*0.0D0/
50027 DATA (TXNAME(1,I),I=NNEXT,NMXRES)/
50028 & NLEFT*' '/
50029 DATA (TXNAME(2,I),I=NNEXT,NMXRES)/
50030 & NLEFT*' '/
50031C
50032 DATA (RSTAB(I),I=1,NMXRES)/NMXRES*.FALSE./
50033 DATA DKPSET/.FALSE./
50034C
50035 DATA NDKYS/2263/
50036 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 1, 19)/
50037 & 6,0.334D0,100, 2, 7, 5, 0, 0,
50038 & 6,0.333D0,100, 4, 9, 5, 0, 0,
50039 & 6,0.111D0,100,122,127, 5, 0, 0,
50040 & 6,0.111D0,100,124,129, 5, 0, 0,
50041 & 6,0.111D0,100,126,131, 5, 0, 0,
50042 & 12,0.334D0,100, 8, 1, 11, 0, 0,
50043 & 12,0.333D0,100, 10, 3, 11, 0, 0,
50044 & 12,0.111D0,100,128,121, 11, 0, 0,
50045 & 12,0.111D0,100,130,123, 11, 0, 0,
50046 & 12,0.111D0,100,132,125, 11, 0, 0,
50047 & 21,0.988D0, 0, 59, 59, 0, 0, 0,
50048 & 21,0.012D0, 0,127,121, 59, 0, 0,
50049 & 22,0.388D0, 0, 59, 59, 0, 0, 0,
50050 & 22,0.319D0, 0, 21, 21, 21, 0, 0,
50051 & 22,0.001D0, 0, 21, 59, 59, 0, 0,
50052 & 22,0.236D0, 0, 38, 30, 21, 0, 0,
50053 & 22,0.049D0, 0, 38, 30, 59, 0, 0,
50054 & 22,0.005D0, 0,127,121, 59, 0, 0,
50055 & 22,0.002D0, 0, 38, 30,127,121, 0/
50056 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 20, 38)/
50057 & 23,0.989D0, 0, 38, 30, 0, 0, 0,
50058 & 23,0.010D0, 0, 38, 30, 59, 0, 0,
50059 & 23,0.001D0, 0, 21, 59, 0, 0, 0,
50060 & 24,0.888D0, 0, 38, 30, 21, 0, 0,
50061 & 24,0.085D0, 0, 21, 59, 0, 0, 0,
50062 & 24,0.022D0, 0, 38, 30, 0, 0, 0,
50063 & 24,0.001D0, 0, 22, 59, 0, 0, 0,
50064 & 24,0.001D0, 0, 21,127,121, 0, 0,
50065 & 24,0.003D0, 0, 38, 30, 21, 21, 0,
50066 & 25,0.437D0, 0, 38, 30, 22, 0, 0,
50067 & 25,0.302D0, 0, 23, 59, 0, 0, 0,
50068 & 25,0.208D0, 0, 21, 21, 22, 0, 0,
50069 & 25,0.030D0, 0, 24, 59, 0, 0, 0,
50070 & 25,0.021D0, 0, 59, 59, 0, 0, 0,
50071 & 25,0.002D0, 0, 21, 21, 21, 0, 0,
50072 & 26,0.566D0, 0, 38, 30, 0, 0, 0,
50073 & 26,0.283D0, 0, 21, 21, 0, 0, 0,
50074 & 26,0.069D0, 0, 38, 30, 21, 21, 0,
50075 & 26,0.023D0, 0, 46, 34, 0, 0, 0/
50076 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 39, 57)/
50077 & 26,0.023D0, 0, 50, 42, 0, 0, 0,
50078 & 26,0.028D0, 0, 38, 38, 30, 30, 0,
50079 & 26,0.005D0, 0, 22, 22, 0, 0, 0,
50080 & 26,0.003D0, 0, 21, 21, 21, 21, 0,
50081 & 27,0.499D0, 0, 39, 30, 0, 0, 0,
50082 & 27,0.499D0, 0, 31, 38, 0, 0, 0,
50083 & 27,0.002D0, 0, 21, 59, 59, 0, 0,
50084 & 28,0.148D0, 0, 21, 21, 38, 30, 0,
50085 & 28,0.148D0, 0, 23, 38, 30, 0, 0,
50086 & 28,0.147D0, 0,291, 30, 0, 0, 0,
50087 & 28,0.147D0, 0,290, 21, 0, 0, 0,
50088 & 28,0.147D0, 0,292, 38, 0, 0, 0,
50089 & 28,0.067D0, 0, 22, 38, 30, 0, 0,
50090 & 28,0.033D0, 0, 22, 21, 21, 0, 0,
50091 & 28,0.032D0, 0, 46, 42, 30, 0, 0,
50092 & 28,0.016D0, 0, 46, 34, 21, 0, 0,
50093 & 28,0.016D0, 0, 50, 42, 21, 0, 0,
50094 & 28,0.032D0, 0, 50, 34, 38, 0, 0,
50095 & 28,0.066D0, 0, 59, 23, 0, 0, 0/
50096 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 58, 76)/
50097 & 28,0.001D0, 0, 56, 59, 0, 0, 0,
50098 & 29,0.349D0, 0, 39, 30, 0, 0, 0,
50099 & 29,0.349D0, 0, 31, 38, 0, 0, 0,
50100 & 29,0.144D0, 0, 22, 21, 0, 0, 0,
50101 & 29,0.104D0, 0, 24, 38, 30, 0, 0,
50102 & 29,0.024D0, 0, 46, 34, 0, 0, 0,
50103 & 29,0.024D0, 0, 50, 42, 0, 0, 0,
50104 & 29,0.006D0, 0, 25, 21, 0, 0, 0,
50105 & 30,1.000D0, 0,123,130, 0, 0, 0,
50106 & 31,1.000D0, 0, 30, 21, 0, 0, 0,
50107 & 32,0.499D0, 0, 31, 21, 0, 0, 0,
50108 & 32,0.499D0, 0, 23, 30, 0, 0, 0,
50109 & 32,0.002D0, 0, 30, 59, 0, 0, 0,
50110 & 33,0.349D0, 0, 31, 21, 0, 0, 0,
50111 & 33,0.349D0, 0, 23, 30, 0, 0, 0,
50112 & 33,0.144D0, 0, 22, 30, 0, 0, 0,
50113 & 33,0.101D0, 0, 24, 30, 21, 0, 0,
50114 & 33,0.048D0, 0, 50, 34, 0, 0, 0,
50115 & 33,0.006D0, 0, 25, 30, 0, 0, 0/
50116 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 77, 95)/
50117 & 33,0.003D0, 0, 30, 59, 0, 0, 0,
50118 & 34,0.629D0, 0,123,130, 0, 0, 0,
50119 & 34,0.212D0, 0, 30, 21, 0, 0, 0,
50120 & 34,0.056D0, 0, 30, 38, 30, 0, 0,
50121 & 34,0.017D0, 0, 30, 21, 21, 0, 0,
50122 & 34,0.048D0,101,121,128, 21, 0, 0,
50123 & 34,0.032D0,101,123,130, 21, 0, 0,
50124 & 34,0.006D0, 0,123,130, 59, 0, 0,
50125 & 35,0.666D0, 0, 42, 30, 0, 0, 0,
50126 & 35,0.333D0, 0, 34, 21, 0, 0, 0,
50127 & 35,0.001D0, 0, 34, 59, 0, 0, 0,
50128 & 36,0.627D0, 0, 43, 30, 0, 0, 0,
50129 & 36,0.313D0, 0, 35, 21, 0, 0, 0,
50130 & 36,0.020D0, 0, 42, 31, 0, 0, 0,
50131 & 36,0.010D0, 0, 34, 23, 0, 0, 0,
50132 & 36,0.020D0, 0, 34,294, 0, 0, 0,
50133 & 36,0.010D0, 0, 34, 24, 0, 0, 0,
50134 & 37,0.331D0, 0, 42, 30, 0, 0, 0,
50135 & 37,0.166D0, 0, 34, 21, 0, 0, 0/
50136 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 96, 114)/
50137 & 37,0.168D0, 0, 43, 30, 0, 0, 0,
50138 & 37,0.084D0, 0, 35, 21, 0, 0, 0,
50139 & 37,0.087D0, 0, 35, 38, 30, 0, 0,
50140 & 37,0.044D0, 0, 35, 21, 21, 0, 0,
50141 & 37,0.059D0, 0, 42, 31, 0, 0, 0,
50142 & 37,0.029D0, 0, 34, 23, 0, 0, 0,
50143 & 37,0.029D0, 0, 34, 24, 0, 0, 0,
50144 & 37,0.002D0, 0, 34, 59, 0, 0, 0,
50145 & 37,0.001D0, 0, 34, 22, 0, 0, 0,
50146 & 38,1.000D0, 0,129,124, 0, 0, 0,
50147 & 39,1.000D0, 0, 38, 21, 0, 0, 0,
50148 & 40,0.499D0, 0, 39, 21, 0, 0, 0,
50149 & 40,0.499D0, 0, 23, 38, 0, 0, 0,
50150 & 40,0.002D0, 0, 38, 59, 0, 0, 0,
50151 & 41,0.349D0, 0, 39, 21, 0, 0, 0,
50152 & 41,0.349D0, 0, 23, 38, 0, 0, 0,
50153 & 41,0.144D0, 0, 22, 38, 0, 0, 0,
50154 & 41,0.101D0, 0, 24, 38, 21, 0, 0,
50155 & 41,0.048D0, 0, 46, 42, 0, 0, 0/
50156 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 115, 133)/
50157 & 41,0.006D0, 0, 25, 38, 0, 0, 0,
50158 & 41,0.003D0, 0, 38, 59, 0, 0, 0,
50159 & 42,0.500D0, 0, 60, 0, 0, 0, 0,
50160 & 42,0.500D0, 0, 61, 0, 0, 0, 0,
50161 & 43,0.665D0, 0, 34, 38, 0, 0, 0,
50162 & 43,0.333D0, 0, 42, 21, 0, 0, 0,
50163 & 43,0.002D0, 0, 42, 59, 0, 0, 0,
50164 & 44,0.627D0, 0, 35, 38, 0, 0, 0,
50165 & 44,0.313D0, 0, 43, 21, 0, 0, 0,
50166 & 44,0.020D0, 0, 34, 39, 0, 0, 0,
50167 & 44,0.010D0, 0, 42, 23, 0, 0, 0,
50168 & 44,0.020D0, 0, 42,294, 0, 0, 0,
50169 & 44,0.010D0, 0, 42, 24, 0, 0, 0,
50170 & 45,0.331D0, 0, 34, 38, 0, 0, 0,
50171 & 45,0.166D0, 0, 42, 21, 0, 0, 0,
50172 & 45,0.168D0, 0, 35, 38, 0, 0, 0,
50173 & 45,0.084D0, 0, 43, 21, 0, 0, 0,
50174 & 45,0.089D0, 0, 42, 38, 30, 0, 0,
50175 & 45,0.044D0, 0, 42, 21, 21, 0, 0/
50176 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 134, 152)/
50177 & 45,0.059D0, 0, 34, 39, 0, 0, 0,
50178 & 45,0.029D0, 0, 42, 23, 0, 0, 0,
50179 & 45,0.029D0, 0, 42, 24, 0, 0, 0,
50180 & 45,0.001D0, 0, 42, 22, 0, 0, 0,
50181 & 46,0.629D0, 0,129,124, 0, 0, 0,
50182 & 46,0.212D0, 0, 38, 21, 0, 0, 0,
50183 & 46,0.056D0, 0, 38, 38, 30, 0, 0,
50184 & 46,0.017D0, 0, 38, 21, 21, 0, 0,
50185 & 46,0.032D0,101,129,124, 21, 0, 0,
50186 & 46,0.048D0,101,127,122, 21, 0, 0,
50187 & 46,0.006D0, 0,129,124, 59, 0, 0,
50188 & 47,0.666D0, 0, 50, 38, 0, 0, 0,
50189 & 47,0.333D0, 0, 46, 21, 0, 0, 0,
50190 & 47,0.001D0, 0, 46, 59, 0, 0, 0,
50191 & 48,0.627D0, 0, 51, 38, 0, 0, 0,
50192 & 48,0.313D0, 0, 47, 21, 0, 0, 0,
50193 & 48,0.020D0, 0, 50, 39, 0, 0, 0,
50194 & 48,0.010D0, 0, 46, 23, 0, 0, 0,
50195 & 48,0.020D0, 0, 46,294, 0, 0, 0/
50196 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 153, 171)/
50197 & 48,0.010D0, 0, 46, 24, 0, 0, 0,
50198 & 49,0.331D0, 0, 50, 38, 0, 0, 0,
50199 & 49,0.166D0, 0, 46, 21, 0, 0, 0,
50200 & 49,0.168D0, 0, 51, 38, 0, 0, 0,
50201 & 49,0.084D0, 0, 47, 21, 0, 0, 0,
50202 & 49,0.087D0, 0, 47, 38, 30, 0, 0,
50203 & 49,0.044D0, 0, 47, 21, 21, 0, 0,
50204 & 49,0.059D0, 0, 50, 39, 0, 0, 0,
50205 & 49,0.029D0, 0, 46, 23, 0, 0, 0,
50206 & 49,0.029D0, 0, 46, 24, 0, 0, 0,
50207 & 49,0.002D0, 0, 46, 59, 0, 0, 0,
50208 & 49,0.001D0, 0, 46, 22, 0, 0, 0,
50209 & 50,0.500D0, 0, 60, 0, 0, 0, 0,
50210 & 50,0.500D0, 0, 61, 0, 0, 0, 0,
50211 & 51,0.665D0, 0, 46, 30, 0, 0, 0,
50212 & 51,0.333D0, 0, 50, 21, 0, 0, 0,
50213 & 51,0.002D0, 0, 50, 59, 0, 0, 0,
50214 & 52,0.627D0, 0, 47, 30, 0, 0, 0,
50215 & 52,0.313D0, 0, 51, 21, 0, 0, 0/
50216 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 172, 190)/
50217 & 52,0.020D0, 0, 46, 31, 0, 0, 0,
50218 & 52,0.010D0, 0, 50, 23, 0, 0, 0,
50219 & 52,0.020D0, 0, 50,294, 0, 0, 0,
50220 & 52,0.010D0, 0, 50, 24, 0, 0, 0,
50221 & 53,0.331D0, 0, 46, 30, 0, 0, 0,
50222 & 53,0.166D0, 0, 50, 21, 0, 0, 0,
50223 & 53,0.168D0, 0, 47, 30, 0, 0, 0,
50224 & 53,0.084D0, 0, 51, 21, 0, 0, 0,
50225 & 53,0.089D0, 0, 50, 38, 30, 0, 0,
50226 & 53,0.044D0, 0, 50, 21, 21, 0, 0,
50227 & 53,0.059D0, 0, 46, 31, 0, 0, 0,
50228 & 53,0.029D0, 0, 50, 23, 0, 0, 0,
50229 & 53,0.029D0, 0, 50, 24, 0, 0, 0,
50230 & 53,0.001D0, 0, 50, 22, 0, 0, 0,
50231 & 56,0.490D0, 0, 46, 34, 0, 0, 0,
50232 & 56,0.342D0, 0, 61, 60, 0, 0, 0,
50233 & 56,0.043D0, 0, 39, 30, 0, 0, 0,
50234 & 56,0.043D0, 0, 23, 21, 0, 0, 0,
50235 & 56,0.043D0, 0, 31, 38, 0, 0, 0/
50236 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 191, 209)/
50237 & 56,0.025D0, 0, 38, 30, 21, 0, 0,
50238 & 56,0.013D0, 0, 22, 59, 0, 0, 0,
50239 & 56,0.001D0, 0, 21, 59, 0, 0, 0,
50240 & 57,0.250D0, 0, 50, 43, 0, 0, 0,
50241 & 57,0.250D0, 0, 34, 47, 0, 0, 0,
50242 & 57,0.250D0, 0, 42, 51, 0, 0, 0,
50243 & 57,0.250D0, 0, 46, 35, 0, 0, 0,
50244 & 58,0.356D0, 0, 46, 34, 0, 0, 0,
50245 & 58,0.356D0, 0, 50, 42, 0, 0, 0,
50246 & 58,0.279D0, 0, 22, 22, 0, 0, 0,
50247 & 58,0.006D0, 0, 38, 30, 0, 0, 0,
50248 & 58,0.003D0, 0, 21, 21, 0, 0, 0,
50249 & 60,0.684D0, 0, 38, 30, 0, 0, 0,
50250 & 60,0.314D0, 0, 21, 21, 0, 0, 0,
50251 & 60,0.002D0, 0, 38, 30, 59, 0, 0,
50252 & 61,0.216D0, 0, 21, 21, 21, 0, 0,
50253 & 61,0.124D0, 0, 38, 30, 21, 0, 0,
50254 & 61,0.135D0,101,123,130, 38, 0, 0,
50255 & 61,0.135D0,101,124,129, 30, 0, 0/
50256 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 210, 228)/
50257 & 61,0.187D0,101,121,128, 38, 0, 0,
50258 & 61,0.187D0,101,122,127, 30, 0, 0,
50259 & 61,0.006D0, 0,121,128, 38, 59, 0,
50260 & 61,0.006D0, 0,122,127, 30, 59, 0,
50261 & 61,0.002D0, 0, 38, 30, 0, 0, 0,
50262 & 61,0.001D0, 0, 21, 21, 0, 0, 0,
50263 & 61,0.001D0, 0, 59, 59, 0, 0, 0,
50264 & 74,0.663D0, 0, 73, 21, 0, 0, 0,
50265 & 74,0.331D0, 0, 75, 38, 0, 0, 0,
50266 & 74,0.006D0, 0, 73, 59, 0, 0, 0,
50267 & 75,1.000D0,101,121,128, 73, 0, 0,
50268 & 76,0.663D0, 0, 75, 21, 0, 0, 0,
50269 & 76,0.331D0, 0, 73, 30, 0, 0, 0,
50270 & 76,0.006D0, 0, 75, 59, 0, 0, 0,
50271 & 77,1.000D0, 0, 75, 30, 0, 0, 0,
50272 & 78,0.638D0, 0, 73, 30, 0, 0, 0,
50273 & 78,0.358D0, 0, 75, 21, 0, 0, 0,
50274 & 78,0.002D0, 0, 75, 59, 0, 0, 0,
50275 & 78,0.001D0, 0, 73, 30, 59, 0, 0/
50276 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 229, 247)/
50277 & 78,0.001D0,101,121,128, 73, 0, 0,
50278 & 79,0.995D0, 0, 78, 59, 0, 0, 0,
50279 & 79,0.005D0, 0, 78,127,121, 0, 0,
50280 & 80,0.880D0, 0, 78, 21, 0, 0, 0,
50281 & 80,0.060D0, 0, 86, 30, 0, 0, 0,
50282 & 80,0.060D0, 0, 81, 38, 0, 0, 0,
50283 & 81,0.998D0, 0, 75, 30, 0, 0, 0,
50284 & 81,0.001D0, 0, 75, 30, 59, 0, 0,
50285 & 81,0.001D0,101,121,128, 75, 0, 0,
50286 & 82,0.880D0, 0, 78, 30, 0, 0, 0,
50287 & 82,0.060D0, 0, 79, 30, 0, 0, 0,
50288 & 82,0.060D0, 0, 81, 21, 0, 0, 0,
50289 & 83,0.999D0, 0, 78, 30, 0, 0, 0,
50290 & 83,0.001D0,101,121,128, 78, 0, 0,
50291 & 84,0.667D0, 0, 88, 30, 0, 0, 0,
50292 & 84,0.333D0, 0, 83, 21, 0, 0, 0,
50293 & 85,1.000D0, 0, 73, 38, 0, 0, 0,
50294 & 86,0.516D0, 0, 73, 21, 0, 0, 0,
50295 & 86,0.483D0, 0, 75, 38, 0, 0, 0/
50296 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 248, 266)/
50297 & 86,0.001D0, 0, 73, 59, 0, 0, 0,
50298 & 87,0.880D0, 0, 78, 38, 0, 0, 0,
50299 & 87,0.060D0, 0, 86, 21, 0, 0, 0,
50300 & 87,0.060D0, 0, 79, 38, 0, 0, 0,
50301 & 88,0.995D0, 0, 78, 21, 0, 0, 0,
50302 & 88,0.001D0, 0, 78, 59, 0, 0, 0,
50303 & 88,0.004D0, 0, 79, 59, 0, 0, 0,
50304 & 89,0.667D0, 0, 83, 38, 0, 0, 0,
50305 & 89,0.333D0, 0, 88, 21, 0, 0, 0,
50306 & 90,0.675D0, 0, 78, 34, 0, 0, 0,
50307 & 90,0.233D0, 0, 88, 30, 0, 0, 0,
50308 & 90,0.086D0, 0, 83, 21, 0, 0, 0,
50309 & 90,0.006D0,101,121,128, 88, 0, 0,
50310 & 92,0.663D0, 0, 91, 21, 0, 0, 0,
50311 & 92,0.331D0, 0, 93, 30, 0, 0, 0,
50312 & 92,0.006D0, 0, 91, 59, 0, 0, 0,
50313 & 93,1.000D0,101,127,122, 91, 0, 0,
50314 & 94,0.663D0, 0, 93, 21, 0, 0, 0,
50315 & 94,0.331D0, 0, 91, 38, 0, 0, 0/
50316 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 267, 285)/
50317 & 94,0.006D0, 0, 93, 59, 0, 0, 0,
50318 & 95,1.000D0, 0, 93, 38, 0, 0, 0,
50319 & 96,0.638D0, 0, 91, 38, 0, 0, 0,
50320 & 96,0.358D0, 0, 93, 21, 0, 0, 0,
50321 & 96,0.002D0, 0, 93, 59, 0, 0, 0,
50322 & 96,0.001D0, 0, 91, 38, 59, 0, 0,
50323 & 96,0.001D0,101,127,122, 91, 0, 0,
50324 & 97,0.995D0, 0, 96, 59, 0, 0, 0,
50325 & 97,0.005D0, 0, 96,127,121, 0, 0,
50326 & 98,0.880D0, 0, 96, 21, 0, 0, 0,
50327 & 98,0.060D0, 0,104, 38, 0, 0, 0,
50328 & 98,0.060D0, 0, 99, 30, 0, 0, 0,
50329 & 99,0.998D0, 0, 93, 38, 0, 0, 0,
50330 & 99,0.001D0, 0, 93, 38, 59, 0, 0,
50331 & 99,0.001D0,101,127,122, 93, 0, 0,
50332 & 100,0.880D0, 0, 96, 38, 0, 0, 0,
50333 & 100,0.060D0, 0, 97, 38, 0, 0, 0,
50334 & 100,0.060D0, 0, 99, 21, 0, 0, 0,
50335 & 101,0.999D0, 0, 96, 38, 0, 0, 0/
50336 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 286, 304)/
50337 & 101,0.001D0,101,127,122, 96, 0, 0,
50338 & 102,0.667D0, 0,106, 38, 0, 0, 0,
50339 & 102,0.333D0, 0,101, 21, 0, 0, 0,
50340 & 103,1.000D0, 0, 91, 30, 0, 0, 0,
50341 & 104,0.516D0, 0, 91, 21, 0, 0, 0,
50342 & 104,0.483D0, 0, 93, 30, 0, 0, 0,
50343 & 104,0.001D0, 0, 91, 59, 0, 0, 0,
50344 & 105,0.880D0, 0, 96, 30, 0, 0, 0,
50345 & 105,0.060D0, 0,104, 21, 0, 0, 0,
50346 & 105,0.060D0, 0, 97, 30, 0, 0, 0,
50347 & 106,0.995D0, 0, 96, 21, 0, 0, 0,
50348 & 106,0.001D0, 0, 96, 59, 0, 0, 0,
50349 & 106,0.004D0, 0, 97, 59, 0, 0, 0,
50350 & 107,0.667D0, 0,101, 30, 0, 0, 0,
50351 & 107,0.333D0, 0,106, 21, 0, 0, 0,
50352 & 108,0.675D0, 0, 96, 46, 0, 0, 0,
50353 & 108,0.233D0, 0,106, 38, 0, 0, 0,
50354 & 108,0.086D0, 0,101, 21, 0, 0, 0,
50355 & 108,0.006D0,101,127,122,106, 0, 0/
50356 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 305, 323)/
50357 & 123,0.986D0,100,121,128,124, 0, 0,
50358 & 123,0.014D0, 0,121,128,124, 59, 0,
50359 & 125,0.178D0,100,121,128,126, 0, 0,
50360 & 125,0.171D0,100,123,130,126, 0, 0,
50361 & 125,0.002D0, 0,123,130, 59,126, 0,
50362 & 125,0.111D0, 0, 30,126, 0, 0, 0,
50363 & 125,0.253D0, 0, 31,126, 0, 0, 0,
50364 & 125,0.181D0, 0, 32,126, 0, 0, 0,
50365 & 125,0.002D0, 0, 30, 22, 21,126, 0,
50366 & 125,0.018D0, 0, 30, 24,126, 0, 0,
50367 & 125,0.004D0, 0, 30, 24, 21,126, 0,
50368 & 125,0.015D0, 0, 31, 23,126, 0, 0,
50369 & 125,0.001D0, 0, 31, 24, 21,126, 0,
50370 & 125,0.024D0, 0, 32, 21,126, 0, 0,
50371 & 125,0.002D0, 0, 32, 38, 30,126, 0,
50372 & 125,0.007D0, 0, 34,126, 0, 0, 0,
50373 & 125,0.014D0, 0, 35,126, 0, 0, 0,
50374 & 125,0.003D0, 0, 35, 21,126, 0, 0,
50375 & 125,0.001D0, 0, 34, 38, 30,126, 0/
50376 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 324, 342)/
50377 & 125,0.004D0, 0, 30, 43,126, 0, 0,
50378 & 125,0.003D0, 0, 34, 50,126, 0, 0,
50379 & 125,0.003D0, 0, 34, 51,126, 0, 0,
50380 & 125,0.003D0, 0, 30, 50, 42,126, 0,
50381 & 129,0.986D0,100,127,122,130, 0, 0,
50382 & 129,0.014D0, 0,127,122,130, 59, 0,
50383 & 131,0.178D0,100,127,122,132, 0, 0,
50384 & 131,0.171D0,100,129,124,132, 0, 0,
50385 & 131,0.002D0, 0,129,124, 59,132, 0,
50386 & 131,0.111D0, 0, 38,132, 0, 0, 0,
50387 & 131,0.253D0, 0, 39,132, 0, 0, 0,
50388 & 131,0.181D0, 0, 40,132, 0, 0, 0,
50389 & 131,0.002D0, 0, 38, 22, 21,132, 0,
50390 & 131,0.018D0, 0, 38, 24,132, 0, 0,
50391 & 131,0.004D0, 0, 38, 24, 21,132, 0,
50392 & 131,0.015D0, 0, 39, 23,132, 0, 0,
50393 & 131,0.001D0, 0, 39, 24, 21,132, 0,
50394 & 131,0.024D0, 0, 40, 21,132, 0, 0,
50395 & 131,0.002D0, 0, 40, 38, 30,132, 0/
50396 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 343, 361)/
50397 & 131,0.007D0, 0, 46,132, 0, 0, 0,
50398 & 131,0.014D0, 0, 47,132, 0, 0, 0,
50399 & 131,0.003D0, 0, 47, 21,132, 0, 0,
50400 & 131,0.001D0, 0, 46, 38, 30,132, 0,
50401 & 131,0.004D0, 0, 38, 51,132, 0, 0,
50402 & 131,0.003D0, 0, 46, 42,132, 0, 0,
50403 & 131,0.003D0, 0, 46, 43,132, 0, 0,
50404 & 131,0.003D0, 0, 38, 50, 42,132, 0,
50405 & 136,0.067D0,101,122,127, 42, 0, 0,
50406 & 136,0.067D0,101,124,129, 42, 0, 0,
50407 & 136,0.048D0,101,122,127, 43, 0, 0,
50408 & 136,0.048D0,101,124,129, 43, 0, 0,
50409 & 136,0.003D0, 0, 34, 38,122,127, 0,
50410 & 136,0.003D0, 0, 34, 38,124,129, 0,
50411 & 136,0.006D0,101,122,127, 21, 0, 0,
50412 & 136,0.006D0,101,124,129, 21, 0, 0,
50413 & 136,0.002D0,101,122,127, 23, 0, 0,
50414 & 136,0.002D0,101,124,129, 23, 0, 0,
50415 & 136,0.055D0, 0, 34, 38, 38, 0, 0/
50416 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 362, 380)/
50417 & 136,0.031D0, 0, 34, 39, 38, 0, 0,
50418 & 136,0.042D0, 0, 34, 38, 38, 21, 21,
50419 & 136,0.002D0, 0, 34, 38, 38, 38, 31,
50420 & 136,0.021D0, 0, 35, 38, 38, 0, 0,
50421 & 136,0.027D0, 0, 42, 38, 0, 0, 0,
50422 & 136,0.066D0, 0, 42, 39, 0, 0, 0,
50423 & 136,0.081D0, 0, 42, 40, 0, 0, 0,
50424 & 136,0.024D0, 0, 42, 38, 21, 0, 0,
50425 & 136,0.004D0, 0, 42, 38, 23, 0, 0,
50426 & 136,0.069D0, 0, 42, 38, 38, 30, 21,
50427 & 136,0.001D0, 0, 42, 38, 38, 30, 23,
50428 & 136,0.022D0, 0, 43, 38, 0, 0, 0,
50429 & 136,0.021D0, 0, 43, 39, 0, 0, 0,
50430 & 136,0.042D0, 0, 43, 38, 21, 0, 0,
50431 & 136,0.008D0, 0, 43, 38, 23, 0, 0,
50432 & 136,0.010D0, 0, 43, 38, 38, 30, 0,
50433 & 136,0.050D0, 0,311, 38, 0, 0, 0,
50434 & 136,0.034D0, 0,329, 38, 0, 0, 0,
50435 & 136,0.010D0, 0,369, 38, 0, 0, 0/
50436 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 381, 399)/
50437 & 136,0.031D0, 0, 46, 42, 42, 0, 0,
50438 & 136,0.003D0, 0, 38, 21, 0, 0, 0,
50439 & 136,0.001D0, 0, 38, 23, 0, 0, 0,
50440 & 136,0.002D0, 0, 38, 38, 30, 0, 0,
50441 & 136,0.008D0, 0, 38, 22, 0, 0, 0,
50442 & 136,0.001D0, 0, 38, 38, 38, 30, 30,
50443 & 136,0.003D0, 0, 38, 38, 38, 30, 31,
50444 & 136,0.008D0, 0, 46, 42, 0, 0, 0,
50445 & 136,0.005D0, 0, 46, 43, 0, 0, 0,
50446 & 136,0.026D0, 0, 47, 43, 0, 0, 0,
50447 & 136,0.005D0, 0, 46, 34, 38, 0, 0,
50448 & 136,0.007D0, 0, 38, 56, 0, 0, 0,
50449 & 136,0.023D0, 0, 38, 56, 21, 0, 0,
50450 & 136,0.005D0, 0, 46, 46, 34, 0, 0,
50451 & 137,0.683D0, 0,140, 38, 0, 0, 0,
50452 & 137,0.306D0, 0,136, 21, 0, 0, 0,
50453 & 137,0.011D0, 0,136, 59, 0, 0, 0,
50454 & 138,0.667D0, 0,141, 38, 0, 0, 0,
50455 & 138,0.333D0, 0,137, 21, 0, 0, 0/
50456 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 400, 418)/
50457 & 139,0.220D0, 0,140, 38, 0, 0, 0,
50458 & 139,0.110D0, 0,136, 21, 0, 0, 0,
50459 & 139,0.380D0, 0,141, 38, 0, 0, 0,
50460 & 139,0.190D0, 0,137, 21, 0, 0, 0,
50461 & 139,0.004D0, 0,136, 22, 0, 0, 0,
50462 & 139,0.064D0, 0,141, 38, 21, 0, 0,
50463 & 139,0.032D0, 0,137, 38, 30, 0, 0,
50464 & 140,0.037D0,101,122,127, 34, 0, 0,
50465 & 140,0.037D0,101,124,129, 34, 0, 0,
50466 & 140,0.016D0,101,122,127, 35, 0, 0,
50467 & 140,0.016D0,101,124,129, 35, 0, 0,
50468 & 140,0.013D0, 0, 34, 21,122,127, 0,
50469 & 140,0.013D0, 0, 34, 21,124,129, 0,
50470 & 140,0.012D0, 0, 42, 30,122,127, 0,
50471 & 140,0.012D0, 0, 42, 30,124,129, 0,
50472 & 140,0.003D0,101,122,127, 30, 0, 0,
50473 & 140,0.003D0,101,124,129, 30, 0, 0,
50474 & 140,0.039D0, 0, 34, 38, 0, 0, 0,
50475 & 140,0.091D0, 0, 34, 39, 0, 0, 0/
50476 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 419, 437)/
50477 & 140,0.067D0, 0, 34, 40, 0, 0, 0,
50478 & 140,0.004D0, 0, 34, 38, 21, 0, 0,
50479 & 140,0.100D0, 0, 34, 38, 21, 21, 0,
50480 & 140,0.058D0, 0, 34, 38, 23, 0, 0,
50481 & 140,0.020D0, 0, 34, 38, 24, 0, 0,
50482 & 140,0.006D0, 0, 34, 38, 25, 0, 0,
50483 & 140,0.043D0, 0, 35, 38, 0, 0, 0,
50484 & 140,0.035D0, 0, 35, 39, 0, 0, 0,
50485 & 140,0.007D0, 0,312, 38, 0, 0, 0,
50486 & 140,0.007D0, 0,330, 38, 0, 0, 0,
50487 & 140,0.020D0, 0, 42, 21, 0, 0, 0,
50488 & 140,0.006D0, 0, 42, 22, 0, 0, 0,
50489 & 140,0.009D0, 0, 42, 23, 0, 0, 0,
50490 & 140,0.016D0, 0, 42, 24, 0, 0, 0,
50491 & 140,0.014D0, 0, 42, 25, 0, 0, 0,
50492 & 140,0.003D0, 0, 42,293, 0, 0, 0,
50493 & 140,0.007D0, 0, 42, 56, 0, 0, 0,
50494 & 140,0.003D0, 0, 42, 26, 0, 0, 0,
50495 & 140,0.004D0, 0, 42,294, 0, 0, 0/
50496 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 438, 456)/
50497 & 140,0.006D0, 0, 42, 21, 21, 0, 0,
50498 & 140,0.042D0, 0, 42, 38, 30, 21, 0,
50499 & 140,0.004D0, 0, 42, 38, 38, 30, 30,
50500 & 140,0.076D0, 0, 42, 38, 30, 21, 21,
50501 & 140,0.026D0, 0, 43, 21, 0, 0, 0,
50502 & 140,0.014D0, 0, 43, 22, 0, 0, 0,
50503 & 140,0.014D0, 0, 43, 23, 0, 0, 0,
50504 & 140,0.011D0, 0, 43, 24, 0, 0, 0,
50505 & 140,0.018D0, 0, 43, 38, 30, 0, 0,
50506 & 140,0.004D0, 0, 42, 46, 34, 0, 0,
50507 & 140,0.004D0, 0, 42, 46, 34, 21, 0,
50508 & 140,0.005D0, 0, 42, 42, 50, 0, 0,
50509 & 140,0.002D0, 0, 38, 30, 0, 0, 0,
50510 & 140,0.001D0, 0, 21, 21, 0, 0, 0,
50511 & 140,0.008D0, 0, 38, 30, 21, 0, 0,
50512 & 140,0.007D0, 0, 38, 38, 30, 30, 0,
50513 & 140,0.015D0, 0, 38, 38, 30, 30, 21,
50514 & 140,0.004D0, 0, 46, 34, 0, 0, 0,
50515 & 140,0.003D0, 0, 47, 34, 0, 0, 0/
50516 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 457, 475)/
50517 & 140,0.002D0, 0, 46, 35, 0, 0, 0,
50518 & 140,0.001D0, 0, 50, 42, 0, 0, 0,
50519 & 140,0.002D0, 0, 51, 43, 0, 0, 0,
50520 & 140,0.003D0, 0, 50, 34, 38, 0, 0,
50521 & 140,0.003D0, 0, 42, 46, 30, 0, 0,
50522 & 140,0.001D0, 0, 46, 34, 38, 30, 21,
50523 & 140,0.002D0, 0, 56, 23, 0, 0, 0,
50524 & 140,0.001D0, 0, 56, 38, 30, 0, 0,
50525 & 141,0.636D0, 0,140, 21, 0, 0, 0,
50526 & 141,0.364D0, 0,140, 59, 0, 0, 0,
50527 & 142,0.667D0, 0,137, 30, 0, 0, 0,
50528 & 142,0.333D0, 0,141, 21, 0, 0, 0,
50529 & 143,0.220D0, 0,136, 30, 0, 0, 0,
50530 & 143,0.110D0, 0,140, 21, 0, 0, 0,
50531 & 143,0.380D0, 0,137, 30, 0, 0, 0,
50532 & 143,0.190D0, 0,141, 21, 0, 0, 0,
50533 & 143,0.004D0, 0,140, 22, 0, 0, 0,
50534 & 143,0.064D0, 0,137, 30, 21, 0, 0,
50535 & 143,0.032D0, 0,141, 38, 30, 0, 0/
50536 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 476, 494)/
50537 & 144,0.009D0, 0,124,129, 0, 0, 0,
50538 & 144,0.019D0,101,122,127, 56, 0, 0,
50539 & 144,0.019D0,101,124,129, 56, 0, 0,
50540 & 144,0.025D0,101,122,127, 22, 0, 0,
50541 & 144,0.025D0,101,124,129, 22, 0, 0,
50542 & 144,0.009D0,101,122,127, 25, 0, 0,
50543 & 144,0.009D0,101,124,129, 25, 0, 0,
50544 & 144,0.036D0, 0, 46, 42, 0, 0, 0,
50545 & 144,0.034D0, 0, 46, 43, 0, 0, 0,
50546 & 144,0.007D0, 0, 46,329, 0, 0, 0,
50547 & 144,0.043D0, 0, 47, 42, 0, 0, 0,
50548 & 144,0.058D0, 0, 47, 43, 0, 0, 0,
50549 & 144,0.011D0, 0, 46, 34, 38, 0, 0,
50550 & 144,0.055D0, 0, 46, 34, 38, 21, 0,
50551 & 144,0.003D0, 0, 46, 34, 38, 38, 30,
50552 & 144,0.014D0, 0, 46, 42, 38, 30, 0,
50553 & 144,0.017D0, 0, 50, 34, 38, 38, 0,
50554 & 144,0.036D0, 0, 56, 38, 0, 0, 0,
50555 & 144,0.067D0, 0, 56, 39, 0, 0, 0/
50556 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 495, 513)/
50557 & 144,0.023D0, 0, 56, 38, 21, 0, 0,
50558 & 144,0.018D0, 0, 56, 38, 38, 30, 0,
50559 & 144,0.020D0, 0, 22, 38, 0, 0, 0,
50560 & 144,0.001D0, 0, 23, 38, 0, 0, 0,
50561 & 144,0.009D0, 0, 24, 38, 0, 0, 0,
50562 & 144,0.049D0, 0, 25, 38, 0, 0, 0,
50563 & 144,0.011D0, 0,293, 38, 0, 0, 0,
50564 & 144,0.015D0, 0, 22, 38, 21, 0, 0,
50565 & 144,0.016D0, 0, 25, 38, 21, 0, 0,
50566 & 144,0.103D0, 0, 22, 39, 0, 0, 0,
50567 & 144,0.120D0, 0, 25, 39, 0, 0, 0,
50568 & 144,0.010D0, 0, 38, 38, 30, 0, 0,
50569 & 144,0.046D0, 0, 38, 38, 30, 21, 0,
50570 & 144,0.003D0, 0, 38, 38, 38, 30, 30,
50571 & 144,0.042D0, 0, 38, 30, 30, 38, 39,
50572 & 144,0.001D0, 0, 46, 23, 0, 0, 0,
50573 & 144,0.005D0, 0, 46, 38, 30, 0, 0,
50574 & 144,0.001D0, 0, 46, 56, 0, 0, 0,
50575 & 144,0.004D0, 0, 50, 38, 0, 0, 0/
50576 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 514, 532)/
50577 & 144,0.007D0, 0, 51, 38, 0, 0, 0,
50578 & 145,0.900D0, 0,144, 59, 0, 0, 0,
50579 & 145,0.100D0, 0,144, 21, 0, 0, 0,
50580 & 146,0.500D0, 0,137, 50, 0, 0, 0,
50581 & 146,0.500D0, 0,141, 46, 0, 0, 0,
50582 & 147,0.440D0, 0,136, 50, 0, 0, 0,
50583 & 147,0.440D0, 0,140, 46, 0, 0, 0,
50584 & 147,0.055D0, 0,137, 50, 0, 0, 0,
50585 & 147,0.055D0, 0,141, 46, 0, 0, 0,
50586 & 147,0.010D0, 0,144, 22, 0, 0, 0,
50587 & 148,1.000D0, 0,150, 38, 0, 0, 0,
50588 & 149,1.000D0, 0,150, 38, 0, 0, 0,
50589 & 150,0.028D0,101,122,127, 78, 0, 0,
50590 & 150,0.010D0,101,122,127, 80, 0, 0,
50591 & 150,0.028D0,101,124,129, 78, 0, 0,
50592 & 150,0.010D0,101,124,129, 80, 0, 0,
50593 & 150,0.026D0, 0, 73, 42, 0, 0, 0,
50594 & 150,0.030D0, 0, 73, 42, 21, 0, 0,
50595 & 150,0.029D0, 0, 73, 42, 38, 30, 0/
50596 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 533, 551)/
50597 & 150,0.014D0, 0, 73, 42, 22, 0, 0,
50598 & 150,0.020D0, 0, 73, 43, 0, 0, 0,
50599 & 150,0.029D0, 0, 73, 34, 38, 0, 0,
50600 & 150,0.039D0, 0, 73, 34, 38, 21, 0,
50601 & 150,0.002D0, 0, 73, 34, 38, 38, 30,
50602 & 150,0.010D0, 0, 73, 34, 38, 21, 21,
50603 & 150,0.014D0, 0, 73, 35, 38, 0, 0,
50604 & 150,0.010D0, 0, 74, 42, 0, 0, 0,
50605 & 150,0.020D0, 0, 74, 43, 0, 0, 0,
50606 & 150,0.010D0, 0, 74, 43, 21, 0, 0,
50607 & 150,0.007D0, 0, 85, 34, 0, 0, 0,
50608 & 150,0.014D0, 0, 85, 35, 0, 0, 0,
50609 & 150,0.004D0, 0, 73,293, 0, 0, 0,
50610 & 150,0.003D0, 0, 73, 38, 30, 0, 0,
50611 & 150,0.003D0, 0, 73, 38, 30, 38, 30,
50612 & 150,0.001D0, 0, 73, 56, 0, 0, 0,
50613 & 150,0.002D0, 0, 73, 46, 34, 0, 0,
50614 & 150,0.010D0, 0, 78, 38, 0, 0, 0,
50615 & 150,0.020D0, 0, 78, 39, 0, 0, 0/
50616 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 552, 570)/
50617 & 150,0.030D0, 0, 78, 38, 21, 0, 0,
50618 & 150,0.010D0, 0, 78, 38, 22, 0, 0,
50619 & 150,0.020D0, 0, 78, 38, 24, 0, 0,
50620 & 150,0.035D0, 0, 78, 38, 38, 30, 0,
50621 & 150,0.020D0, 0, 78, 38, 21, 21, 0,
50622 & 150,0.010D0, 0, 78, 38, 38, 30, 21,
50623 & 150,0.010D0, 0, 78, 38, 21, 21, 21,
50624 & 150,0.007D0, 0, 78, 46, 42, 0, 0,
50625 & 150,0.011D0, 0, 79, 38, 0, 0, 0,
50626 & 150,0.022D0, 0, 79, 38, 21, 0, 0,
50627 & 150,0.013D0, 0, 79, 38, 38, 30, 0,
50628 & 150,0.010D0, 0, 79, 38, 21, 21, 0,
50629 & 150,0.007D0, 0, 79, 38, 38, 30, 21,
50630 & 150,0.005D0, 0, 79, 38, 21, 21, 21,
50631 & 150,0.005D0, 0, 80, 38, 0, 0, 0,
50632 & 150,0.015D0, 0, 80, 39, 0, 0, 0,
50633 & 150,0.011D0, 0, 86, 21, 0, 0, 0,
50634 & 150,0.007D0, 0, 86, 22, 0, 0, 0,
50635 & 150,0.010D0, 0, 86, 23, 0, 0, 0/
50636 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 571, 589)/
50637 & 150,0.031D0, 0, 86, 24, 0, 0, 0,
50638 & 150,0.010D0, 0, 86, 25, 0, 0, 0,
50639 & 150,0.004D0, 0, 86, 56, 0, 0, 0,
50640 & 150,0.026D0, 0, 86, 38, 30, 0, 0,
50641 & 150,0.005D0, 0, 86, 38, 38, 30, 30,
50642 & 150,0.005D0, 0, 86, 38, 30, 21, 21,
50643 & 150,0.005D0, 0, 87, 21, 0, 0, 0,
50644 & 150,0.006D0, 0, 87, 23, 0, 0, 0,
50645 & 150,0.004D0, 0, 86, 46, 34, 0, 0,
50646 & 150,0.002D0, 0, 86, 46, 30, 0, 0,
50647 & 150,0.001D0, 0, 86, 46, 30, 21, 0,
50648 & 150,0.016D0, 0, 81, 38, 38, 0, 0,
50649 & 150,0.003D0, 0, 88, 46, 0, 0, 0,
50650 & 150,0.002D0, 0, 89, 46, 0, 0, 0,
50651 & 150,0.003D0, 0, 83, 46, 38, 0, 0,
50652 & 150,0.040D0, 0, 75, 46, 21, 0, 0,
50653 & 150,0.040D0, 0, 75, 46, 38, 30, 0,
50654 & 150,0.020D0, 0, 75, 46, 21, 21, 0,
50655 & 150,0.010D0, 0, 75, 46, 38, 30, 21/
50656 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 590, 608)/
50657 & 150,0.010D0, 0, 75, 46, 21, 21, 21,
50658 & 150,0.020D0, 0, 75, 47, 21, 0, 0,
50659 & 150,0.040D0, 0, 75, 42, 38, 0, 0,
50660 & 150,0.020D0, 0, 75, 42, 39, 0, 0,
50661 & 150,0.010D0, 0, 75, 42, 38, 38, 30,
50662 & 150,0.010D0, 0, 75, 42, 38, 21, 21,
50663 & 150,0.006D0, 0, 75, 43, 38, 0, 0,
50664 & 151,1.000D0, 0,150, 21, 0, 0, 0,
50665 & 152,1.000D0, 0,150, 21, 0, 0, 0,
50666 & 153,1.000D0, 0,150, 30, 0, 0, 0,
50667 & 154,1.000D0, 0,150, 30, 0, 0, 0,
50668 & 155,0.045D0,101,122,127, 88, 0, 0,
50669 & 155,0.005D0,101,122,127, 89, 0, 0,
50670 & 155,0.045D0,101,124,129, 88, 0, 0,
50671 & 155,0.005D0,101,124,129, 89, 0, 0,
50672 & 155,0.021D0, 0, 86, 42, 0, 0, 0,
50673 & 155,0.032D0, 0, 87, 42, 0, 0, 0,
50674 & 155,0.032D0, 0, 79, 38, 42, 0, 0,
50675 & 155,0.045D0, 0, 86, 43, 0, 0, 0/
50676 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 609, 627)/
50677 & 155,0.065D0, 0, 87, 43, 0, 0, 0,
50678 & 155,0.065D0, 0, 79, 38, 43, 0, 0,
50679 & 155,0.055D0, 0, 88, 38, 0, 0, 0,
50680 & 155,0.160D0, 0, 88, 39, 0, 0, 0,
50681 & 155,0.105D0, 0, 89, 38, 0, 0, 0,
50682 & 155,0.320D0, 0, 89, 39, 0, 0, 0,
50683 & 156,1.000D0, 0,155, 59, 0, 0, 0,
50684 & 157,0.667D0, 0,158, 38, 0, 0, 0,
50685 & 157,0.333D0, 0,155, 21, 0, 0, 0,
50686 & 158,0.045D0,101,122,127, 83, 0, 0,
50687 & 158,0.045D0,101,124,129, 83, 0, 0,
50688 & 158,0.005D0,101,122,127, 84, 0, 0,
50689 & 158,0.005D0,101,124,129, 84, 0, 0,
50690 & 158,0.020D0, 0, 79, 42, 0, 0, 0,
50691 & 158,0.020D0, 0, 79, 21, 42, 0, 0,
50692 & 158,0.020D0, 0, 80, 42, 0, 0, 0,
50693 & 158,0.060D0, 0, 79, 43, 0, 0, 0,
50694 & 158,0.060D0, 0, 79, 21, 43, 0, 0,
50695 & 158,0.060D0, 0, 80, 43, 0, 0, 0/
50696 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 628, 646)/
50697 & 158,0.020D0, 0, 86, 34, 0, 0, 0,
50698 & 158,0.060D0, 0, 86, 35, 0, 0, 0,
50699 & 158,0.040D0, 0, 87, 34, 0, 0, 0,
50700 & 158,0.120D0, 0, 87, 35, 0, 0, 0,
50701 & 158,0.020D0, 0, 83, 38, 0, 0, 0,
50702 & 158,0.060D0, 0, 83, 39, 0, 0, 0,
50703 & 158,0.040D0, 0, 84, 38, 0, 0, 0,
50704 & 158,0.120D0, 0, 84, 39, 0, 0, 0,
50705 & 158,0.010D0, 0, 88, 21, 0, 0, 0,
50706 & 158,0.030D0, 0, 88, 23, 0, 0, 0,
50707 & 158,0.020D0, 0, 89, 21, 0, 0, 0,
50708 & 158,0.060D0, 0, 89, 23, 0, 0, 0,
50709 & 158,0.030D0, 0, 88, 56, 0, 0, 0,
50710 & 158,0.030D0, 0, 90, 46, 0, 0, 0,
50711 & 159,1.000D0, 0,158, 59, 0, 0, 0,
50712 & 160,0.670D0, 0,155, 30, 0, 0, 0,
50713 & 160,0.330D0, 0,158, 21, 0, 0, 0,
50714 & 161,0.050D0,101,122,127, 90, 0, 0,
50715 & 161,0.050D0,101,124,129, 90, 0, 0/
50716 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 647, 665)/
50717 & 161,0.075D0, 0, 88, 42, 0, 0, 0,
50718 & 161,0.225D0, 0, 88, 43, 0, 0, 0,
50719 & 161,0.150D0, 0, 89, 42, 0, 0, 0,
50720 & 161,0.450D0, 0, 89, 43, 0, 0, 0,
50721 & 162,1.000D0, 0,161, 59, 0, 0, 0,
50722 & 163,0.028D0, 0, 25, 38, 30, 0, 0,
50723 & 163,0.014D0, 0, 25, 21, 21, 0, 0,
50724 & 163,0.018D0, 0, 39, 31, 0, 0, 0,
50725 & 163,0.009D0, 0, 23, 23, 0, 0, 0,
50726 & 163,0.010D0, 0, 51, 34, 38, 0, 0,
50727 & 163,0.010D0, 0, 43, 47, 30, 0, 0,
50728 & 163,0.004D0, 0, 51, 43, 0, 0, 0,
50729 & 163,0.004D0, 0, 47, 35, 0, 0, 0,
50730 & 163,0.007D0, 0, 56, 56, 0, 0, 0,
50731 & 163,0.022D0, 0, 46, 42, 30, 0, 0,
50732 & 163,0.011D0, 0, 46, 34, 21, 0, 0,
50733 & 163,0.011D0, 0, 50, 42, 21, 0, 0,
50734 & 163,0.022D0, 0, 50, 34, 38, 0, 0,
50735 & 163,0.032D0, 0, 22, 38, 30, 0, 0/
50736 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 666, 684)/
50737 & 163,0.016D0, 0, 22, 21, 21, 0, 0,
50738 & 163,0.020D0, 0, 38, 30, 46, 34, 0,
50739 & 163,0.012D0, 0, 38, 30, 38, 30, 0,
50740 & 163,0.001D0, 0, 73, 91, 0, 0, 0,
50741 & 163,0.001D0, 0, 59, 59, 0, 0, 0,
50742 & 163,0.748D0, 0, 13, 13, 0, 0, 0,
50743 & 164,0.060D0, 0,121,127, 0, 0, 0,
50744 & 164,0.060D0, 0,123,129, 0, 0, 0,
50745 & 164,0.004D0, 0, 39, 30, 0, 0, 0,
50746 & 164,0.004D0, 0, 23, 21, 0, 0, 0,
50747 & 164,0.004D0, 0, 31, 38, 0, 0, 0,
50748 & 164,0.003D0, 0, 41, 31, 0, 0, 0,
50749 & 164,0.003D0, 0, 29, 23, 0, 0, 0,
50750 & 164,0.003D0, 0, 33, 39, 0, 0, 0,
50751 & 164,0.009D0, 0, 24, 38, 38, 30, 30,
50752 & 164,0.007D0, 0, 24, 38, 30, 0, 0,
50753 & 164,0.003D0, 0, 51, 45, 0, 0, 0,
50754 & 164,0.003D0, 0, 43, 53, 0, 0, 0,
50755 & 164,0.003D0, 0, 24, 51, 42, 0, 0/
50756 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 685, 703)/
50757 & 164,0.003D0, 0, 24, 43, 50, 0, 0,
50758 & 164,0.004D0, 0, 24, 26, 0, 0, 0,
50759 & 164,0.003D0, 0, 46, 35, 0, 0, 0,
50760 & 164,0.003D0, 0, 34, 47, 0, 0, 0,
50761 & 164,0.002D0, 0, 50, 43, 0, 0, 0,
50762 & 164,0.002D0, 0, 42, 51, 0, 0, 0,
50763 & 164,0.003D0, 0, 24, 21, 21, 0, 0,
50764 & 164,0.002D0, 0,286, 30, 0, 0, 0,
50765 & 164,0.002D0, 0,287, 38, 0, 0, 0,
50766 & 164,0.003D0, 0, 24, 46, 42, 30, 0,
50767 & 164,0.003D0, 0, 24, 34, 50, 38, 0,
50768 & 164,0.002D0, 0,285, 21, 0, 0, 0,
50769 & 164,0.001D0, 0, 56, 51, 42, 0, 0,
50770 & 164,0.001D0, 0, 56, 43, 50, 0, 0,
50771 & 164,0.001D0, 0, 24, 50, 42, 0, 0,
50772 & 164,0.001D0, 0, 24, 46, 34, 0, 0,
50773 & 164,0.002D0, 0, 56, 38, 30, 38, 30,
50774 & 164,0.002D0, 0, 85, 91, 30, 0, 0,
50775 & 164,0.002D0, 0,103, 73, 38, 0, 0/
50776 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 704, 722)/
50777 & 164,0.002D0, 0, 24, 22, 0, 0, 0,
50778 & 164,0.001D0, 0, 56, 50, 42, 0, 0,
50779 & 164,0.001D0, 0, 56, 46, 34, 0, 0,
50780 & 164,0.001D0, 0, 73, 91, 24, 0, 0,
50781 & 164,0.001D0, 0, 85,103, 0, 0, 0,
50782 & 164,0.001D0, 0, 82,100, 0, 0, 0,
50783 & 164,0.001D0, 0, 87,105, 0, 0, 0,
50784 & 164,0.001D0, 0, 73, 91, 25, 0, 0,
50785 & 164,0.001D0, 0, 56, 58, 0, 0, 0,
50786 & 164,0.001D0, 0, 56, 38, 30, 0, 0,
50787 & 164,0.001D0, 0, 56, 46, 42, 30, 0,
50788 & 164,0.001D0, 0, 56, 34, 50, 38, 0,
50789 & 164,0.001D0, 0, 56, 22, 0, 0, 0,
50790 & 164,0.001D0, 0, 84,102, 0, 0, 0,
50791 & 164,0.001D0, 0, 73, 34, 98, 0, 0,
50792 & 164,0.001D0, 0, 91, 46, 80, 0, 0,
50793 & 164,0.034D0, 0, 38, 38, 30, 30, 21,
50794 & 164,0.029D0, 0, 23, 23, 23, 21, 0,
50795 & 164,0.015D0, 0, 38, 30, 21, 0, 0/
50796 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 723, 741)/
50797 & 164,0.012D0, 0, 38, 30, 21, 34, 46,
50798 & 164,0.009D0, 0, 23, 23, 23, 24, 0,
50799 & 164,0.007D0, 0, 38, 30, 34, 46, 0,
50800 & 164,0.002D0, 0, 46, 42, 30, 0, 0,
50801 & 164,0.001D0, 0, 46, 34, 21, 0, 0,
50802 & 164,0.001D0, 0, 50, 42, 21, 0, 0,
50803 & 164,0.002D0, 0, 50, 34, 38, 0, 0,
50804 & 164,0.006D0, 0, 73, 91, 38, 30, 0,
50805 & 164,0.004D0, 0, 38, 30, 38, 30, 0,
50806 & 164,0.004D0, 0, 38, 30, 38, 30, 23,
50807 & 164,0.004D0, 0, 75, 93, 38, 30, 0,
50808 & 164,0.001D0, 0, 86,104, 0, 0, 0,
50809 & 164,0.001D0, 0, 79, 97, 0, 0, 0,
50810 & 164,0.001D0, 0, 81, 99, 0, 0, 0,
50811 & 164,0.003D0, 0, 23, 23, 34, 46, 0,
50812 & 164,0.002D0, 0, 73, 91, 38, 30, 21,
50813 & 164,0.002D0, 0, 73, 91, 0, 0, 0,
50814 & 164,0.002D0, 0, 73, 91, 22, 0, 0,
50815 & 164,0.002D0, 0, 73, 93, 30, 0, 0/
50816 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 742, 760)/
50817 & 164,0.002D0, 0, 75, 93, 0, 0, 0,
50818 & 164,0.001D0, 0, 83,102, 0, 0, 0,
50819 & 164,0.001D0, 0, 88,106, 0, 0, 0,
50820 & 164,0.001D0, 0, 78, 96, 0, 0, 0,
50821 & 164,0.001D0, 0, 73, 91, 21, 0, 0,
50822 & 164,0.001D0, 0, 78,104, 38, 0, 0,
50823 & 164,0.001D0, 0, 96, 86, 30, 0, 0,
50824 & 164,0.001D0, 0, 73, 34, 96, 0, 0,
50825 & 164,0.001D0, 0, 91, 46, 78, 0, 0,
50826 & 164,0.001D0, 0, 46, 34, 46, 34, 0,
50827 & 164,0.013D0, 0, 59,163, 0, 0, 0,
50828 & 164,0.008D0, 0, 59, 38, 30, 21, 21,
50829 & 164,0.004D0, 0, 59, 22, 38, 30, 0,
50830 & 164,0.002D0, 0, 59, 22, 21, 21, 0,
50831 & 164,0.003D0, 0, 59, 39, 31, 0, 0,
50832 & 164,0.002D0, 0, 59, 23, 23, 0, 0,
50833 & 164,0.004D0, 0, 59, 25, 0, 0, 0,
50834 & 164,0.003D0, 0, 59, 38, 30, 38, 30,
50835 & 164,0.002D0, 0, 59, 24, 24, 0, 0/
50836 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 761, 779)/
50837 & 164,0.001D0, 0, 59, 26, 0, 0, 0,
50838 & 164,0.001D0, 0, 59, 22, 0, 0, 0,
50839 & 164,0.001D0, 0, 59, 28, 0, 0, 0,
50840 & 164,0.001D0, 0, 59, 58, 0, 0, 0,
50841 & 164,0.020D0, 0, 1, 7, 0, 0, 0,
50842 & 164,0.080D0, 0, 2, 8, 0, 0, 0,
50843 & 164,0.020D0, 0, 3, 9, 0, 0, 0,
50844 & 164,0.364D0,130, 13, 13, 13, 0, 0,
50845 & 164,0.091D0,130, 13, 13, 59, 0, 0,
50846 & 165,0.037D0, 0, 38, 30, 38, 30, 0,
50847 & 165,0.030D0, 0, 38, 30, 46, 34, 0,
50848 & 165,0.016D0, 0, 23, 38, 30, 0, 0,
50849 & 165,0.015D0, 0, 23, 38, 30, 38, 30,
50850 & 165,0.004D0, 0, 46, 43, 30, 0, 0,
50851 & 165,0.002D0, 0, 46, 35, 21, 0, 0,
50852 & 165,0.002D0, 0, 51, 43, 21, 0, 0,
50853 & 165,0.004D0, 0, 51, 35, 38, 0, 0,
50854 & 165,0.008D0, 0, 38, 30, 0, 0, 0,
50855 & 165,0.007D0, 0, 46, 34, 0, 0, 0/
50856 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 780, 798)/
50857 & 165,0.005D0, 0, 38, 30, 73, 91, 0,
50858 & 165,0.003D0, 0, 21, 21, 0, 0, 0,
50859 & 165,0.003D0, 0, 22, 22, 0, 0, 0,
50860 & 165,0.007D0, 0, 59,164, 0, 0, 0,
50861 & 165,0.857D0, 0, 13, 13, 0, 0, 0,
50862 & 166,0.008D0, 0,121,127, 0, 0, 0,
50863 & 166,0.008D0, 0,123,129, 0, 0, 0,
50864 & 166,0.001D0, 0,125,131, 0, 0, 0,
50865 & 166,0.338D0, 0,164, 38, 30, 0, 0,
50866 & 166,0.169D0, 0,164, 21, 21, 0, 0,
50867 & 166,0.027D0, 0,164, 22, 0, 0, 0,
50868 & 166,0.001D0, 0,164, 21, 0, 0, 0,
50869 & 166,0.004D0, 0, 23, 23, 23, 21, 0,
50870 & 166,0.003D0, 0, 23, 23, 21, 0, 0,
50871 & 166,0.002D0, 0, 38, 30, 46, 34, 0,
50872 & 166,0.001D0, 0, 38, 30, 73, 91, 0,
50873 & 166,0.093D0, 0, 59,165, 0, 0, 0,
50874 & 166,0.087D0, 0, 59,302, 0, 0, 0,
50875 & 166,0.078D0, 0, 59,303, 0, 0, 0/
50876 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 799, 817)/
50877 & 166,0.003D0, 0, 59,163, 0, 0, 0,
50878 & 166,0.003D0, 0, 1, 7, 0, 0, 0,
50879 & 166,0.012D0, 0, 2, 8, 0, 0, 0,
50880 & 166,0.003D0, 0, 3, 9, 0, 0, 0,
50881 & 166,0.127D0,130, 13, 13, 13, 0, 0,
50882 & 166,0.032D0,130, 13, 13, 59, 0, 0,
50883 & 167,0.500D0, 0,136,171, 0, 0, 0,
50884 & 167,0.500D0, 0,140,175, 0, 0, 0,
50885 & 171,0.067D0,101,128,121, 50, 0, 0,
50886 & 171,0.067D0,101,130,123, 50, 0, 0,
50887 & 171,0.048D0,101,128,121, 51, 0, 0,
50888 & 171,0.048D0,101,130,123, 51, 0, 0,
50889 & 171,0.003D0, 0,128,121, 46, 30, 0,
50890 & 171,0.003D0, 0,130,123, 46, 30, 0,
50891 & 171,0.006D0,101,128,121, 21, 0, 0,
50892 & 171,0.006D0,101,130,123, 21, 0, 0,
50893 & 171,0.002D0,101,128,121, 23, 0, 0,
50894 & 171,0.002D0,101,130,123, 23, 0, 0,
50895 & 171,0.055D0, 0, 46, 30, 30, 0, 0/
50896 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 818, 836)/
50897 & 171,0.031D0, 0, 46, 31, 30, 0, 0,
50898 & 171,0.042D0, 0, 46, 30, 30, 21, 21,
50899 & 171,0.002D0, 0, 46, 30, 30, 30, 39,
50900 & 171,0.021D0, 0, 47, 30, 30, 0, 0,
50901 & 171,0.027D0, 0, 50, 30, 0, 0, 0,
50902 & 171,0.066D0, 0, 50, 31, 0, 0, 0,
50903 & 171,0.081D0, 0, 50, 32, 0, 0, 0,
50904 & 171,0.024D0, 0, 50, 30, 21, 0, 0,
50905 & 171,0.004D0, 0, 50, 30, 23, 0, 0,
50906 & 171,0.069D0, 0, 50, 30, 30, 38, 21,
50907 & 171,0.001D0, 0, 50, 30, 30, 38, 23,
50908 & 171,0.022D0, 0, 51, 30, 0, 0, 0,
50909 & 171,0.021D0, 0, 51, 31, 0, 0, 0,
50910 & 171,0.042D0, 0, 51, 30, 21, 0, 0,
50911 & 171,0.008D0, 0, 51, 30, 23, 0, 0,
50912 & 171,0.010D0, 0, 51, 30, 30, 38, 0,
50913 & 171,0.050D0, 0,309, 30, 0, 0, 0,
50914 & 171,0.034D0, 0,328, 30, 0, 0, 0,
50915 & 171,0.010D0, 0,368, 30, 0, 0, 0/
50916 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 837, 855)/
50917 & 171,0.031D0, 0, 34, 50, 50, 0, 0,
50918 & 171,0.003D0, 0, 30, 21, 0, 0, 0,
50919 & 171,0.001D0, 0, 30, 23, 0, 0, 0,
50920 & 171,0.002D0, 0, 30, 30, 38, 0, 0,
50921 & 171,0.008D0, 0, 30, 22, 0, 0, 0,
50922 & 171,0.001D0, 0, 30, 30, 30, 38, 38,
50923 & 171,0.003D0, 0, 30, 30, 30, 38, 39,
50924 & 171,0.008D0, 0, 34, 50, 0, 0, 0,
50925 & 171,0.005D0, 0, 34, 51, 0, 0, 0,
50926 & 171,0.026D0, 0, 35, 51, 0, 0, 0,
50927 & 171,0.005D0, 0, 34, 46, 30, 0, 0,
50928 & 171,0.007D0, 0, 30, 56, 0, 0, 0,
50929 & 171,0.023D0, 0, 30, 56, 21, 0, 0,
50930 & 171,0.005D0, 0, 34, 34, 46, 0, 0,
50931 & 172,0.683D0, 0,175, 30, 0, 0, 0,
50932 & 172,0.306D0, 0,171, 21, 0, 0, 0,
50933 & 172,0.011D0, 0,171, 59, 0, 0, 0,
50934 & 173,0.667D0, 0,176, 30, 0, 0, 0,
50935 & 173,0.333D0, 0,172, 21, 0, 0, 0/
50936 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 856, 874)/
50937 & 174,0.220D0, 0,175, 30, 0, 0, 0,
50938 & 174,0.110D0, 0,171, 21, 0, 0, 0,
50939 & 174,0.380D0, 0,176, 30, 0, 0, 0,
50940 & 174,0.190D0, 0,172, 21, 0, 0, 0,
50941 & 174,0.004D0, 0,171, 22, 0, 0, 0,
50942 & 174,0.064D0, 0,176, 30, 21, 0, 0,
50943 & 174,0.032D0, 0,172, 38, 30, 0, 0,
50944 & 175,0.037D0,101,128,121, 46, 0, 0,
50945 & 175,0.037D0,101,130,123, 46, 0, 0,
50946 & 175,0.016D0,101,128,121, 47, 0, 0,
50947 & 175,0.016D0,101,130,123, 47, 0, 0,
50948 & 175,0.013D0, 0,128,121, 46, 21, 0,
50949 & 175,0.013D0, 0,130,123, 46, 21, 0,
50950 & 175,0.012D0, 0,128,121, 50, 38, 0,
50951 & 175,0.012D0, 0,130,123, 50, 38, 0,
50952 & 175,0.003D0,101,128,121, 38, 0, 0,
50953 & 175,0.003D0,101,130,123, 38, 0, 0,
50954 & 175,0.039D0, 0, 46, 30, 0, 0, 0,
50955 & 175,0.091D0, 0, 46, 31, 0, 0, 0/
50956 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 875, 893)/
50957 & 175,0.067D0, 0, 46, 32, 0, 0, 0,
50958 & 175,0.004D0, 0, 46, 30, 21, 0, 0,
50959 & 175,0.100D0, 0, 46, 30, 21, 21, 0,
50960 & 175,0.058D0, 0, 46, 30, 23, 0, 0,
50961 & 175,0.020D0, 0, 46, 30, 24, 0, 0,
50962 & 175,0.006D0, 0, 46, 30, 25, 0, 0,
50963 & 175,0.043D0, 0, 47, 30, 0, 0, 0,
50964 & 175,0.035D0, 0, 47, 31, 0, 0, 0,
50965 & 175,0.007D0, 0,310, 30, 0, 0, 0,
50966 & 175,0.007D0, 0,327, 30, 0, 0, 0,
50967 & 175,0.020D0, 0, 50, 21, 0, 0, 0,
50968 & 175,0.006D0, 0, 50, 22, 0, 0, 0,
50969 & 175,0.009D0, 0, 50, 23, 0, 0, 0,
50970 & 175,0.016D0, 0, 50, 24, 0, 0, 0,
50971 & 175,0.014D0, 0, 50, 25, 0, 0, 0,
50972 & 175,0.003D0, 0, 50,293, 0, 0, 0,
50973 & 175,0.007D0, 0, 50, 56, 0, 0, 0,
50974 & 175,0.003D0, 0, 50, 26, 0, 0, 0,
50975 & 175,0.004D0, 0, 50,294, 0, 0, 0/
50976 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 894, 912)/
50977 & 175,0.006D0, 0, 50, 21, 21, 0, 0,
50978 & 175,0.042D0, 0, 50, 30, 38, 21, 0,
50979 & 175,0.004D0, 0, 50, 30, 30, 38, 38,
50980 & 175,0.076D0, 0, 50, 30, 38, 21, 21,
50981 & 175,0.026D0, 0, 51, 21, 0, 0, 0,
50982 & 175,0.014D0, 0, 51, 22, 0, 0, 0,
50983 & 175,0.014D0, 0, 51, 23, 0, 0, 0,
50984 & 175,0.011D0, 0, 51, 24, 0, 0, 0,
50985 & 175,0.018D0, 0, 51, 30, 38, 0, 0,
50986 & 175,0.004D0, 0, 50, 34, 46, 0, 0,
50987 & 175,0.004D0, 0, 50, 34, 46, 21, 0,
50988 & 175,0.005D0, 0, 50, 50, 42, 0, 0,
50989 & 175,0.002D0, 0, 30, 38, 0, 0, 0,
50990 & 175,0.001D0, 0, 21, 21, 0, 0, 0,
50991 & 175,0.008D0, 0, 30, 38, 21, 0, 0,
50992 & 175,0.007D0, 0, 30, 30, 38, 38, 0,
50993 & 175,0.015D0, 0, 30, 30, 38, 38, 21,
50994 & 175,0.004D0, 0, 34, 46, 0, 0, 0,
50995 & 175,0.003D0, 0, 35, 46, 0, 0, 0/
50996 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 913, 931)/
50997 & 175,0.002D0, 0, 34, 47, 0, 0, 0,
50998 & 175,0.001D0, 0, 42, 50, 0, 0, 0,
50999 & 175,0.002D0, 0, 43, 51, 0, 0, 0,
51000 & 175,0.003D0, 0, 42, 46, 30, 0, 0,
51001 & 175,0.003D0, 0, 50, 34, 38, 0, 0,
51002 & 175,0.001D0, 0, 34, 46, 30, 38, 21,
51003 & 175,0.002D0, 0, 56, 23, 0, 0, 0,
51004 & 175,0.001D0, 0, 56, 30, 38, 0, 0,
51005 & 176,0.636D0, 0,175, 21, 0, 0, 0,
51006 & 176,0.364D0, 0,175, 59, 0, 0, 0,
51007 & 177,0.667D0, 0,172, 38, 0, 0, 0,
51008 & 177,0.333D0, 0,176, 21, 0, 0, 0,
51009 & 178,0.220D0, 0,171, 38, 0, 0, 0,
51010 & 178,0.110D0, 0,175, 21, 0, 0, 0,
51011 & 178,0.380D0, 0,172, 38, 0, 0, 0,
51012 & 178,0.190D0, 0,176, 21, 0, 0, 0,
51013 & 178,0.004D0, 0,175, 22, 0, 0, 0,
51014 & 178,0.064D0, 0,172, 38, 21, 0, 0,
51015 & 178,0.032D0, 0,176, 38, 30, 0, 0/
51016 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 932, 950)/
51017 & 179,0.009D0, 0,130,123, 0, 0, 0,
51018 & 179,0.019D0,101,128,121, 56, 0, 0,
51019 & 179,0.019D0,101,130,123, 56, 0, 0,
51020 & 179,0.025D0,101,128,121, 22, 0, 0,
51021 & 179,0.025D0,101,130,123, 22, 0, 0,
51022 & 179,0.009D0,101,128,121, 25, 0, 0,
51023 & 179,0.009D0,101,130,123, 25, 0, 0,
51024 & 179,0.036D0, 0, 34, 50, 0, 0, 0,
51025 & 179,0.034D0, 0, 34, 51, 0, 0, 0,
51026 & 179,0.007D0, 0, 34,328, 0, 0, 0,
51027 & 179,0.043D0, 0, 35, 50, 0, 0, 0,
51028 & 179,0.058D0, 0, 35, 51, 0, 0, 0,
51029 & 179,0.011D0, 0, 34, 46, 30, 0, 0,
51030 & 179,0.055D0, 0, 34, 46, 30, 21, 0,
51031 & 179,0.003D0, 0, 34, 46, 30, 38, 30,
51032 & 179,0.014D0, 0, 34, 50, 38, 30, 0,
51033 & 179,0.017D0, 0, 42, 46, 30, 30, 0,
51034 & 179,0.036D0, 0, 56, 30, 0, 0, 0,
51035 & 179,0.067D0, 0, 56, 31, 0, 0, 0/
51036 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 951, 969)/
51037 & 179,0.023D0, 0, 56, 30, 21, 0, 0,
51038 & 179,0.018D0, 0, 56, 30, 38, 30, 0,
51039 & 179,0.020D0, 0, 22, 30, 0, 0, 0,
51040 & 179,0.001D0, 0, 23, 30, 0, 0, 0,
51041 & 179,0.009D0, 0, 24, 30, 0, 0, 0,
51042 & 179,0.049D0, 0, 25, 30, 0, 0, 0,
51043 & 179,0.011D0, 0,293, 30, 0, 0, 0,
51044 & 179,0.015D0, 0, 22, 30, 21, 0, 0,
51045 & 179,0.016D0, 0, 25, 30, 21, 0, 0,
51046 & 179,0.103D0, 0, 22, 31, 0, 0, 0,
51047 & 179,0.120D0, 0, 25, 31, 0, 0, 0,
51048 & 179,0.010D0, 0, 30, 38, 30, 0, 0,
51049 & 179,0.046D0, 0, 30, 38, 30, 21, 0,
51050 & 179,0.003D0, 0, 30, 38, 38, 30, 30,
51051 & 179,0.042D0, 0, 30, 38, 38, 30, 31,
51052 & 179,0.001D0, 0, 34, 23, 0, 0, 0,
51053 & 179,0.005D0, 0, 34, 38, 30, 0, 0,
51054 & 179,0.001D0, 0, 34, 56, 0, 0, 0,
51055 & 179,0.004D0, 0, 42, 30, 0, 0, 0/
51056 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 970, 988)/
51057 & 179,0.007D0, 0, 43, 30, 0, 0, 0,
51058 & 180,0.900D0, 0,179, 59, 0, 0, 0,
51059 & 180,0.100D0, 0,179, 21, 0, 0, 0,
51060 & 181,0.500D0, 0,172, 42, 0, 0, 0,
51061 & 181,0.500D0, 0,176, 34, 0, 0, 0,
51062 & 182,0.440D0, 0,171, 42, 0, 0, 0,
51063 & 182,0.440D0, 0,175, 34, 0, 0, 0,
51064 & 182,0.055D0, 0,172, 42, 0, 0, 0,
51065 & 182,0.055D0, 0,176, 34, 0, 0, 0,
51066 & 182,0.010D0, 0,179, 22, 0, 0, 0,
51067 & 183,1.000D0, 0,185, 30, 0, 0, 0,
51068 & 184,1.000D0, 0,185, 30, 0, 0, 0,
51069 & 185,0.028D0,101,128,121, 96, 0, 0,
51070 & 185,0.010D0,101,128,121, 98, 0, 0,
51071 & 185,0.028D0,101,130,123, 96, 0, 0,
51072 & 185,0.010D0,101,130,123, 98, 0, 0,
51073 & 185,0.026D0, 0, 91, 50, 0, 0, 0,
51074 & 185,0.030D0, 0, 91, 50, 21, 0, 0,
51075 & 185,0.029D0, 0, 91, 50, 38, 30, 0/
51076 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I= 989,1007)/
51077 & 185,0.014D0, 0, 91, 50, 22, 0, 0,
51078 & 185,0.020D0, 0, 91, 51, 0, 0, 0,
51079 & 185,0.029D0, 0, 91, 46, 30, 0, 0,
51080 & 185,0.039D0, 0, 91, 46, 30, 21, 0,
51081 & 185,0.002D0, 0, 91, 46, 30, 30, 38,
51082 & 185,0.010D0, 0, 91, 46, 30, 21, 21,
51083 & 185,0.014D0, 0, 91, 47, 30, 0, 0,
51084 & 185,0.010D0, 0, 92, 50, 0, 0, 0,
51085 & 185,0.020D0, 0, 92, 51, 0, 0, 0,
51086 & 185,0.010D0, 0, 92, 51, 21, 0, 0,
51087 & 185,0.007D0, 0,103, 46, 0, 0, 0,
51088 & 185,0.014D0, 0,103, 47, 0, 0, 0,
51089 & 185,0.004D0, 0, 91,293, 0, 0, 0,
51090 & 185,0.003D0, 0, 91, 38, 30, 0, 0,
51091 & 185,0.003D0, 0, 91, 38, 30, 38, 30,
51092 & 185,0.001D0, 0, 91, 56, 0, 0, 0,
51093 & 185,0.002D0, 0, 91, 46, 34, 0, 0,
51094 & 185,0.010D0, 0, 96, 30, 0, 0, 0,
51095 & 185,0.020D0, 0, 96, 31, 0, 0, 0/
51096 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1008,1026)/
51097 & 185,0.030D0, 0, 96, 30, 21, 0, 0,
51098 & 185,0.010D0, 0, 96, 30, 22, 0, 0,
51099 & 185,0.020D0, 0, 96, 30, 24, 0, 0,
51100 & 185,0.035D0, 0, 96, 30, 30, 38, 0,
51101 & 185,0.020D0, 0, 96, 30, 21, 21, 0,
51102 & 185,0.010D0, 0, 96, 30, 38, 30, 21,
51103 & 185,0.010D0, 0, 96, 30, 21, 21, 21,
51104 & 185,0.007D0, 0, 96, 34, 50, 0, 0,
51105 & 185,0.011D0, 0, 97, 30, 0, 0, 0,
51106 & 185,0.022D0, 0, 97, 30, 21, 0, 0,
51107 & 185,0.013D0, 0, 97, 30, 38, 30, 0,
51108 & 185,0.010D0, 0, 97, 30, 21, 21, 0,
51109 & 185,0.007D0, 0, 97, 30, 38, 30, 21,
51110 & 185,0.005D0, 0, 97, 30, 21, 21, 21,
51111 & 185,0.005D0, 0, 98, 30, 0, 0, 0,
51112 & 185,0.015D0, 0, 98, 31, 0, 0, 0,
51113 & 185,0.011D0, 0,104, 21, 0, 0, 0,
51114 & 185,0.007D0, 0,104, 22, 0, 0, 0,
51115 & 185,0.010D0, 0,104, 23, 0, 0, 0/
51116 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1027,1045)/
51117 & 185,0.031D0, 0,104, 24, 0, 0, 0,
51118 & 185,0.010D0, 0,104, 25, 0, 0, 0,
51119 & 185,0.004D0, 0,104, 56, 0, 0, 0,
51120 & 185,0.026D0, 0,104, 38, 30, 0, 0,
51121 & 185,0.005D0, 0,104, 38, 38, 30, 30,
51122 & 185,0.005D0, 0,104, 38, 30, 21, 21,
51123 & 185,0.005D0, 0,105, 21, 0, 0, 0,
51124 & 185,0.006D0, 0,105, 23, 0, 0, 0,
51125 & 185,0.004D0, 0,104, 46, 34, 0, 0,
51126 & 185,0.002D0, 0,104, 34, 38, 0, 0,
51127 & 185,0.001D0, 0,104, 34, 38, 21, 0,
51128 & 185,0.016D0, 0, 99, 30, 30, 0, 0,
51129 & 185,0.003D0, 0,106, 34, 0, 0, 0,
51130 & 185,0.002D0, 0,107, 34, 0, 0, 0,
51131 & 185,0.003D0, 0,101, 34, 30, 0, 0,
51132 & 185,0.040D0, 0, 93, 34, 21, 0, 0,
51133 & 185,0.040D0, 0, 93, 34, 38, 30, 0,
51134 & 185,0.020D0, 0, 93, 34, 21, 21, 0,
51135 & 185,0.010D0, 0, 93, 34, 38, 30, 21/
51136 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1046,1064)/
51137 & 185,0.010D0, 0, 93, 34, 21, 21, 21,
51138 & 185,0.020D0, 0, 93, 35, 21, 0, 0,
51139 & 185,0.040D0, 0, 93, 50, 30, 0, 0,
51140 & 185,0.020D0, 0, 93, 50, 31, 0, 0,
51141 & 185,0.010D0, 0, 93, 50, 30, 38, 30,
51142 & 185,0.010D0, 0, 93, 50, 30, 21, 21,
51143 & 185,0.006D0, 0, 93, 51, 30, 0, 0,
51144 & 186,1.000D0, 0,185, 21, 0, 0, 0,
51145 & 187,1.000D0, 0,185, 21, 0, 0, 0,
51146 & 188,1.000D0, 0,185, 38, 0, 0, 0,
51147 & 189,1.000D0, 0,185, 38, 0, 0, 0,
51148 & 190,0.045D0,101,128,121,106, 0, 0,
51149 & 190,0.005D0,101,128,121,107, 0, 0,
51150 & 190,0.045D0,101,130,123,106, 0, 0,
51151 & 190,0.005D0,101,130,123,107, 0, 0,
51152 & 190,0.021D0, 0,104, 50, 0, 0, 0,
51153 & 190,0.032D0, 0,105, 50, 0, 0, 0,
51154 & 190,0.032D0, 0, 97, 30, 50, 0, 0,
51155 & 190,0.045D0, 0,104, 51, 0, 0, 0/
51156 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1065,1083)/
51157 & 190,0.065D0, 0,105, 51, 0, 0, 0,
51158 & 190,0.065D0, 0, 97, 30, 51, 0, 0,
51159 & 190,0.055D0, 0,106, 30, 0, 0, 0,
51160 & 190,0.160D0, 0,106, 31, 0, 0, 0,
51161 & 190,0.105D0, 0,107, 30, 0, 0, 0,
51162 & 190,0.320D0, 0,107, 31, 0, 0, 0,
51163 & 191,1.000D0, 0,190, 59, 0, 0, 0,
51164 & 192,0.667D0, 0,193, 30, 0, 0, 0,
51165 & 192,0.333D0, 0,190, 21, 0, 0, 0,
51166 & 193,0.045D0,101,128,121,101, 0, 0,
51167 & 193,0.045D0,101,130,123,101, 0, 0,
51168 & 193,0.005D0,101,128,121,102, 0, 0,
51169 & 193,0.005D0,101,130,123,102, 0, 0,
51170 & 193,0.020D0, 0, 97, 50, 0, 0, 0,
51171 & 193,0.020D0, 0, 97, 21, 50, 0, 0,
51172 & 193,0.020D0, 0, 98, 50, 0, 0, 0,
51173 & 193,0.060D0, 0, 97, 51, 0, 0, 0,
51174 & 193,0.060D0, 0, 97, 21, 51, 0, 0,
51175 & 193,0.060D0, 0, 98, 51, 0, 0, 0/
51176 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1084,1102)/
51177 & 193,0.020D0, 0,104, 46, 0, 0, 0,
51178 & 193,0.060D0, 0,104, 47, 0, 0, 0,
51179 & 193,0.040D0, 0,105, 46, 0, 0, 0,
51180 & 193,0.120D0, 0,105, 47, 0, 0, 0,
51181 & 193,0.020D0, 0,101, 30, 0, 0, 0,
51182 & 193,0.060D0, 0,101, 31, 0, 0, 0,
51183 & 193,0.040D0, 0,102, 30, 0, 0, 0,
51184 & 193,0.120D0, 0,102, 31, 0, 0, 0,
51185 & 193,0.010D0, 0,106, 21, 0, 0, 0,
51186 & 193,0.030D0, 0,106, 23, 0, 0, 0,
51187 & 193,0.020D0, 0,107, 21, 0, 0, 0,
51188 & 193,0.060D0, 0,107, 23, 0, 0, 0,
51189 & 193,0.030D0, 0,106, 56, 0, 0, 0,
51190 & 193,0.030D0, 0,108, 34, 0, 0, 0,
51191 & 194,1.000D0, 0,193, 59, 0, 0, 0,
51192 & 195,0.670D0, 0,190, 38, 0, 0, 0,
51193 & 195,0.330D0, 0,193, 21, 0, 0, 0,
51194 & 196,0.050D0,101,128,121,108, 0, 0,
51195 & 196,0.050D0,101,130,123,108, 0, 0/
51196 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1103,1121)/
51197 & 196,0.075D0, 0,106, 50, 0, 0, 0,
51198 & 196,0.225D0, 0,106, 51, 0, 0, 0,
51199 & 196,0.150D0, 0,107, 50, 0, 0, 0,
51200 & 196,0.450D0, 0,107, 51, 0, 0, 0,
51201 & 197,1.000D0, 0,196, 59, 0, 0, 0,
51202 & 209,0.250D0,100, 1, 8, 4, 0, 0,
51203 & 209,0.250D0,100, 3, 10, 4, 0, 0,
51204 & 209,0.250D0,100, 5, 12, 4, 0, 0,
51205 & 209,0.085D0,100,121,128, 4, 0, 0,
51206 & 209,0.085D0,100,123,130, 4, 0, 0,
51207 & 209,0.080D0,100,125,132, 4, 0, 0,
51208 & 210,0.250D0,100, 2, 7,209, 0, 0,
51209 & 210,0.250D0,100, 4, 9,209, 0, 0,
51210 & 210,0.250D0,100, 6, 11,209, 0, 0,
51211 & 210,0.085D0,100,122,127,209, 0, 0,
51212 & 210,0.085D0,100,124,129,209, 0, 0,
51213 & 210,0.080D0,100,126,131,209, 0, 0,
51214 & 211,0.250D0,100, 1, 8, 6, 0, 0,
51215 & 211,0.250D0,100, 3, 10, 6, 0, 0/
51216 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1122,1140)/
51217 & 211,0.250D0,100, 5, 12, 6, 0, 0,
51218 & 211,0.085D0,100,121,128, 6, 0, 0,
51219 & 211,0.085D0,100,123,130, 6, 0, 0,
51220 & 211,0.080D0,100,125,132, 6, 0, 0,
51221 & 212,0.250D0,100, 2, 7,211, 0, 0,
51222 & 212,0.250D0,100, 4, 9,211, 0, 0,
51223 & 212,0.250D0,100, 6, 11,211, 0, 0,
51224 & 212,0.085D0,100,122,127,211, 0, 0,
51225 & 212,0.085D0,100,124,129,211, 0, 0,
51226 & 212,0.080D0,100,126,131,211, 0, 0,
51227 & 215,0.250D0,100, 7, 2, 10, 0, 0,
51228 & 215,0.250D0,100, 9, 4, 10, 0, 0,
51229 & 215,0.250D0,100, 11, 6, 10, 0, 0,
51230 & 215,0.085D0,100,127,122, 10, 0, 0,
51231 & 215,0.085D0,100,129,124, 10, 0, 0,
51232 & 215,0.080D0,100,131,126, 10, 0, 0,
51233 & 216,0.250D0,100, 8, 1,215, 0, 0,
51234 & 216,0.250D0,100, 10, 3,215, 0, 0,
51235 & 216,0.250D0,100, 12, 5,215, 0, 0/
51236 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1141,1159)/
51237 & 216,0.085D0,100,128,121,215, 0, 0,
51238 & 216,0.085D0,100,130,123,215, 0, 0,
51239 & 216,0.080D0,100,132,125,215, 0, 0,
51240 & 217,0.250D0,100, 7, 2, 12, 0, 0,
51241 & 217,0.250D0,100, 9, 4, 12, 0, 0,
51242 & 217,0.250D0,100, 11, 6, 12, 0, 0,
51243 & 217,0.085D0,100,127,122, 12, 0, 0,
51244 & 217,0.085D0,100,129,124, 12, 0, 0,
51245 & 217,0.080D0,100,131,126, 12, 0, 0,
51246 & 218,0.250D0,100, 8, 1,217, 0, 0,
51247 & 218,0.250D0,100, 10, 3,217, 0, 0,
51248 & 218,0.250D0,100, 12, 5,217, 0, 0,
51249 & 218,0.085D0,100,128,121,217, 0, 0,
51250 & 218,0.085D0,100,130,123,217, 0, 0,
51251 & 218,0.080D0,100,132,125,217, 0, 0,
51252 & 221,0.016D0,101,121,128,136, 0, 0,
51253 & 221,0.016D0,101,123,130,136, 0, 0,
51254 & 221,0.008D0,101,125,132,136, 0, 0,
51255 & 221,0.048D0,101,121,128,137, 0, 0/
51256 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1160,1178)/
51257 & 221,0.048D0,101,123,130,137, 0, 0,
51258 & 221,0.022D0,101,125,132,137, 0, 0,
51259 & 221,0.003D0,101,121,128,331, 0, 0,
51260 & 221,0.003D0,101,123,130,331, 0, 0,
51261 & 221,0.001D0,101,125,132,331, 0, 0,
51262 & 221,0.008D0,101,121,128,138, 0, 0,
51263 & 221,0.008D0,101,123,130,138, 0, 0,
51264 & 221,0.004D0,101,125,132,138, 0, 0,
51265 & 221,0.008D0,101,121,128,313, 0, 0,
51266 & 221,0.008D0,101,123,130,313, 0, 0,
51267 & 221,0.004D0,101,125,132,313, 0, 0,
51268 & 221,0.013D0,101,121,128,139, 0, 0,
51269 & 221,0.013D0,101,123,130,139, 0, 0,
51270 & 221,0.006D0,101,125,132,139, 0, 0,
51271 & 221,0.004D0, 0,136, 30, 0, 0, 0,
51272 & 221,0.010D0, 0,136, 31, 0, 0, 0,
51273 & 221,0.006D0, 0,136, 32, 0, 0, 0,
51274 & 221,0.003D0, 0,137, 30, 0, 0, 0,
51275 & 221,0.009D0, 0,137, 31, 0, 0, 0/
51276 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1179,1197)/
51277 & 221,0.017D0, 0,137, 32, 0, 0, 0,
51278 & 221,0.011D0, 0,136,179, 0, 0, 0,
51279 & 221,0.015D0, 0,136,180, 0, 0, 0,
51280 & 221,0.011D0, 0,137,179, 0, 0, 0,
51281 & 221,0.022D0, 0,137,180, 0, 0, 0,
51282 & 221,0.001D0, 0,164, 42, 0, 0, 0,
51283 & 221,0.002D0, 0,164, 43, 0, 0, 0,
51284 & 221,0.001D0, 0,165, 42, 0, 0, 0,
51285 & 221,0.001D0, 0,165, 43, 0, 0, 0,
51286 & 221,0.001D0, 0,166, 42, 0, 0, 0,
51287 & 221,0.001D0, 0,166, 43, 0, 0, 0,
51288 & 221,0.207D0,100, 1, 8, 4, 7, 0,
51289 & 221,0.207D0,100, 3, 10, 4, 7, 0,
51290 & 221,0.024D0,100, 1, 8, 2, 7, 0,
51291 & 221,0.024D0,100, 3, 10, 2, 7, 0,
51292 & 221,0.012D0,100, 3, 8, 4, 7, 0,
51293 & 221,0.012D0,100, 1, 10, 4, 7, 0,
51294 & 221,0.069D0,100, 4, 8, 1, 7, 0,
51295 & 221,0.069D0,100, 4, 10, 3, 7, 0/
51296 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1198,1216)/
51297 & 221,0.008D0,100, 2, 8, 1, 7, 0,
51298 & 221,0.008D0,100, 2, 10, 3, 7, 0,
51299 & 221,0.004D0,100, 4, 8, 3, 7, 0,
51300 & 221,0.004D0,100, 4, 10, 1, 7, 0,
51301 & 222,0.016D0,101,121,128,140, 0, 0,
51302 & 222,0.016D0,101,123,130,140, 0, 0,
51303 & 222,0.008D0,101,125,132,140, 0, 0,
51304 & 222,0.048D0,101,121,128,141, 0, 0,
51305 & 222,0.048D0,101,123,130,141, 0, 0,
51306 & 222,0.022D0,101,125,132,141, 0, 0,
51307 & 222,0.003D0,101,121,128,332, 0, 0,
51308 & 222,0.003D0,101,123,130,332, 0, 0,
51309 & 222,0.001D0,101,125,132,332, 0, 0,
51310 & 222,0.008D0,101,121,128,142, 0, 0,
51311 & 222,0.008D0,101,123,130,142, 0, 0,
51312 & 222,0.004D0,101,125,132,142, 0, 0,
51313 & 222,0.008D0,101,121,128,314, 0, 0,
51314 & 222,0.008D0,101,123,130,314, 0, 0,
51315 & 222,0.004D0,101,125,132,314, 0, 0/
51316 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1217,1235)/
51317 & 222,0.013D0,101,121,128,143, 0, 0,
51318 & 222,0.013D0,101,123,130,143, 0, 0,
51319 & 222,0.006D0,101,125,132,143, 0, 0,
51320 & 222,0.004D0, 0,140, 30, 0, 0, 0,
51321 & 222,0.010D0, 0,140, 31, 0, 0, 0,
51322 & 222,0.006D0, 0,140, 32, 0, 0, 0,
51323 & 222,0.003D0, 0,141, 30, 0, 0, 0,
51324 & 222,0.009D0, 0,141, 31, 0, 0, 0,
51325 & 222,0.017D0, 0,141, 32, 0, 0, 0,
51326 & 222,0.011D0, 0,140,179, 0, 0, 0,
51327 & 222,0.015D0, 0,140,180, 0, 0, 0,
51328 & 222,0.011D0, 0,141,179, 0, 0, 0,
51329 & 222,0.022D0, 0,141,180, 0, 0, 0,
51330 & 222,0.001D0, 0,164, 34, 0, 0, 0,
51331 & 222,0.002D0, 0,164, 35, 0, 0, 0,
51332 & 222,0.001D0, 0,165, 34, 0, 0, 0,
51333 & 222,0.001D0, 0,165, 35, 0, 0, 0,
51334 & 222,0.001D0, 0,166, 34, 0, 0, 0,
51335 & 222,0.001D0, 0,166, 35, 0, 0, 0/
51336 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1236,1254)/
51337 & 222,0.207D0,100, 1, 8, 4, 8, 0,
51338 & 222,0.207D0,100, 3, 10, 4, 8, 0,
51339 & 222,0.024D0,100, 1, 8, 2, 8, 0,
51340 & 222,0.024D0,100, 3, 10, 2, 8, 0,
51341 & 222,0.012D0,100, 3, 8, 4, 8, 0,
51342 & 222,0.012D0,100, 1, 10, 4, 8, 0,
51343 & 222,0.069D0,100, 4, 8, 1, 8, 0,
51344 & 222,0.069D0,100, 4, 10, 3, 8, 0,
51345 & 222,0.008D0,100, 2, 8, 1, 8, 0,
51346 & 222,0.008D0,100, 2, 10, 3, 8, 0,
51347 & 222,0.004D0,100, 4, 8, 3, 8, 0,
51348 & 222,0.004D0,100, 4, 10, 1, 8, 0,
51349 & 223,0.016D0,101,121,128,144, 0, 0,
51350 & 223,0.016D0,101,123,130,144, 0, 0,
51351 & 223,0.008D0,101,125,132,144, 0, 0,
51352 & 223,0.048D0,101,121,128,145, 0, 0,
51353 & 223,0.048D0,101,123,130,145, 0, 0,
51354 & 223,0.022D0,101,125,132,145, 0, 0,
51355 & 223,0.003D0,101,121,128,333, 0, 0/
51356 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1255,1273)/
51357 & 223,0.003D0,101,123,130,333, 0, 0,
51358 & 223,0.001D0,101,125,132,333, 0, 0,
51359 & 223,0.008D0,101,121,128,146, 0, 0,
51360 & 223,0.008D0,101,123,130,146, 0, 0,
51361 & 223,0.004D0,101,125,132,146, 0, 0,
51362 & 223,0.008D0,101,121,128,315, 0, 0,
51363 & 223,0.008D0,101,123,130,315, 0, 0,
51364 & 223,0.004D0,101,125,132,315, 0, 0,
51365 & 223,0.013D0,101,121,128,147, 0, 0,
51366 & 223,0.013D0,101,123,130,147, 0, 0,
51367 & 223,0.006D0,101,125,132,147, 0, 0,
51368 & 223,0.004D0, 0,144, 30, 0, 0, 0,
51369 & 223,0.010D0, 0,144, 31, 0, 0, 0,
51370 & 223,0.006D0, 0,144, 32, 0, 0, 0,
51371 & 223,0.003D0, 0,145, 30, 0, 0, 0,
51372 & 223,0.009D0, 0,145, 31, 0, 0, 0,
51373 & 223,0.017D0, 0,145, 32, 0, 0, 0,
51374 & 223,0.011D0, 0,144,179, 0, 0, 0,
51375 & 223,0.015D0, 0,144,180, 0, 0, 0/
51376 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1274,1292)/
51377 & 223,0.011D0, 0,145,179, 0, 0, 0,
51378 & 223,0.022D0, 0,145,180, 0, 0, 0,
51379 & 223,0.001D0, 0,164, 25, 0, 0, 0,
51380 & 223,0.002D0, 0,164, 56, 0, 0, 0,
51381 & 223,0.001D0, 0,165, 25, 0, 0, 0,
51382 & 223,0.001D0, 0,165, 56, 0, 0, 0,
51383 & 223,0.001D0, 0,166, 25, 0, 0, 0,
51384 & 223,0.001D0, 0,166, 56, 0, 0, 0,
51385 & 223,0.207D0,100, 1, 8, 4, 9, 0,
51386 & 223,0.207D0,100, 3, 10, 4, 9, 0,
51387 & 223,0.024D0,100, 1, 8, 2, 9, 0,
51388 & 223,0.024D0,100, 3, 10, 2, 9, 0,
51389 & 223,0.012D0,100, 3, 8, 4, 9, 0,
51390 & 223,0.012D0,100, 1, 10, 4, 9, 0,
51391 & 223,0.069D0,100, 4, 8, 1, 9, 0,
51392 & 223,0.069D0,100, 4, 10, 3, 9, 0,
51393 & 223,0.008D0,100, 2, 8, 1, 9, 0,
51394 & 223,0.008D0,100, 2, 10, 3, 9, 0,
51395 & 223,0.004D0,100, 4, 8, 3, 9, 0/
51396 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1293,1311)/
51397 & 223,0.004D0,100, 4, 10, 1, 9, 0,
51398 & 224,0.090D0,100,121,128, 4,109, 0,
51399 & 224,0.090D0,100,123,130, 4,109, 0,
51400 & 224,0.045D0,100,125,132, 4,109, 0,
51401 & 224,0.010D0,100,121,128, 2,109, 0,
51402 & 224,0.010D0,100,123,130, 2,109, 0,
51403 & 224,0.005D0,100,125,132, 2,109, 0,
51404 & 224,0.242D0,100, 1, 8, 4,109, 0,
51405 & 224,0.242D0,100, 3, 10, 4,109, 0,
51406 & 224,0.027D0,100, 1, 8, 2,109, 0,
51407 & 224,0.027D0,100, 3, 10, 2,109, 0,
51408 & 224,0.012D0,100, 3, 8, 4,109, 0,
51409 & 224,0.012D0,100, 1, 10, 4,109, 0,
51410 & 224,0.081D0,100, 4, 8, 1,109, 0,
51411 & 224,0.081D0,100, 4, 10, 3,109, 0,
51412 & 224,0.009D0,100, 2, 8, 1,109, 0,
51413 & 224,0.009D0,100, 2, 10, 3,109, 0,
51414 & 224,0.004D0,100, 4, 8, 3,109, 0,
51415 & 224,0.004D0,100, 4, 10, 1,109, 0/
51416 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1312,1330)/
51417 & 225,0.090D0,100,121,128, 4,110, 0,
51418 & 225,0.090D0,100,123,130, 4,110, 0,
51419 & 225,0.045D0,100,125,132, 4,110, 0,
51420 & 225,0.010D0,100,121,128, 2,110, 0,
51421 & 225,0.010D0,100,123,130, 2,110, 0,
51422 & 225,0.005D0,100,125,132, 2,110, 0,
51423 & 225,0.242D0,100, 1, 8, 4,110, 0,
51424 & 225,0.242D0,100, 3, 10, 4,110, 0,
51425 & 225,0.027D0,100, 1, 8, 2,110, 0,
51426 & 225,0.027D0,100, 3, 10, 2,110, 0,
51427 & 225,0.012D0,100, 3, 8, 4,110, 0,
51428 & 225,0.012D0,100, 1, 10, 4,110, 0,
51429 & 225,0.081D0,100, 4, 8, 1,110, 0,
51430 & 225,0.081D0,100, 4, 10, 3,110, 0,
51431 & 225,0.009D0,100, 2, 8, 1,110, 0,
51432 & 225,0.009D0,100, 2, 10, 3,110, 0,
51433 & 225,0.004D0,100, 4, 8, 3,110, 0,
51434 & 225,0.004D0,100, 4, 10, 1,110, 0,
51435 & 226,0.090D0,100,121,128, 4,111, 0/
51436 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1331,1349)/
51437 & 226,0.090D0,100,123,130, 4,111, 0,
51438 & 226,0.045D0,100,125,132, 4,111, 0,
51439 & 226,0.010D0,100,121,128, 2,111, 0,
51440 & 226,0.010D0,100,123,130, 2,111, 0,
51441 & 226,0.005D0,100,125,132, 2,111, 0,
51442 & 226,0.242D0,100, 1, 8, 4,111, 0,
51443 & 226,0.242D0,100, 3, 10, 4,111, 0,
51444 & 226,0.027D0,100, 1, 8, 2,111, 0,
51445 & 226,0.027D0,100, 3, 10, 2,111, 0,
51446 & 226,0.012D0,100, 3, 8, 4,111, 0,
51447 & 226,0.012D0,100, 1, 10, 4,111, 0,
51448 & 226,0.081D0,100, 4, 8, 1,111, 0,
51449 & 226,0.081D0,100, 4, 10, 3,111, 0,
51450 & 226,0.009D0,100, 2, 8, 1,111, 0,
51451 & 226,0.009D0,100, 2, 10, 3,111, 0,
51452 & 226,0.004D0,100, 4, 8, 3,111, 0,
51453 & 226,0.004D0,100, 4, 10, 1,111, 0,
51454 & 227,0.090D0,100,121,128, 4,112, 0,
51455 & 227,0.090D0,100,123,130, 4,112, 0/
51456 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1350,1368)/
51457 & 227,0.045D0,100,125,132, 4,112, 0,
51458 & 227,0.010D0,100,121,128, 2,112, 0,
51459 & 227,0.010D0,100,123,130, 2,112, 0,
51460 & 227,0.005D0,100,125,132, 2,112, 0,
51461 & 227,0.242D0,100, 1, 8, 4,112, 0,
51462 & 227,0.242D0,100, 3, 10, 4,112, 0,
51463 & 227,0.027D0,100, 1, 8, 2,112, 0,
51464 & 227,0.027D0,100, 3, 10, 2,112, 0,
51465 & 227,0.012D0,100, 3, 8, 4,112, 0,
51466 & 227,0.012D0,100, 1, 10, 4,112, 0,
51467 & 227,0.081D0,100, 4, 8, 1,112, 0,
51468 & 227,0.081D0,100, 4, 10, 3,112, 0,
51469 & 227,0.009D0,100, 2, 8, 1,112, 0,
51470 & 227,0.009D0,100, 2, 10, 3,112, 0,
51471 & 227,0.004D0,100, 4, 8, 3,112, 0,
51472 & 227,0.004D0,100, 4, 10, 1,112, 0,
51473 & 228,0.090D0,100,121,128, 4,113, 0,
51474 & 228,0.090D0,100,123,130, 4,113, 0,
51475 & 228,0.045D0,100,125,132, 4,113, 0/
51476 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1369,1387)/
51477 & 228,0.010D0,100,121,128, 2,113, 0,
51478 & 228,0.010D0,100,123,130, 2,113, 0,
51479 & 228,0.005D0,100,125,132, 2,113, 0,
51480 & 228,0.242D0,100, 1, 8, 4,113, 0,
51481 & 228,0.242D0,100, 3, 10, 4,113, 0,
51482 & 228,0.027D0,100, 1, 8, 2,113, 0,
51483 & 228,0.027D0,100, 3, 10, 2,113, 0,
51484 & 228,0.012D0,100, 3, 8, 4,113, 0,
51485 & 228,0.012D0,100, 1, 10, 4,113, 0,
51486 & 228,0.081D0,100, 4, 8, 1,113, 0,
51487 & 228,0.081D0,100, 4, 10, 3,113, 0,
51488 & 228,0.009D0,100, 2, 8, 1,113, 0,
51489 & 228,0.009D0,100, 2, 10, 3,113, 0,
51490 & 228,0.004D0,100, 4, 8, 3,113, 0,
51491 & 228,0.004D0,100, 4, 10, 1,113, 0,
51492 & 229,0.090D0,100,121,128, 4,114, 0,
51493 & 229,0.090D0,100,123,130, 4,114, 0,
51494 & 229,0.045D0,100,125,132, 4,114, 0,
51495 & 229,0.010D0,100,121,128, 2,114, 0/
51496 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1388,1406)/
51497 & 229,0.010D0,100,123,130, 2,114, 0,
51498 & 229,0.005D0,100,125,132, 2,114, 0,
51499 & 229,0.242D0,100, 1, 8, 4,114, 0,
51500 & 229,0.242D0,100, 3, 10, 4,114, 0,
51501 & 229,0.027D0,100, 1, 8, 2,114, 0,
51502 & 229,0.027D0,100, 3, 10, 2,114, 0,
51503 & 229,0.012D0,100, 3, 8, 4,114, 0,
51504 & 229,0.012D0,100, 1, 10, 4,114, 0,
51505 & 229,0.081D0,100, 4, 8, 1,114, 0,
51506 & 229,0.081D0,100, 4, 10, 3,114, 0,
51507 & 229,0.009D0,100, 2, 8, 1,114, 0,
51508 & 229,0.009D0,100, 2, 10, 3,114, 0,
51509 & 229,0.004D0,100, 4, 8, 3,114, 0,
51510 & 229,0.004D0,100, 4, 10, 1,114, 0,
51511 & 230,0.080D0,100,121,128, 4, 10, 0,
51512 & 230,0.080D0,100,123,130, 4, 10, 0,
51513 & 230,0.040D0,100,125,132, 4, 10, 0,
51514 & 230,0.080D0,100,121,128, 9, 5, 0,
51515 & 230,0.080D0,100,123,130, 9, 5, 0/
51516 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1407,1425)/
51517 & 230,0.228D0,100, 1, 8, 4, 10, 0,
51518 & 230,0.228D0,100, 3, 10, 4, 10, 0,
51519 & 230,0.012D0,100, 3, 8, 4, 10, 0,
51520 & 230,0.012D0,100, 1, 10, 4, 10, 0,
51521 & 230,0.076D0,100, 4, 8, 1, 10, 0,
51522 & 230,0.076D0,100, 4, 10, 3, 10, 0,
51523 & 230,0.004D0,100, 4, 8, 3, 10, 0,
51524 & 230,0.004D0,100, 4, 10, 1, 10, 0,
51525 & 231,0.025D0, 0,121,127, 0, 0, 0,
51526 & 231,0.025D0, 0,123,129, 0, 0, 0,
51527 & 231,0.025D0, 0,125,131, 0, 0, 0,
51528 & 231,0.008D0, 0, 1, 7, 0, 0, 0,
51529 & 231,0.033D0, 0, 2, 8, 0, 0, 0,
51530 & 231,0.008D0, 0, 3, 9, 0, 0, 0,
51531 & 231,0.033D0, 0, 4, 10, 0, 0, 0,
51532 & 231,0.801D0,130, 13, 13, 13, 0, 0,
51533 & 231,0.042D0,130, 13, 13, 59, 0, 0,
51534 & 245,0.016D0,101,127,122,171, 0, 0,
51535 & 245,0.016D0,101,129,124,171, 0, 0/
51536 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1426,1444)/
51537 & 245,0.008D0,101,131,126,171, 0, 0,
51538 & 245,0.048D0,101,127,122,172, 0, 0,
51539 & 245,0.048D0,101,129,124,172, 0, 0,
51540 & 245,0.022D0,101,131,126,172, 0, 0,
51541 & 245,0.003D0,101,127,122,334, 0, 0,
51542 & 245,0.003D0,101,129,124,334, 0, 0,
51543 & 245,0.001D0,101,131,126,334, 0, 0,
51544 & 245,0.008D0,101,127,122,173, 0, 0,
51545 & 245,0.008D0,101,129,124,173, 0, 0,
51546 & 245,0.004D0,101,131,126,173, 0, 0,
51547 & 245,0.008D0,101,127,122,316, 0, 0,
51548 & 245,0.008D0,101,129,124,316, 0, 0,
51549 & 245,0.004D0,101,131,126,316, 0, 0,
51550 & 245,0.013D0,101,127,122,174, 0, 0,
51551 & 245,0.013D0,101,129,124,174, 0, 0,
51552 & 245,0.006D0,101,131,126,174, 0, 0,
51553 & 245,0.004D0, 0,171, 38, 0, 0, 0,
51554 & 245,0.010D0, 0,171, 39, 0, 0, 0,
51555 & 245,0.006D0, 0,171, 40, 0, 0, 0/
51556 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1445,1463)/
51557 & 245,0.003D0, 0,172, 38, 0, 0, 0,
51558 & 245,0.009D0, 0,172, 39, 0, 0, 0,
51559 & 245,0.017D0, 0,172, 40, 0, 0, 0,
51560 & 245,0.011D0, 0,171,144, 0, 0, 0,
51561 & 245,0.015D0, 0,171,145, 0, 0, 0,
51562 & 245,0.011D0, 0,172,144, 0, 0, 0,
51563 & 245,0.022D0, 0,172,145, 0, 0, 0,
51564 & 245,0.001D0, 0,164, 50, 0, 0, 0,
51565 & 245,0.002D0, 0,164, 51, 0, 0, 0,
51566 & 245,0.001D0, 0,165, 50, 0, 0, 0,
51567 & 245,0.001D0, 0,165, 51, 0, 0, 0,
51568 & 245,0.001D0, 0,166, 50, 0, 0, 0,
51569 & 245,0.001D0, 0,166, 51, 0, 0, 0,
51570 & 245,0.207D0,100, 7, 2, 10, 1, 0,
51571 & 245,0.207D0,100, 9, 4, 10, 1, 0,
51572 & 245,0.024D0,100, 7, 2, 8, 1, 0,
51573 & 245,0.024D0,100, 9, 4, 8, 1, 0,
51574 & 245,0.012D0,100, 9, 2, 10, 1, 0,
51575 & 245,0.012D0,100, 7, 4, 10, 1, 0/
51576 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1464,1482)/
51577 & 245,0.069D0,100, 10, 2, 7, 1, 0,
51578 & 245,0.069D0,100, 10, 4, 9, 1, 0,
51579 & 245,0.008D0,100, 8, 2, 7, 1, 0,
51580 & 245,0.008D0,100, 8, 4, 9, 1, 0,
51581 & 245,0.004D0,100, 10, 2, 9, 1, 0,
51582 & 245,0.004D0,100, 10, 4, 7, 1, 0,
51583 & 246,0.016D0,101,127,122,175, 0, 0,
51584 & 246,0.016D0,101,129,124,175, 0, 0,
51585 & 246,0.008D0,101,131,126,175, 0, 0,
51586 & 246,0.048D0,101,127,122,176, 0, 0,
51587 & 246,0.048D0,101,129,124,176, 0, 0,
51588 & 246,0.022D0,101,131,126,176, 0, 0,
51589 & 246,0.003D0,101,127,122,335, 0, 0,
51590 & 246,0.003D0,101,129,124,335, 0, 0,
51591 & 246,0.001D0,101,131,126,335, 0, 0,
51592 & 246,0.008D0,101,127,122,177, 0, 0,
51593 & 246,0.008D0,101,129,124,177, 0, 0,
51594 & 246,0.004D0,101,131,126,177, 0, 0,
51595 & 246,0.008D0,101,127,122,317, 0, 0/
51596 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1483,1501)/
51597 & 246,0.008D0,101,129,124,317, 0, 0,
51598 & 246,0.004D0,101,131,126,317, 0, 0,
51599 & 246,0.013D0,101,127,122,178, 0, 0,
51600 & 246,0.013D0,101,129,124,178, 0, 0,
51601 & 246,0.006D0,101,131,126,178, 0, 0,
51602 & 246,0.004D0, 0,175, 38, 0, 0, 0,
51603 & 246,0.010D0, 0,175, 39, 0, 0, 0,
51604 & 246,0.006D0, 0,175, 40, 0, 0, 0,
51605 & 246,0.003D0, 0,176, 38, 0, 0, 0,
51606 & 246,0.009D0, 0,176, 39, 0, 0, 0,
51607 & 246,0.017D0, 0,176, 40, 0, 0, 0,
51608 & 246,0.011D0, 0,175,144, 0, 0, 0,
51609 & 246,0.015D0, 0,175,145, 0, 0, 0,
51610 & 246,0.011D0, 0,176,144, 0, 0, 0,
51611 & 246,0.022D0, 0,176,145, 0, 0, 0,
51612 & 246,0.001D0, 0,164, 46, 0, 0, 0,
51613 & 246,0.002D0, 0,164, 47, 0, 0, 0,
51614 & 246,0.001D0, 0,165, 46, 0, 0, 0,
51615 & 246,0.001D0, 0,165, 47, 0, 0, 0/
51616 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1502,1520)/
51617 & 246,0.001D0, 0,166, 46, 0, 0, 0,
51618 & 246,0.001D0, 0,166, 47, 0, 0, 0,
51619 & 246,0.207D0,100, 7, 2, 10, 2, 0,
51620 & 246,0.207D0,100, 9, 4, 10, 2, 0,
51621 & 246,0.024D0,100, 7, 2, 8, 2, 0,
51622 & 246,0.024D0,100, 9, 4, 8, 2, 0,
51623 & 246,0.012D0,100, 9, 2, 10, 2, 0,
51624 & 246,0.012D0,100, 7, 4, 10, 2, 0,
51625 & 246,0.069D0,100, 10, 2, 7, 2, 0,
51626 & 246,0.069D0,100, 10, 4, 9, 2, 0,
51627 & 246,0.008D0,100, 8, 2, 7, 2, 0,
51628 & 246,0.008D0,100, 8, 4, 9, 2, 0,
51629 & 246,0.004D0,100, 10, 2, 9, 2, 0,
51630 & 246,0.004D0,100, 10, 4, 7, 2, 0,
51631 & 247,0.016D0,101,127,122,179, 0, 0,
51632 & 247,0.016D0,101,129,124,179, 0, 0,
51633 & 247,0.008D0,101,131,126,179, 0, 0,
51634 & 247,0.048D0,101,127,122,180, 0, 0,
51635 & 247,0.048D0,101,129,124,180, 0, 0/
51636 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1521,1539)/
51637 & 247,0.022D0,101,131,126,180, 0, 0,
51638 & 247,0.003D0,101,127,122,336, 0, 0,
51639 & 247,0.003D0,101,129,124,336, 0, 0,
51640 & 247,0.001D0,101,131,126,336, 0, 0,
51641 & 247,0.008D0,101,127,122,181, 0, 0,
51642 & 247,0.008D0,101,129,124,181, 0, 0,
51643 & 247,0.004D0,101,131,126,181, 0, 0,
51644 & 247,0.008D0,101,127,122,318, 0, 0,
51645 & 247,0.008D0,101,129,124,318, 0, 0,
51646 & 247,0.004D0,101,131,126,318, 0, 0,
51647 & 247,0.013D0,101,127,122,182, 0, 0,
51648 & 247,0.013D0,101,129,124,182, 0, 0,
51649 & 247,0.006D0,101,131,126,182, 0, 0,
51650 & 247,0.004D0, 0,179, 38, 0, 0, 0,
51651 & 247,0.010D0, 0,179, 39, 0, 0, 0,
51652 & 247,0.006D0, 0,179, 40, 0, 0, 0,
51653 & 247,0.003D0, 0,180, 38, 0, 0, 0,
51654 & 247,0.009D0, 0,180, 39, 0, 0, 0,
51655 & 247,0.017D0, 0,180, 40, 0, 0, 0/
51656 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1540,1558)/
51657 & 247,0.011D0, 0,179,144, 0, 0, 0,
51658 & 247,0.015D0, 0,179,145, 0, 0, 0,
51659 & 247,0.011D0, 0,180,144, 0, 0, 0,
51660 & 247,0.022D0, 0,180,145, 0, 0, 0,
51661 & 247,0.001D0, 0,164, 25, 0, 0, 0,
51662 & 247,0.002D0, 0,164, 56, 0, 0, 0,
51663 & 247,0.001D0, 0,165, 25, 0, 0, 0,
51664 & 247,0.001D0, 0,165, 56, 0, 0, 0,
51665 & 247,0.001D0, 0,166, 25, 0, 0, 0,
51666 & 247,0.001D0, 0,166, 56, 0, 0, 0,
51667 & 247,0.207D0,100, 7, 2, 10, 3, 0,
51668 & 247,0.207D0,100, 9, 4, 10, 3, 0,
51669 & 247,0.024D0,100, 7, 2, 8, 3, 0,
51670 & 247,0.024D0,100, 9, 4, 8, 3, 0,
51671 & 247,0.012D0,100, 9, 2, 10, 3, 0,
51672 & 247,0.012D0,100, 7, 4, 10, 3, 0,
51673 & 247,0.069D0,100, 10, 2, 7, 3, 0,
51674 & 247,0.069D0,100, 10, 4, 9, 3, 0,
51675 & 247,0.008D0,100, 8, 2, 7, 3, 0/
51676 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1559,1577)/
51677 & 247,0.008D0,100, 8, 4, 9, 3, 0,
51678 & 247,0.004D0,100, 10, 2, 9, 3, 0,
51679 & 247,0.004D0,100, 10, 4, 7, 3, 0,
51680 & 248,0.090D0,100,127,122, 10,115, 0,
51681 & 248,0.090D0,100,129,124, 10,115, 0,
51682 & 248,0.045D0,100,131,126, 10,115, 0,
51683 & 248,0.010D0,100,127,122, 8,115, 0,
51684 & 248,0.010D0,100,129,124, 8,115, 0,
51685 & 248,0.005D0,100,131,126, 8,115, 0,
51686 & 248,0.242D0,100, 7, 2, 10,115, 0,
51687 & 248,0.242D0,100, 9, 4, 10,115, 0,
51688 & 248,0.027D0,100, 7, 2, 8,115, 0,
51689 & 248,0.027D0,100, 9, 4, 8,115, 0,
51690 & 248,0.012D0,100, 9, 2, 10,115, 0,
51691 & 248,0.012D0,100, 7, 4, 10,115, 0,
51692 & 248,0.081D0,100, 10, 2, 7,115, 0,
51693 & 248,0.081D0,100, 10, 4, 9,115, 0,
51694 & 248,0.009D0,100, 8, 2, 7,115, 0,
51695 & 248,0.009D0,100, 8, 4, 9,115, 0/
51696 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1578,1596)/
51697 & 248,0.004D0,100, 10, 2, 9,115, 0,
51698 & 248,0.004D0,100, 10, 4, 7,115, 0,
51699 & 249,0.090D0,100,127,122, 10,116, 0,
51700 & 249,0.090D0,100,129,124, 10,116, 0,
51701 & 249,0.045D0,100,131,126, 10,116, 0,
51702 & 249,0.010D0,100,127,122, 8,116, 0,
51703 & 249,0.010D0,100,129,124, 8,116, 0,
51704 & 249,0.005D0,100,131,126, 8,116, 0,
51705 & 249,0.242D0,100, 7, 2, 10,116, 0,
51706 & 249,0.242D0,100, 9, 4, 10,116, 0,
51707 & 249,0.027D0,100, 7, 2, 8,116, 0,
51708 & 249,0.027D0,100, 9, 4, 8,116, 0,
51709 & 249,0.012D0,100, 9, 2, 10,116, 0,
51710 & 249,0.012D0,100, 7, 4, 10,116, 0,
51711 & 249,0.081D0,100, 10, 2, 7,116, 0,
51712 & 249,0.081D0,100, 10, 4, 9,116, 0,
51713 & 249,0.009D0,100, 8, 2, 7,116, 0,
51714 & 249,0.009D0,100, 8, 4, 9,116, 0,
51715 & 249,0.004D0,100, 10, 2, 9,116, 0/
51716 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1597,1615)/
51717 & 249,0.004D0,100, 10, 4, 7,116, 0,
51718 & 250,0.090D0,100,127,122, 10,117, 0,
51719 & 250,0.090D0,100,129,124, 10,117, 0,
51720 & 250,0.045D0,100,131,126, 10,117, 0,
51721 & 250,0.010D0,100,127,122, 8,117, 0,
51722 & 250,0.010D0,100,129,124, 8,117, 0,
51723 & 250,0.005D0,100,131,126, 8,117, 0,
51724 & 250,0.242D0,100, 7, 2, 10,117, 0,
51725 & 250,0.242D0,100, 9, 4, 10,117, 0,
51726 & 250,0.027D0,100, 7, 2, 8,117, 0,
51727 & 250,0.027D0,100, 9, 4, 8,117, 0,
51728 & 250,0.012D0,100, 9, 2, 10,117, 0,
51729 & 250,0.012D0,100, 7, 4, 10,117, 0,
51730 & 250,0.081D0,100, 10, 2, 7,117, 0,
51731 & 250,0.081D0,100, 10, 4, 9,117, 0,
51732 & 250,0.009D0,100, 8, 2, 7,117, 0,
51733 & 250,0.009D0,100, 8, 4, 9,117, 0,
51734 & 250,0.004D0,100, 10, 2, 9,117, 0,
51735 & 250,0.004D0,100, 10, 4, 7,117, 0/
51736 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1616,1634)/
51737 & 251,0.090D0,100,127,122, 10,118, 0,
51738 & 251,0.090D0,100,129,124, 10,118, 0,
51739 & 251,0.045D0,100,131,126, 10,118, 0,
51740 & 251,0.010D0,100,127,122, 8,118, 0,
51741 & 251,0.010D0,100,129,124, 8,118, 0,
51742 & 251,0.005D0,100,131,126, 8,118, 0,
51743 & 251,0.242D0,100, 7, 2, 10,118, 0,
51744 & 251,0.242D0,100, 9, 4, 10,118, 0,
51745 & 251,0.027D0,100, 7, 2, 8,118, 0,
51746 & 251,0.027D0,100, 9, 4, 8,118, 0,
51747 & 251,0.012D0,100, 9, 2, 10,118, 0,
51748 & 251,0.012D0,100, 7, 4, 10,118, 0,
51749 & 251,0.081D0,100, 10, 2, 7,118, 0,
51750 & 251,0.081D0,100, 10, 4, 9,118, 0,
51751 & 251,0.009D0,100, 8, 2, 7,118, 0,
51752 & 251,0.009D0,100, 8, 4, 9,118, 0,
51753 & 251,0.004D0,100, 10, 2, 9,118, 0,
51754 & 251,0.004D0,100, 10, 4, 7,118, 0,
51755 & 252,0.090D0,100,127,122, 10,119, 0/
51756 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1635,1653)/
51757 & 252,0.090D0,100,129,124, 10,119, 0,
51758 & 252,0.045D0,100,131,126, 10,119, 0,
51759 & 252,0.010D0,100,127,122, 8,119, 0,
51760 & 252,0.010D0,100,129,124, 8,119, 0,
51761 & 252,0.005D0,100,131,126, 8,119, 0,
51762 & 252,0.242D0,100, 7, 2, 10,119, 0,
51763 & 252,0.242D0,100, 9, 4, 10,119, 0,
51764 & 252,0.027D0,100, 7, 2, 8,119, 0,
51765 & 252,0.027D0,100, 9, 4, 8,119, 0,
51766 & 252,0.012D0,100, 9, 2, 10,119, 0,
51767 & 252,0.012D0,100, 7, 4, 10,119, 0,
51768 & 252,0.081D0,100, 10, 2, 7,119, 0,
51769 & 252,0.081D0,100, 10, 4, 9,119, 0,
51770 & 252,0.009D0,100, 8, 2, 7,119, 0,
51771 & 252,0.009D0,100, 8, 4, 9,119, 0,
51772 & 252,0.004D0,100, 10, 2, 9,119, 0,
51773 & 252,0.004D0,100, 10, 4, 7,119, 0,
51774 & 253,0.090D0,100,127,122, 10,120, 0,
51775 & 253,0.090D0,100,129,124, 10,120, 0/
51776 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1654,1672)/
51777 & 253,0.045D0,100,131,126, 10,120, 0,
51778 & 253,0.010D0,100,127,122, 8,120, 0,
51779 & 253,0.010D0,100,129,124, 8,120, 0,
51780 & 253,0.005D0,100,131,126, 8,120, 0,
51781 & 253,0.242D0,100, 7, 2, 10,120, 0,
51782 & 253,0.242D0,100, 9, 4, 10,120, 0,
51783 & 253,0.027D0,100, 7, 2, 8,120, 0,
51784 & 253,0.027D0,100, 9, 4, 8,120, 0,
51785 & 253,0.012D0,100, 9, 2, 10,120, 0,
51786 & 253,0.012D0,100, 7, 4, 10,120, 0,
51787 & 253,0.081D0,100, 10, 2, 7,120, 0,
51788 & 253,0.081D0,100, 10, 4, 9,120, 0,
51789 & 253,0.009D0,100, 8, 2, 7,120, 0,
51790 & 253,0.009D0,100, 8, 4, 9,120, 0,
51791 & 253,0.004D0,100, 10, 2, 9,120, 0,
51792 & 253,0.004D0,100, 10, 4, 7,120, 0,
51793 & 254,0.080D0,100,127,122, 10, 4, 0,
51794 & 254,0.080D0,100,129,124, 10, 4, 0,
51795 & 254,0.040D0,100,131,126, 10, 4, 0/
51796 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1673,1691)/
51797 & 254,0.080D0,100,127,122, 3, 11, 0,
51798 & 254,0.080D0,100,129,124, 3, 11, 0,
51799 & 254,0.228D0,100, 7, 2, 10, 4, 0,
51800 & 254,0.228D0,100, 9, 4, 10, 4, 0,
51801 & 254,0.012D0,100, 9, 2, 10, 4, 0,
51802 & 254,0.012D0,100, 7, 4, 10, 4, 0,
51803 & 254,0.076D0,100, 10, 2, 7, 4, 0,
51804 & 254,0.076D0,100, 10, 4, 9, 4, 0,
51805 & 254,0.004D0,100, 10, 2, 9, 4, 0,
51806 & 254,0.004D0,100, 10, 4, 7, 4, 0,
51807 & 265,1.000D0, 0,221, 59, 0, 0, 0,
51808 & 266,1.000D0, 0,222, 59, 0, 0, 0,
51809 & 267,1.000D0, 0,223, 59, 0, 0, 0,
51810 & 268,0.667D0, 0,266, 38, 0, 0, 0,
51811 & 268,0.333D0, 0,265, 21, 0, 0, 0,
51812 & 269,0.667D0, 0,265, 30, 0, 0, 0,
51813 & 269,0.333D0, 0,266, 21, 0, 0, 0,
51814 & 270,0.500D0, 0,265, 50, 0, 0, 0,
51815 & 270,0.500D0, 0,266, 46, 0, 0, 0/
51816 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1692,1710)/
51817 & 271,0.290D0, 0,266, 38, 0, 0, 0,
51818 & 271,0.150D0, 0,265, 21, 0, 0, 0,
51819 & 271,0.290D0, 0,222, 38, 0, 0, 0,
51820 & 271,0.150D0, 0,221, 21, 0, 0, 0,
51821 & 271,0.060D0, 0,266, 38, 21, 0, 0,
51822 & 271,0.020D0, 0,265, 38, 30, 0, 0,
51823 & 271,0.010D0, 0,265, 21, 21, 0, 0,
51824 & 271,0.020D0, 0,222, 38, 21, 0, 0,
51825 & 271,0.010D0, 0,221, 38, 30, 0, 0,
51826 & 272,0.290D0, 0,265, 30, 0, 0, 0,
51827 & 272,0.150D0, 0,266, 21, 0, 0, 0,
51828 & 272,0.290D0, 0,221, 30, 0, 0, 0,
51829 & 272,0.150D0, 0,222, 21, 0, 0, 0,
51830 & 272,0.060D0, 0,265, 30, 21, 0, 0,
51831 & 272,0.020D0, 0,266, 38, 30, 0, 0,
51832 & 272,0.010D0, 0,266, 21, 21, 0, 0,
51833 & 272,0.020D0, 0,221, 30, 21, 0, 0,
51834 & 272,0.010D0, 0,222, 38, 30, 0, 0,
51835 & 273,0.350D0, 0,221, 50, 0, 0, 0/
51836 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1711,1729)/
51837 & 273,0.350D0, 0,222, 46, 0, 0, 0,
51838 & 273,0.150D0, 0,265, 50, 0, 0, 0,
51839 & 273,0.150D0, 0,266, 46, 0, 0, 0,
51840 & 274,1.000D0, 0,245, 59, 0, 0, 0,
51841 & 275,1.000D0, 0,246, 59, 0, 0, 0,
51842 & 276,1.000D0, 0,247, 59, 0, 0, 0,
51843 & 277,0.667D0, 0,275, 30, 0, 0, 0,
51844 & 277,0.333D0, 0,274, 21, 0, 0, 0,
51845 & 278,0.667D0, 0,274, 38, 0, 0, 0,
51846 & 278,0.333D0, 0,275, 21, 0, 0, 0,
51847 & 279,0.500D0, 0,274, 42, 0, 0, 0,
51848 & 279,0.500D0, 0,275, 34, 0, 0, 0,
51849 & 280,0.290D0, 0,275, 30, 0, 0, 0,
51850 & 280,0.150D0, 0,274, 21, 0, 0, 0,
51851 & 280,0.290D0, 0,246, 30, 0, 0, 0,
51852 & 280,0.150D0, 0,245, 21, 0, 0, 0,
51853 & 280,0.060D0, 0,275, 30, 21, 0, 0,
51854 & 280,0.020D0, 0,274, 38, 30, 0, 0,
51855 & 280,0.010D0, 0,274, 21, 21, 0, 0/
51856 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1730,1748)/
51857 & 280,0.020D0, 0,246, 30, 21, 0, 0,
51858 & 280,0.010D0, 0,245, 38, 30, 0, 0,
51859 & 281,0.290D0, 0,274, 38, 0, 0, 0,
51860 & 281,0.150D0, 0,275, 21, 0, 0, 0,
51861 & 281,0.290D0, 0,245, 38, 0, 0, 0,
51862 & 281,0.150D0, 0,246, 21, 0, 0, 0,
51863 & 281,0.060D0, 0,274, 38, 21, 0, 0,
51864 & 281,0.020D0, 0,275, 38, 30, 0, 0,
51865 & 281,0.010D0, 0,275, 21, 21, 0, 0,
51866 & 281,0.020D0, 0,245, 38, 21, 0, 0,
51867 & 281,0.010D0, 0,246, 38, 30, 0, 0,
51868 & 282,0.350D0, 0,245, 42, 0, 0, 0,
51869 & 282,0.350D0, 0,246, 34, 0, 0, 0,
51870 & 282,0.150D0, 0,274, 42, 0, 0, 0,
51871 & 282,0.150D0, 0,275, 34, 0, 0, 0,
51872 & 285,1.000D0, 0, 24, 21, 0, 0, 0,
51873 & 286,0.998D0, 0, 24, 38, 0, 0, 0,
51874 & 286,0.002D0, 0, 38, 59, 0, 0, 0,
51875 & 287,0.998D0, 0, 24, 30, 0, 0, 0/
51876 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1749,1767)/
51877 & 287,0.002D0, 0, 30, 59, 0, 0, 0,
51878 & 288,0.330D0, 0, 39, 30, 0, 0, 0,
51879 & 288,0.340D0, 0, 23, 21, 0, 0, 0,
51880 & 288,0.330D0, 0, 31, 38, 0, 0, 0,
51881 & 289,0.250D0, 0, 46, 35, 0, 0, 0,
51882 & 289,0.250D0, 0, 34, 47, 0, 0, 0,
51883 & 289,0.250D0, 0, 50, 43, 0, 0, 0,
51884 & 289,0.250D0, 0, 42, 51, 0, 0, 0,
51885 & 290,0.996D0, 0, 22, 21, 0, 0, 0,
51886 & 290,0.002D0, 0, 46, 34, 0, 0, 0,
51887 & 290,0.002D0, 0, 50, 42, 0, 0, 0,
51888 & 291,0.996D0, 0, 22, 38, 0, 0, 0,
51889 & 291,0.004D0, 0, 46, 42, 0, 0, 0,
51890 & 292,0.996D0, 0, 22, 30, 0, 0, 0,
51891 & 292,0.004D0, 0, 50, 34, 0, 0, 0,
51892 & 293,0.520D0, 0, 38, 30, 0, 0, 0,
51893 & 293,0.260D0, 0, 21, 21, 0, 0, 0,
51894 & 293,0.110D0, 0, 46, 34, 0, 0, 0,
51895 & 293,0.110D0, 0, 50, 42, 0, 0, 0/
51896 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1768,1786)/
51897 & 294,0.620D0, 0, 38, 30, 0, 0, 0,
51898 & 294,0.310D0, 0, 21, 21, 0, 0, 0,
51899 & 294,0.035D0, 0, 46, 34, 0, 0, 0,
51900 & 294,0.035D0, 0, 50, 42, 0, 0, 0,
51901 & 295,1.000D0, 0,254, 59, 0, 0, 0,
51902 & 296,1.000D0, 0,230, 59, 0, 0, 0,
51903 & 297,1.000D0, 0,254, 59, 0, 0, 0,
51904 & 298,1.000D0, 0,230, 59, 0, 0, 0,
51905 & 299,1.000D0, 0,254, 59, 0, 0, 0,
51906 & 300,1.000D0, 0,230, 59, 0, 0, 0,
51907 & 301,0.050D0, 0,121,127, 0, 0, 0,
51908 & 301,0.050D0, 0,123,129, 0, 0, 0,
51909 & 301,0.017D0, 0, 1, 7, 0, 0, 0,
51910 & 301,0.066D0, 0, 2, 8, 0, 0, 0,
51911 & 301,0.017D0, 0, 3, 9, 0, 0, 0,
51912 & 301,0.640D0,130, 13, 13, 13, 0, 0,
51913 & 301,0.160D0,130, 13, 13, 59, 0, 0,
51914 & 302,0.022D0, 0, 38, 30, 38, 30, 23,
51915 & 302,0.016D0, 0, 38, 30, 38, 30, 0/
51916 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1787,1805)/
51917 & 302,0.009D0, 0, 38, 30, 46, 34, 0,
51918 & 302,0.004D0, 0, 23, 38, 30, 0, 0,
51919 & 302,0.002D0, 0, 46, 43, 30, 0, 0,
51920 & 302,0.002D0, 0, 34, 51, 38, 0, 0,
51921 & 302,0.001D0, 0, 38, 30, 73, 91, 0,
51922 & 302,0.273D0, 0, 59,164, 0, 0, 0,
51923 & 302,0.671D0, 0, 13, 13, 0, 0, 0,
51924 & 303,0.022D0, 0, 38, 30, 38, 30, 0,
51925 & 303,0.019D0, 0, 38, 30, 46, 34, 0,
51926 & 303,0.012D0, 0, 38, 30, 38, 30, 23,
51927 & 303,0.007D0, 0, 23, 38, 30, 0, 0,
51928 & 303,0.002D0, 0, 46, 43, 30, 0, 0,
51929 & 303,0.002D0, 0, 34, 51, 38, 0, 0,
51930 & 303,0.003D0, 0, 38, 30, 73, 91, 0,
51931 & 303,0.002D0, 0, 38, 30, 0, 0, 0,
51932 & 303,0.002D0, 0, 46, 34, 0, 0, 0,
51933 & 303,0.001D0, 0, 21, 21, 0, 0, 0,
51934 & 303,0.135D0, 0, 59,164, 0, 0, 0,
51935 & 303,0.793D0, 0, 13, 13, 0, 0, 0/
51936 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1806,1824)/
51937 & 304,1.000D0, 0, 13, 13, 0, 0, 0,
51938 & 305,1.000D0, 0, 13, 13, 0, 0, 0,
51939 & 306,0.050D0, 0, 59,231, 0, 0, 0,
51940 & 306,0.950D0, 0, 13, 13, 0, 0, 0,
51941 & 307,0.350D0, 0, 59,231, 0, 0, 0,
51942 & 307,0.650D0, 0, 13, 13, 0, 0, 0,
51943 & 308,0.220D0, 0, 59,231, 0, 0, 0,
51944 & 308,0.780D0, 0, 13, 13, 0, 0, 0,
51945 & 309,0.280D0, 0, 46, 31, 0, 0, 0,
51946 & 309,0.140D0, 0, 50, 23, 0, 0, 0,
51947 & 309,0.187D0, 0,327, 30, 0, 0, 0,
51948 & 309,0.093D0, 0,328, 21, 0, 0, 0,
51949 & 309,0.110D0, 0, 50, 24, 0, 0, 0,
51950 & 309,0.107D0, 0, 47, 30, 0, 0, 0,
51951 & 309,0.053D0, 0, 51, 21, 0, 0, 0,
51952 & 309,0.030D0, 0, 50,293, 0, 0, 0,
51953 & 310,0.280D0, 0, 50, 39, 0, 0, 0,
51954 & 310,0.140D0, 0, 46, 23, 0, 0, 0,
51955 & 310,0.187D0, 0,328, 38, 0, 0, 0/
51956 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1825,1843)/
51957 & 310,0.093D0, 0,327, 21, 0, 0, 0,
51958 & 310,0.110D0, 0, 46, 24, 0, 0, 0,
51959 & 310,0.107D0, 0, 51, 38, 0, 0, 0,
51960 & 310,0.053D0, 0, 47, 21, 0, 0, 0,
51961 & 310,0.030D0, 0, 46,293, 0, 0, 0,
51962 & 311,0.280D0, 0, 34, 39, 0, 0, 0,
51963 & 311,0.140D0, 0, 42, 23, 0, 0, 0,
51964 & 311,0.187D0, 0,330, 38, 0, 0, 0,
51965 & 311,0.093D0, 0,329, 21, 0, 0, 0,
51966 & 311,0.110D0, 0, 42, 24, 0, 0, 0,
51967 & 311,0.107D0, 0, 35, 38, 0, 0, 0,
51968 & 311,0.053D0, 0, 43, 21, 0, 0, 0,
51969 & 311,0.030D0, 0, 42,293, 0, 0, 0,
51970 & 312,0.280D0, 0, 42, 31, 0, 0, 0,
51971 & 312,0.140D0, 0, 34, 23, 0, 0, 0,
51972 & 312,0.187D0, 0,329, 30, 0, 0, 0,
51973 & 312,0.093D0, 0,330, 21, 0, 0, 0,
51974 & 312,0.110D0, 0, 34, 24, 0, 0, 0,
51975 & 312,0.107D0, 0, 43, 30, 0, 0, 0/
51976 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1844,1862)/
51977 & 312,0.053D0, 0, 35, 21, 0, 0, 0,
51978 & 312,0.030D0, 0, 34,293, 0, 0, 0,
51979 & 313,0.430D0, 0,140, 38, 0, 0, 0,
51980 & 313,0.215D0, 0,136, 21, 0, 0, 0,
51981 & 313,0.235D0, 0,140, 38, 21, 0, 0,
51982 & 313,0.120D0, 0,136, 38, 30, 0, 0,
51983 & 314,0.430D0, 0,136, 30, 0, 0, 0,
51984 & 314,0.215D0, 0,140, 21, 0, 0, 0,
51985 & 314,0.235D0, 0,136, 30, 21, 0, 0,
51986 & 314,0.120D0, 0,140, 38, 30, 0, 0,
51987 & 315,0.480D0, 0,136, 50, 0, 0, 0,
51988 & 315,0.480D0, 0,140, 46, 0, 0, 0,
51989 & 315,0.040D0, 0,145, 59, 0, 0, 0,
51990 & 316,0.430D0, 0,175, 30, 0, 0, 0,
51991 & 316,0.215D0, 0,171, 21, 0, 0, 0,
51992 & 316,0.235D0, 0,175, 30, 21, 0, 0,
51993 & 316,0.120D0, 0,171, 38, 30, 0, 0,
51994 & 317,0.430D0, 0,171, 38, 0, 0, 0,
51995 & 317,0.215D0, 0,175, 21, 0, 0, 0/
51996 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1863,1881)/
51997 & 317,0.235D0, 0,171, 38, 21, 0, 0,
51998 & 317,0.120D0, 0,175, 38, 30, 0, 0,
51999 & 318,0.480D0, 0,171, 42, 0, 0, 0,
52000 & 318,0.480D0, 0,175, 34, 0, 0, 0,
52001 & 318,0.040D0, 0,180, 59, 0, 0, 0,
52002 & 319,0.540D0, 0,275, 30, 0, 0, 0,
52003 & 319,0.270D0, 0,274, 21, 0, 0, 0,
52004 & 319,0.030D0, 0,275, 30, 21, 0, 0,
52005 & 319,0.010D0, 0,274, 38, 30, 0, 0,
52006 & 319,0.010D0, 0,274, 21, 21, 0, 0,
52007 & 319,0.090D0, 0,246, 30, 21, 0, 0,
52008 & 319,0.030D0, 0,245, 38, 30, 0, 0,
52009 & 319,0.020D0, 0,245, 21, 21, 0, 0,
52010 & 320,0.540D0, 0,274, 38, 0, 0, 0,
52011 & 320,0.270D0, 0,275, 21, 0, 0, 0,
52012 & 320,0.030D0, 0,274, 38, 21, 0, 0,
52013 & 320,0.010D0, 0,275, 38, 30, 0, 0,
52014 & 320,0.010D0, 0,275, 21, 21, 0, 0,
52015 & 320,0.090D0, 0,245, 38, 21, 0, 0/
52016 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1882,1900)/
52017 & 320,0.030D0, 0,246, 38, 30, 0, 0,
52018 & 320,0.020D0, 0,246, 21, 21, 0, 0,
52019 & 321,0.500D0, 0,266, 46, 0, 0, 0,
52020 & 321,0.500D0, 0,265, 50, 0, 0, 0,
52021 & 322,1.000D0, 0,254, 59, 0, 0, 0,
52022 & 323,0.540D0, 0,266, 38, 0, 0, 0,
52023 & 323,0.270D0, 0,265, 21, 0, 0, 0,
52024 & 323,0.030D0, 0,266, 38, 21, 0, 0,
52025 & 323,0.010D0, 0,265, 38, 30, 0, 0,
52026 & 323,0.010D0, 0,265, 21, 21, 0, 0,
52027 & 323,0.090D0, 0,222, 38, 21, 0, 0,
52028 & 323,0.030D0, 0,221, 38, 30, 0, 0,
52029 & 323,0.020D0, 0,221, 21, 21, 0, 0,
52030 & 324,0.540D0, 0,265, 30, 0, 0, 0,
52031 & 324,0.270D0, 0,266, 21, 0, 0, 0,
52032 & 324,0.030D0, 0,265, 30, 21, 0, 0,
52033 & 324,0.010D0, 0,266, 38, 30, 0, 0,
52034 & 324,0.010D0, 0,266, 21, 21, 0, 0,
52035 & 324,0.090D0, 0,221, 30, 21, 0, 0/
52036 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1901,1919)/
52037 & 324,0.030D0, 0,222, 38, 30, 0, 0,
52038 & 324,0.020D0, 0,222, 21, 21, 0, 0,
52039 & 325,0.500D0, 0,275, 34, 0, 0, 0,
52040 & 325,0.500D0, 0,274, 42, 0, 0, 0,
52041 & 326,1.000D0, 0,230, 59, 0, 0, 0,
52042 & 327,0.667D0, 0, 50, 38, 0, 0, 0,
52043 & 327,0.333D0, 0, 46, 21, 0, 0, 0,
52044 & 328,0.667D0, 0, 46, 30, 0, 0, 0,
52045 & 328,0.333D0, 0, 50, 21, 0, 0, 0,
52046 & 329,0.667D0, 0, 34, 38, 0, 0, 0,
52047 & 329,0.333D0, 0, 42, 21, 0, 0, 0,
52048 & 330,0.667D0, 0, 42, 30, 0, 0, 0,
52049 & 330,0.333D0, 0, 34, 21, 0, 0, 0,
52050 & 331,0.667D0, 0,140, 38, 0, 0, 0,
52051 & 331,0.333D0, 0,136, 21, 0, 0, 0,
52052 & 332,0.667D0, 0,136, 30, 0, 0, 0,
52053 & 332,0.333D0, 0,140, 21, 0, 0, 0,
52054 & 333,0.500D0, 0,136, 50, 0, 0, 0,
52055 & 333,0.500D0, 0,140, 46, 0, 0, 0/
52056 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1920,1938)/
52057 & 334,0.667D0, 0,175, 30, 0, 0, 0,
52058 & 334,0.333D0, 0,171, 21, 0, 0, 0,
52059 & 335,0.667D0, 0,171, 38, 0, 0, 0,
52060 & 335,0.333D0, 0,175, 21, 0, 0, 0,
52061 & 336,0.500D0, 0,171, 42, 0, 0, 0,
52062 & 336,0.500D0, 0,175, 34, 0, 0, 0,
52063 & 337,0.667D0, 0,246, 30, 0, 0, 0,
52064 & 337,0.333D0, 0,245, 21, 0, 0, 0,
52065 & 338,0.667D0, 0,245, 38, 0, 0, 0,
52066 & 338,0.333D0, 0,246, 21, 0, 0, 0,
52067 & 339,0.500D0, 0,246, 34, 0, 0, 0,
52068 & 339,0.500D0, 0,245, 42, 0, 0, 0,
52069 & 340,1.000D0, 0,254, 59, 0, 0, 0,
52070 & 341,0.667D0, 0,222, 38, 0, 0, 0,
52071 & 341,0.333D0, 0,221, 21, 0, 0, 0,
52072 & 342,0.667D0, 0,221, 30, 0, 0, 0,
52073 & 342,0.333D0, 0,222, 21, 0, 0, 0,
52074 & 343,0.500D0, 0,222, 46, 0, 0, 0,
52075 & 343,0.500D0, 0,221, 50, 0, 0, 0/
52076 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1939,1957)/
52077 & 344,1.000D0, 0,230, 59, 0, 0, 0,
52078 & 345,1.000D0, 0,225, 30, 0, 0, 0,
52079 & 346,1.000D0, 0,225, 21, 0, 0, 0,
52080 & 347,1.000D0, 0,225, 21, 0, 0, 0,
52081 & 348,1.000D0, 0,225, 38, 0, 0, 0,
52082 & 349,0.600D0, 0,228, 38, 0, 0, 0,
52083 & 349,0.300D0, 0,227, 21, 0, 0, 0,
52084 & 349,0.100D0, 0,227, 59, 0, 0, 0,
52085 & 350,0.600D0, 0,228, 38, 0, 0, 0,
52086 & 350,0.300D0, 0,227, 21, 0, 0, 0,
52087 & 350,0.100D0, 0,227, 59, 0, 0, 0,
52088 & 351,0.600D0, 0,227, 30, 0, 0, 0,
52089 & 351,0.300D0, 0,228, 21, 0, 0, 0,
52090 & 351,0.100D0, 0,228, 59, 0, 0, 0,
52091 & 352,0.600D0, 0,227, 30, 0, 0, 0,
52092 & 352,0.300D0, 0,228, 21, 0, 0, 0,
52093 & 352,0.100D0, 0,228, 59, 0, 0, 0,
52094 & 353,1.000D0, 0,229, 59, 0, 0, 0,
52095 & 354,1.000D0, 0,249, 38, 0, 0, 0/
52096 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1958,1976)/
52097 & 355,1.000D0, 0,249, 21, 0, 0, 0,
52098 & 356,1.000D0, 0,249, 21, 0, 0, 0,
52099 & 357,1.000D0, 0,249, 30, 0, 0, 0,
52100 & 358,0.600D0, 0,252, 30, 0, 0, 0,
52101 & 358,0.300D0, 0,251, 21, 0, 0, 0,
52102 & 358,0.100D0, 0,251, 59, 0, 0, 0,
52103 & 359,0.600D0, 0,252, 30, 0, 0, 0,
52104 & 359,0.300D0, 0,251, 21, 0, 0, 0,
52105 & 359,0.100D0, 0,251, 59, 0, 0, 0,
52106 & 360,0.600D0, 0,251, 38, 0, 0, 0,
52107 & 360,0.300D0, 0,252, 21, 0, 0, 0,
52108 & 360,0.100D0, 0,252, 59, 0, 0, 0,
52109 & 361,0.600D0, 0,251, 38, 0, 0, 0,
52110 & 361,0.300D0, 0,252, 21, 0, 0, 0,
52111 & 361,0.100D0, 0,252, 59, 0, 0, 0,
52112 & 362,1.000D0, 0,253, 59, 0, 0, 0,
52113 & 363,0.400D0, 0, 53, 38, 0, 0, 0,
52114 & 363,0.200D0, 0, 49, 21, 0, 0, 0,
52115 & 363,0.100D0, 0, 51, 38, 0, 0, 0/
52116 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1977,1995)/
52117 & 363,0.050D0, 0, 47, 21, 0, 0, 0,
52118 & 363,0.150D0, 0, 46, 26, 0, 0, 0,
52119 & 363,0.050D0, 0, 46, 56, 0, 0, 0,
52120 & 363,0.050D0, 0, 46, 24, 0, 0, 0,
52121 & 364,0.400D0, 0, 49, 30, 0, 0, 0,
52122 & 364,0.200D0, 0, 53, 21, 0, 0, 0,
52123 & 364,0.100D0, 0, 47, 30, 0, 0, 0,
52124 & 364,0.050D0, 0, 51, 21, 0, 0, 0,
52125 & 364,0.150D0, 0, 50, 26, 0, 0, 0,
52126 & 364,0.050D0, 0, 50, 56, 0, 0, 0,
52127 & 364,0.050D0, 0, 50, 24, 0, 0, 0,
52128 & 365,0.400D0, 0, 37, 38, 0, 0, 0,
52129 & 365,0.200D0, 0, 45, 21, 0, 0, 0,
52130 & 365,0.100D0, 0, 35, 38, 0, 0, 0,
52131 & 365,0.050D0, 0, 43, 21, 0, 0, 0,
52132 & 365,0.150D0, 0, 42, 26, 0, 0, 0,
52133 & 365,0.050D0, 0, 42, 56, 0, 0, 0,
52134 & 365,0.050D0, 0, 42, 24, 0, 0, 0,
52135 & 366,0.400D0, 0, 45, 30, 0, 0, 0/
52136 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=1996,2014)/
52137 & 366,0.200D0, 0, 37, 21, 0, 0, 0,
52138 & 366,0.100D0, 0, 43, 30, 0, 0, 0,
52139 & 366,0.050D0, 0, 35, 21, 0, 0, 0,
52140 & 366,0.150D0, 0, 34, 26, 0, 0, 0,
52141 & 366,0.050D0, 0, 34, 56, 0, 0, 0,
52142 & 366,0.050D0, 0, 34, 24, 0, 0, 0,
52143 & 367,0.258D0, 0, 50, 38, 0, 0, 0,
52144 & 367,0.129D0, 0, 46, 21, 0, 0, 0,
52145 & 367,0.209D0, 0, 50, 39, 0, 0, 0,
52146 & 367,0.105D0, 0, 46, 23, 0, 0, 0,
52147 & 367,0.199D0, 0, 51, 38, 0, 0, 0,
52148 & 367,0.100D0, 0, 47, 21, 0, 0, 0,
52149 & 368,0.258D0, 0, 46, 30, 0, 0, 0,
52150 & 368,0.129D0, 0, 50, 21, 0, 0, 0,
52151 & 368,0.209D0, 0, 46, 31, 0, 0, 0,
52152 & 368,0.105D0, 0, 50, 23, 0, 0, 0,
52153 & 368,0.199D0, 0, 47, 30, 0, 0, 0,
52154 & 368,0.100D0, 0, 51, 21, 0, 0, 0,
52155 & 369,0.258D0, 0, 34, 38, 0, 0, 0/
52156 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2015,2033)/
52157 & 369,0.129D0, 0, 42, 21, 0, 0, 0,
52158 & 369,0.209D0, 0, 34, 39, 0, 0, 0,
52159 & 369,0.105D0, 0, 42, 23, 0, 0, 0,
52160 & 369,0.199D0, 0, 35, 38, 0, 0, 0,
52161 & 369,0.100D0, 0, 43, 21, 0, 0, 0,
52162 & 370,0.258D0, 0, 42, 30, 0, 0, 0,
52163 & 370,0.129D0, 0, 34, 21, 0, 0, 0,
52164 & 370,0.209D0, 0, 42, 31, 0, 0, 0,
52165 & 370,0.105D0, 0, 34, 23, 0, 0, 0,
52166 & 370,0.199D0, 0, 43, 30, 0, 0, 0,
52167 & 370,0.100D0, 0, 35, 21, 0, 0, 0,
52168 & 371,0.400D0, 0, 53, 38, 0, 0, 0,
52169 & 371,0.200D0, 0, 49, 21, 0, 0, 0,
52170 & 371,0.100D0, 0, 51, 38, 0, 0, 0,
52171 & 371,0.050D0, 0, 47, 21, 0, 0, 0,
52172 & 371,0.150D0, 0, 46, 26, 0, 0, 0,
52173 & 371,0.050D0, 0, 46, 56, 0, 0, 0,
52174 & 371,0.050D0, 0, 46, 24, 0, 0, 0,
52175 & 372,0.400D0, 0, 49, 30, 0, 0, 0/
52176 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2034,2052)/
52177 & 372,0.200D0, 0, 53, 21, 0, 0, 0,
52178 & 372,0.100D0, 0, 47, 30, 0, 0, 0,
52179 & 372,0.050D0, 0, 51, 21, 0, 0, 0,
52180 & 372,0.150D0, 0, 50, 26, 0, 0, 0,
52181 & 372,0.050D0, 0, 50, 56, 0, 0, 0,
52182 & 372,0.050D0, 0, 50, 24, 0, 0, 0,
52183 & 373,0.400D0, 0, 37, 38, 0, 0, 0,
52184 & 373,0.200D0, 0, 45, 21, 0, 0, 0,
52185 & 373,0.100D0, 0, 35, 38, 0, 0, 0,
52186 & 373,0.050D0, 0, 43, 21, 0, 0, 0,
52187 & 373,0.150D0, 0, 42, 26, 0, 0, 0,
52188 & 373,0.050D0, 0, 42, 56, 0, 0, 0,
52189 & 373,0.050D0, 0, 42, 24, 0, 0, 0,
52190 & 374,0.400D0, 0, 45, 30, 0, 0, 0,
52191 & 374,0.200D0, 0, 37, 21, 0, 0, 0,
52192 & 374,0.100D0, 0, 43, 30, 0, 0, 0,
52193 & 374,0.050D0, 0, 35, 21, 0, 0, 0,
52194 & 374,0.150D0, 0, 34, 26, 0, 0, 0,
52195 & 374,0.050D0, 0, 34, 56, 0, 0, 0/
52196 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2053,2071)/
52197 & 374,0.050D0, 0, 34, 24, 0, 0, 0,
52198 & 375,0.208D0, 0, 50, 39, 0, 0, 0,
52199 & 375,0.104D0, 0, 46, 23, 0, 0, 0,
52200 & 375,0.134D0, 0, 51, 38, 0, 0, 0,
52201 & 375,0.067D0, 0, 47, 21, 0, 0, 0,
52202 & 375,0.124D0, 0, 50, 38, 0, 0, 0,
52203 & 375,0.062D0, 0, 46, 21, 0, 0, 0,
52204 & 375,0.301D0, 0, 46, 22, 0, 0, 0,
52205 & 376,0.208D0, 0, 46, 31, 0, 0, 0,
52206 & 376,0.104D0, 0, 50, 23, 0, 0, 0,
52207 & 376,0.134D0, 0, 47, 30, 0, 0, 0,
52208 & 376,0.067D0, 0, 51, 21, 0, 0, 0,
52209 & 376,0.124D0, 0, 46, 30, 0, 0, 0,
52210 & 376,0.062D0, 0, 50, 21, 0, 0, 0,
52211 & 376,0.301D0, 0, 50, 22, 0, 0, 0,
52212 & 377,0.208D0, 0, 34, 39, 0, 0, 0,
52213 & 377,0.104D0, 0, 42, 23, 0, 0, 0,
52214 & 377,0.134D0, 0, 35, 38, 0, 0, 0,
52215 & 377,0.067D0, 0, 43, 21, 0, 0, 0/
52216 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2072,2090)/
52217 & 377,0.124D0, 0, 34, 38, 0, 0, 0,
52218 & 377,0.062D0, 0, 42, 21, 0, 0, 0,
52219 & 377,0.301D0, 0, 42, 22, 0, 0, 0,
52220 & 378,0.208D0, 0, 42, 31, 0, 0, 0,
52221 & 378,0.104D0, 0, 34, 23, 0, 0, 0,
52222 & 378,0.134D0, 0, 43, 30, 0, 0, 0,
52223 & 378,0.067D0, 0, 35, 21, 0, 0, 0,
52224 & 378,0.124D0, 0, 42, 30, 0, 0, 0,
52225 & 378,0.062D0, 0, 34, 21, 0, 0, 0,
52226 & 378,0.301D0, 0, 34, 22, 0, 0, 0,
52227 & 379,0.562D0, 0, 26, 38, 0, 0, 0,
52228 & 379,0.155D0, 0, 39, 21, 0, 0, 0,
52229 & 379,0.155D0, 0, 23, 38, 0, 0, 0,
52230 & 379,0.088D0, 0,293, 38, 0, 0, 0,
52231 & 379,0.020D0, 0, 46, 43, 0, 0, 0,
52232 & 379,0.020D0, 0, 42, 47, 0, 0, 0,
52233 & 380,0.562D0, 0, 26, 21, 0, 0, 0,
52234 & 380,0.155D0, 0, 39, 30, 0, 0, 0,
52235 & 380,0.155D0, 0, 31, 38, 0, 0, 0/
52236 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2091,2109)/
52237 & 380,0.088D0, 0,293, 21, 0, 0, 0,
52238 & 380,0.010D0, 0, 46, 35, 0, 0, 0,
52239 & 380,0.010D0, 0, 50, 43, 0, 0, 0,
52240 & 380,0.010D0, 0, 34, 47, 0, 0, 0,
52241 & 380,0.010D0, 0, 42, 51, 0, 0, 0,
52242 & 381,0.562D0, 0, 26, 30, 0, 0, 0,
52243 & 381,0.155D0, 0, 31, 21, 0, 0, 0,
52244 & 381,0.155D0, 0, 23, 30, 0, 0, 0,
52245 & 381,0.088D0, 0,293, 30, 0, 0, 0,
52246 & 381,0.020D0, 0, 34, 51, 0, 0, 0,
52247 & 381,0.020D0, 0, 50, 35, 0, 0, 0,
52248 & 382,0.360D0, 0, 31, 38, 38, 0, 0,
52249 & 382,0.180D0, 0, 23, 38, 21, 0, 0,
52250 & 382,0.040D0, 0, 39, 21, 21, 0, 0,
52251 & 382,0.020D0, 0, 39, 38, 30, 0, 0,
52252 & 382,0.300D0, 0, 38, 21, 0, 0, 0,
52253 & 382,0.040D0, 0, 46, 43, 0, 0, 0,
52254 & 382,0.040D0, 0, 42, 47, 0, 0, 0,
52255 & 382,0.020D0, 0, 22, 39, 0, 0, 0/
52256 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2110,2128)/
52257 & 383,0.180D0, 0, 39, 30, 21, 0, 0,
52258 & 383,0.180D0, 0, 31, 38, 21, 0, 0,
52259 & 383,0.160D0, 0, 23, 21, 21, 0, 0,
52260 & 383,0.080D0, 0, 23, 38, 30, 0, 0,
52261 & 383,0.300D0, 0, 38, 30, 0, 0, 0,
52262 & 383,0.020D0, 0, 46, 35, 0, 0, 0,
52263 & 383,0.020D0, 0, 50, 43, 0, 0, 0,
52264 & 383,0.020D0, 0, 34, 47, 0, 0, 0,
52265 & 383,0.020D0, 0, 42, 51, 0, 0, 0,
52266 & 383,0.020D0, 0, 22, 23, 0, 0, 0,
52267 & 384,0.360D0, 0, 39, 30, 30, 0, 0,
52268 & 384,0.180D0, 0, 23, 30, 21, 0, 0,
52269 & 384,0.040D0, 0, 31, 21, 21, 0, 0,
52270 & 384,0.020D0, 0, 31, 30, 38, 0, 0,
52271 & 384,0.300D0, 0, 30, 21, 0, 0, 0,
52272 & 384,0.040D0, 0, 34, 51, 0, 0, 0,
52273 & 384,0.040D0, 0, 50, 35, 0, 0, 0,
52274 & 384,0.020D0, 0, 22, 31, 0, 0, 0,
52275 & 385,0.184D0, 0, 41, 21, 0, 0, 0/
52276 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2129,2147)/
52277 & 385,0.184D0, 0, 29, 38, 0, 0, 0,
52278 & 385,0.184D0, 0, 39, 23, 0, 0, 0,
52279 & 385,0.236D0, 0, 38, 21, 0, 0, 0,
52280 & 385,0.160D0, 0, 24, 38, 0, 0, 0,
52281 & 385,0.018D0, 0, 46, 43, 0, 0, 0,
52282 & 385,0.018D0, 0, 42, 47, 0, 0, 0,
52283 & 385,0.016D0, 0, 46, 42, 0, 0, 0,
52284 & 386,0.184D0, 0, 41, 30, 0, 0, 0,
52285 & 386,0.184D0, 0, 33, 38, 0, 0, 0,
52286 & 386,0.184D0, 0, 39, 31, 0, 0, 0,
52287 & 386,0.236D0, 0, 38, 30, 0, 0, 0,
52288 & 386,0.160D0, 0, 24, 21, 0, 0, 0,
52289 & 386,0.009D0, 0, 46, 35, 0, 0, 0,
52290 & 386,0.009D0, 0, 50, 43, 0, 0, 0,
52291 & 386,0.009D0, 0, 34, 47, 0, 0, 0,
52292 & 386,0.009D0, 0, 42, 51, 0, 0, 0,
52293 & 386,0.008D0, 0, 46, 34, 0, 0, 0,
52294 & 386,0.008D0, 0, 42, 50, 0, 0, 0,
52295 & 387,0.184D0, 0, 33, 21, 0, 0, 0/
52296 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2148,2166)/
52297 & 387,0.184D0, 0, 29, 30, 0, 0, 0,
52298 & 387,0.184D0, 0, 31, 23, 0, 0, 0,
52299 & 387,0.236D0, 0, 30, 21, 0, 0, 0,
52300 & 387,0.160D0, 0, 24, 30, 0, 0, 0,
52301 & 387,0.018D0, 0, 34, 51, 0, 0, 0,
52302 & 387,0.018D0, 0, 50, 35, 0, 0, 0,
52303 & 387,0.016D0, 0, 34, 50, 0, 0, 0,
52304 & 388,0.183D0, 0,231, 38, 30, 0, 0,
52305 & 388,0.091D0, 0,231, 21, 21, 0, 0,
52306 & 388,0.067D0, 0, 59,307, 0, 0, 0,
52307 & 388,0.066D0, 0, 59,308, 0, 0, 0,
52308 & 388,0.043D0, 0, 59,309, 0, 0, 0,
52309 & 388,0.446D0,130, 13, 13, 13, 0, 0,
52310 & 388,0.023D0,130, 13, 13, 59, 0, 0,
52311 & 388,0.013D0, 0,121,127, 0, 0, 0,
52312 & 388,0.013D0, 0,123,129, 0, 0, 0,
52313 & 388,0.013D0, 0,125,131, 0, 0, 0,
52314 & 388,0.004D0, 0, 1, 7, 0, 0, 0,
52315 & 388,0.017D0, 0, 2, 8, 0, 0, 0/
52316 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2167,2185)/
52317 & 388,0.004D0, 0, 3, 9, 0, 0, 0,
52318 & 388,0.017D0, 0, 4, 10, 0, 0, 0,
52319 & 389,0.046D0, 0, 59,388, 0, 0, 0,
52320 & 389,0.009D0, 0, 59,231, 0, 0, 0,
52321 & 389,0.755D0, 0, 13, 13, 0, 0, 0,
52322 & 389,0.030D0, 0,121,127, 0, 0, 0,
52323 & 389,0.030D0, 0,123,129, 0, 0, 0,
52324 & 389,0.030D0, 0,125,131, 0, 0, 0,
52325 & 389,0.010D0, 0, 1, 7, 0, 0, 0,
52326 & 389,0.040D0, 0, 2, 8, 0, 0, 0,
52327 & 389,0.010D0, 0, 3, 9, 0, 0, 0,
52328 & 389,0.040D0, 0, 4, 10, 0, 0, 0,
52329 & 390,0.210D0, 0, 59,388, 0, 0, 0,
52330 & 390,0.085D0, 0, 59,231, 0, 0, 0,
52331 & 390,0.565D0, 0, 13, 13, 0, 0, 0,
52332 & 390,0.022D0, 0,121,127, 0, 0, 0,
52333 & 390,0.022D0, 0,123,129, 0, 0, 0,
52334 & 390,0.022D0, 0,125,131, 0, 0, 0,
52335 & 390,0.007D0, 0, 1, 7, 0, 0, 0/
52336 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2186,2204)/
52337 & 390,0.030D0, 0, 2, 8, 0, 0, 0,
52338 & 390,0.007D0, 0, 3, 9, 0, 0, 0,
52339 & 390,0.030D0, 0, 4, 10, 0, 0, 0,
52340 & 391,0.162D0, 0, 59,388, 0, 0, 0,
52341 & 391,0.071D0, 0, 59,231, 0, 0, 0,
52342 & 391,0.615D0, 0, 13, 13, 0, 0, 0,
52343 & 391,0.024D0, 0,121,127, 0, 0, 0,
52344 & 391,0.024D0, 0,123,129, 0, 0, 0,
52345 & 391,0.024D0, 0,125,131, 0, 0, 0,
52346 & 391,0.008D0, 0, 1, 7, 0, 0, 0,
52347 & 391,0.032D0, 0, 2, 8, 0, 0, 0,
52348 & 391,0.008D0, 0, 3, 9, 0, 0, 0,
52349 & 391,0.032D0, 0, 4, 10, 0, 0, 0,
52350 & 392,0.034D0, 0,267, 38, 30, 0, 0,
52351 & 392,0.017D0, 0,267, 21, 21, 0, 0,
52352 & 392,0.044D0, 0,231, 38, 30, 0, 0,
52353 & 392,0.022D0, 0,231, 21, 21, 0, 0,
52354 & 392,0.050D0, 0,267, 59, 59, 0, 0,
52355 & 392,0.114D0, 0, 59,389, 0, 0, 0/
52356 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2205,2223)/
52357 & 392,0.113D0, 0, 59,390, 0, 0, 0,
52358 & 392,0.054D0, 0, 59,391, 0, 0, 0,
52359 & 392,0.403D0,130, 13, 13, 13, 0, 0,
52360 & 392,0.021D0,130, 13, 13, 59, 0, 0,
52361 & 392,0.020D0, 0,121,127, 0, 0, 0,
52362 & 392,0.020D0, 0,123,129, 0, 0, 0,
52363 & 392,0.020D0, 0,125,131, 0, 0, 0,
52364 & 392,0.007D0, 0, 1, 7, 0, 0, 0,
52365 & 392,0.027D0, 0, 2, 8, 0, 0, 0,
52366 & 392,0.007D0, 0, 3, 9, 0, 0, 0,
52367 & 392,0.027D0, 0, 4, 10, 0, 0, 0,
52368 & 393,0.250D0, 0,246,222, 0, 0, 0,
52369 & 393,0.250D0, 0,245,221, 0, 0, 0,
52370 & 393,0.385D0,130, 13, 13, 13, 0, 0,
52371 & 393,0.020D0,130, 13, 13, 59, 0, 0,
52372 & 393,0.015D0, 0,121,127, 0, 0, 0,
52373 & 393,0.015D0, 0,123,129, 0, 0, 0,
52374 & 393,0.015D0, 0,125,131, 0, 0, 0,
52375 & 393,0.005D0, 0, 1, 7, 0, 0, 0/
52376 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2224,2242)/
52377 & 393,0.020D0, 0, 2, 8, 0, 0, 0,
52378 & 393,0.005D0, 0, 3, 9, 0, 0, 0,
52379 & 393,0.020D0, 0, 4, 10, 0, 0, 0,
52380 & 395,0.195D0, 0, 39, 30, 0, 0, 0,
52381 & 395,0.195D0, 0, 23, 21, 0, 0, 0,
52382 & 395,0.195D0, 0, 31, 38, 0, 0, 0,
52383 & 395,0.105D0, 0,286, 30, 0, 0, 0,
52384 & 395,0.105D0, 0,285, 21, 0, 0, 0,
52385 & 395,0.105D0, 0,287, 38, 0, 0, 0,
52386 & 395,0.065D0, 0, 24, 38, 30, 0, 0,
52387 & 395,0.035D0, 0, 24, 21, 21, 0, 0,
52388 & 396,0.320D0, 0, 46, 34, 0, 0, 0,
52389 & 396,0.320D0, 0, 60, 61, 0, 0, 0,
52390 & 396,0.090D0, 0, 46, 35, 0, 0, 0,
52391 & 396,0.090D0, 0, 42, 51, 0, 0, 0,
52392 & 396,0.090D0, 0, 50, 43, 0, 0, 0,
52393 & 396,0.090D0, 0, 34, 47, 0, 0, 0,
52394 & 397,0.312D0, 0, 41, 30, 0, 0, 0,
52395 & 397,0.312D0, 0, 29, 21, 0, 0, 0/
52396 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2243,2261)/
52397 & 397,0.312D0, 0, 33, 38, 0, 0, 0,
52398 & 397,0.016D0, 0, 46, 35, 0, 0, 0,
52399 & 397,0.016D0, 0, 42, 51, 0, 0, 0,
52400 & 397,0.016D0, 0, 50, 43, 0, 0, 0,
52401 & 397,0.016D0, 0, 34, 47, 0, 0, 0,
52402 & 398,0.805D0, 0, 26, 22, 0, 0, 0,
52403 & 398,0.065D0, 0, 41, 30, 0, 0, 0,
52404 & 398,0.065D0, 0, 29, 21, 0, 0, 0,
52405 & 398,0.065D0, 0, 33, 38, 0, 0, 0,
52406 & 399,0.667D0, 0, 24, 38, 30, 0, 0,
52407 & 399,0.333D0, 0, 24, 21, 21, 0, 0,
52408 & 62,0.440D0, 0, 21, 22, 0, 0, 0,
52409 & 62,0.160D0, 0, 21, 25, 0, 0, 0,
52410 & 62,0.200D0, 0, 50, 42, 0, 0, 0,
52411 & 62,0.200D0, 0, 46, 34, 0, 0, 0,
52412 & 63,0.440D0, 0, 38, 22, 0, 0, 0,
52413 & 63,0.160D0, 0, 38, 25, 0, 0, 0,
52414 & 63,0.400D0, 0, 46, 42, 0, 0, 0,
52415 & 64,0.440D0, 0, 30, 22, 0, 0, 0/
52416 DATA (IDK(I),BRFRAC(I),NME(I),(IDKPRD(J,I),J=1,5),I=2262,2263)/
52417 & 64,0.160D0, 0, 30, 25, 0, 0, 0,
52418 & 64,0.400D0, 0, 50, 34, 0, 0, 0/
52419C--data for MRST98 LO PDF's
52420 DATA (FMRS(1,1,I, 1),I=1,49)/
52421 & 0.01518D0, 0.01868D0, 0.02298D0, 0.02594D0, 0.02828D0,
52422 & 0.03023D0, 0.03724D0, 0.04592D0, 0.05197D0, 0.05679D0,
52423 & 0.06085D0, 0.07576D0, 0.09547D0, 0.11035D0, 0.12307D0,
52424 & 0.13453D0, 0.15525D0, 0.18319D0, 0.22542D0, 0.26441D0,
52425 & 0.33553D0, 0.39881D0, 0.45451D0, 0.51363D0, 0.56120D0,
52426 & 0.59755D0, 0.62324D0, 0.63889D0, 0.64529D0, 0.64295D0,
52427 & 0.63335D0, 0.61691D0, 0.59464D0, 0.56748D0, 0.53621D0,
52428 & 0.50180D0, 0.46495D0, 0.42660D0, 0.38735D0, 0.34791D0,
52429 & 0.30888D0, 0.27105D0, 0.23455D0, 0.16807D0, 0.11197D0,
52430 & 0.06774D0, 0.03566D0, 0.00443D0, 0.00000D0/
52431 DATA (FMRS(1,1,I, 2),I=1,49)/
52432 & 0.01534D0, 0.01889D0, 0.02325D0, 0.02625D0, 0.02862D0,
52433 & 0.03061D0, 0.03771D0, 0.04653D0, 0.05268D0, 0.05757D0,
52434 & 0.06171D0, 0.07691D0, 0.09707D0, 0.11230D0, 0.12533D0,
52435 & 0.13708D0, 0.15827D0, 0.18678D0, 0.22968D0, 0.26907D0,
52436 & 0.34038D0, 0.40321D0, 0.45801D0, 0.51556D0, 0.56122D0,
52437 & 0.59551D0, 0.61905D0, 0.63261D0, 0.63699D0, 0.63286D0,
52438 & 0.62162D0, 0.60381D0, 0.58043D0, 0.55244D0, 0.52060D0,
52439 & 0.48591D0, 0.44902D0, 0.41090D0, 0.37213D0, 0.33332D0,
52440 & 0.29514D0, 0.25827D0, 0.22283D0, 0.15873D0, 0.10506D0,
52441 & 0.06310D0, 0.03294D0, 0.00399D0, 0.00000D0/
52442 DATA (FMRS(1,1,I, 3),I=1,49)/
52443 & 0.01559D0, 0.01920D0, 0.02365D0, 0.02672D0, 0.02914D0,
52444 & 0.03116D0, 0.03842D0, 0.04744D0, 0.05374D0, 0.05876D0,
52445 & 0.06301D0, 0.07866D0, 0.09949D0, 0.11525D0, 0.12874D0,
52446 & 0.14090D0, 0.16278D0, 0.19212D0, 0.23598D0, 0.27589D0,
52447 & 0.34735D0, 0.40941D0, 0.46279D0, 0.51792D0, 0.56073D0,
52448 & 0.59195D0, 0.61237D0, 0.62289D0, 0.62439D0, 0.61773D0,
52449 & 0.60419D0, 0.58448D0, 0.55962D0, 0.53052D0, 0.49799D0,
52450 & 0.46298D0, 0.42617D0, 0.38844D0, 0.35048D0, 0.31268D0,
52451 & 0.27573D0, 0.24031D0, 0.20643D0, 0.14575D0, 0.09554D0,
52452 & 0.05679D0, 0.02927D0, 0.00342D0, 0.00000D0/
52453 DATA (FMRS(1,1,I, 4),I=1,49)/
52454 & 0.01577D0, 0.01944D0, 0.02395D0, 0.02707D0, 0.02952D0,
52455 & 0.03158D0, 0.03895D0, 0.04812D0, 0.05453D0, 0.05964D0,
52456 & 0.06398D0, 0.07996D0, 0.10128D0, 0.11743D0, 0.13126D0,
52457 & 0.14371D0, 0.16610D0, 0.19602D0, 0.24052D0, 0.28078D0,
52458 & 0.35225D0, 0.41367D0, 0.46596D0, 0.51926D0, 0.56000D0,
52459 & 0.58897D0, 0.60716D0, 0.61554D0, 0.61505D0, 0.60661D0,
52460 & 0.59150D0, 0.57049D0, 0.54465D0, 0.51484D0, 0.48194D0,
52461 & 0.44680D0, 0.41012D0, 0.37271D0, 0.33536D0, 0.29833D0,
52462 & 0.26227D0, 0.22791D0, 0.19519D0, 0.13692D0, 0.08913D0,
52463 & 0.05257D0, 0.02685D0, 0.00306D0, 0.00000D0/
52464 DATA (FMRS(1,1,I, 5),I=1,49)/
52465 & 0.01597D0, 0.01969D0, 0.02427D0, 0.02744D0, 0.02993D0,
52466 & 0.03202D0, 0.03952D0, 0.04885D0, 0.05537D0, 0.06058D0,
52467 & 0.06501D0, 0.08134D0, 0.10319D0, 0.11975D0, 0.13393D0,
52468 & 0.14669D0, 0.16958D0, 0.20009D0, 0.24521D0, 0.28578D0,
52469 & 0.35715D0, 0.41781D0, 0.46887D0, 0.52022D0, 0.55877D0,
52470 & 0.58539D0, 0.60126D0, 0.60744D0, 0.60489D0, 0.59469D0,
52471 & 0.57807D0, 0.55581D0, 0.52903D0, 0.49861D0, 0.46535D0,
52472 & 0.43012D0, 0.39368D0, 0.35672D0, 0.32002D0, 0.28380D0,
52473 & 0.24878D0, 0.21549D0, 0.18398D0, 0.12819D0, 0.08284D0,
52474 & 0.04845D0, 0.02451D0, 0.00272D0, 0.00000D0/
52475 DATA (FMRS(1,1,I, 6),I=1,49)/
52476 & 0.01613D0, 0.01990D0, 0.02455D0, 0.02776D0, 0.03029D0,
52477 & 0.03241D0, 0.04001D0, 0.04949D0, 0.05611D0, 0.06141D0,
52478 & 0.06592D0, 0.08256D0, 0.10485D0, 0.12178D0, 0.13626D0,
52479 & 0.14927D0, 0.17260D0, 0.20361D0, 0.24924D0, 0.29005D0,
52480 & 0.36128D0, 0.42124D0, 0.47121D0, 0.52086D0, 0.55750D0,
52481 & 0.58213D0, 0.59603D0, 0.60035D0, 0.59612D0, 0.58445D0,
52482 & 0.56659D0, 0.54334D0, 0.51581D0, 0.48493D0, 0.45142D0,
52483 & 0.41618D0, 0.37998D0, 0.34345D0, 0.30732D0, 0.27182D0,
52484 & 0.23768D0, 0.20532D0, 0.17482D0, 0.12110D0, 0.07777D0,
52485 & 0.04515D0, 0.02267D0, 0.00245D0, 0.00000D0/
52486 DATA (FMRS(1,1,I, 7),I=1,49)/
52487 & 0.01630D0, 0.02011D0, 0.02482D0, 0.02807D0, 0.03063D0,
52488 & 0.03278D0, 0.04049D0, 0.05010D0, 0.05683D0, 0.06221D0,
52489 & 0.06680D0, 0.08373D0, 0.10647D0, 0.12373D0, 0.13849D0,
52490 & 0.15175D0, 0.17549D0, 0.20695D0, 0.25304D0, 0.29403D0,
52491 & 0.36506D0, 0.42430D0, 0.47319D0, 0.52118D0, 0.55597D0,
52492 & 0.57870D0, 0.59079D0, 0.59337D0, 0.58760D0, 0.57458D0,
52493 & 0.55556D0, 0.53145D0, 0.50329D0, 0.47196D0, 0.43832D0,
52494 & 0.40316D0, 0.36719D0, 0.33110D0, 0.29555D0, 0.26076D0,
52495 & 0.22742D0, 0.19600D0, 0.16642D0, 0.11467D0, 0.07318D0,
52496 & 0.04221D0, 0.02103D0, 0.00223D0, 0.00000D0/
52497 DATA (FMRS(1,1,I, 8),I=1,49)/
52498 & 0.01647D0, 0.02033D0, 0.02511D0, 0.02840D0, 0.03100D0,
52499 & 0.03318D0, 0.04101D0, 0.05076D0, 0.05760D0, 0.06307D0,
52500 & 0.06774D0, 0.08499D0, 0.10819D0, 0.12581D0, 0.14088D0,
52501 & 0.15440D0, 0.17856D0, 0.21047D0, 0.25702D0, 0.29817D0,
52502 & 0.36893D0, 0.42735D0, 0.47507D0, 0.52128D0, 0.55411D0,
52503 & 0.57487D0, 0.58505D0, 0.58586D0, 0.57850D0, 0.56412D0,
52504 & 0.54397D0, 0.51898D0, 0.49021D0, 0.45851D0, 0.42474D0,
52505 & 0.38970D0, 0.35404D0, 0.31842D0, 0.28351D0, 0.24949D0,
52506 & 0.21700D0, 0.18654D0, 0.15795D0, 0.10821D0, 0.06861D0,
52507 & 0.03930D0, 0.01942D0, 0.00201D0, 0.00000D0/
52508 DATA (FMRS(1,1,I, 9),I=1,49)/
52509 & 0.01662D0, 0.02053D0, 0.02536D0, 0.02869D0, 0.03133D0,
52510 & 0.03353D0, 0.04146D0, 0.05135D0, 0.05828D0, 0.06382D0,
52511 & 0.06856D0, 0.08610D0, 0.10971D0, 0.12764D0, 0.14296D0,
52512 & 0.15670D0, 0.18121D0, 0.21352D0, 0.26045D0, 0.30172D0,
52513 & 0.37220D0, 0.42986D0, 0.47655D0, 0.52120D0, 0.55234D0,
52514 & 0.57141D0, 0.57995D0, 0.57927D0, 0.57058D0, 0.55506D0,
52515 & 0.53402D0, 0.50830D0, 0.47904D0, 0.44709D0, 0.41323D0,
52516 & 0.37832D0, 0.34296D0, 0.30776D0, 0.27344D0, 0.24008D0,
52517 & 0.20833D0, 0.17868D0, 0.15093D0, 0.10287D0, 0.06487D0,
52518 & 0.03693D0, 0.01812D0, 0.00183D0, 0.00000D0/
52519 DATA (FMRS(1,1,I,10),I=1,49)/
52520 & 0.01676D0, 0.02072D0, 0.02560D0, 0.02898D0, 0.03164D0,
52521 & 0.03388D0, 0.04190D0, 0.05191D0, 0.05894D0, 0.06456D0,
52522 & 0.06937D0, 0.08718D0, 0.11117D0, 0.12940D0, 0.14497D0,
52523 & 0.15892D0, 0.18377D0, 0.21643D0, 0.26368D0, 0.30503D0,
52524 & 0.37520D0, 0.43209D0, 0.47774D0, 0.52089D0, 0.55041D0,
52525 & 0.56787D0, 0.57486D0, 0.57280D0, 0.56285D0, 0.54631D0,
52526 & 0.52442D0, 0.49810D0, 0.46842D0, 0.43624D0, 0.40236D0,
52527 & 0.36762D0, 0.33255D0, 0.29778D0, 0.26402D0, 0.23132D0,
52528 & 0.20029D0, 0.17139D0, 0.14445D0, 0.09798D0, 0.06147D0,
52529 & 0.03479D0, 0.01695D0, 0.00168D0, 0.00000D0/
52530 DATA (FMRS(1,1,I,11),I=1,49)/
52531 & 0.01688D0, 0.02087D0, 0.02580D0, 0.02920D0, 0.03189D0,
52532 & 0.03415D0, 0.04225D0, 0.05236D0, 0.05946D0, 0.06515D0,
52533 & 0.07001D0, 0.08804D0, 0.11234D0, 0.13081D0, 0.14657D0,
52534 & 0.16068D0, 0.18579D0, 0.21873D0, 0.26622D0, 0.30762D0,
52535 & 0.37751D0, 0.43378D0, 0.47859D0, 0.52054D0, 0.54880D0,
52536 & 0.56500D0, 0.57079D0, 0.56765D0, 0.55675D0, 0.53942D0,
52537 & 0.51689D0, 0.49012D0, 0.46015D0, 0.42782D0, 0.39393D0,
52538 & 0.35936D0, 0.32453D0, 0.29009D0, 0.25678D0, 0.22461D0,
52539 & 0.19416D0, 0.16583D0, 0.13951D0, 0.09427D0, 0.05892D0,
52540 & 0.03318D0, 0.01609D0, 0.00157D0, 0.00000D0/
52541 DATA (FMRS(1,1,I,12),I=1,49)/
52542 & 0.01713D0, 0.02119D0, 0.02622D0, 0.02969D0, 0.03243D0,
52543 & 0.03474D0, 0.04300D0, 0.05334D0, 0.06060D0, 0.06641D0,
52544 & 0.07140D0, 0.08989D0, 0.11485D0, 0.13381D0, 0.14997D0,
52545 & 0.16442D0, 0.19008D0, 0.22357D0, 0.27152D0, 0.31299D0,
52546 & 0.38219D0, 0.43708D0, 0.48008D0, 0.51946D0, 0.54505D0,
52547 & 0.55859D0, 0.56192D0, 0.55654D0, 0.54370D0, 0.52483D0,
52548 & 0.50100D0, 0.47335D0, 0.44283D0, 0.41025D0, 0.37649D0,
52549 & 0.34225D0, 0.30799D0, 0.27433D0, 0.24202D0, 0.21092D0,
52550 & 0.18167D0, 0.15459D0, 0.12954D0, 0.08683D0, 0.05380D0,
52551 & 0.03001D0, 0.01438D0, 0.00136D0, 0.00000D0/
52552 DATA (FMRS(1,1,I,13),I=1,49)/
52553 & 0.01734D0, 0.02147D0, 0.02658D0, 0.03011D0, 0.03290D0,
52554 & 0.03525D0, 0.04366D0, 0.05419D0, 0.06158D0, 0.06752D0,
52555 & 0.07261D0, 0.09150D0, 0.11703D0, 0.13641D0, 0.15292D0,
52556 & 0.16765D0, 0.19375D0, 0.22769D0, 0.27599D0, 0.31747D0,
52557 & 0.38599D0, 0.43964D0, 0.48105D0, 0.51822D0, 0.54152D0,
52558 & 0.55284D0, 0.55412D0, 0.54689D0, 0.53251D0, 0.51240D0,
52559 & 0.48756D0, 0.45925D0, 0.42833D0, 0.39563D0, 0.36202D0,
52560 & 0.32809D0, 0.29438D0, 0.26143D0, 0.22998D0, 0.19977D0,
52561 & 0.17155D0, 0.14553D0, 0.12155D0, 0.08091D0, 0.04976D0,
52562 & 0.02753D0, 0.01306D0, 0.00120D0, 0.00000D0/
52563 DATA (FMRS(1,1,I,14),I=1,49)/
52564 & 0.01759D0, 0.02179D0, 0.02699D0, 0.03059D0, 0.03343D0,
52565 & 0.03582D0, 0.04441D0, 0.05515D0, 0.06270D0, 0.06876D0,
52566 & 0.07397D0, 0.09331D0, 0.11948D0, 0.13933D0, 0.15621D0,
52567 & 0.17125D0, 0.19782D0, 0.23224D0, 0.28086D0, 0.32228D0,
52568 & 0.38998D0, 0.44216D0, 0.48181D0, 0.51649D0, 0.53727D0,
52569 & 0.54619D0, 0.54525D0, 0.53606D0, 0.52007D0, 0.49864D0,
52570 & 0.47286D0, 0.44390D0, 0.41261D0, 0.37987D0, 0.34645D0,
52571 & 0.31295D0, 0.27985D0, 0.24773D0, 0.21718D0, 0.18802D0,
52572 & 0.16091D0, 0.13605D0, 0.11323D0, 0.07479D0, 0.04562D0,
52573 & 0.02500D0, 0.01174D0, 0.00105D0, 0.00000D0/
52574 DATA (FMRS(1,1,I,15),I=1,49)/
52575 & 0.01784D0, 0.02212D0, 0.02742D0, 0.03109D0, 0.03399D0,
52576 & 0.03643D0, 0.04519D0, 0.05616D0, 0.06388D0, 0.07007D0,
52577 & 0.07541D0, 0.09522D0, 0.12203D0, 0.14235D0, 0.15961D0,
52578 & 0.17496D0, 0.20199D0, 0.23684D0, 0.28574D0, 0.32703D0,
52579 & 0.39374D0, 0.44435D0, 0.48208D0, 0.51422D0, 0.53243D0,
52580 & 0.53888D0, 0.53581D0, 0.52470D0, 0.50714D0, 0.48444D0,
52581 & 0.45778D0, 0.42824D0, 0.39670D0, 0.36400D0, 0.33079D0,
52582 & 0.29784D0, 0.26546D0, 0.23422D0, 0.20462D0, 0.17657D0,
52583 & 0.15056D0, 0.12684D0, 0.10517D0, 0.06893D0, 0.04169D0,
52584 & 0.02264D0, 0.01051D0, 0.00091D0, 0.00000D0/
52585 DATA (FMRS(1,1,I,16),I=1,49)/
52586 & 0.01807D0, 0.02243D0, 0.02782D0, 0.03155D0, 0.03450D0,
52587 & 0.03698D0, 0.04591D0, 0.05708D0, 0.06495D0, 0.07127D0,
52588 & 0.07672D0, 0.09696D0, 0.12435D0, 0.14510D0, 0.16268D0,
52589 & 0.17830D0, 0.20573D0, 0.24094D0, 0.29002D0, 0.33115D0,
52590 & 0.39689D0, 0.44603D0, 0.48202D0, 0.51185D0, 0.52778D0,
52591 & 0.53213D0, 0.52713D0, 0.51440D0, 0.49550D0, 0.47182D0,
52592 & 0.44444D0, 0.41444D0, 0.38277D0, 0.35014D0, 0.31726D0,
52593 & 0.28479D0, 0.25306D0, 0.22258D0, 0.19389D0, 0.16682D0,
52594 & 0.14175D0, 0.11905D0, 0.09839D0, 0.06403D0, 0.03844D0,
52595 & 0.02069D0, 0.00951D0, 0.00080D0, 0.00000D0/
52596 DATA (FMRS(1,1,I,17),I=1,49)/
52597 & 0.01831D0, 0.02273D0, 0.02822D0, 0.03202D0, 0.03502D0,
52598 & 0.03755D0, 0.04663D0, 0.05802D0, 0.06604D0, 0.07249D0,
52599 & 0.07805D0, 0.09872D0, 0.12670D0, 0.14787D0, 0.16578D0,
52600 & 0.18165D0, 0.20947D0, 0.24500D0, 0.29423D0, 0.33515D0,
52601 & 0.39986D0, 0.44747D0, 0.48171D0, 0.50924D0, 0.52291D0,
52602 & 0.52522D0, 0.51836D0, 0.50409D0, 0.48395D0, 0.45934D0,
52603 & 0.43132D0, 0.40095D0, 0.36919D0, 0.33668D0, 0.30419D0,
52604 & 0.27223D0, 0.24118D0, 0.21147D0, 0.18368D0, 0.15756D0,
52605 & 0.13343D0, 0.11172D0, 0.09203D0, 0.05947D0, 0.03543D0,
52606 & 0.01891D0, 0.00861D0, 0.00070D0, 0.00000D0/
52607 DATA (FMRS(1,1,I,18),I=1,49)/
52608 & 0.01851D0, 0.02299D0, 0.02855D0, 0.03241D0, 0.03546D0,
52609 & 0.03802D0, 0.04724D0, 0.05881D0, 0.06696D0, 0.07351D0,
52610 & 0.07917D0, 0.10019D0, 0.12865D0, 0.15015D0, 0.16833D0,
52611 & 0.18440D0, 0.21252D0, 0.24831D0, 0.29761D0, 0.33832D0,
52612 & 0.40212D0, 0.44845D0, 0.48121D0, 0.50687D0, 0.51871D0,
52613 & 0.51934D0, 0.51104D0, 0.49556D0, 0.47446D0, 0.44911D0,
52614 & 0.42066D0, 0.39005D0, 0.35822D0, 0.32587D0, 0.29370D0,
52615 & 0.26224D0, 0.23174D0, 0.20270D0, 0.17561D0, 0.15023D0,
52616 & 0.12693D0, 0.10599D0, 0.08707D0, 0.05595D0, 0.03312D0,
52617 & 0.01756D0, 0.00793D0, 0.00063D0, 0.00000D0/
52618 DATA (FMRS(1,1,I,19),I=1,49)/
52619 & 0.01875D0, 0.02330D0, 0.02896D0, 0.03288D0, 0.03599D0,
52620 & 0.03859D0, 0.04798D0, 0.05977D0, 0.06807D0, 0.07475D0,
52621 & 0.08052D0, 0.10198D0, 0.13101D0, 0.15292D0, 0.17139D0,
52622 & 0.18771D0, 0.21617D0, 0.25222D0, 0.30155D0, 0.34198D0,
52623 & 0.40461D0, 0.44935D0, 0.48033D0, 0.50374D0, 0.51343D0,
52624 & 0.51210D0, 0.50212D0, 0.48526D0, 0.46307D0, 0.43693D0,
52625 & 0.40797D0, 0.37715D0, 0.34533D0, 0.31321D0, 0.28148D0,
52626 & 0.25058D0, 0.22080D0, 0.19255D0, 0.16635D0, 0.14187D0,
52627 & 0.11948D0, 0.09946D0, 0.08142D0, 0.05198D0, 0.03054D0,
52628 & 0.01606D0, 0.00718D0, 0.00056D0, 0.00000D0/
52629 DATA (FMRS(1,1,I,20),I=1,49)/
52630 & 0.01896D0, 0.02358D0, 0.02932D0, 0.03331D0, 0.03646D0,
52631 & 0.03911D0, 0.04864D0, 0.06062D0, 0.06906D0, 0.07585D0,
52632 & 0.08173D0, 0.10357D0, 0.13310D0, 0.15536D0, 0.17410D0,
52633 & 0.19062D0, 0.21937D0, 0.25563D0, 0.30495D0, 0.34510D0,
52634 & 0.40666D0, 0.44998D0, 0.47941D0, 0.50085D0, 0.50868D0,
52635 & 0.50571D0, 0.49430D0, 0.47628D0, 0.45320D0, 0.42642D0,
52636 & 0.39707D0, 0.36611D0, 0.33435D0, 0.30245D0, 0.27113D0,
52637 & 0.24074D0, 0.21159D0, 0.18404D0, 0.15862D0, 0.13491D0,
52638 & 0.11330D0, 0.09405D0, 0.07676D0, 0.04872D0, 0.02844D0,
52639 & 0.01484D0, 0.00658D0, 0.00050D0, 0.00000D0/
52640 DATA (FMRS(1,1,I,21),I=1,49)/
52641 & 0.01916D0, 0.02384D0, 0.02966D0, 0.03370D0, 0.03689D0,
52642 & 0.03958D0, 0.04926D0, 0.06141D0, 0.06998D0, 0.07687D0,
52643 & 0.08284D0, 0.10503D0, 0.13502D0, 0.15758D0, 0.17655D0,
52644 & 0.19325D0, 0.22223D0, 0.25866D0, 0.30794D0, 0.34779D0,
52645 & 0.40831D0, 0.45032D0, 0.47832D0, 0.49795D0, 0.50413D0,
52646 & 0.49968D0, 0.48705D0, 0.46802D0, 0.44417D0, 0.41690D0,
52647 & 0.38723D0, 0.35619D0, 0.32452D0, 0.29287D0, 0.26194D0,
52648 & 0.23205D0, 0.20344D0, 0.17655D0, 0.15180D0, 0.12880D0,
52649 & 0.10792D0, 0.08934D0, 0.07273D0, 0.04591D0, 0.02665D0,
52650 & 0.01381D0, 0.00607D0, 0.00045D0, 0.00000D0/
52651 DATA (FMRS(1,1,I,22),I=1,49)/
52652 & 0.01941D0, 0.02417D0, 0.03009D0, 0.03420D0, 0.03745D0,
52653 & 0.04018D0, 0.05003D0, 0.06241D0, 0.07114D0, 0.07817D0,
52654 & 0.08426D0, 0.10688D0, 0.13744D0, 0.16039D0, 0.17965D0,
52655 & 0.19656D0, 0.22582D0, 0.26244D0, 0.31163D0, 0.35107D0,
52656 & 0.41025D0, 0.45056D0, 0.47676D0, 0.49416D0, 0.49829D0,
52657 & 0.49204D0, 0.47792D0, 0.45768D0, 0.43295D0, 0.40511D0,
52658 & 0.37512D0, 0.34401D0, 0.31250D0, 0.28120D0, 0.25076D0,
52659 & 0.22150D0, 0.19361D0, 0.16754D0, 0.14361D0, 0.12149D0,
52660 & 0.10149D0, 0.08376D0, 0.06796D0, 0.04260D0, 0.02455D0,
52661 & 0.01262D0, 0.00549D0, 0.00039D0, 0.00000D0/
52662 DATA (FMRS(1,1,I,23),I=1,49)/
52663 & 0.01965D0, 0.02448D0, 0.03049D0, 0.03467D0, 0.03797D0,
52664 & 0.04075D0, 0.05077D0, 0.06336D0, 0.07225D0, 0.07940D0,
52665 & 0.08560D0, 0.10863D0, 0.13972D0, 0.16302D0, 0.18254D0,
52666 & 0.19964D0, 0.22916D0, 0.26592D0, 0.31498D0, 0.35400D0,
52667 & 0.41189D0, 0.45060D0, 0.47511D0, 0.49045D0, 0.49274D0,
52668 & 0.48487D0, 0.46938D0, 0.44808D0, 0.42260D0, 0.39428D0,
52669 & 0.36409D0, 0.33294D0, 0.30164D0, 0.27069D0, 0.24070D0,
52670 & 0.21203D0, 0.18488D0, 0.15951D0, 0.13633D0, 0.11502D0,
52671 & 0.09581D0, 0.07887D0, 0.06380D0, 0.03974D0, 0.02273D0,
52672 & 0.01159D0, 0.00500D0, 0.00035D0, 0.00000D0/
52673 DATA (FMRS(1,1,I,24),I=1,49)/
52674 & 0.01987D0, 0.02478D0, 0.03088D0, 0.03511D0, 0.03847D0,
52675 & 0.04129D0, 0.05147D0, 0.06426D0, 0.07329D0, 0.08055D0,
52676 & 0.08686D0, 0.11027D0, 0.14184D0, 0.16546D0, 0.18521D0,
52677 & 0.20248D0, 0.23220D0, 0.26906D0, 0.31795D0, 0.35654D0,
52678 & 0.41317D0, 0.45035D0, 0.47330D0, 0.48677D0, 0.48734D0,
52679 & 0.47799D0, 0.46135D0, 0.43917D0, 0.41301D0, 0.38430D0,
52680 & 0.35392D0, 0.32282D0, 0.29171D0, 0.26113D0, 0.23164D0,
52681 & 0.20355D0, 0.17701D0, 0.15231D0, 0.12990D0, 0.10928D0,
52682 & 0.09079D0, 0.07455D0, 0.06012D0, 0.03723D0, 0.02116D0,
52683 & 0.01072D0, 0.00459D0, 0.00031D0, 0.00000D0/
52684 DATA (FMRS(1,1,I,25),I=1,49)/
52685 & 0.02010D0, 0.02507D0, 0.03126D0, 0.03556D0, 0.03897D0,
52686 & 0.04183D0, 0.05216D0, 0.06515D0, 0.07433D0, 0.08171D0,
52687 & 0.08812D0, 0.11191D0, 0.14397D0, 0.16790D0, 0.18786D0,
52688 & 0.20530D0, 0.23522D0, 0.27216D0, 0.32085D0, 0.35900D0,
52689 & 0.41434D0, 0.45001D0, 0.47142D0, 0.48304D0, 0.48197D0,
52690 & 0.47120D0, 0.45346D0, 0.43043D0, 0.40367D0, 0.37460D0,
52691 & 0.34407D0, 0.31306D0, 0.28215D0, 0.25197D0, 0.22296D0,
52692 & 0.19546D0, 0.16953D0, 0.14549D0, 0.12381D0, 0.10387D0,
52693 & 0.08608D0, 0.07049D0, 0.05669D0, 0.03490D0, 0.01971D0,
52694 & 0.00991D0, 0.00421D0, 0.00028D0, 0.00000D0/
52695 DATA (FMRS(1,1,I,26),I=1,49)/
52696 & 0.02032D0, 0.02536D0, 0.03164D0, 0.03600D0, 0.03946D0,
52697 & 0.04236D0, 0.05285D0, 0.06604D0, 0.07535D0, 0.08285D0,
52698 & 0.08936D0, 0.11352D0, 0.14603D0, 0.17026D0, 0.19043D0,
52699 & 0.20801D0, 0.23810D0, 0.27509D0, 0.32355D0, 0.36123D0,
52700 & 0.41527D0, 0.44945D0, 0.46936D0, 0.47919D0, 0.47657D0,
52701 & 0.46453D0, 0.44572D0, 0.42188D0, 0.39463D0, 0.36526D0,
52702 & 0.33462D0, 0.30373D0, 0.27307D0, 0.24328D0, 0.21472D0,
52703 & 0.18782D0, 0.16253D0, 0.13914D0, 0.11811D0, 0.09886D0,
52704 & 0.08171D0, 0.06673D0, 0.05353D0, 0.03277D0, 0.01840D0,
52705 & 0.00919D0, 0.00387D0, 0.00025D0, 0.00000D0/
52706 DATA (FMRS(1,1,I,27),I=1,49)/
52707 & 0.02054D0, 0.02564D0, 0.03200D0, 0.03642D0, 0.03992D0,
52708 & 0.04287D0, 0.05350D0, 0.06688D0, 0.07633D0, 0.08394D0,
52709 & 0.09053D0, 0.11504D0, 0.14798D0, 0.17249D0, 0.19284D0,
52710 & 0.21055D0, 0.24079D0, 0.27781D0, 0.32602D0, 0.36325D0,
52711 & 0.41604D0, 0.44883D0, 0.46732D0, 0.47551D0, 0.47145D0,
52712 & 0.45823D0, 0.43846D0, 0.41392D0, 0.38625D0, 0.35664D0,
52713 & 0.32595D0, 0.29518D0, 0.26477D0, 0.23536D0, 0.20725D0,
52714 & 0.18088D0, 0.15618D0, 0.13340D0, 0.11297D0, 0.09435D0,
52715 & 0.07779D0, 0.06337D0, 0.05071D0, 0.03088D0, 0.01724D0,
52716 & 0.00855D0, 0.00357D0, 0.00023D0, 0.00000D0/
52717 DATA (FMRS(1,1,I,28),I=1,49)/
52718 & 0.02074D0, 0.02591D0, 0.03234D0, 0.03682D0, 0.04037D0,
52719 & 0.04335D0, 0.05412D0, 0.06768D0, 0.07725D0, 0.08496D0,
52720 & 0.09165D0, 0.11648D0, 0.14982D0, 0.17457D0, 0.19509D0,
52721 & 0.21292D0, 0.24327D0, 0.28031D0, 0.32827D0, 0.36504D0,
52722 & 0.41665D0, 0.44811D0, 0.46527D0, 0.47196D0, 0.46656D0,
52723 & 0.45228D0, 0.43165D0, 0.40650D0, 0.37846D0, 0.34867D0,
52724 & 0.31800D0, 0.28733D0, 0.25718D0, 0.22812D0, 0.20048D0,
52725 & 0.17458D0, 0.15043D0, 0.12823D0, 0.10834D0, 0.09029D0,
52726 & 0.07427D0, 0.06037D0, 0.04820D0, 0.02920D0, 0.01621D0,
52727 & 0.00800D0, 0.00332D0, 0.00021D0, 0.00000D0/
52728 DATA (FMRS(1,1,I,29),I=1,49)/
52729 & 0.02094D0, 0.02617D0, 0.03269D0, 0.03722D0, 0.04081D0,
52730 & 0.04383D0, 0.05475D0, 0.06848D0, 0.07818D0, 0.08599D0,
52731 & 0.09277D0, 0.11792D0, 0.15165D0, 0.17664D0, 0.19733D0,
52732 & 0.21527D0, 0.24574D0, 0.28277D0, 0.33045D0, 0.36674D0,
52733 & 0.41715D0, 0.44728D0, 0.46313D0, 0.46834D0, 0.46164D0,
52734 & 0.44631D0, 0.42488D0, 0.39917D0, 0.37077D0, 0.34082D0,
52735 & 0.31017D0, 0.27964D0, 0.24978D0, 0.22107D0, 0.19390D0,
52736 & 0.16849D0, 0.14488D0, 0.12325D0, 0.10390D0, 0.08640D0,
52737 & 0.07092D0, 0.05751D0, 0.04581D0, 0.02761D0, 0.01524D0,
52738 & 0.00748D0, 0.00308D0, 0.00019D0, 0.00000D0/
52739 DATA (FMRS(1,1,I,30),I=1,49)/
52740 & 0.02115D0, 0.02644D0, 0.03303D0, 0.03762D0, 0.04125D0,
52741 & 0.04431D0, 0.05536D0, 0.06927D0, 0.07910D0, 0.08701D0,
52742 & 0.09387D0, 0.11934D0, 0.15345D0, 0.17867D0, 0.19951D0,
52743 & 0.21755D0, 0.24811D0, 0.28512D0, 0.33251D0, 0.36831D0,
52744 & 0.41752D0, 0.44634D0, 0.46092D0, 0.46470D0, 0.45678D0,
52745 & 0.44042D0, 0.41827D0, 0.39206D0, 0.36329D0, 0.33323D0,
52746 & 0.30260D0, 0.27226D0, 0.24270D0, 0.21435D0, 0.18761D0,
52747 & 0.16271D0, 0.13963D0, 0.11853D0, 0.09974D0, 0.08276D0,
52748 & 0.06777D0, 0.05484D0, 0.04358D0, 0.02615D0, 0.01436D0,
52749 & 0.00700D0, 0.00286D0, 0.00017D0, 0.00000D0/
52750 DATA (FMRS(1,1,I,31),I=1,49)/
52751 & 0.02134D0, 0.02669D0, 0.03336D0, 0.03800D0, 0.04168D0,
52752 & 0.04477D0, 0.05595D0, 0.07003D0, 0.07997D0, 0.08798D0,
52753 & 0.09492D0, 0.12069D0, 0.15515D0, 0.18059D0, 0.20157D0,
52754 & 0.21970D0, 0.25034D0, 0.28732D0, 0.33440D0, 0.36974D0,
52755 & 0.41780D0, 0.44538D0, 0.45878D0, 0.46121D0, 0.45216D0,
52756 & 0.43488D0, 0.41206D0, 0.38539D0, 0.35634D0, 0.32619D0,
52757 & 0.29560D0, 0.26544D0, 0.23618D0, 0.20818D0, 0.18185D0,
52758 & 0.15743D0, 0.13483D0, 0.11423D0, 0.09594D0, 0.07945D0,
52759 & 0.06492D0, 0.05243D0, 0.04157D0, 0.02483D0, 0.01357D0,
52760 & 0.00658D0, 0.00267D0, 0.00016D0, 0.00000D0/
52761 DATA (FMRS(1,1,I,32),I=1,49)/
52762 & 0.02153D0, 0.02693D0, 0.03367D0, 0.03836D0, 0.04208D0,
52763 & 0.04521D0, 0.05651D0, 0.07075D0, 0.08080D0, 0.08890D0,
52764 & 0.09592D0, 0.12197D0, 0.15676D0, 0.18239D0, 0.20349D0,
52765 & 0.22170D0, 0.25240D0, 0.28933D0, 0.33609D0, 0.37098D0,
52766 & 0.41793D0, 0.44434D0, 0.45663D0, 0.45780D0, 0.44772D0,
52767 & 0.42965D0, 0.40618D0, 0.37910D0, 0.34986D0, 0.31963D0,
52768 & 0.28912D0, 0.25913D0, 0.23015D0, 0.20249D0, 0.17658D0,
52769 & 0.15257D0, 0.13044D0, 0.11030D0, 0.09247D0, 0.07643D0,
52770 & 0.06234D0, 0.05026D0, 0.03976D0, 0.02365D0, 0.01287D0,
52771 & 0.00620D0, 0.00250D0, 0.00014D0, 0.00000D0/
52772 DATA (FMRS(1,1,I,33),I=1,49)/
52773 & 0.02171D0, 0.02717D0, 0.03398D0, 0.03872D0, 0.04248D0,
52774 & 0.04565D0, 0.05708D0, 0.07147D0, 0.08164D0, 0.08983D0,
52775 & 0.09693D0, 0.12326D0, 0.15838D0, 0.18421D0, 0.20543D0,
52776 & 0.22371D0, 0.25448D0, 0.29136D0, 0.33779D0, 0.37222D0,
52777 & 0.41806D0, 0.44331D0, 0.45449D0, 0.45441D0, 0.44330D0,
52778 & 0.42446D0, 0.40038D0, 0.37291D0, 0.34349D0, 0.31319D0,
52779 & 0.28277D0, 0.25295D0, 0.22427D0, 0.19695D0, 0.17145D0,
52780 & 0.14785D0, 0.12618D0, 0.10650D0, 0.08912D0, 0.07353D0,
52781 & 0.05986D0, 0.04817D0, 0.03803D0, 0.02252D0, 0.01220D0,
52782 & 0.00585D0, 0.00235D0, 0.00013D0, 0.00000D0/
52783 DATA (FMRS(1,1,I,34),I=1,49)/
52784 & 0.02190D0, 0.02741D0, 0.03429D0, 0.03909D0, 0.04289D0,
52785 & 0.04609D0, 0.05764D0, 0.07219D0, 0.08247D0, 0.09075D0,
52786 & 0.09793D0, 0.12453D0, 0.15996D0, 0.18597D0, 0.20731D0,
52787 & 0.22565D0, 0.25646D0, 0.29325D0, 0.33935D0, 0.37330D0,
52788 & 0.41800D0, 0.44209D0, 0.45219D0, 0.45092D0, 0.43883D0,
52789 & 0.41923D0, 0.39461D0, 0.36679D0, 0.33718D0, 0.30687D0,
52790 & 0.27654D0, 0.24693D0, 0.21853D0, 0.19159D0, 0.16650D0,
52791 & 0.14332D0, 0.12207D0, 0.10288D0, 0.08593D0, 0.07076D0,
52792 & 0.05749D0, 0.04618D0, 0.03639D0, 0.02146D0, 0.01157D0,
52793 & 0.00552D0, 0.00220D0, 0.00012D0, 0.00000D0/
52794 DATA (FMRS(1,1,I,35),I=1,49)/
52795 & 0.02208D0, 0.02764D0, 0.03459D0, 0.03943D0, 0.04327D0,
52796 & 0.04650D0, 0.05818D0, 0.07288D0, 0.08327D0, 0.09162D0,
52797 & 0.09888D0, 0.12574D0, 0.16147D0, 0.18765D0, 0.20909D0,
52798 & 0.22750D0, 0.25834D0, 0.29505D0, 0.34083D0, 0.37432D0,
52799 & 0.41794D0, 0.44094D0, 0.45002D0, 0.44763D0, 0.43463D0,
52800 & 0.41432D0, 0.38921D0, 0.36108D0, 0.33130D0, 0.30099D0,
52801 & 0.27077D0, 0.24136D0, 0.21322D0, 0.18665D0, 0.16193D0,
52802 & 0.13915D0, 0.11830D0, 0.09955D0, 0.08301D0, 0.06823D0,
52803 & 0.05533D0, 0.04437D0, 0.03490D0, 0.02050D0, 0.01100D0,
52804 & 0.00523D0, 0.00207D0, 0.00011D0, 0.00000D0/
52805 DATA (FMRS(1,1,I,36),I=1,49)/
52806 & 0.02225D0, 0.02787D0, 0.03488D0, 0.03977D0, 0.04364D0,
52807 & 0.04690D0, 0.05869D0, 0.07354D0, 0.08402D0, 0.09246D0,
52808 & 0.09978D0, 0.12689D0, 0.16290D0, 0.18924D0, 0.21077D0,
52809 & 0.22923D0, 0.26010D0, 0.29672D0, 0.34217D0, 0.37521D0,
52810 & 0.41781D0, 0.43978D0, 0.44789D0, 0.44447D0, 0.43062D0,
52811 & 0.40968D0, 0.38412D0, 0.35571D0, 0.32579D0, 0.29550D0,
52812 & 0.26538D0, 0.23618D0, 0.20831D0, 0.18206D0, 0.15771D0,
52813 & 0.13531D0, 0.11485D0, 0.09649D0, 0.08034D0, 0.06592D0,
52814 & 0.05337D0, 0.04272D0, 0.03354D0, 0.01963D0, 0.01049D0,
52815 & 0.00496D0, 0.00196D0, 0.00011D0, 0.00000D0/
52816 DATA (FMRS(1,1,I,37),I=1,49)/
52817 & 0.02242D0, 0.02809D0, 0.03517D0, 0.04010D0, 0.04401D0,
52818 & 0.04731D0, 0.05921D0, 0.07420D0, 0.08479D0, 0.09331D0,
52819 & 0.10070D0, 0.12805D0, 0.16433D0, 0.19082D0, 0.21245D0,
52820 & 0.23095D0, 0.26184D0, 0.29836D0, 0.34345D0, 0.37604D0,
52821 & 0.41760D0, 0.43853D0, 0.44568D0, 0.44123D0, 0.42654D0,
52822 & 0.40499D0, 0.37899D0, 0.35034D0, 0.32029D0, 0.29001D0,
52823 & 0.26003D0, 0.23104D0, 0.20345D0, 0.17752D0, 0.15354D0,
52824 & 0.13153D0, 0.11147D0, 0.09348D0, 0.07771D0, 0.06366D0,
52825 & 0.05147D0, 0.04112D0, 0.03222D0, 0.01879D0, 0.01000D0,
52826 & 0.00471D0, 0.00185D0, 0.00010D0, 0.00000D0/
52827 DATA (FMRS(1,1,I,38),I=1,49)/
52828 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52829 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52830 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52831 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52832 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52833 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52834 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52835 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52836 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
52837 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
52838 DATA (FMRS(1,2,I, 1),I=1,49)/
52839 & 0.00513D0, 0.00648D0, 0.00818D0, 0.00938D0, 0.01034D0,
52840 & 0.01116D0, 0.01418D0, 0.01818D0, 0.02118D0, 0.02372D0,
52841 & 0.02613D0, 0.03576D0, 0.05040D0, 0.06228D0, 0.07266D0,
52842 & 0.08202D0, 0.09864D0, 0.12002D0, 0.14955D0, 0.17387D0,
52843 & 0.21184D0, 0.23954D0, 0.25956D0, 0.27606D0, 0.28502D0,
52844 & 0.28790D0, 0.28586D0, 0.27985D0, 0.27060D0, 0.25918D0,
52845 & 0.24535D0, 0.23028D0, 0.21416D0, 0.19735D0, 0.18044D0,
52846 & 0.16347D0, 0.14671D0, 0.13049D0, 0.11512D0, 0.10018D0,
52847 & 0.08630D0, 0.07360D0, 0.06172D0, 0.04171D0, 0.02610D0,
52848 & 0.01478D0, 0.00721D0, 0.00074D0, 0.00000D0/
52849 DATA (FMRS(1,2,I, 2),I=1,49)/
52850 & 0.00518D0, 0.00654D0, 0.00828D0, 0.00950D0, 0.01049D0,
52851 & 0.01133D0, 0.01443D0, 0.01854D0, 0.02162D0, 0.02423D0,
52852 & 0.02670D0, 0.03657D0, 0.05155D0, 0.06366D0, 0.07421D0,
52853 & 0.08371D0, 0.10052D0, 0.12206D0, 0.15163D0, 0.17583D0,
52854 & 0.21329D0, 0.24028D0, 0.25950D0, 0.27498D0, 0.28295D0,
52855 & 0.28491D0, 0.28206D0, 0.27535D0, 0.26555D0, 0.25365D0,
52856 & 0.23952D0, 0.22423D0, 0.20802D0, 0.19123D0, 0.17441D0,
52857 & 0.15763D0, 0.14114D0, 0.12520D0, 0.11019D0, 0.09565D0,
52858 & 0.08218D0, 0.06990D0, 0.05847D0, 0.03927D0, 0.02442D0,
52859 & 0.01373D0, 0.00665D0, 0.00066D0, 0.00000D0/
52860 DATA (FMRS(1,2,I, 3),I=1,49)/
52861 & 0.00524D0, 0.00664D0, 0.00843D0, 0.00970D0, 0.01072D0,
52862 & 0.01159D0, 0.01481D0, 0.01908D0, 0.02229D0, 0.02501D0,
52863 & 0.02757D0, 0.03781D0, 0.05328D0, 0.06572D0, 0.07653D0,
52864 & 0.08622D0, 0.10330D0, 0.12505D0, 0.15465D0, 0.17864D0,
52865 & 0.21528D0, 0.24119D0, 0.25922D0, 0.27320D0, 0.27971D0,
52866 & 0.28035D0, 0.27635D0, 0.26864D0, 0.25807D0, 0.24551D0,
52867 & 0.23101D0, 0.21544D0, 0.19911D0, 0.18240D0, 0.16578D0,
52868 & 0.14929D0, 0.13320D0, 0.11772D0, 0.10322D0, 0.08926D0,
52869 & 0.07639D0, 0.06473D0, 0.05394D0, 0.03591D0, 0.02212D0,
52870 & 0.01231D0, 0.00589D0, 0.00057D0, 0.00000D0/
52871 DATA (FMRS(1,2,I, 4),I=1,49)/
52872 & 0.00529D0, 0.00672D0, 0.00855D0, 0.00985D0, 0.01090D0,
52873 & 0.01179D0, 0.01510D0, 0.01949D0, 0.02279D0, 0.02558D0,
52874 & 0.02822D0, 0.03873D0, 0.05456D0, 0.06724D0, 0.07823D0,
52875 & 0.08806D0, 0.10532D0, 0.12720D0, 0.15680D0, 0.18061D0,
52876 & 0.21663D0, 0.24172D0, 0.25888D0, 0.27177D0, 0.27723D0,
52877 & 0.27696D0, 0.27213D0, 0.26373D0, 0.25262D0, 0.23966D0,
52878 & 0.22489D0, 0.20919D0, 0.19281D0, 0.17616D0, 0.15968D0,
52879 & 0.14345D0, 0.12763D0, 0.11250D0, 0.09838D0, 0.08485D0,
52880 & 0.07242D0, 0.06118D0, 0.05083D0, 0.03363D0, 0.02058D0,
52881 & 0.01136D0, 0.00539D0, 0.00050D0, 0.00000D0/
52882 DATA (FMRS(1,2,I, 5),I=1,49)/
52883 & 0.00534D0, 0.00680D0, 0.00868D0, 0.01001D0, 0.01108D0,
52884 & 0.01200D0, 0.01540D0, 0.01993D0, 0.02332D0, 0.02620D0,
52885 & 0.02891D0, 0.03971D0, 0.05590D0, 0.06884D0, 0.08000D0,
52886 & 0.08997D0, 0.10741D0, 0.12941D0, 0.15897D0, 0.18257D0,
52887 & 0.21790D0, 0.24212D0, 0.25836D0, 0.27010D0, 0.27446D0,
52888 & 0.27326D0, 0.26762D0, 0.25853D0, 0.24692D0, 0.23356D0,
52889 & 0.21851D0, 0.20270D0, 0.18633D0, 0.16975D0, 0.15345D0,
52890 & 0.13751D0, 0.12199D0, 0.10721D0, 0.09351D0, 0.08043D0,
52891 & 0.06843D0, 0.05765D0, 0.04775D0, 0.03138D0, 0.01907D0,
52892 & 0.01045D0, 0.00491D0, 0.00045D0, 0.00000D0/
52893 DATA (FMRS(1,2,I, 6),I=1,49)/
52894 & 0.00539D0, 0.00688D0, 0.00879D0, 0.01015D0, 0.01125D0,
52895 & 0.01219D0, 0.01567D0, 0.02031D0, 0.02379D0, 0.02674D0,
52896 & 0.02951D0, 0.04056D0, 0.05708D0, 0.07022D0, 0.08154D0,
52897 & 0.09162D0, 0.10921D0, 0.13130D0, 0.16082D0, 0.18422D0,
52898 & 0.21894D0, 0.24239D0, 0.25783D0, 0.26859D0, 0.27204D0,
52899 & 0.27005D0, 0.26373D0, 0.25409D0, 0.24206D0, 0.22838D0,
52900 & 0.21313D0, 0.19724D0, 0.18088D0, 0.16440D0, 0.14826D0,
52901 & 0.13257D0, 0.11731D0, 0.10284D0, 0.08950D0, 0.07679D0,
52902 & 0.06517D0, 0.05477D0, 0.04524D0, 0.02956D0, 0.01786D0,
52903 & 0.00972D0, 0.00453D0, 0.00040D0, 0.00000D0/
52904 DATA (FMRS(1,2,I, 7),I=1,49)/
52905 & 0.00544D0, 0.00695D0, 0.00890D0, 0.01029D0, 0.01141D0,
52906 & 0.01237D0, 0.01593D0, 0.02068D0, 0.02425D0, 0.02727D0,
52907 & 0.03010D0, 0.04138D0, 0.05820D0, 0.07155D0, 0.08301D0,
52908 & 0.09319D0, 0.11091D0, 0.13308D0, 0.16253D0, 0.18572D0,
52909 & 0.21983D0, 0.24255D0, 0.25721D0, 0.26706D0, 0.26966D0,
52910 & 0.26692D0, 0.25996D0, 0.24983D0, 0.23740D0, 0.22344D0,
52911 & 0.20806D0, 0.19209D0, 0.17575D0, 0.15940D0, 0.14342D0,
52912 & 0.12794D0, 0.11298D0, 0.09881D0, 0.08579D0, 0.07344D0,
52913 & 0.06219D0, 0.05213D0, 0.04295D0, 0.02791D0, 0.01677D0,
52914 & 0.00906D0, 0.00419D0, 0.00037D0, 0.00000D0/
52915 DATA (FMRS(1,2,I, 8),I=1,49)/
52916 & 0.00549D0, 0.00703D0, 0.00902D0, 0.01044D0, 0.01159D0,
52917 & 0.01257D0, 0.01622D0, 0.02109D0, 0.02474D0, 0.02783D0,
52918 & 0.03073D0, 0.04227D0, 0.05940D0, 0.07296D0, 0.08456D0,
52919 & 0.09485D0, 0.11270D0, 0.13493D0, 0.16429D0, 0.18726D0,
52920 & 0.22070D0, 0.24263D0, 0.25647D0, 0.26535D0, 0.26707D0,
52921 & 0.26357D0, 0.25596D0, 0.24532D0, 0.23250D0, 0.21829D0,
52922 & 0.20276D0, 0.18675D0, 0.17045D0, 0.15424D0, 0.13845D0,
52923 & 0.12321D0, 0.10855D0, 0.09470D0, 0.08203D0, 0.07005D0,
52924 & 0.05917D0, 0.04947D0, 0.04065D0, 0.02627D0, 0.01569D0,
52925 & 0.00842D0, 0.00386D0, 0.00033D0, 0.00000D0/
52926 DATA (FMRS(1,2,I, 9),I=1,49)/
52927 & 0.00553D0, 0.00711D0, 0.00913D0, 0.01057D0, 0.01174D0,
52928 & 0.01274D0, 0.01647D0, 0.02144D0, 0.02517D0, 0.02833D0,
52929 & 0.03129D0, 0.04304D0, 0.06045D0, 0.07418D0, 0.08591D0,
52930 & 0.09629D0, 0.11425D0, 0.13653D0, 0.16579D0, 0.18855D0,
52931 & 0.22139D0, 0.24264D0, 0.25577D0, 0.26380D0, 0.26479D0,
52932 & 0.26063D0, 0.25250D0, 0.24142D0, 0.22830D0, 0.21390D0,
52933 & 0.19824D0, 0.18222D0, 0.16597D0, 0.14988D0, 0.13426D0,
52934 & 0.11924D0, 0.10484D0, 0.09128D0, 0.07889D0, 0.06724D0,
52935 & 0.05666D0, 0.04727D0, 0.03875D0, 0.02492D0, 0.01480D0,
52936 & 0.00790D0, 0.00360D0, 0.00030D0, 0.00000D0/
52937 DATA (FMRS(1,2,I,10),I=1,49)/
52938 & 0.00558D0, 0.00718D0, 0.00923D0, 0.01071D0, 0.01190D0,
52939 & 0.01291D0, 0.01671D0, 0.02178D0, 0.02559D0, 0.02881D0,
52940 & 0.03183D0, 0.04379D0, 0.06146D0, 0.07536D0, 0.08720D0,
52941 & 0.09766D0, 0.11571D0, 0.13802D0, 0.16719D0, 0.18973D0,
52942 & 0.22198D0, 0.24256D0, 0.25502D0, 0.26225D0, 0.26252D0,
52943 & 0.25776D0, 0.24914D0, 0.23766D0, 0.22428D0, 0.20968D0,
52944 & 0.19393D0, 0.17791D0, 0.16173D0, 0.14575D0, 0.13032D0,
52945 & 0.11552D0, 0.10136D0, 0.08807D0, 0.07596D0, 0.06462D0,
52946 & 0.05433D0, 0.04524D0, 0.03701D0, 0.02369D0, 0.01400D0,
52947 & 0.00743D0, 0.00336D0, 0.00028D0, 0.00000D0/
52948 DATA (FMRS(1,2,I,11),I=1,49)/
52949 & 0.00562D0, 0.00723D0, 0.00932D0, 0.01081D0, 0.01202D0,
52950 & 0.01305D0, 0.01691D0, 0.02206D0, 0.02593D0, 0.02920D0,
52951 & 0.03226D0, 0.04438D0, 0.06226D0, 0.07629D0, 0.08822D0,
52952 & 0.09874D0, 0.11687D0, 0.13920D0, 0.16827D0, 0.19064D0,
52953 & 0.22242D0, 0.24246D0, 0.25439D0, 0.26100D0, 0.26071D0,
52954 & 0.25548D0, 0.24648D0, 0.23472D0, 0.22112D0, 0.20638D0,
52955 & 0.19059D0, 0.17454D0, 0.15845D0, 0.14257D0, 0.12728D0,
52956 & 0.11265D0, 0.09869D0, 0.08561D0, 0.07373D0, 0.06261D0,
52957 & 0.05256D0, 0.04369D0, 0.03568D0, 0.02275D0, 0.01339D0,
52958 & 0.00707D0, 0.00318D0, 0.00026D0, 0.00000D0/
52959 DATA (FMRS(1,2,I,12),I=1,49)/
52960 & 0.00570D0, 0.00736D0, 0.00950D0, 0.01104D0, 0.01228D0,
52961 & 0.01335D0, 0.01733D0, 0.02266D0, 0.02665D0, 0.03003D0,
52962 & 0.03319D0, 0.04566D0, 0.06397D0, 0.07827D0, 0.09038D0,
52963 & 0.10102D0, 0.11928D0, 0.14164D0, 0.17050D0, 0.19247D0,
52964 & 0.22321D0, 0.24211D0, 0.25293D0, 0.25822D0, 0.25677D0,
52965 & 0.25059D0, 0.24082D0, 0.22847D0, 0.21448D0, 0.19945D0,
52966 & 0.18361D0, 0.16759D0, 0.15163D0, 0.13598D0, 0.12100D0,
52967 & 0.10676D0, 0.09321D0, 0.08058D0, 0.06917D0, 0.05856D0,
52968 & 0.04898D0, 0.04057D0, 0.03301D0, 0.02089D0, 0.01219D0,
52969 & 0.00638D0, 0.00284D0, 0.00022D0, 0.00000D0/
52970 DATA (FMRS(1,2,I,13),I=1,49)/
52971 & 0.00578D0, 0.00747D0, 0.00966D0, 0.01124D0, 0.01252D0,
52972 & 0.01361D0, 0.01770D0, 0.02318D0, 0.02729D0, 0.03076D0,
52973 & 0.03400D0, 0.04677D0, 0.06545D0, 0.07997D0, 0.09223D0,
52974 & 0.10297D0, 0.12133D0, 0.14370D0, 0.17234D0, 0.19395D0,
52975 & 0.22379D0, 0.24170D0, 0.25156D0, 0.25575D0, 0.25334D0,
52976 & 0.24638D0, 0.23598D0, 0.22317D0, 0.20887D0, 0.19364D0,
52977 & 0.17776D0, 0.16180D0, 0.14597D0, 0.13054D0, 0.11583D0,
52978 & 0.10193D0, 0.08873D0, 0.07648D0, 0.06548D0, 0.05529D0,
52979 & 0.04609D0, 0.03806D0, 0.03088D0, 0.01941D0, 0.01124D0,
52980 & 0.00583D0, 0.00257D0, 0.00020D0, 0.00000D0/
52981 DATA (FMRS(1,2,I,14),I=1,49)/
52982 & 0.00586D0, 0.00760D0, 0.00985D0, 0.01147D0, 0.01278D0,
52983 & 0.01391D0, 0.01812D0, 0.02377D0, 0.02801D0, 0.03158D0,
52984 & 0.03491D0, 0.04802D0, 0.06710D0, 0.08186D0, 0.09428D0,
52985 & 0.10512D0, 0.12358D0, 0.14593D0, 0.17430D0, 0.19551D0,
52986 & 0.22431D0, 0.24113D0, 0.24990D0, 0.25292D0, 0.24948D0,
52987 & 0.24168D0, 0.23063D0, 0.21737D0, 0.20273D0, 0.18735D0,
52988 & 0.17142D0, 0.15550D0, 0.13986D0, 0.12470D0, 0.11033D0,
52989 & 0.09680D0, 0.08400D0, 0.07217D0, 0.06162D0, 0.05183D0,
52990 & 0.04308D0, 0.03546D0, 0.02866D0, 0.01788D0, 0.01027D0,
52991 & 0.00528D0, 0.00231D0, 0.00017D0, 0.00000D0/
52992 DATA (FMRS(1,2,I,15),I=1,49)/
52993 & 0.00596D0, 0.00773D0, 0.01005D0, 0.01171D0, 0.01307D0,
52994 & 0.01423D0, 0.01857D0, 0.02439D0, 0.02876D0, 0.03244D0,
52995 & 0.03586D0, 0.04932D0, 0.06880D0, 0.08380D0, 0.09637D0,
52996 & 0.10730D0, 0.12584D0, 0.14815D0, 0.17622D0, 0.19694D0,
52997 & 0.22466D0, 0.24034D0, 0.24804D0, 0.24983D0, 0.24536D0,
52998 & 0.23677D0, 0.22506D0, 0.21136D0, 0.19645D0, 0.18096D0,
52999 & 0.16500D0, 0.14922D0, 0.13378D0, 0.11890D0, 0.10488D0,
53000 & 0.09171D0, 0.07933D0, 0.06793D0, 0.05781D0, 0.04848D0,
53001 & 0.04016D0, 0.03293D0, 0.02652D0, 0.01642D0, 0.00936D0,
53002 & 0.00477D0, 0.00206D0, 0.00015D0, 0.00000D0/
53003 DATA (FMRS(1,2,I,16),I=1,49)/
53004 & 0.00604D0, 0.00786D0, 0.01023D0, 0.01194D0, 0.01333D0,
53005 & 0.01452D0, 0.01898D0, 0.02497D0, 0.02945D0, 0.03323D0,
53006 & 0.03674D0, 0.05050D0, 0.07034D0, 0.08554D0, 0.09824D0,
53007 & 0.10925D0, 0.12785D0, 0.15009D0, 0.17786D0, 0.19815D0,
53008 & 0.22486D0, 0.23952D0, 0.24625D0, 0.24698D0, 0.24163D0,
53009 & 0.23233D0, 0.22009D0, 0.20603D0, 0.19091D0, 0.17529D0,
53010 & 0.15938D0, 0.14374D0, 0.12849D0, 0.11388D0, 0.10016D0,
53011 & 0.08733D0, 0.07533D0, 0.06433D0, 0.05458D0, 0.04564D0,
53012 & 0.03769D0, 0.03082D0, 0.02473D0, 0.01521D0, 0.00860D0,
53013 & 0.00435D0, 0.00186D0, 0.00013D0, 0.00000D0/
53014 DATA (FMRS(1,2,I,17),I=1,49)/
53015 & 0.00614D0, 0.00799D0, 0.01042D0, 0.01217D0, 0.01359D0,
53016 & 0.01482D0, 0.01940D0, 0.02555D0, 0.03016D0, 0.03404D0,
53017 & 0.03763D0, 0.05170D0, 0.07188D0, 0.08729D0, 0.10010D0,
53018 & 0.11119D0, 0.12983D0, 0.15200D0, 0.17943D0, 0.19928D0,
53019 & 0.22497D0, 0.23860D0, 0.24438D0, 0.24406D0, 0.23786D0,
53020 & 0.22788D0, 0.21517D0, 0.20077D0, 0.18546D0, 0.16976D0,
53021 & 0.15392D0, 0.13841D0, 0.12338D0, 0.10905D0, 0.09563D0,
53022 & 0.08314D0, 0.07152D0, 0.06090D0, 0.05152D0, 0.04295D0,
53023 & 0.03537D0, 0.02883D0, 0.02306D0, 0.01409D0, 0.00791D0,
53024 & 0.00396D0, 0.00168D0, 0.00011D0, 0.00000D0/
53025 DATA (FMRS(1,2,I,18),I=1,49)/
53026 & 0.00621D0, 0.00810D0, 0.01058D0, 0.01236D0, 0.01382D0,
53027 & 0.01507D0, 0.01975D0, 0.02604D0, 0.03075D0, 0.03471D0,
53028 & 0.03837D0, 0.05269D0, 0.07316D0, 0.08872D0, 0.10163D0,
53029 & 0.11277D0, 0.13143D0, 0.15352D0, 0.18066D0, 0.20012D0,
53030 & 0.22496D0, 0.23774D0, 0.24276D0, 0.24159D0, 0.23471D0,
53031 & 0.22421D0, 0.21113D0, 0.19645D0, 0.18102D0, 0.16532D0,
53032 & 0.14952D0, 0.13412D0, 0.11930D0, 0.10519D0, 0.09201D0,
53033 & 0.07983D0, 0.06850D0, 0.05818D0, 0.04914D0, 0.04085D0,
53034 & 0.03356D0, 0.02728D0, 0.02176D0, 0.01322D0, 0.00738D0,
53035 & 0.00367D0, 0.00154D0, 0.00010D0, 0.00000D0/
53036 DATA (FMRS(1,2,I,19),I=1,49)/
53037 & 0.00631D0, 0.00824D0, 0.01077D0, 0.01261D0, 0.01410D0,
53038 & 0.01538D0, 0.02018D0, 0.02663D0, 0.03146D0, 0.03553D0,
53039 & 0.03927D0, 0.05390D0, 0.07469D0, 0.09044D0, 0.10345D0,
53040 & 0.11464D0, 0.13332D0, 0.15529D0, 0.18206D0, 0.20106D0,
53041 & 0.22486D0, 0.23661D0, 0.24071D0, 0.23855D0, 0.23089D0,
53042 & 0.21978D0, 0.20626D0, 0.19133D0, 0.17575D0, 0.16006D0,
53043 & 0.14433D0, 0.12911D0, 0.11452D0, 0.10069D0, 0.08783D0,
53044 & 0.07600D0, 0.06503D0, 0.05507D0, 0.04638D0, 0.03845D0,
53045 & 0.03149D0, 0.02552D0, 0.02030D0, 0.01225D0, 0.00679D0,
53046 & 0.00335D0, 0.00139D0, 0.00009D0, 0.00000D0/
53047 DATA (FMRS(1,2,I,20),I=1,49)/
53048 & 0.00640D0, 0.00837D0, 0.01095D0, 0.01282D0, 0.01434D0,
53049 & 0.01565D0, 0.02057D0, 0.02717D0, 0.03210D0, 0.03625D0,
53050 & 0.04007D0, 0.05496D0, 0.07605D0, 0.09195D0, 0.10504D0,
53051 & 0.11628D0, 0.13496D0, 0.15682D0, 0.18325D0, 0.20182D0,
53052 & 0.22471D0, 0.23557D0, 0.23887D0, 0.23587D0, 0.22753D0,
53053 & 0.21592D0, 0.20204D0, 0.18691D0, 0.17123D0, 0.15556D0,
53054 & 0.13990D0, 0.12485D0, 0.11047D0, 0.09690D0, 0.08432D0,
53055 & 0.07279D0, 0.06213D0, 0.05248D0, 0.04407D0, 0.03646D0,
53056 & 0.02978D0, 0.02408D0, 0.01910D0, 0.01145D0, 0.00631D0,
53057 & 0.00309D0, 0.00127D0, 0.00008D0, 0.00000D0/
53058 DATA (FMRS(1,2,I,21),I=1,49)/
53059 & 0.00648D0, 0.00848D0, 0.01111D0, 0.01302D0, 0.01457D0,
53060 & 0.01591D0, 0.02092D0, 0.02766D0, 0.03269D0, 0.03692D0,
53061 & 0.04081D0, 0.05593D0, 0.07728D0, 0.09331D0, 0.10647D0,
53062 & 0.11774D0, 0.13641D0, 0.15816D0, 0.18425D0, 0.20243D0,
53063 & 0.22446D0, 0.23452D0, 0.23710D0, 0.23336D0, 0.22443D0,
53064 & 0.21239D0, 0.19820D0, 0.18290D0, 0.16716D0, 0.15148D0,
53065 & 0.13595D0, 0.12104D0, 0.10685D0, 0.09353D0, 0.08121D0,
53066 & 0.06995D0, 0.05958D0, 0.05021D0, 0.04207D0, 0.03472D0,
53067 & 0.02829D0, 0.02282D0, 0.01806D0, 0.01077D0, 0.00590D0,
53068 & 0.00287D0, 0.00118D0, 0.00007D0, 0.00000D0/
53069 DATA (FMRS(1,2,I,22),I=1,49)/
53070 & 0.00659D0, 0.00863D0, 0.01133D0, 0.01328D0, 0.01487D0,
53071 & 0.01624D0, 0.02138D0, 0.02828D0, 0.03345D0, 0.03777D0,
53072 & 0.04174D0, 0.05717D0, 0.07882D0, 0.09501D0, 0.10826D0,
53073 & 0.11956D0, 0.13822D0, 0.15980D0, 0.18547D0, 0.20313D0,
53074 & 0.22408D0, 0.23313D0, 0.23482D0, 0.23017D0, 0.22053D0,
53075 & 0.20797D0, 0.19344D0, 0.17794D0, 0.16215D0, 0.14650D0,
53076 & 0.13110D0, 0.11639D0, 0.10245D0, 0.08944D0, 0.07745D0,
53077 & 0.06653D0, 0.05651D0, 0.04748D0, 0.03968D0, 0.03265D0,
53078 & 0.02652D0, 0.02133D0, 0.01682D0, 0.00997D0, 0.00542D0,
53079 & 0.00262D0, 0.00106D0, 0.00006D0, 0.00000D0/
53080 DATA (FMRS(1,2,I,23),I=1,49)/
53081 & 0.00669D0, 0.00878D0, 0.01153D0, 0.01352D0, 0.01515D0,
53082 & 0.01655D0, 0.02181D0, 0.02888D0, 0.03416D0, 0.03858D0,
53083 & 0.04263D0, 0.05833D0, 0.08027D0, 0.09661D0, 0.10992D0,
53084 & 0.12125D0, 0.13987D0, 0.16129D0, 0.18654D0, 0.20370D0,
53085 & 0.22365D0, 0.23178D0, 0.23266D0, 0.22717D0, 0.21689D0,
53086 & 0.20387D0, 0.18906D0, 0.17340D0, 0.15758D0, 0.14198D0,
53087 & 0.12670D0, 0.11220D0, 0.09851D0, 0.08577D0, 0.07408D0,
53088 & 0.06350D0, 0.05377D0, 0.04507D0, 0.03757D0, 0.03084D0,
53089 & 0.02497D0, 0.02003D0, 0.01574D0, 0.00927D0, 0.00500D0,
53090 & 0.00240D0, 0.00096D0, 0.00006D0, 0.00000D0/
53091 DATA (FMRS(1,2,I,24),I=1,49)/
53092 & 0.00679D0, 0.00892D0, 0.01172D0, 0.01376D0, 0.01542D0,
53093 & 0.01685D0, 0.02222D0, 0.02944D0, 0.03483D0, 0.03934D0,
53094 & 0.04345D0, 0.05941D0, 0.08161D0, 0.09806D0, 0.11144D0,
53095 & 0.12278D0, 0.14136D0, 0.16260D0, 0.18745D0, 0.20414D0,
53096 & 0.22314D0, 0.23041D0, 0.23054D0, 0.22429D0, 0.21345D0,
53097 & 0.20006D0, 0.18498D0, 0.16918D0, 0.15336D0, 0.13783D0,
53098 & 0.12271D0, 0.10840D0, 0.09494D0, 0.08246D0, 0.07106D0,
53099 & 0.06075D0, 0.05132D0, 0.04292D0, 0.03570D0, 0.02922D0,
53100 & 0.02361D0, 0.01888D0, 0.01480D0, 0.00867D0, 0.00465D0,
53101 & 0.00221D0, 0.00088D0, 0.00005D0, 0.00000D0/
53102 DATA (FMRS(1,2,I,25),I=1,49)/
53103 & 0.00689D0, 0.00906D0, 0.01192D0, 0.01399D0, 0.01569D0,
53104 & 0.01715D0, 0.02264D0, 0.03000D0, 0.03550D0, 0.04009D0,
53105 & 0.04429D0, 0.06049D0, 0.08294D0, 0.09952D0, 0.11294D0,
53106 & 0.12429D0, 0.14282D0, 0.16389D0, 0.18832D0, 0.20454D0,
53107 & 0.22261D0, 0.22902D0, 0.22843D0, 0.22145D0, 0.21007D0,
53108 & 0.19632D0, 0.18101D0, 0.16509D0, 0.14928D0, 0.13382D0,
53109 & 0.11886D0, 0.10475D0, 0.09153D0, 0.07931D0, 0.06819D0,
53110 & 0.05815D0, 0.04900D0, 0.04089D0, 0.03393D0, 0.02770D0,
53111 & 0.02232D0, 0.01781D0, 0.01392D0, 0.00811D0, 0.00432D0,
53112 & 0.00204D0, 0.00081D0, 0.00004D0, 0.00000D0/
53113 DATA (FMRS(1,2,I,26),I=1,49)/
53114 & 0.00699D0, 0.00920D0, 0.01211D0, 0.01423D0, 0.01596D0,
53115 & 0.01744D0, 0.02304D0, 0.03056D0, 0.03616D0, 0.04084D0,
53116 & 0.04510D0, 0.06154D0, 0.08423D0, 0.10091D0, 0.11437D0,
53117 & 0.12573D0, 0.14419D0, 0.16508D0, 0.18909D0, 0.20485D0,
53118 & 0.22201D0, 0.22760D0, 0.22631D0, 0.21867D0, 0.20676D0,
53119 & 0.19266D0, 0.17717D0, 0.16120D0, 0.14536D0, 0.12999D0,
53120 & 0.11520D0, 0.10128D0, 0.08831D0, 0.07633D0, 0.06548D0,
53121 & 0.05572D0, 0.04685D0, 0.03900D0, 0.03228D0, 0.02629D0,
53122 & 0.02113D0, 0.01682D0, 0.01311D0, 0.00760D0, 0.00403D0,
53123 & 0.00189D0, 0.00074D0, 0.00004D0, 0.00000D0/
53124 DATA (FMRS(1,2,I,27),I=1,49)/
53125 & 0.00708D0, 0.00933D0, 0.01230D0, 0.01445D0, 0.01621D0,
53126 & 0.01773D0, 0.02343D0, 0.03108D0, 0.03678D0, 0.04155D0,
53127 & 0.04587D0, 0.06253D0, 0.08544D0, 0.10221D0, 0.11571D0,
53128 & 0.12707D0, 0.14546D0, 0.16617D0, 0.18977D0, 0.20509D0,
53129 & 0.22139D0, 0.22623D0, 0.22430D0, 0.21604D0, 0.20367D0,
53130 & 0.18926D0, 0.17361D0, 0.15759D0, 0.14176D0, 0.12648D0,
53131 & 0.11185D0, 0.09812D0, 0.08537D0, 0.07364D0, 0.06303D0,
53132 & 0.05352D0, 0.04490D0, 0.03729D0, 0.03081D0, 0.02503D0,
53133 & 0.02007D0, 0.01594D0, 0.01240D0, 0.00714D0, 0.00376D0,
53134 & 0.00176D0, 0.00068D0, 0.00004D0, 0.00000D0/
53135 DATA (FMRS(1,2,I,28),I=1,49)/
53136 & 0.00718D0, 0.00946D0, 0.01247D0, 0.01467D0, 0.01646D0,
53137 & 0.01800D0, 0.02380D0, 0.03158D0, 0.03738D0, 0.04221D0,
53138 & 0.04660D0, 0.06346D0, 0.08657D0, 0.10342D0, 0.11695D0,
53139 & 0.12830D0, 0.14663D0, 0.16715D0, 0.19037D0, 0.20527D0,
53140 & 0.22075D0, 0.22489D0, 0.22237D0, 0.21353D0, 0.20079D0,
53141 & 0.18610D0, 0.17031D0, 0.15425D0, 0.13844D0, 0.12326D0,
53142 & 0.10877D0, 0.09523D0, 0.08268D0, 0.07119D0, 0.06080D0,
53143 & 0.05153D0, 0.04314D0, 0.03575D0, 0.02948D0, 0.02390D0,
53144 & 0.01913D0, 0.01516D0, 0.01177D0, 0.00675D0, 0.00353D0,
53145 & 0.00164D0, 0.00063D0, 0.00003D0, 0.00000D0/
53146 DATA (FMRS(1,2,I,29),I=1,49)/
53147 & 0.00727D0, 0.00959D0, 0.01265D0, 0.01488D0, 0.01670D0,
53148 & 0.01827D0, 0.02417D0, 0.03208D0, 0.03797D0, 0.04288D0,
53149 & 0.04733D0, 0.06440D0, 0.08769D0, 0.10463D0, 0.11818D0,
53150 & 0.12952D0, 0.14777D0, 0.16810D0, 0.19092D0, 0.20540D0,
53151 & 0.22008D0, 0.22352D0, 0.22043D0, 0.21103D0, 0.19791D0,
53152 & 0.18297D0, 0.16705D0, 0.15095D0, 0.13519D0, 0.12011D0,
53153 & 0.10577D0, 0.09241D0, 0.08008D0, 0.06881D0, 0.05866D0,
53154 & 0.04961D0, 0.04145D0, 0.03427D0, 0.02822D0, 0.02282D0,
53155 & 0.01822D0, 0.01441D0, 0.01116D0, 0.00637D0, 0.00332D0,
53156 & 0.00153D0, 0.00059D0, 0.00003D0, 0.00000D0/
53157 DATA (FMRS(1,2,I,30),I=1,49)/
53158 & 0.00737D0, 0.00972D0, 0.01283D0, 0.01510D0, 0.01695D0,
53159 & 0.01854D0, 0.02454D0, 0.03258D0, 0.03856D0, 0.04354D0,
53160 & 0.04805D0, 0.06532D0, 0.08879D0, 0.10580D0, 0.11936D0,
53161 & 0.13069D0, 0.14886D0, 0.16900D0, 0.19141D0, 0.20548D0,
53162 & 0.21937D0, 0.22213D0, 0.21850D0, 0.20855D0, 0.19507D0,
53163 & 0.17994D0, 0.16388D0, 0.14775D0, 0.13208D0, 0.11709D0,
53164 & 0.10291D0, 0.08973D0, 0.07760D0, 0.06655D0, 0.05664D0,
53165 & 0.04779D0, 0.03985D0, 0.03289D0, 0.02702D0, 0.02182D0,
53166 & 0.01738D0, 0.01372D0, 0.01060D0, 0.00602D0, 0.00312D0,
53167 & 0.00143D0, 0.00055D0, 0.00003D0, 0.00000D0/
53168 DATA (FMRS(1,2,I,31),I=1,49)/
53169 & 0.00746D0, 0.00985D0, 0.01300D0, 0.01530D0, 0.01718D0,
53170 & 0.01880D0, 0.02489D0, 0.03306D0, 0.03912D0, 0.04417D0,
53171 & 0.04873D0, 0.06619D0, 0.08983D0, 0.10690D0, 0.12048D0,
53172 & 0.13179D0, 0.14987D0, 0.16982D0, 0.19186D0, 0.20553D0,
53173 & 0.21868D0, 0.22081D0, 0.21666D0, 0.20623D0, 0.19242D0,
53174 & 0.17710D0, 0.16093D0, 0.14478D0, 0.12919D0, 0.11430D0,
53175 & 0.10026D0, 0.08726D0, 0.07533D0, 0.06447D0, 0.05479D0,
53176 & 0.04614D0, 0.03840D0, 0.03163D0, 0.02594D0, 0.02091D0,
53177 & 0.01662D0, 0.01309D0, 0.01009D0, 0.00571D0, 0.00295D0,
53178 & 0.00134D0, 0.00051D0, 0.00003D0, 0.00000D0/
53179 DATA (FMRS(1,2,I,32),I=1,49)/
53180 & 0.00755D0, 0.00997D0, 0.01317D0, 0.01550D0, 0.01741D0,
53181 & 0.01905D0, 0.02522D0, 0.03351D0, 0.03966D0, 0.04477D0,
53182 & 0.04938D0, 0.06700D0, 0.09079D0, 0.10792D0, 0.12151D0,
53183 & 0.13280D0, 0.15080D0, 0.17056D0, 0.19223D0, 0.20552D0,
53184 & 0.21797D0, 0.21951D0, 0.21489D0, 0.20403D0, 0.18991D0,
53185 & 0.17441D0, 0.15817D0, 0.14202D0, 0.12646D0, 0.11170D0,
53186 & 0.09780D0, 0.08498D0, 0.07322D0, 0.06257D0, 0.05306D0,
53187 & 0.04463D0, 0.03708D0, 0.03049D0, 0.02496D0, 0.02008D0,
53188 & 0.01594D0, 0.01252D0, 0.00963D0, 0.00542D0, 0.00279D0,
53189 & 0.00126D0, 0.00048D0, 0.00002D0, 0.00000D0/
53190 DATA (FMRS(1,2,I,33),I=1,49)/
53191 & 0.00764D0, 0.01009D0, 0.01333D0, 0.01570D0, 0.01763D0,
53192 & 0.01930D0, 0.02556D0, 0.03396D0, 0.04019D0, 0.04537D0,
53193 & 0.05004D0, 0.06783D0, 0.09177D0, 0.10895D0, 0.12254D0,
53194 & 0.13381D0, 0.15173D0, 0.17130D0, 0.19261D0, 0.20552D0,
53195 & 0.21726D0, 0.21822D0, 0.21313D0, 0.20185D0, 0.18743D0,
53196 & 0.17175D0, 0.15545D0, 0.13931D0, 0.12379D0, 0.10917D0,
53197 & 0.09540D0, 0.08276D0, 0.07118D0, 0.06072D0, 0.05139D0,
53198 & 0.04317D0, 0.03581D0, 0.02938D0, 0.02402D0, 0.01929D0,
53199 & 0.01528D0, 0.01198D0, 0.00920D0, 0.00516D0, 0.00264D0,
53200 & 0.00119D0, 0.00045D0, 0.00002D0, 0.00000D0/
53201 DATA (FMRS(1,2,I,34),I=1,49)/
53202 & 0.00773D0, 0.01021D0, 0.01350D0, 0.01590D0, 0.01786D0,
53203 & 0.01955D0, 0.02590D0, 0.03441D0, 0.04072D0, 0.04597D0,
53204 & 0.05068D0, 0.06863D0, 0.09272D0, 0.10994D0, 0.12353D0,
53205 & 0.13477D0, 0.15260D0, 0.17197D0, 0.19290D0, 0.20543D0,
53206 & 0.21649D0, 0.21688D0, 0.21134D0, 0.19965D0, 0.18497D0,
53207 & 0.16913D0, 0.15278D0, 0.13665D0, 0.12121D0, 0.10669D0,
53208 & 0.09308D0, 0.08060D0, 0.06921D0, 0.05894D0, 0.04980D0,
53209 & 0.04176D0, 0.03458D0, 0.02833D0, 0.02311D0, 0.01853D0,
53210 & 0.01465D0, 0.01147D0, 0.00879D0, 0.00491D0, 0.00250D0,
53211 & 0.00112D0, 0.00042D0, 0.00002D0, 0.00000D0/
53212 DATA (FMRS(1,2,I,35),I=1,49)/
53213 & 0.00781D0, 0.01033D0, 0.01366D0, 0.01609D0, 0.01808D0,
53214 & 0.01979D0, 0.02622D0, 0.03484D0, 0.04123D0, 0.04653D0,
53215 & 0.05129D0, 0.06941D0, 0.09362D0, 0.11088D0, 0.12448D0,
53216 & 0.13569D0, 0.15342D0, 0.17260D0, 0.19318D0, 0.20535D0,
53217 & 0.21576D0, 0.21562D0, 0.20966D0, 0.19759D0, 0.18266D0,
53218 & 0.16668D0, 0.15028D0, 0.13418D0, 0.11882D0, 0.10439D0,
53219 & 0.09094D0, 0.07861D0, 0.06739D0, 0.05729D0, 0.04834D0,
53220 & 0.04048D0, 0.03346D0, 0.02736D0, 0.02228D0, 0.01784D0,
53221 & 0.01408D0, 0.01100D0, 0.00842D0, 0.00468D0, 0.00237D0,
53222 & 0.00106D0, 0.00039D0, 0.00002D0, 0.00000D0/
53223 DATA (FMRS(1,2,I,36),I=1,49)/
53224 & 0.00790D0, 0.01044D0, 0.01382D0, 0.01628D0, 0.01829D0,
53225 & 0.02002D0, 0.02653D0, 0.03525D0, 0.04172D0, 0.04707D0,
53226 & 0.05188D0, 0.07013D0, 0.09447D0, 0.11177D0, 0.12535D0,
53227 & 0.13654D0, 0.15418D0, 0.17318D0, 0.19341D0, 0.20524D0,
53228 & 0.21505D0, 0.21440D0, 0.20805D0, 0.19563D0, 0.18048D0,
53229 & 0.16438D0, 0.14795D0, 0.13186D0, 0.11657D0, 0.10226D0,
53230 & 0.08894D0, 0.07676D0, 0.06571D0, 0.05578D0, 0.04700D0,
53231 & 0.03929D0, 0.03242D0, 0.02648D0, 0.02153D0, 0.01720D0,
53232 & 0.01356D0, 0.01058D0, 0.00808D0, 0.00448D0, 0.00226D0,
53233 & 0.00101D0, 0.00037D0, 0.00002D0, 0.00000D0/
53234 DATA (FMRS(1,2,I,37),I=1,49)/
53235 & 0.00798D0, 0.01056D0, 0.01397D0, 0.01646D0, 0.01850D0,
53236 & 0.02025D0, 0.02684D0, 0.03567D0, 0.04221D0, 0.04762D0,
53237 & 0.05247D0, 0.07087D0, 0.09532D0, 0.11265D0, 0.12622D0,
53238 & 0.13738D0, 0.15492D0, 0.17373D0, 0.19361D0, 0.20510D0,
53239 & 0.21429D0, 0.21315D0, 0.20641D0, 0.19365D0, 0.17829D0,
53240 & 0.16207D0, 0.14561D0, 0.12954D0, 0.11434D0, 0.10013D0,
53241 & 0.08696D0, 0.07493D0, 0.06406D0, 0.05429D0, 0.04567D0,
53242 & 0.03812D0, 0.03141D0, 0.02561D0, 0.02079D0, 0.01659D0,
53243 & 0.01305D0, 0.01017D0, 0.00775D0, 0.00428D0, 0.00215D0,
53244 & 0.00095D0, 0.00035D0, 0.00002D0, 0.00000D0/
53245 DATA (FMRS(1,2,I,38),I=1,49)/
53246 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53247 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53248 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53249 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53250 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53251 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53252 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53253 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53254 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53255 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53256 DATA (FMRS(1,3,I, 1),I=1,49)/
53257 & 3.68244D0, 3.61785D0, 3.55346D0, 3.51555D0, 3.48837D0,
53258 & 3.46702D0, 3.39811D0, 3.32177D0, 3.27072D0, 3.23000D0,
53259 & 3.19378D0, 3.05765D0, 2.86346D0, 2.71339D0, 2.58651D0,
53260 & 2.47572D0, 2.28777D0, 2.06245D0, 1.78178D0, 1.57726D0,
53261 & 1.30519D0, 1.14076D0, 1.03654D0, 0.95264D0, 0.89447D0,
53262 & 0.84663D0, 0.80090D0, 0.75325D0, 0.70217D0, 0.64784D0,
53263 & 0.59048D0, 0.53173D0, 0.47263D0, 0.41459D0, 0.35887D0,
53264 & 0.30634D0, 0.25757D0, 0.21335D0, 0.17415D0, 0.13936D0,
53265 & 0.10957D0, 0.08459D0, 0.06372D0, 0.03369D0, 0.01574D0,
53266 & 0.00625D0, 0.00195D0, 0.00005D0, 0.00000D0/
53267 DATA (FMRS(1,3,I, 2),I=1,49)/
53268 & 6.24307D0, 5.86376D0, 5.50631D0, 5.30646D0, 5.16844D0,
53269 & 5.06337D0, 4.74657D0, 4.44005D0, 4.26242D0, 4.13555D0,
53270 & 4.03502D0, 3.71094D0, 3.34882D0, 3.11051D0, 2.92600D0,
53271 & 2.77355D0, 2.52821D0, 2.24967D0, 1.91859D0, 1.68481D0,
53272 & 1.37946D0, 1.19535D0, 1.07673D0, 0.97819D0, 0.90750D0,
53273 & 0.84881D0, 0.79381D0, 0.73852D0, 0.68149D0, 0.62276D0,
53274 & 0.56254D0, 0.50226D0, 0.44285D0, 0.38548D0, 0.33123D0,
53275 & 0.28073D0, 0.23437D0, 0.19279D0, 0.15633D0, 0.12427D0,
53276 & 0.09707D0, 0.07445D0, 0.05572D0, 0.02906D0, 0.01339D0,
53277 & 0.00524D0, 0.00161D0, 0.00004D0, 0.00000D0/
53278 DATA (FMRS(1,3,I, 3),I=1,49)/
53279 & 11.05139D0, 9.94786D0, 8.95244D0, 8.41536D0, 8.05287D0,
53280 & 7.78166D0, 6.98996D0, 6.26416D0, 5.86369D0, 5.58758D0,
53281 & 5.37431D0, 4.72923D0, 4.08790D0, 3.70661D0, 3.43015D0,
53282 & 3.21204D0, 2.87740D0, 2.51734D0, 2.11023D0, 1.83283D0,
53283 & 1.47833D0, 1.26530D0, 1.12571D0, 1.00618D0, 0.91793D0,
53284 & 0.84442D0, 0.77712D0, 0.71204D0, 0.64770D0, 0.58389D0,
53285 & 0.52071D0, 0.45928D0, 0.40030D0, 0.34459D0, 0.29298D0,
53286 & 0.24576D0, 0.20309D0, 0.16540D0, 0.13284D0, 0.10462D0,
53287 & 0.08093D0, 0.06152D0, 0.04560D0, 0.02333D0, 0.01054D0,
53288 & 0.00404D0, 0.00122D0, 0.00003D0, 0.00000D0/
53289 DATA (FMRS(1,3,I, 4),I=1,49)/
53290 & 15.37825D0, 13.53065D0, 11.90193D0, 11.03924D0, 10.46378D0,
53291 & 10.03696D0, 8.81034D0, 7.71341D0, 7.12073D0, 6.71781D0,
53292 & 6.40918D0, 5.49848D0, 4.63276D0, 4.13943D0, 3.79203D0,
53293 & 3.52386D0, 3.12196D0, 2.70149D0, 2.23890D0, 1.93011D0,
53294 & 1.54059D0, 1.30714D0, 1.15286D0, 1.01886D0, 0.91881D0,
53295 & 0.83562D0, 0.76055D0, 0.68952D0, 0.62095D0, 0.55452D0,
53296 & 0.49011D0, 0.42861D0, 0.37052D0, 0.31647D0, 0.26702D0,
53297 & 0.22241D0, 0.18246D0, 0.14751D0, 0.11769D0, 0.09209D0,
53298 & 0.07074D0, 0.05343D0, 0.03933D0, 0.01985D0, 0.00885D0,
53299 & 0.00335D0, 0.00100D0, 0.00002D0, 0.00000D0/
53300 DATA (FMRS(1,3,I, 5),I=1,49)/
53301 & 20.54786D0, 17.73643D0, 15.30522D0, 14.03720D0, 13.19955D0,
53302 & 12.58273D0, 10.83264D0, 9.29877D0, 8.48369D0, 7.93560D0,
53303 & 7.51848D0, 6.31010D0, 5.19808D0, 4.58383D0, 4.16067D0,
53304 & 3.83948D0, 3.36690D0, 2.88348D0, 2.36367D0, 2.02276D0,
53305 & 1.59751D0, 1.34336D0, 1.17440D0, 1.02619D0, 0.91484D0,
53306 & 0.82260D0, 0.74049D0, 0.66431D0, 0.59227D0, 0.52387D0,
53307 & 0.45886D0, 0.39784D0, 0.34106D0, 0.28898D0, 0.24193D0,
53308 & 0.20003D0, 0.16291D0, 0.13075D0, 0.10361D0, 0.08049D0,
53309 & 0.06141D0, 0.04606D0, 0.03367D0, 0.01676D0, 0.00737D0,
53310 & 0.00275D0, 0.00081D0, 0.00002D0, 0.00000D0/
53311 DATA (FMRS(1,3,I, 6),I=1,49)/
53312 & 25.87997D0, 22.00579D0, 18.70564D0, 17.00514D0, 15.89031D0,
53313 & 15.07400D0, 12.78092D0, 10.80231D0, 9.76436D0, 9.07223D0,
53314 & 8.54820D0, 7.05063D0, 5.70461D0, 4.97765D0, 4.48471D0,
53315 & 4.11512D0, 3.57867D0, 3.03899D0, 2.46867D0, 2.09967D0,
53316 & 1.64344D0, 1.37152D0, 1.19009D0, 1.03003D0, 0.90944D0,
53317 & 0.81000D0, 0.72245D0, 0.64242D0, 0.56795D0, 0.49835D0,
53318 & 0.43318D0, 0.37285D0, 0.31739D0, 0.26712D0, 0.22217D0,
53319 & 0.18254D0, 0.14775D0, 0.11786D0, 0.09285D0, 0.07171D0,
53320 & 0.05439D0, 0.04056D0, 0.02948D0, 0.01450D0, 0.00631D0,
53321 & 0.00232D0, 0.00067D0, 0.00002D0, 0.00000D0/
53322 DATA (FMRS(1,3,I, 7),I=1,49)/
53323 & 31.48650D0, 26.43816D0, 22.19174D0, 20.02570D0, 18.61470D0,
53324 & 17.58636D0, 14.72161D0, 12.28168D0, 11.01532D0, 10.17669D0,
53325 & 9.54456D0, 7.75761D0, 6.18119D0, 5.34474D0, 4.78459D0,
53326 & 4.36861D0, 3.77149D0, 3.17878D0, 2.56125D0, 2.16614D0,
53327 & 1.68135D0, 1.39321D0, 1.20050D0, 1.02990D0, 0.90129D0,
53328 & 0.79577D0, 0.70378D0, 0.62075D0, 0.54457D0, 0.47435D0,
53329 & 0.40939D0, 0.34999D0, 0.29601D0, 0.24758D0, 0.20467D0,
53330 & 0.16718D0, 0.13453D0, 0.10670D0, 0.08361D0, 0.06425D0,
53331 & 0.04845D0, 0.03594D0, 0.02598D0, 0.01264D0, 0.00544D0,
53332 & 0.00198D0, 0.00057D0, 0.00001D0, 0.00000D0/
53333 DATA (FMRS(1,3,I, 8),I=1,49)/
53334 & 38.19562D0, 31.67731D0, 26.26192D0, 23.52700D0, 21.75654D0,
53335 & 20.47217D0, 16.92324D0, 13.93891D0, 12.40615D0, 11.39793D0,
53336 & 10.64140D0, 8.52490D0, 6.69053D0, 5.73328D0, 5.09966D0,
53337 & 4.63338D0, 3.97084D0, 3.32155D0, 2.65414D0, 2.23167D0,
53338 & 1.71719D0, 1.41235D0, 1.20819D0, 1.02708D0, 0.89064D0,
53339 & 0.77934D0, 0.68328D0, 0.59764D0, 0.52014D0, 0.44964D0,
53340 & 0.38523D0, 0.32704D0, 0.27476D0, 0.22832D0, 0.18758D0,
53341 & 0.15228D0, 0.12182D0, 0.09604D0, 0.07484D0, 0.05719D0,
53342 & 0.04288D0, 0.03164D0, 0.02275D0, 0.01095D0, 0.00466D0,
53343 & 0.00168D0, 0.00048D0, 0.00001D0, 0.00000D0/
53344 DATA (FMRS(1,3,I, 9),I=1,49)/
53345 & 44.69263D0, 36.69535D0, 30.11768D0, 26.82255D0, 24.70025D0,
53346 & 23.16639D0, 18.95601D0, 15.45187D0, 13.66736D0, 12.49995D0,
53347 & 11.62724D0, 9.20581D0, 7.13631D0, 6.07035D0, 5.37118D0,
53348 & 4.86033D0, 4.14011D0, 3.44140D0, 2.73081D0, 2.28485D0,
53349 & 1.74506D0, 1.42613D0, 1.21246D0, 1.02274D0, 0.88003D0,
53350 & 0.76424D0, 0.66513D0, 0.57765D0, 0.49935D0, 0.42889D0,
53351 & 0.36519D0, 0.30820D0, 0.25746D0, 0.21275D0, 0.17388D0,
53352 & 0.14043D0, 0.11178D0, 0.08767D0, 0.06799D0, 0.05171D0,
53353 & 0.03859D0, 0.02834D0, 0.02028D0, 0.00968D0, 0.00408D0,
53354 & 0.00146D0, 0.00041D0, 0.00001D0, 0.00000D0/
53355 DATA (FMRS(1,3,I,10),I=1,49)/
53356 & 51.42669D0, 41.84610D0, 34.03689D0, 30.15309D0, 27.66303D0,
53357 & 25.86942D0, 20.97504D0, 16.93923D0, 14.89954D0, 13.57172D0,
53358 & 12.58248D0, 9.85775D0, 7.55746D0, 6.38605D0, 5.62372D0,
53359 & 5.07013D0, 4.29501D0, 3.54959D0, 2.79853D0, 2.33075D0,
53360 & 1.76763D0, 1.43584D0, 1.21358D0, 1.01625D0, 0.86814D0,
53361 & 0.74860D0, 0.64707D0, 0.55827D0, 0.47958D0, 0.40941D0,
53362 & 0.34660D0, 0.29089D0, 0.24172D0, 0.19871D0, 0.16160D0,
53363 & 0.12988D0, 0.10289D0, 0.08032D0, 0.06202D0, 0.04695D0,
53364 & 0.03489D0, 0.02551D0, 0.01818D0, 0.00860D0, 0.00360D0,
53365 & 0.00128D0, 0.00036D0, 0.00001D0, 0.00000D0/
53366 DATA (FMRS(1,3,I,11),I=1,49)/
53367 & 57.20334D0, 46.22931D0, 37.34534D0, 32.95134D0, 30.14391D0,
53368 & 28.12686D0, 22.64741D0, 18.16087D0, 15.90648D0, 14.44434D0,
53369 & 13.35786D0, 10.38182D0, 7.89242D0, 6.63544D0, 5.82215D0,
53370 & 5.23423D0, 4.41529D0, 3.63279D0, 2.84983D0, 2.36499D0,
53371 & 1.78374D0, 1.44206D0, 1.21326D0, 1.01023D0, 0.85815D0,
53372 & 0.73593D0, 0.63273D0, 0.54312D0, 0.46430D0, 0.39449D0,
53373 & 0.33248D0, 0.27783D0, 0.22993D0, 0.18826D0, 0.15250D0,
53374 & 0.12212D0, 0.09637D0, 0.07495D0, 0.05770D0, 0.04352D0,
53375 & 0.03223D0, 0.02349D0, 0.01668D0, 0.00784D0, 0.00326D0,
53376 & 0.00115D0, 0.00032D0, 0.00001D0, 0.00000D0/
53377 DATA (FMRS(1,3,I,12),I=1,49)/
53378 & 70.62117D0, 56.29525D0, 44.85603D0, 39.26056D0, 35.71024D0,
53379 & 33.17249D0, 26.34026D0, 20.82458D0, 18.08508D0, 16.32156D0,
53380 & 15.01807D0, 11.48651D0, 8.58576D0, 7.14521D0, 6.22372D0,
53381 & 5.56345D0, 4.65284D0, 3.79371D0, 2.94559D0, 2.42633D0,
53382 & 1.80899D0, 1.44797D0, 1.20662D0, 0.99291D0, 0.83369D0,
53383 & 0.70687D0, 0.60112D0, 0.51056D0, 0.43209D0, 0.36357D0,
53384 & 0.30359D0, 0.25146D0, 0.20630D0, 0.16753D0, 0.13462D0,
53385 & 0.10696D0, 0.08376D0, 0.06466D0, 0.04944D0, 0.03702D0,
53386 & 0.02722D0, 0.01971D0, 0.01390D0, 0.00645D0, 0.00265D0,
53387 & 0.00093D0, 0.00026D0, 0.00001D0, 0.00000D0/
53388 DATA (FMRS(1,3,I,13),I=1,49)/
53389 & 83.50434D0, 65.82890D0, 51.87140D0, 45.10521D0, 40.83618D0,
53390 & 37.79736D0, 29.67546D0, 23.19327D0, 20.00393D0, 17.96325D0,
53391 & 16.46149D0, 12.42825D0, 9.16326D0, 7.56303D0, 6.54853D0,
53392 & 5.82663D0, 4.83880D0, 3.91602D0, 3.01472D0, 2.46779D0,
53393 & 1.82202D0, 1.44614D0, 1.19543D0, 0.97402D0, 0.80992D0,
53394 & 0.68027D0, 0.57325D0, 0.48262D0, 0.40504D0, 0.33808D0,
53395 & 0.28014D0, 0.23033D0, 0.18761D0, 0.15130D0, 0.12077D0,
53396 & 0.09534D0, 0.07419D0, 0.05692D0, 0.04326D0, 0.03220D0,
53397 & 0.02354D0, 0.01696D0, 0.01189D0, 0.00546D0, 0.00222D0,
53398 & 0.00077D0, 0.00021D0, 0.00001D0, 0.00000D0/
53399 DATA (FMRS(1,3,I,14),I=1,49)/
53400 & 99.26808D0, 77.34151D0, 60.22972D0, 52.01289D0, 46.85941D0,
53401 & 43.20707D0, 33.52017D0, 25.88194D0, 22.16110D0, 19.79557D0,
53402 & 18.06292D0, 13.45200D0, 9.77556D0, 7.99825D0, 6.88178D0,
53403 & 6.09288D0, 5.02224D0, 4.03207D0, 3.07569D0, 2.50055D0,
53404 & 1.82658D0, 1.43637D0, 1.17694D0, 0.94870D0, 0.78062D0,
53405 & 0.64903D0, 0.54156D0, 0.45166D0, 0.37564D0, 0.31084D0,
53406 & 0.25547D0, 0.20834D0, 0.16843D0, 0.13481D0, 0.10686D0,
53407 & 0.08378D0, 0.06476D0, 0.04934D0, 0.03727D0, 0.02756D0,
53408 & 0.02003D0, 0.01435D0, 0.01000D0, 0.00454D0, 0.00183D0,
53409 & 0.00063D0, 0.00017D0, 0.00000D0, 0.00000D0/
53410 DATA (FMRS(1,3,I,15),I=1,49)/
53411 & 117.13634D0, 90.22787D0, 69.46667D0, 59.58908D0, 53.42973D0,
53412 & 49.08310D0, 37.64029D0, 28.72286D0, 24.42074D0, 21.70264D0,
53413 & 19.72087D0, 14.49332D0, 10.38573D0, 8.42544D0, 7.20484D0,
53414 & 6.34818D0, 5.19436D0, 4.13748D0, 3.12707D0, 2.52493D0,
53415 & 1.82437D0, 1.42118D0, 1.15415D0, 0.92032D0, 0.74934D0,
53416 & 0.61673D0, 0.50955D0, 0.42103D0, 0.34703D0, 0.28471D0,
53417 & 0.23205D0, 0.18777D0, 0.15064D0, 0.11967D0, 0.09419D0,
53418 & 0.07336D0, 0.05631D0, 0.04263D0, 0.03201D0, 0.02354D0,
53419 & 0.01700D0, 0.01211D0, 0.00839D0, 0.00377D0, 0.00151D0,
53420 & 0.00052D0, 0.00014D0, 0.00000D0, 0.00000D0/
53421 DATA (FMRS(1,3,I,16),I=1,49)/
53422 & 134.87820D0,102.87527D0, 78.42588D0, 66.88609D0, 59.72612D0,
53423 & 54.69190D0, 41.52393D0, 31.36570D0, 26.50579D0, 23.45176D0,
53424 & 21.23395D0, 15.42784D0, 10.92244D0, 8.79593D0, 7.48170D0,
53425 & 6.56462D0, 5.33723D0, 4.22208D0, 3.16533D0, 2.54035D0,
53426 & 1.81781D0, 1.40424D0, 1.13142D0, 0.89365D0, 0.72095D0,
53427 & 0.58811D0, 0.48181D0, 0.39483D0, 0.32289D0, 0.26295D0,
53428 & 0.21278D0, 0.17100D0, 0.13629D0, 0.10758D0, 0.08415D0,
53429 & 0.06517D0, 0.04972D0, 0.03744D0, 0.02797D0, 0.02046D0,
53430 & 0.01470D0, 0.01042D0, 0.00719D0, 0.00321D0, 0.00127D0,
53431 & 0.00043D0, 0.00012D0, 0.00000D0, 0.00000D0/
53432 DATA (FMRS(1,3,I,17),I=1,49)/
53433 & 154.38010D0,116.63111D0, 88.06633D0, 74.68806D0, 66.42747D0,
53434 & 60.64011D0, 45.59593D0, 34.10384D0, 28.65021D0, 25.24085D0,
53435 & 22.77463D0, 16.36506D0, 11.45095D0, 9.15610D0, 7.74790D0,
53436 & 6.77064D0, 5.47057D0, 4.29852D0, 3.19720D0, 2.55058D0,
53437 & 1.80771D0, 1.38488D0, 1.10716D0, 0.86634D0, 0.69264D0,
53438 & 0.56014D0, 0.45511D0, 0.36997D0, 0.30026D0, 0.24276D0,
53439 & 0.19507D0, 0.15573D0, 0.12333D0, 0.09676D0, 0.07524D0,
53440 & 0.05794D0, 0.04395D0, 0.03292D0, 0.02447D0, 0.01781D0,
53441 & 0.01274D0, 0.00899D0, 0.00618D0, 0.00274D0, 0.00108D0,
53442 & 0.00037D0, 0.00010D0, 0.00000D0, 0.00000D0/
53443 DATA (FMRS(1,3,I,18),I=1,49)/
53444 & 171.60985D0,128.66806D0, 96.41977D0, 81.40891D0, 72.17590D0,
53445 & 65.72558D0, 49.04064D0, 36.39427D0, 30.43144D0, 26.71914D0,
53446 & 24.04215D0, 17.12464D0, 11.87120D0, 9.43856D0, 7.95410D0,
53447 & 6.92832D0, 5.57016D0, 4.35322D0, 3.21721D0, 2.55406D0,
53448 & 1.79608D0, 1.36671D0, 1.08575D0, 0.84319D0, 0.66925D0,
53449 & 0.53749D0, 0.43376D0, 0.35041D0, 0.28267D0, 0.22722D0,
53450 & 0.18154D0, 0.14418D0, 0.11359D0, 0.08871D0, 0.06865D0,
53451 & 0.05262D0, 0.03976D0, 0.02965D0, 0.02195D0, 0.01592D0,
53452 & 0.01135D0, 0.00798D0, 0.00547D0, 0.00241D0, 0.00095D0,
53453 & 0.00032D0, 0.00009D0, 0.00000D0, 0.00000D0/
53454 DATA (FMRS(1,3,I,19),I=1,49)/
53455 & 193.78899D0,144.01862D0,106.97157D0, 89.85031D0, 79.36631D0,
53456 & 72.06629D0, 53.29134D0, 39.18974D0, 32.59051D0, 28.50177D0,
53457 & 25.56394D0, 18.02311D0, 12.35926D0, 9.76179D0, 8.18702D0,
53458 & 7.10431D0, 5.67841D0, 4.40968D0, 3.23437D0, 2.55292D0,
53459 & 1.77867D0, 1.34261D0, 1.05865D0, 0.81484D0, 0.64125D0,
53460 & 0.51082D0, 0.40904D0, 0.32798D0, 0.26269D0, 0.20975D0,
53461 & 0.16651D0, 0.13145D0, 0.10293D0, 0.07994D0, 0.06153D0,
53462 & 0.04691D0, 0.03527D0, 0.02618D0, 0.01929D0, 0.01394D0,
53463 & 0.00989D0, 0.00693D0, 0.00473D0, 0.00207D0, 0.00081D0,
53464 & 0.00027D0, 0.00007D0, 0.00000D0, 0.00000D0/
53465 DATA (FMRS(1,3,I,20),I=1,49)/
53466 & 214.89481D0,158.49641D0,116.83355D0, 97.69725D0, 86.02460D0,
53467 & 77.91979D0, 57.17770D0, 41.71972D0, 34.53225D0, 30.09744D0,
53468 & 26.92084D0, 18.81368D0, 12.78187D0, 10.03830D0, 8.38419D0,
53469 & 7.25181D0, 5.76723D0, 4.45410D0, 3.24560D0, 2.54901D0,
53470 & 1.76164D0, 1.32048D0, 1.03446D0, 0.79010D0, 0.61721D0,
53471 & 0.48824D0, 0.38835D0, 0.30938D0, 0.24629D0, 0.19551D0,
53472 & 0.15438D0, 0.12122D0, 0.09444D0, 0.07299D0, 0.05594D0,
53473 & 0.04245D0, 0.03178D0, 0.02349D0, 0.01725D0, 0.01242D0,
53474 & 0.00879D0, 0.00614D0, 0.00418D0, 0.00182D0, 0.00071D0,
53475 & 0.00024D0, 0.00007D0, 0.00000D0, 0.00000D0/
53476 DATA (FMRS(1,3,I,21),I=1,49)/
53477 & 234.93695D0,172.12665D0,126.03609D0,104.98046D0, 92.18044D0,
53478 & 83.31506D0, 60.72429D0, 44.00365D0, 36.27307D0, 31.52044D0,
53479 & 28.12565D0, 19.50453D0, 13.14306D0, 10.27071D0, 8.54710D0,
53480 & 7.37140D0, 5.83642D0, 4.48556D0, 3.24949D0, 2.54059D0,
53481 & 1.74309D0, 1.29840D0, 1.01128D0, 0.76711D0, 0.59538D0,
53482 & 0.46805D0, 0.37012D0, 0.29319D0, 0.23219D0, 0.18337D0,
53483 & 0.14410D0, 0.11261D0, 0.08738D0, 0.06725D0, 0.05133D0,
53484 & 0.03881D0, 0.02895D0, 0.02133D0, 0.01562D0, 0.01121D0,
53485 & 0.00791D0, 0.00551D0, 0.00374D0, 0.00162D0, 0.00063D0,
53486 & 0.00021D0, 0.00006D0, 0.00000D0, 0.00000D0/
53487 DATA (FMRS(1,3,I,22),I=1,49)/
53488 & 261.98752D0,190.37146D0,138.25069D0,114.59908D0,100.28083D0,
53489 & 90.39440D0, 65.33586D0, 46.94503D0, 38.50155D0, 33.33386D0,
53490 & 29.65516D0, 20.37022D0, 13.58831D0, 10.55348D0, 8.74295D0,
53491 & 7.51340D0, 5.91633D0, 4.51953D0, 3.25037D0, 2.52703D0,
53492 & 1.71812D0, 1.26985D0, 0.98192D0, 0.73853D0, 0.56860D0,
53493 & 0.44359D0, 0.34825D0, 0.27396D0, 0.21556D0, 0.16918D0,
53494 & 0.13216D0, 0.10269D0, 0.07927D0, 0.06069D0, 0.04611D0,
53495 & 0.03471D0, 0.02577D0, 0.01891D0, 0.01380D0, 0.00987D0,
53496 & 0.00694D0, 0.00482D0, 0.00326D0, 0.00141D0, 0.00055D0,
53497 & 0.00018D0, 0.00005D0, 0.00000D0, 0.00000D0/
53498 DATA (FMRS(1,3,I,23),I=1,49)/
53499 & 289.01031D0,208.43709D0,150.23653D0,123.98669D0,108.15595D0,
53500 & 97.25583D0, 69.76177D0, 49.73855D0, 40.60409D0, 35.03629D0,
53501 & 31.08496D0, 21.16773D0, 13.99081D0, 10.80513D0, 8.91469D0,
53502 & 7.63597D0, 5.98282D0, 4.54504D0, 3.24687D0, 2.51128D0,
53503 & 1.69316D0, 1.24243D0, 0.95435D0, 0.71223D0, 0.54431D0,
53504 & 0.42170D0, 0.32889D0, 0.25710D0, 0.20110D0, 0.15697D0,
53505 & 0.12195D0, 0.09429D0, 0.07242D0, 0.05518D0, 0.04175D0,
53506 & 0.03132D0, 0.02316D0, 0.01693D0, 0.01232D0, 0.00878D0,
53507 & 0.00615D0, 0.00426D0, 0.00288D0, 0.00124D0, 0.00048D0,
53508 & 0.00016D0, 0.00004D0, 0.00000D0, 0.00000D0/
53509 DATA (FMRS(1,3,I,24),I=1,49)/
53510 & 315.12421D0,225.74153D0,161.61246D0,132.84715D0,115.55888D0,
53511 & 103.68510D0, 73.86555D0, 52.29894D0, 42.51674D0, 36.57598D0,
53512 & 32.37159D0, 21.87235D0, 14.33730D0, 11.01653D0, 9.05547D0,
53513 & 7.73389D0, 6.03187D0, 4.55934D0, 3.23736D0, 2.49207D0,
53514 & 1.66734D0, 1.21544D0, 0.92800D0, 0.68769D0, 0.52210D0,
53515 & 0.40197D0, 0.31164D0, 0.24228D0, 0.18850D0, 0.14640D0,
53516 & 0.11322D0, 0.08715D0, 0.06666D0, 0.05059D0, 0.03813D0,
53517 & 0.02850D0, 0.02101D0, 0.01531D0, 0.01111D0, 0.00790D0,
53518 & 0.00552D0, 0.00382D0, 0.00258D0, 0.00111D0, 0.00043D0,
53519 & 0.00014D0, 0.00004D0, 0.00000D0, 0.00000D0/
53520 DATA (FMRS(1,3,I,25),I=1,49)/
53521 & 342.80673D0,243.95296D0,173.49684D0,142.06322D0,123.23465D0,
53522 & 110.33495D0, 78.07693D0, 54.90473D0, 44.45325D0, 38.12883D0,
53523 & 33.66507D0, 22.57285D0, 14.67683D0, 11.22134D0, 9.19035D0,
53524 & 7.82660D0, 6.07682D0, 4.57070D0, 3.22605D0, 2.47181D0,
53525 & 1.64130D0, 1.18872D0, 0.90224D0, 0.66398D0, 0.50084D0,
53526 & 0.38326D0, 0.29541D0, 0.22842D0, 0.17680D0, 0.13666D0,
53527 & 0.10521D0, 0.08063D0, 0.06143D0, 0.04643D0, 0.03487D0,
53528 & 0.02598D0, 0.01909D0, 0.01388D0, 0.01004D0, 0.00712D0,
53529 & 0.00496D0, 0.00343D0, 0.00231D0, 0.00099D0, 0.00038D0,
53530 & 0.00013D0, 0.00004D0, 0.00000D0, 0.00000D0/
53531 DATA (FMRS(1,3,I,26),I=1,49)/
53532 & 370.71918D0,262.16998D0,185.28712D0,151.16048D0,130.78375D0,
53533 & 116.85600D0, 82.16776D0, 57.40948D0, 46.30192D0, 39.60334D0,
53534 & 34.88776D0, 23.22383D0, 14.98428D0, 11.40259D0, 9.30664D0,
53535 & 7.90402D0, 6.11093D0, 4.57472D0, 3.21035D0, 2.44880D0,
53536 & 1.61427D0, 1.16192D0, 0.87693D0, 0.64114D0, 0.48063D0,
53537 & 0.36570D0, 0.28035D0, 0.21566D0, 0.16615D0, 0.12784D0,
53538 & 0.09801D0, 0.07482D0, 0.05679D0, 0.04277D0, 0.03202D0,
53539 & 0.02378D0, 0.01743D0, 0.01263D0, 0.00912D0, 0.00645D0,
53540 & 0.00449D0, 0.00310D0, 0.00208D0, 0.00089D0, 0.00034D0,
53541 & 0.00012D0, 0.00003D0, 0.00000D0, 0.00000D0/
53542 DATA (FMRS(1,3,I,27),I=1,49)/
53543 & 398.31635D0,280.05777D0,196.78310D0,159.99336D0,138.09111D0,
53544 & 123.15311D0, 86.08746D0, 59.78946D0, 48.04917D0, 40.99130D0,
53545 & 36.03455D0, 23.82682D0, 15.26416D0, 11.56505D0, 9.40909D0,
53546 & 7.97073D0, 6.13825D0, 4.57511D0, 3.19349D0, 2.42581D0,
53547 & 1.58834D0, 1.13668D0, 0.85340D0, 0.62017D0, 0.46227D0,
53548 & 0.34987D0, 0.26689D0, 0.20435D0, 0.15674D0, 0.12011D0,
53549 & 0.09172D0, 0.06977D0, 0.05278D0, 0.03962D0, 0.02958D0,
53550 & 0.02190D0, 0.01601D0, 0.01157D0, 0.00834D0, 0.00589D0,
53551 & 0.00409D0, 0.00282D0, 0.00189D0, 0.00081D0, 0.00031D0,
53552 & 0.00010D0, 0.00003D0, 0.00000D0, 0.00000D0/
53553 DATA (FMRS(1,3,I,28),I=1,49)/
53554 & 425.10541D0,297.30496D0,207.79007D0,168.41481D0,145.03664D0,
53555 & 129.12375D0, 89.77434D0, 62.00834D0, 49.66874D0, 42.27205D0,
53556 & 37.08847D0, 24.37295D0, 15.51221D0, 11.70602D0, 9.49577D0,
53557 & 8.02523D0, 6.15776D0, 4.57120D0, 3.17506D0, 2.40249D0,
53558 & 1.56325D0, 1.11278D0, 0.83141D0, 0.60084D0, 0.44554D0,
53559 & 0.33559D0, 0.25483D0, 0.19432D0, 0.14844D0, 0.11333D0,
53560 & 0.08624D0, 0.06537D0, 0.04932D0, 0.03692D0, 0.02748D0,
53561 & 0.02030D0, 0.01481D0, 0.01068D0, 0.00768D0, 0.00541D0,
53562 & 0.00376D0, 0.00258D0, 0.00173D0, 0.00074D0, 0.00028D0,
53563 & 0.00010D0, 0.00003D0, 0.00000D0, 0.00000D0/
53564 DATA (FMRS(1,3,I,29),I=1,49)/
53565 & 452.96622D0,315.13217D0,219.09509D0,177.03108D0,152.12305D0,
53566 & 135.20210D0, 93.50108D0, 64.23380D0, 51.28493D0, 43.54515D0,
53567 & 38.13279D0, 24.90754D0, 15.75054D0, 11.83897D0, 9.57579D0,
53568 & 8.07414D0, 6.17308D0, 4.56436D0, 3.15482D0, 2.37807D0,
53569 & 1.53780D0, 1.08891D0, 0.80971D0, 0.58195D0, 0.42935D0,
53570 & 0.32187D0, 0.24333D0, 0.18479D0, 0.14060D0, 0.10697D0,
53571 & 0.08112D0, 0.06130D0, 0.04611D0, 0.03442D0, 0.02556D0,
53572 & 0.01884D0, 0.01371D0, 0.00987D0, 0.00709D0, 0.00499D0,
53573 & 0.00346D0, 0.00237D0, 0.00159D0, 0.00068D0, 0.00026D0,
53574 & 0.00009D0, 0.00002D0, 0.00000D0, 0.00000D0/
53575 DATA (FMRS(1,3,I,30),I=1,49)/
53576 & 481.05176D0,332.98895D0,230.34398D0,185.57016D0,159.12541D0,
53577 & 141.19426D0, 97.14677D0, 66.39220D0, 52.84356D0, 44.76743D0,
53578 & 39.13180D0, 25.41137D0, 15.96984D0, 11.95815D0, 9.64523D0,
53579 & 8.11468D0, 6.18265D0, 4.55389D0, 3.13269D0, 2.35270D0,
53580 & 1.51231D0, 1.06542D0, 0.78862D0, 0.56381D0, 0.41396D0,
53581 & 0.30893D0, 0.23257D0, 0.17592D0, 0.13335D0, 0.10111D0,
53582 & 0.07645D0, 0.05760D0, 0.04319D0, 0.03217D0, 0.02383D0,
53583 & 0.01753D0, 0.01273D0, 0.00915D0, 0.00656D0, 0.00461D0,
53584 & 0.00319D0, 0.00219D0, 0.00146D0, 0.00062D0, 0.00024D0,
53585 & 0.00008D0, 0.00002D0, 0.00000D0, 0.00000D0/
53586 DATA (FMRS(1,3,I,31),I=1,49)/
53587 & 508.69336D0,350.46606D0,241.29128D0,193.85184D0,165.89978D0,
53588 & 146.97998D0,100.64462D0, 68.44891D0, 54.32217D0, 45.92301D0,
53589 & 40.07352D0, 25.88124D0, 16.17098D0, 12.06571D0, 9.70659D0,
53590 & 8.14933D0, 6.18899D0, 4.54214D0, 3.11075D0, 2.32815D0,
53591 & 1.48813D0, 1.04340D0, 0.76902D0, 0.54710D0, 0.39988D0,
53592 & 0.29718D0, 0.22284D0, 0.16794D0, 0.12688D0, 0.09590D0,
53593 & 0.07230D0, 0.05433D0, 0.04063D0, 0.03020D0, 0.02232D0,
53594 & 0.01639D0, 0.01188D0, 0.00852D0, 0.00610D0, 0.00428D0,
53595 & 0.00296D0, 0.00203D0, 0.00136D0, 0.00057D0, 0.00022D0,
53596 & 0.00007D0, 0.00002D0, 0.00000D0, 0.00000D0/
53597 DATA (FMRS(1,3,I,32),I=1,49)/
53598 & 535.18030D0,367.11212D0,251.65173D0,201.65910D0,172.26764D0,
53599 & 152.40591D0,103.89980D0, 70.34598D0, 55.67789D0, 46.97741D0,
53600 & 40.92907D0, 26.30087D0, 16.34517D0, 12.15570D0, 9.75539D0,
53601 & 8.17448D0, 6.18955D0, 4.52735D0, 3.08788D0, 2.30359D0,
53602 & 1.46475D0, 1.02248D0, 0.75063D0, 0.53161D0, 0.38695D0,
53603 & 0.28648D0, 0.21405D0, 0.16077D0, 0.12112D0, 0.09128D0,
53604 & 0.06863D0, 0.05145D0, 0.03839D0, 0.02847D0, 0.02101D0,
53605 & 0.01540D0, 0.01114D0, 0.00798D0, 0.00571D0, 0.00400D0,
53606 & 0.00276D0, 0.00189D0, 0.00126D0, 0.00054D0, 0.00020D0,
53607 & 0.00007D0, 0.00002D0, 0.00000D0, 0.00000D0/
53608 DATA (FMRS(1,3,I,33),I=1,49)/
53609 & 563.08673D0,384.57391D0,262.47256D0,209.79239D0,178.88937D0,
53610 & 158.04028D0,107.26506D0, 72.29848D0, 57.06943D0, 48.05758D0,
53611 & 41.80413D0, 26.72791D0, 16.52149D0, 12.24650D0, 9.80451D0,
53612 & 8.19975D0, 6.19012D0, 4.51259D0, 3.06514D0, 2.27926D0,
53613 & 1.44171D0, 1.00196D0, 0.73265D0, 0.51654D0, 0.37443D0,
53614 & 0.27615D0, 0.20559D0, 0.15389D0, 0.11561D0, 0.08687D0,
53615 & 0.06514D0, 0.04872D0, 0.03627D0, 0.02685D0, 0.01977D0,
53616 & 0.01446D0, 0.01045D0, 0.00747D0, 0.00534D0, 0.00374D0,
53617 & 0.00258D0, 0.00176D0, 0.00118D0, 0.00050D0, 0.00019D0,
53618 & 0.00006D0, 0.00002D0, 0.00000D0, 0.00000D0/
53619 DATA (FMRS(1,3,I,34),I=1,49)/
53620 & 590.49207D0,401.61096D0,272.95639D0,217.63766D0,185.25558D0,
53621 & 163.44283D0,110.46277D0, 74.13376D0, 58.36747D0, 49.05885D0,
53622 & 42.61046D0, 27.11206D0, 16.67322D0, 12.31989D0, 9.84041D0,
53623 & 8.21457D0, 6.18338D0, 4.49312D0, 3.03982D0, 2.25340D0,
53624 & 1.41818D0, 0.98144D0, 0.71494D0, 0.50189D0, 0.36238D0,
53625 & 0.26631D0, 0.19763D0, 0.14748D0, 0.11046D0, 0.08279D0,
53626 & 0.06193D0, 0.04622D0, 0.03434D0, 0.02537D0, 0.01865D0,
53627 & 0.01362D0, 0.00983D0, 0.00702D0, 0.00501D0, 0.00351D0,
53628 & 0.00242D0, 0.00165D0, 0.00110D0, 0.00046D0, 0.00018D0,
53629 & 0.00006D0, 0.00002D0, 0.00000D0, 0.00000D0/
53630 DATA (FMRS(1,3,I,35),I=1,49)/
53631 & 617.67798D0,418.44214D0,283.27148D0,225.33791D0,191.49365D0,
53632 & 168.72942D0,113.57884D0, 75.91459D0, 59.62379D0, 50.02613D0,
53633 & 43.38823D0, 27.48080D0, 16.81807D0, 12.38969D0, 9.87443D0,
53634 & 8.22855D0, 6.17694D0, 4.47470D0, 3.01600D0, 2.22915D0,
53635 & 1.39622D0, 0.96237D0, 0.69854D0, 0.48839D0, 0.35132D0,
53636 & 0.25731D0, 0.19037D0, 0.14164D0, 0.10579D0, 0.07911D0,
53637 & 0.05904D0, 0.04396D0, 0.03261D0, 0.02405D0, 0.01765D0,
53638 & 0.01287D0, 0.00928D0, 0.00662D0, 0.00472D0, 0.00330D0,
53639 & 0.00227D0, 0.00155D0, 0.00103D0, 0.00044D0, 0.00017D0,
53640 & 0.00006D0, 0.00002D0, 0.00000D0, 0.00000D0/
53641 DATA (FMRS(1,3,I,36),I=1,49)/
53642 & 643.85529D0,434.56937D0,293.10349D0,232.65437D0,197.40677D0,
53643 & 173.73129D0,116.50865D0, 77.57690D0, 60.79072D0, 50.92106D0,
53644 & 44.10533D0, 27.81589D0, 16.94600D0, 12.44906D0, 9.90141D0,
53645 & 8.23759D0, 6.16791D0, 4.45540D0, 2.99242D0, 2.20560D0,
53646 & 1.37532D0, 0.94442D0, 0.68324D0, 0.47589D0, 0.34114D0,
53647 & 0.24908D0, 0.18375D0, 0.13636D0, 0.10159D0, 0.07580D0,
53648 & 0.05645D0, 0.04195D0, 0.03106D0, 0.02287D0, 0.01676D0,
53649 & 0.01221D0, 0.00879D0, 0.00626D0, 0.00446D0, 0.00311D0,
53650 & 0.00214D0, 0.00146D0, 0.00097D0, 0.00041D0, 0.00016D0,
53651 & 0.00005D0, 0.00001D0, 0.00000D0, 0.00000D0/
53652 DATA (FMRS(1,3,I,37),I=1,49)/
53653 & 670.62598D0,450.98129D0,303.05762D0,240.03790D0,203.35986D0,
53654 & 178.75746D0,119.43383D0, 79.22430D0, 61.94125D0, 51.79964D0,
53655 & 44.80675D0, 28.13850D0, 17.06516D0, 12.50182D0, 9.92310D0,
53656 & 8.24227D0, 6.15572D0, 4.43398D0, 2.96756D0, 2.18122D0,
53657 & 1.35409D0, 0.92638D0, 0.66799D0, 0.46354D0, 0.33115D0,
53658 & 0.24105D0, 0.17731D0, 0.13125D0, 0.09756D0, 0.07262D0,
53659 & 0.05397D0, 0.04005D0, 0.02960D0, 0.02176D0, 0.01592D0,
53660 & 0.01159D0, 0.00833D0, 0.00593D0, 0.00422D0, 0.00294D0,
53661 & 0.00202D0, 0.00138D0, 0.00092D0, 0.00039D0, 0.00015D0,
53662 & 0.00005D0, 0.00001D0, 0.00000D0, 0.00000D0/
53663 DATA (FMRS(1,3,I,38),I=1,49)/
53664 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53665 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53666 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53667 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53668 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53669 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53670 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53671 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53672 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
53673 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53674 DATA (FMRS(1,4,I, 1),I=1,49)/
53675 & 0.86800D0, 0.76598D0, 0.67520D0, 0.62675D0, 0.59428D0,
53676 & 0.57013D0, 0.50046D0, 0.43816D0, 0.40484D0, 0.38253D0,
53677 & 0.36613D0, 0.31874D0, 0.27654D0, 0.25397D0, 0.23882D0,
53678 & 0.22750D0, 0.21099D0, 0.19387D0, 0.17401D0, 0.15872D0,
53679 & 0.13363D0, 0.11222D0, 0.09356D0, 0.07392D0, 0.05824D0,
53680 & 0.04613D0, 0.03700D0, 0.03017D0, 0.02498D0, 0.02125D0,
53681 & 0.01786D0, 0.01513D0, 0.01268D0, 0.01040D0, 0.00852D0,
53682 & 0.00674D0, 0.00520D0, 0.00388D0, 0.00299D0, 0.00201D0,
53683 & 0.00134D0, 0.00094D0, 0.00051D0, 0.00021D0, 0.00007D0,
53684 & 0.00003D0, -0.00001D0, 0.00000D0, 0.00000D0/
53685 DATA (FMRS(1,4,I, 2),I=1,49)/
53686 & 0.88205D0, 0.77983D0, 0.68869D0, 0.63997D0, 0.60729D0,
53687 & 0.58296D0, 0.51264D0, 0.44961D0, 0.41580D0, 0.39312D0,
53688 & 0.37640D0, 0.32792D0, 0.28442D0, 0.26097D0, 0.24515D0,
53689 & 0.23328D0, 0.21590D0, 0.19782D0, 0.17683D0, 0.16077D0,
53690 & 0.13467D0, 0.11273D0, 0.09381D0, 0.07406D0, 0.05839D0,
53691 & 0.04632D0, 0.03722D0, 0.03037D0, 0.02516D0, 0.02135D0,
53692 & 0.01792D0, 0.01513D0, 0.01262D0, 0.01032D0, 0.00842D0,
53693 & 0.00664D0, 0.00510D0, 0.00380D0, 0.00291D0, 0.00197D0,
53694 & 0.00130D0, 0.00091D0, 0.00051D0, 0.00020D0, 0.00007D0,
53695 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
53696 DATA (FMRS(1,4,I, 3),I=1,49)/
53697 & 0.91886D0, 0.81356D0, 0.71953D0, 0.66920D0, 0.63541D0,
53698 & 0.61023D0, 0.53738D0, 0.47189D0, 0.43666D0, 0.41295D0,
53699 & 0.39539D0, 0.34428D0, 0.29794D0, 0.27277D0, 0.25567D0,
53700 & 0.24279D0, 0.22388D0, 0.20416D0, 0.18131D0, 0.16398D0,
53701 & 0.13630D0, 0.11352D0, 0.09418D0, 0.07425D0, 0.05857D0,
53702 & 0.04653D0, 0.03744D0, 0.03056D0, 0.02532D0, 0.02139D0,
53703 & 0.01791D0, 0.01504D0, 0.01246D0, 0.01016D0, 0.00822D0,
53704 & 0.00648D0, 0.00493D0, 0.00368D0, 0.00278D0, 0.00188D0,
53705 & 0.00124D0, 0.00086D0, 0.00051D0, 0.00020D0, 0.00006D0,
53706 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
53707 DATA (FMRS(1,4,I, 4),I=1,49)/
53708 & 0.95997D0, 0.84981D0, 0.75147D0, 0.69884D0, 0.66351D0,
53709 & 0.63718D0, 0.56100D0, 0.49247D0, 0.45556D0, 0.43069D0,
53710 & 0.41221D0, 0.35830D0, 0.30918D0, 0.28239D0, 0.26415D0,
53711 & 0.25039D0, 0.23017D0, 0.20908D0, 0.18474D0, 0.16642D0,
53712 & 0.13752D0, 0.11409D0, 0.09444D0, 0.07437D0, 0.05864D0,
53713 & 0.04662D0, 0.03752D0, 0.03063D0, 0.02535D0, 0.02135D0,
53714 & 0.01783D0, 0.01492D0, 0.01232D0, 0.01000D0, 0.00803D0,
53715 & 0.00631D0, 0.00479D0, 0.00358D0, 0.00268D0, 0.00180D0,
53716 & 0.00120D0, 0.00084D0, 0.00049D0, 0.00020D0, 0.00006D0,
53717 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
53718 DATA (FMRS(1,4,I, 5),I=1,49)/
53719 & 1.02269D0, 0.90363D0, 0.79759D0, 0.74093D0, 0.70294D0,
53720 & 0.67465D0, 0.59289D0, 0.51944D0, 0.47990D0, 0.45324D0,
53721 & 0.43337D0, 0.37541D0, 0.32249D0, 0.29359D0, 0.27391D0,
53722 & 0.25907D0, 0.23726D0, 0.21456D0, 0.18851D0, 0.16906D0,
53723 & 0.13883D0, 0.11469D0, 0.09468D0, 0.07442D0, 0.05863D0,
53724 & 0.04662D0, 0.03753D0, 0.03061D0, 0.02531D0, 0.02124D0,
53725 & 0.01767D0, 0.01472D0, 0.01211D0, 0.00977D0, 0.00782D0,
53726 & 0.00614D0, 0.00464D0, 0.00341D0, 0.00257D0, 0.00173D0,
53727 & 0.00113D0, 0.00080D0, 0.00046D0, 0.00018D0, 0.00005D0,
53728 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
53729 DATA (FMRS(1,4,I, 6),I=1,49)/
53730 & 1.08763D0, 0.95875D0, 0.84428D0, 0.78326D0, 0.74239D0,
53731 & 0.71199D0, 0.62427D0, 0.54563D0, 0.50333D0, 0.47482D0,
53732 & 0.45353D0, 0.39146D0, 0.33478D0, 0.30385D0, 0.28279D0,
53733 & 0.26692D0, 0.24362D0, 0.21944D0, 0.19183D0, 0.17138D0,
53734 & 0.13995D0, 0.11519D0, 0.09486D0, 0.07444D0, 0.05860D0,
53735 & 0.04659D0, 0.03750D0, 0.03056D0, 0.02523D0, 0.02111D0,
53736 & 0.01751D0, 0.01454D0, 0.01191D0, 0.00957D0, 0.00764D0,
53737 & 0.00598D0, 0.00450D0, 0.00328D0, 0.00247D0, 0.00167D0,
53738 & 0.00107D0, 0.00076D0, 0.00044D0, 0.00016D0, 0.00005D0,
53739 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
53740 DATA (FMRS(1,4,I, 7),I=1,49)/
53741 & 1.16556D0, 1.02401D0, 0.89875D0, 0.83219D0, 0.78769D0,
53742 & 0.75465D0, 0.65951D0, 0.57450D0, 0.52889D0, 0.49818D0,
53743 & 0.47520D0, 0.40838D0, 0.34748D0, 0.31432D0, 0.29177D0,
53744 & 0.27481D0, 0.24995D0, 0.22424D0, 0.19505D0, 0.17361D0,
53745 & 0.14101D0, 0.11563D0, 0.09500D0, 0.07441D0, 0.05852D0,
53746 & 0.04652D0, 0.03740D0, 0.03045D0, 0.02509D0, 0.02093D0,
53747 & 0.01733D0, 0.01434D0, 0.01170D0, 0.00939D0, 0.00744D0,
53748 & 0.00582D0, 0.00436D0, 0.00318D0, 0.00238D0, 0.00161D0,
53749 & 0.00104D0, 0.00073D0, 0.00042D0, 0.00014D0, 0.00005D0,
53750 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
53751 DATA (FMRS(1,4,I, 8),I=1,49)/
53752 & 1.26306D0, 1.10484D0, 0.96554D0, 0.89180D0, 0.84263D0,
53753 & 0.80618D0, 0.70157D0, 0.60853D0, 0.55877D0, 0.52532D0,
53754 & 0.50028D0, 0.42768D0, 0.36175D0, 0.32597D0, 0.30171D0,
53755 & 0.28349D0, 0.25687D0, 0.22944D0, 0.19851D0, 0.17597D0,
53756 & 0.14210D0, 0.11607D0, 0.09509D0, 0.07433D0, 0.05839D0,
53757 & 0.04638D0, 0.03725D0, 0.03028D0, 0.02490D0, 0.02071D0,
53758 & 0.01710D0, 0.01411D0, 0.01147D0, 0.00917D0, 0.00724D0,
53759 & 0.00565D0, 0.00421D0, 0.00306D0, 0.00228D0, 0.00155D0,
53760 & 0.00101D0, 0.00070D0, 0.00040D0, 0.00013D0, 0.00005D0,
53761 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
53762 DATA (FMRS(1,4,I, 9),I=1,49)/
53763 & 1.36120D0, 1.18550D0, 1.03156D0, 0.95040D0, 0.89642D0,
53764 & 0.85647D0, 0.74219D0, 0.64102D0, 0.58710D0, 0.55092D0,
53765 & 0.52385D0, 0.44558D0, 0.37481D0, 0.33656D0, 0.31068D0,
53766 & 0.29130D0, 0.26304D0, 0.23405D0, 0.20153D0, 0.17803D0,
53767 & 0.14303D0, 0.11643D0, 0.09515D0, 0.07423D0, 0.05825D0,
53768 & 0.04622D0, 0.03709D0, 0.03010D0, 0.02471D0, 0.02052D0,
53769 & 0.01688D0, 0.01389D0, 0.01125D0, 0.00895D0, 0.00706D0,
53770 & 0.00550D0, 0.00409D0, 0.00295D0, 0.00220D0, 0.00150D0,
53771 & 0.00098D0, 0.00067D0, 0.00039D0, 0.00013D0, 0.00005D0,
53772 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
53773 DATA (FMRS(1,4,I,10),I=1,49)/
53774 & 1.47041D0, 1.27446D0, 1.10370D0, 1.01406D0, 0.95460D0,
53775 & 0.91068D0, 0.78549D0, 0.67526D0, 0.61674D0, 0.57757D0,
53776 & 0.54827D0, 0.46388D0, 0.38797D0, 0.34713D0, 0.31960D0,
53777 & 0.29901D0, 0.26910D0, 0.23853D0, 0.20444D0, 0.17998D0,
53778 & 0.14388D0, 0.11673D0, 0.09517D0, 0.07410D0, 0.05807D0,
53779 & 0.04602D0, 0.03690D0, 0.02989D0, 0.02450D0, 0.02029D0,
53780 & 0.01665D0, 0.01365D0, 0.01102D0, 0.00875D0, 0.00689D0,
53781 & 0.00534D0, 0.00396D0, 0.00285D0, 0.00213D0, 0.00144D0,
53782 & 0.00094D0, 0.00064D0, 0.00038D0, 0.00013D0, 0.00004D0,
53783 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
53784 DATA (FMRS(1,4,I,11),I=1,49)/
53785 & 1.56638D0, 1.35212D0, 1.16625D0, 1.06903D0, 1.00469D0,
53786 & 0.95725D0, 0.82240D0, 0.70420D0, 0.64167D0, 0.59990D0,
53787 & 0.56868D0, 0.47904D0, 0.39878D0, 0.35576D0, 0.32683D0,
53788 & 0.30525D0, 0.27397D0, 0.24210D0, 0.20674D0, 0.18151D0,
53789 & 0.14453D0, 0.11694D0, 0.09517D0, 0.07398D0, 0.05791D0,
53790 & 0.04585D0, 0.03673D0, 0.02971D0, 0.02433D0, 0.02010D0,
53791 & 0.01646D0, 0.01346D0, 0.01083D0, 0.00860D0, 0.00675D0,
53792 & 0.00520D0, 0.00385D0, 0.00277D0, 0.00207D0, 0.00139D0,
53793 & 0.00090D0, 0.00062D0, 0.00037D0, 0.00013D0, 0.00004D0,
53794 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
53795 DATA (FMRS(1,4,I,12),I=1,49)/
53796 & 1.80214D0, 1.54109D0, 1.31694D0, 1.20067D0, 1.12412D0,
53797 & 1.06789D0, 0.90916D0, 0.77146D0, 0.69919D0, 0.65116D0,
53798 & 0.61534D0, 0.51323D0, 0.42280D0, 0.37478D0, 0.34269D0,
53799 & 0.31886D0, 0.28449D0, 0.24976D0, 0.21162D0, 0.18471D0,
53800 & 0.14585D0, 0.11732D0, 0.09509D0, 0.07364D0, 0.05748D0,
53801 & 0.04542D0, 0.03629D0, 0.02928D0, 0.02389D0, 0.01964D0,
53802 & 0.01603D0, 0.01303D0, 0.01043D0, 0.00824D0, 0.00644D0,
53803 & 0.00493D0, 0.00365D0, 0.00261D0, 0.00193D0, 0.00129D0,
53804 & 0.00082D0, 0.00058D0, 0.00033D0, 0.00012D0, 0.00003D0,
53805 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
53806 DATA (FMRS(1,4,I,13),I=1,49)/
53807 & 2.04055D0, 1.73004D0, 1.46588D0, 1.32988D0, 1.24076D0,
53808 & 1.17553D0, 0.99250D0, 0.83521D0, 0.75328D0, 0.69907D0,
53809 & 0.65875D0, 0.54456D0, 0.44445D0, 0.39176D0, 0.35673D0,
53810 & 0.33084D0, 0.29368D0, 0.25636D0, 0.21574D0, 0.18736D0,
53811 & 0.14688D0, 0.11755D0, 0.09493D0, 0.07328D0, 0.05705D0,
53812 & 0.04498D0, 0.03587D0, 0.02887D0, 0.02347D0, 0.01921D0,
53813 & 0.01564D0, 0.01265D0, 0.01010D0, 0.00793D0, 0.00617D0,
53814 & 0.00472D0, 0.00348D0, 0.00248D0, 0.00181D0, 0.00123D0,
53815 & 0.00077D0, 0.00054D0, 0.00031D0, 0.00011D0, 0.00003D0,
53816 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
53817 DATA (FMRS(1,4,I,14),I=1,49)/
53818 & 2.34878D0, 1.97162D0, 1.65417D0, 1.49212D0, 1.38650D0,
53819 & 1.30951D0, 1.09500D0, 0.91263D0, 0.81846D0, 0.75649D0,
53820 & 0.71054D0, 0.58140D0, 0.46952D0, 0.41122D0, 0.37271D0,
53821 & 0.34438D0, 0.30396D0, 0.26367D0, 0.22023D0, 0.19019D0,
53822 & 0.14790D0, 0.11770D0, 0.09464D0, 0.07279D0, 0.05650D0,
53823 & 0.04444D0, 0.03534D0, 0.02838D0, 0.02299D0, 0.01873D0,
53824 & 0.01518D0, 0.01221D0, 0.00971D0, 0.00758D0, 0.00587D0,
53825 & 0.00448D0, 0.00329D0, 0.00233D0, 0.00171D0, 0.00117D0,
53826 & 0.00073D0, 0.00051D0, 0.00028D0, 0.00010D0, 0.00003D0,
53827 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
53828 DATA (FMRS(1,4,I,15),I=1,49)/
53829 & 2.72076D0, 2.25974D0, 1.87603D0, 1.68193D0, 1.55614D0,
53830 & 1.46482D0, 1.21228D0, 1.00004D0, 0.89145D0, 0.82040D0,
53831 & 0.76790D0, 0.62156D0, 0.49638D0, 0.43184D0, 0.38951D0,
53832 & 0.35852D0, 0.31456D0, 0.27109D0, 0.22467D0, 0.19292D0,
53833 & 0.14878D0, 0.11770D0, 0.09423D0, 0.07216D0, 0.05583D0,
53834 & 0.04380D0, 0.03471D0, 0.02777D0, 0.02242D0, 0.01821D0,
53835 & 0.01468D0, 0.01176D0, 0.00931D0, 0.00721D0, 0.00560D0,
53836 & 0.00425D0, 0.00310D0, 0.00215D0, 0.00160D0, 0.00107D0,
53837 & 0.00067D0, 0.00046D0, 0.00026D0, 0.00009D0, 0.00003D0,
53838 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
53839 DATA (FMRS(1,4,I,16),I=1,49)/
53840 & 3.10372D0, 2.55317D0, 2.09952D0, 1.87189D0, 1.72513D0,
53841 & 1.61899D0, 1.32738D0, 1.08482D0, 0.96174D0, 0.88163D0,
53842 & 0.82262D0, 0.65935D0, 0.52128D0, 0.45078D0, 0.40481D0,
53843 & 0.37132D0, 0.32407D0, 0.27766D0, 0.22852D0, 0.19522D0,
53844 & 0.14943D0, 0.11759D0, 0.09376D0, 0.07153D0, 0.05518D0,
53845 & 0.04316D0, 0.03411D0, 0.02721D0, 0.02189D0, 0.01771D0,
53846 & 0.01421D0, 0.01135D0, 0.00894D0, 0.00691D0, 0.00532D0,
53847 & 0.00403D0, 0.00292D0, 0.00202D0, 0.00150D0, 0.00098D0,
53848 & 0.00063D0, 0.00043D0, 0.00024D0, 0.00009D0, 0.00003D0,
53849 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
53850 DATA (FMRS(1,4,I,17),I=1,49)/
53851 & 3.53791D0, 2.88253D0, 2.34786D0, 2.08172D0, 1.91099D0,
53852 & 1.78798D0, 1.45224D0, 1.17581D0, 1.03669D0, 0.94660D0,
53853 & 0.88048D0, 0.69881D0, 0.54694D0, 0.47011D0, 0.42034D0,
53854 & 0.38424D0, 0.33357D0, 0.28414D0, 0.23224D0, 0.19739D0,
53855 & 0.14997D0, 0.11738D0, 0.09322D0, 0.07083D0, 0.05448D0,
53856 & 0.04248D0, 0.03349D0, 0.02663D0, 0.02135D0, 0.01720D0,
53857 & 0.01373D0, 0.01094D0, 0.00857D0, 0.00662D0, 0.00504D0,
53858 & 0.00382D0, 0.00275D0, 0.00191D0, 0.00140D0, 0.00091D0,
53859 & 0.00060D0, 0.00040D0, 0.00021D0, 0.00008D0, 0.00002D0,
53860 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
53861 DATA (FMRS(1,4,I,18),I=1,49)/
53862 & 3.93600D0, 3.18179D0, 2.57144D0, 2.26962D0, 2.07679D0,
53863 & 1.93828D0, 1.56224D0, 1.25519D0, 1.10169D0, 1.00271D0,
53864 & 0.93026D0, 0.73238D0, 0.56848D0, 0.48622D0, 0.43319D0,
53865 & 0.39487D0, 0.34131D0, 0.28936D0, 0.23517D0, 0.19905D0,
53866 & 0.15030D0, 0.11713D0, 0.09270D0, 0.07021D0, 0.05385D0,
53867 & 0.04190D0, 0.03295D0, 0.02612D0, 0.02087D0, 0.01677D0,
53868 & 0.01334D0, 0.01060D0, 0.00827D0, 0.00637D0, 0.00486D0,
53869 & 0.00366D0, 0.00263D0, 0.00181D0, 0.00134D0, 0.00088D0,
53870 & 0.00056D0, 0.00038D0, 0.00020D0, 0.00007D0, 0.00002D0,
53871 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
53872 DATA (FMRS(1,4,I,19),I=1,49)/
53873 & 4.46512D0, 3.57604D0, 2.86339D0, 2.51369D0, 2.29136D0,
53874 & 2.13222D0, 1.70289D0, 1.35573D0, 1.18356D0, 1.07308D0,
53875 & 0.99248D0, 0.77387D0, 0.59477D0, 0.50571D0, 0.44864D0,
53876 & 0.40759D0, 0.35048D0, 0.29545D0, 0.23852D0, 0.20087D0,
53877 & 0.15057D0, 0.11671D0, 0.09200D0, 0.06939D0, 0.05304D0,
53878 & 0.04116D0, 0.03225D0, 0.02548D0, 0.02030D0, 0.01627D0,
53879 & 0.01289D0, 0.01018D0, 0.00793D0, 0.00608D0, 0.00462D0,
53880 & 0.00346D0, 0.00247D0, 0.00170D0, 0.00124D0, 0.00082D0,
53881 & 0.00052D0, 0.00036D0, 0.00020D0, 0.00007D0, 0.00002D0,
53882 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
53883 DATA (FMRS(1,4,I,20),I=1,49)/
53884 & 4.98110D0, 3.95717D0, 3.14315D0, 2.74636D0, 2.49515D0,
53885 & 2.31589D0, 1.83490D0, 1.44924D0, 1.25928D0, 1.13790D0,
53886 & 1.04961D0, 0.81156D0, 0.61839D0, 0.52309D0, 0.46234D0,
53887 & 0.41880D0, 0.35851D0, 0.30072D0, 0.24136D0, 0.20237D0,
53888 & 0.15073D0, 0.11629D0, 0.09134D0, 0.06865D0, 0.05232D0,
53889 & 0.04048D0, 0.03163D0, 0.02492D0, 0.01980D0, 0.01582D0,
53890 & 0.01251D0, 0.00983D0, 0.00765D0, 0.00583D0, 0.00441D0,
53891 & 0.00330D0, 0.00234D0, 0.00161D0, 0.00116D0, 0.00076D0,
53892 & 0.00049D0, 0.00034D0, 0.00019D0, 0.00006D0, 0.00002D0,
53893 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
53894 DATA (FMRS(1,4,I,21),I=1,49)/
53895 & 5.48855D0, 4.32906D0, 3.41400D0, 2.97058D0, 2.69088D0,
53896 & 2.49185D0, 1.96033D0, 1.53734D0, 1.33025D0, 1.19843D0,
53897 & 1.10279D0, 0.84628D0, 0.63987D0, 0.53877D0, 0.47461D0,
53898 & 0.42879D0, 0.36557D0, 0.30530D0, 0.24373D0, 0.20356D0,
53899 & 0.15074D0, 0.11580D0, 0.09065D0, 0.06792D0, 0.05161D0,
53900 & 0.03984D0, 0.03104D0, 0.02440D0, 0.01932D0, 0.01538D0,
53901 & 0.01214D0, 0.00950D0, 0.00738D0, 0.00561D0, 0.00423D0,
53902 & 0.00315D0, 0.00224D0, 0.00152D0, 0.00110D0, 0.00072D0,
53903 & 0.00045D0, 0.00032D0, 0.00018D0, 0.00006D0, 0.00002D0,
53904 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53905 DATA (FMRS(1,4,I,22),I=1,49)/
53906 & 6.18910D0, 4.83835D0, 3.78189D0, 3.27368D0, 2.95458D0,
53907 & 2.72828D0, 2.12748D0, 1.65375D0, 1.42355D0, 1.27771D0,
53908 & 1.17223D0, 0.89116D0, 0.66734D0, 0.55867D0, 0.49010D0,
53909 & 0.44134D0, 0.37438D0, 0.31092D0, 0.24658D0, 0.20493D0,
53910 & 0.15066D0, 0.11512D0, 0.08974D0, 0.06696D0, 0.05069D0,
53911 & 0.03901D0, 0.03030D0, 0.02374D0, 0.01874D0, 0.01485D0,
53912 & 0.01168D0, 0.00911D0, 0.00704D0, 0.00533D0, 0.00400D0,
53913 & 0.00297D0, 0.00211D0, 0.00142D0, 0.00104D0, 0.00068D0,
53914 & 0.00042D0, 0.00029D0, 0.00017D0, 0.00005D0, 0.00002D0,
53915 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
53916 DATA (FMRS(1,4,I,23),I=1,49)/
53917 & 6.90776D0, 5.35634D0, 4.15288D0, 3.57780D0, 3.21822D0,
53918 & 2.96398D0, 2.29266D0, 1.76775D0, 1.51442D0, 1.35462D0,
53919 & 1.23937D0, 0.93411D0, 0.69332D0, 0.57734D0, 0.50454D0,
53920 & 0.45297D0, 0.38246D0, 0.31600D0, 0.24910D0, 0.20608D0,
53921 & 0.15048D0, 0.11442D0, 0.08886D0, 0.06603D0, 0.04982D0,
53922 & 0.03823D0, 0.02961D0, 0.02314D0, 0.01820D0, 0.01437D0,
53923 & 0.01125D0, 0.00875D0, 0.00671D0, 0.00507D0, 0.00380D0,
53924 & 0.00282D0, 0.00198D0, 0.00134D0, 0.00099D0, 0.00065D0,
53925 & 0.00039D0, 0.00026D0, 0.00015D0, 0.00005D0, 0.00002D0,
53926 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
53927 DATA (FMRS(1,4,I,24),I=1,49)/
53928 & 7.62426D0, 5.86871D0, 4.51692D0, 3.87481D0, 3.47482D0,
53929 & 3.19280D0, 2.45168D0, 1.87657D0, 1.60070D0, 1.42736D0,
53930 & 1.30266D0, 0.97414D0, 0.71722D0, 0.59437D0, 0.51760D0,
53931 & 0.46341D0, 0.38962D0, 0.32042D0, 0.25117D0, 0.20694D0,
53932 & 0.15017D0, 0.11367D0, 0.08795D0, 0.06511D0, 0.04897D0,
53933 & 0.03748D0, 0.02894D0, 0.02253D0, 0.01769D0, 0.01392D0,
53934 & 0.01087D0, 0.00842D0, 0.00645D0, 0.00484D0, 0.00362D0,
53935 & 0.00267D0, 0.00187D0, 0.00128D0, 0.00093D0, 0.00060D0,
53936 & 0.00037D0, 0.00024D0, 0.00014D0, 0.00004D0, 0.00002D0,
53937 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53938 DATA (FMRS(1,4,I,25),I=1,49)/
53939 & 8.39819D0, 6.41814D0, 4.90446D0, 4.18965D0, 3.74601D0,
53940 & 3.43405D0, 2.61811D0, 1.98959D0, 1.68991D0, 1.50231D0,
53941 & 1.36770D0, 1.01493D0, 0.74134D0, 0.61144D0, 0.53063D0,
53942 & 0.47380D0, 0.39668D0, 0.32474D0, 0.25316D0, 0.20772D0,
53943 & 0.14981D0, 0.11289D0, 0.08703D0, 0.06420D0, 0.04813D0,
53944 & 0.03673D0, 0.02828D0, 0.02194D0, 0.01719D0, 0.01349D0,
53945 & 0.01049D0, 0.00810D0, 0.00620D0, 0.00463D0, 0.00344D0,
53946 & 0.00252D0, 0.00177D0, 0.00122D0, 0.00086D0, 0.00056D0,
53947 & 0.00034D0, 0.00023D0, 0.00012D0, 0.00004D0, 0.00001D0,
53948 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53949 DATA (FMRS(1,4,I,26),I=1,49)/
53950 & 9.19912D0, 6.98269D0, 5.29980D0, 4.50945D0, 4.02062D0,
53951 & 3.67776D0, 2.78497D0, 2.10203D0, 1.77824D0, 1.57626D0,
53952 & 1.43169D0, 1.05466D0, 0.76454D0, 0.62772D0, 0.54298D0,
53953 & 0.48357D0, 0.40325D0, 0.32867D0, 0.25488D0, 0.20830D0,
53954 & 0.14936D0, 0.11205D0, 0.08608D0, 0.06328D0, 0.04729D0,
53955 & 0.03598D0, 0.02762D0, 0.02140D0, 0.01669D0, 0.01307D0,
53956 & 0.01014D0, 0.00780D0, 0.00595D0, 0.00443D0, 0.00330D0,
53957 & 0.00240D0, 0.00168D0, 0.00114D0, 0.00081D0, 0.00053D0,
53958 & 0.00032D0, 0.00022D0, 0.00012D0, 0.00004D0, 0.00001D0,
53959 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53960 DATA (FMRS(1,4,I,27),I=1,49)/
53961 & 10.00621D0, 7.54783D0, 5.69293D0, 4.82623D0, 4.29189D0,
53962 & 3.91798D0, 2.94832D0, 2.21133D0, 1.86373D0, 1.64761D0,
53963 & 1.49327D0, 1.09257D0, 0.78647D0, 0.64301D0, 0.55451D0,
53964 & 0.49265D0, 0.40930D0, 0.33223D0, 0.25638D0, 0.20876D0,
53965 & 0.14886D0, 0.11122D0, 0.08517D0, 0.06240D0, 0.04650D0,
53966 & 0.03528D0, 0.02702D0, 0.02089D0, 0.01623D0, 0.01267D0,
53967 & 0.00980D0, 0.00752D0, 0.00573D0, 0.00425D0, 0.00316D0,
53968 & 0.00230D0, 0.00159D0, 0.00107D0, 0.00077D0, 0.00050D0,
53969 & 0.00030D0, 0.00020D0, 0.00011D0, 0.00003D0, 0.00001D0,
53970 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53971 DATA (FMRS(1,4,I,28),I=1,49)/
53972 & 10.80590D0, 8.10435D0, 6.07766D0, 5.13510D0, 4.55568D0,
53973 & 4.15111D0, 3.10583D0, 2.31601D0, 1.94527D0, 1.71546D0,
53974 & 1.55167D0, 1.12822D0, 0.80689D0, 0.65715D0, 0.56511D0,
53975 & 0.50095D0, 0.41476D0, 0.33539D0, 0.25764D0, 0.20907D0,
53976 & 0.14833D0, 0.11039D0, 0.08428D0, 0.06155D0, 0.04576D0,
53977 & 0.03462D0, 0.02647D0, 0.02040D0, 0.01582D0, 0.01230D0,
53978 & 0.00949D0, 0.00726D0, 0.00551D0, 0.00409D0, 0.00302D0,
53979 & 0.00221D0, 0.00152D0, 0.00102D0, 0.00073D0, 0.00048D0,
53980 & 0.00029D0, 0.00019D0, 0.00010D0, 0.00004D0, 0.00001D0,
53981 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53982 DATA (FMRS(1,4,I,29),I=1,49)/
53983 & 11.65207D0, 8.68978D0, 6.48001D0, 5.45700D0, 4.82993D0,
53984 & 4.39300D0, 3.26826D0, 2.42329D0, 2.02852D0, 1.78454D0,
53985 & 1.61099D0, 1.16415D0, 0.82729D0, 0.67117D0, 0.57557D0,
53986 & 0.50910D0, 0.42008D0, 0.33842D0, 0.25880D0, 0.20930D0,
53987 & 0.14773D0, 0.10953D0, 0.08337D0, 0.06069D0, 0.04500D0,
53988 & 0.03397D0, 0.02591D0, 0.01991D0, 0.01541D0, 0.01194D0,
53989 & 0.00919D0, 0.00702D0, 0.00530D0, 0.00393D0, 0.00290D0,
53990 & 0.00211D0, 0.00145D0, 0.00096D0, 0.00070D0, 0.00045D0,
53991 & 0.00028D0, 0.00018D0, 0.00010D0, 0.00003D0, 0.00001D0,
53992 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
53993 DATA (FMRS(1,4,I,30),I=1,49)/
53994 & 12.52131D0, 9.28774D0, 6.88859D0, 5.78276D0, 5.10678D0,
53995 & 4.63673D0, 3.43094D0, 2.53005D0, 2.11104D0, 1.85281D0,
53996 & 1.66948D0, 1.19929D0, 0.84705D0, 0.68466D0, 0.58556D0,
53997 & 0.51685D0, 0.42507D0, 0.34121D0, 0.25979D0, 0.20942D0,
53998 & 0.14709D0, 0.10866D0, 0.08245D0, 0.05983D0, 0.04425D0,
53999 & 0.03334D0, 0.02536D0, 0.01943D0, 0.01501D0, 0.01160D0,
54000 & 0.00891D0, 0.00678D0, 0.00511D0, 0.00378D0, 0.00279D0,
54001 & 0.00202D0, 0.00138D0, 0.00091D0, 0.00067D0, 0.00043D0,
54002 & 0.00026D0, 0.00018D0, 0.00010D0, 0.00003D0, 0.00001D0,
54003 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54004 DATA (FMRS(1,4,I,31),I=1,49)/
54005 & 13.38978D0, 9.88200D0, 7.29246D0, 6.10376D0, 5.37897D0,
54006 & 4.87592D0, 3.58970D0, 2.63365D0, 2.19084D0, 1.91866D0,
54007 & 1.72578D0, 1.23288D0, 0.86578D0, 0.69738D0, 0.59494D0,
54008 & 0.52409D0, 0.42970D0, 0.34375D0, 0.26065D0, 0.20947D0,
54009 & 0.14644D0, 0.10781D0, 0.08158D0, 0.05902D0, 0.04354D0,
54010 & 0.03274D0, 0.02484D0, 0.01899D0, 0.01463D0, 0.01128D0,
54011 & 0.00865D0, 0.00657D0, 0.00493D0, 0.00364D0, 0.00268D0,
54012 & 0.00194D0, 0.00132D0, 0.00087D0, 0.00064D0, 0.00041D0,
54013 & 0.00025D0, 0.00017D0, 0.00009D0, 0.00003D0, 0.00001D0,
54014 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54015 DATA (FMRS(1,4,I,32),I=1,49)/
54016 & 14.23688D0, 10.45864D0, 7.68231D0, 6.41264D0, 5.64030D0,
54017 & 5.10517D0, 3.74102D0, 2.73180D0, 2.26617D0, 1.98065D0,
54018 & 1.77865D0, 1.26417D0, 0.88305D0, 0.70902D0, 0.60346D0,
54019 & 0.53062D0, 0.43382D0, 0.34595D0, 0.26134D0, 0.20941D0,
54020 & 0.14577D0, 0.10696D0, 0.08072D0, 0.05825D0, 0.04287D0,
54021 & 0.03215D0, 0.02436D0, 0.01857D0, 0.01428D0, 0.01098D0,
54022 & 0.00840D0, 0.00638D0, 0.00476D0, 0.00351D0, 0.00258D0,
54023 & 0.00187D0, 0.00127D0, 0.00083D0, 0.00061D0, 0.00039D0,
54024 & 0.00024D0, 0.00016D0, 0.00009D0, 0.00002D0, 0.00001D0,
54025 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54026 DATA (FMRS(1,4,I,33),I=1,49)/
54027 & 15.13941D0, 11.07021D0, 8.09390D0, 6.73786D0, 5.91493D0,
54028 & 5.34574D0, 3.89907D0, 2.83385D0, 2.34427D0, 2.04479D0,
54029 & 1.83327D0, 1.29634D0, 0.90070D0, 0.72088D0, 0.61213D0,
54030 & 0.53725D0, 0.43798D0, 0.34817D0, 0.26202D0, 0.20935D0,
54031 & 0.14510D0, 0.10612D0, 0.07988D0, 0.05749D0, 0.04221D0,
54032 & 0.03158D0, 0.02388D0, 0.01816D0, 0.01393D0, 0.01069D0,
54033 & 0.00816D0, 0.00620D0, 0.00459D0, 0.00338D0, 0.00248D0,
54034 & 0.00179D0, 0.00121D0, 0.00080D0, 0.00058D0, 0.00037D0,
54035 & 0.00022D0, 0.00014D0, 0.00008D0, 0.00002D0, 0.00001D0,
54036 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54037 DATA (FMRS(1,4,I,34),I=1,49)/
54038 & 16.04276D0, 11.67919D0, 8.50158D0, 7.05899D0, 6.18548D0,
54039 & 5.58230D0, 4.05359D0, 2.93300D0, 2.41985D0, 2.10667D0,
54040 & 1.88583D0, 1.32700D0, 0.91732D0, 0.73194D0, 0.62013D0,
54041 & 0.54331D0, 0.44171D0, 0.35007D0, 0.26248D0, 0.20913D0,
54042 & 0.14434D0, 0.10523D0, 0.07901D0, 0.05671D0, 0.04155D0,
54043 & 0.03102D0, 0.02340D0, 0.01777D0, 0.01360D0, 0.01042D0,
54044 & 0.00793D0, 0.00600D0, 0.00446D0, 0.00326D0, 0.00238D0,
54045 & 0.00173D0, 0.00118D0, 0.00076D0, 0.00055D0, 0.00036D0,
54046 & 0.00022D0, 0.00014D0, 0.00007D0, 0.00002D0, 0.00001D0,
54047 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54048 DATA (FMRS(1,4,I,35),I=1,49)/
54049 & 16.94849D0, 12.28721D0, 8.90688D0, 7.37746D0, 6.45332D0,
54050 & 5.81617D0, 4.20570D0, 3.03017D0, 2.49373D0, 2.16705D0,
54051 & 1.93704D0, 1.35674D0, 0.93336D0, 0.74257D0, 0.62781D0,
54052 & 0.54911D0, 0.44527D0, 0.35187D0, 0.26291D0, 0.20892D0,
54053 & 0.14363D0, 0.10440D0, 0.07819D0, 0.05599D0, 0.04092D0,
54054 & 0.03050D0, 0.02296D0, 0.01740D0, 0.01329D0, 0.01017D0,
54055 & 0.00772D0, 0.00583D0, 0.00433D0, 0.00315D0, 0.00229D0,
54056 & 0.00167D0, 0.00114D0, 0.00073D0, 0.00053D0, 0.00035D0,
54057 & 0.00021D0, 0.00013D0, 0.00007D0, 0.00002D0, 0.00001D0,
54058 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54059 DATA (FMRS(1,4,I,36),I=1,49)/
54060 & 17.83243D0, 12.87802D0, 9.29900D0, 7.68475D0, 6.71127D0,
54061 & 6.04107D0, 4.35129D0, 3.12272D0, 2.56388D0, 2.22424D0,
54062 & 1.98545D0, 1.38466D0, 0.94830D0, 0.75241D0, 0.63488D0,
54063 & 0.55441D0, 0.44848D0, 0.35346D0, 0.26323D0, 0.20867D0,
54064 & 0.14292D0, 0.10358D0, 0.07741D0, 0.05529D0, 0.04033D0,
54065 & 0.03000D0, 0.02255D0, 0.01705D0, 0.01300D0, 0.00993D0,
54066 & 0.00753D0, 0.00566D0, 0.00421D0, 0.00306D0, 0.00221D0,
54067 & 0.00161D0, 0.00110D0, 0.00071D0, 0.00051D0, 0.00034D0,
54068 & 0.00020D0, 0.00013D0, 0.00007D0, 0.00002D0, 0.00001D0,
54069 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54070 DATA (FMRS(1,4,I,37),I=1,49)/
54071 & 18.74867D0, 13.48785D0, 9.70200D0, 7.99976D0, 6.97522D0,
54072 & 6.27087D0, 4.49936D0, 3.21639D0, 2.63465D0, 2.28182D0,
54073 & 2.03408D0, 1.41252D0, 0.96307D0, 0.76207D0, 0.64176D0,
54074 & 0.55956D0, 0.45155D0, 0.35492D0, 0.26347D0, 0.20834D0,
54075 & 0.14216D0, 0.10274D0, 0.07660D0, 0.05459D0, 0.03974D0,
54076 & 0.02950D0, 0.02213D0, 0.01670D0, 0.01272D0, 0.00970D0,
54077 & 0.00733D0, 0.00550D0, 0.00408D0, 0.00297D0, 0.00214D0,
54078 & 0.00155D0, 0.00105D0, 0.00068D0, 0.00049D0, 0.00032D0,
54079 & 0.00018D0, 0.00012D0, 0.00007D0, 0.00002D0, 0.00001D0,
54080 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54081 DATA (FMRS(1,4,I,38),I=1,49)/
54082 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54083 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54084 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54085 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54086 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54087 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54088 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54089 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54090 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54091 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54092 DATA (FMRS(1,5,I, 1),I=1,49)/
54093 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54094 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54095 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54096 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54097 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54098 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54099 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54100 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54101 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54102 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54103 DATA (FMRS(1,5,I, 2),I=1,49)/
54104 & 0.00003D0, 0.00003D0, 0.00002D0, 0.00002D0, 0.00002D0,
54105 & 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0,
54106 & 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0,
54107 & 0.00002D0, 0.00002D0, 0.00001D0, 0.00001D0, 0.00001D0,
54108 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0,
54109 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0,
54110 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00000D0, 0.00000D0,
54111 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54112 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54113 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54114 DATA (FMRS(1,5,I, 3),I=1,49)/
54115 & 0.03227D0, 0.02900D0, 0.02605D0, 0.02445D0, 0.02338D0,
54116 & 0.02257D0, 0.02019D0, 0.01798D0, 0.01674D0, 0.01586D0,
54117 & 0.01516D0, 0.01302D0, 0.01084D0, 0.00956D0, 0.00865D0,
54118 & 0.00795D0, 0.00692D0, 0.00587D0, 0.00477D0, 0.00405D0,
54119 & 0.00317D0, 0.00263D0, 0.00225D0, 0.00190D0, 0.00163D0,
54120 & 0.00139D0, 0.00119D0, 0.00101D0, 0.00085D0, 0.00072D0,
54121 & 0.00059D0, 0.00048D0, 0.00039D0, 0.00031D0, 0.00025D0,
54122 & 0.00019D0, 0.00015D0, 0.00011D0, 0.00008D0, 0.00006D0,
54123 & 0.00004D0, 0.00003D0, 0.00002D0, 0.00001D0, 0.00000D0,
54124 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54125 DATA (FMRS(1,5,I, 4),I=1,49)/
54126 & 0.08412D0, 0.07493D0, 0.06672D0, 0.06231D0, 0.05935D0,
54127 & 0.05713D0, 0.05068D0, 0.04474D0, 0.04144D0, 0.03913D0,
54128 & 0.03731D0, 0.03177D0, 0.02623D0, 0.02303D0, 0.02077D0,
54129 & 0.01905D0, 0.01652D0, 0.01397D0, 0.01129D0, 0.00957D0,
54130 & 0.00745D0, 0.00615D0, 0.00525D0, 0.00441D0, 0.00375D0,
54131 & 0.00320D0, 0.00272D0, 0.00230D0, 0.00193D0, 0.00161D0,
54132 & 0.00132D0, 0.00108D0, 0.00087D0, 0.00069D0, 0.00054D0,
54133 & 0.00042D0, 0.00032D0, 0.00024D0, 0.00018D0, 0.00013D0,
54134 & 0.00009D0, 0.00006D0, 0.00004D0, 0.00001D0, 0.00000D0,
54135 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54136 DATA (FMRS(1,5,I, 5),I=1,49)/
54137 & 0.14877D0, 0.13082D0, 0.11499D0, 0.10659D0, 0.10097D0,
54138 & 0.09680D0, 0.08477D0, 0.07388D0, 0.06791D0, 0.06379D0,
54139 & 0.06056D0, 0.05091D0, 0.04152D0, 0.03619D0, 0.03249D0,
54140 & 0.02969D0, 0.02561D0, 0.02153D0, 0.01729D0, 0.01459D0,
54141 & 0.01127D0, 0.00925D0, 0.00785D0, 0.00655D0, 0.00553D0,
54142 & 0.00469D0, 0.00396D0, 0.00333D0, 0.00278D0, 0.00231D0,
54143 & 0.00189D0, 0.00153D0, 0.00123D0, 0.00097D0, 0.00076D0,
54144 & 0.00059D0, 0.00045D0, 0.00034D0, 0.00025D0, 0.00018D0,
54145 & 0.00012D0, 0.00009D0, 0.00006D0, 0.00001D0, 0.00000D0,
54146 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54147 DATA (FMRS(1,5,I, 6),I=1,49)/
54148 & 0.22202D0, 0.19306D0, 0.16779D0, 0.15452D0, 0.14570D0,
54149 & 0.13918D0, 0.12051D0, 0.10386D0, 0.09484D0, 0.08868D0,
54150 & 0.08388D0, 0.06972D0, 0.05624D0, 0.04872D0, 0.04355D0,
54151 & 0.03966D0, 0.03405D0, 0.02848D0, 0.02274D0, 0.01911D0,
54152 & 0.01466D0, 0.01197D0, 0.01011D0, 0.00838D0, 0.00703D0,
54153 & 0.00592D0, 0.00498D0, 0.00416D0, 0.00346D0, 0.00286D0,
54154 & 0.00233D0, 0.00188D0, 0.00150D0, 0.00118D0, 0.00092D0,
54155 & 0.00071D0, 0.00054D0, 0.00041D0, 0.00030D0, 0.00021D0,
54156 & 0.00015D0, 0.00010D0, 0.00007D0, 0.00001D0, 0.00000D0,
54157 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54158 DATA (FMRS(1,5,I, 7),I=1,49)/
54159 & 0.30272D0, 0.26063D0, 0.22430D0, 0.20535D0, 0.19284D0,
54160 & 0.18362D0, 0.15743D0, 0.13433D0, 0.12195D0, 0.11355D0,
54161 & 0.10705D0, 0.08808D0, 0.07034D0, 0.06058D0, 0.05394D0,
54162 & 0.04898D0, 0.04185D0, 0.03485D0, 0.02767D0, 0.02316D0,
54163 & 0.01766D0, 0.01434D0, 0.01204D0, 0.00992D0, 0.00828D0,
54164 & 0.00693D0, 0.00580D0, 0.00482D0, 0.00399D0, 0.00328D0,
54165 & 0.00266D0, 0.00214D0, 0.00170D0, 0.00133D0, 0.00104D0,
54166 & 0.00080D0, 0.00060D0, 0.00045D0, 0.00033D0, 0.00024D0,
54167 & 0.00016D0, 0.00011D0, 0.00007D0, 0.00001D0, 0.00000D0,
54168 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54169 DATA (FMRS(1,5,I, 8),I=1,49)/
54170 & 0.40640D0, 0.34641D0, 0.29514D0, 0.26863D0, 0.25121D0,
54171 & 0.23843D0, 0.20237D0, 0.17095D0, 0.15427D0, 0.14303D0,
54172 & 0.13440D0, 0.10944D0, 0.08650D0, 0.07407D0, 0.06568D0,
54173 & 0.05945D0, 0.05056D0, 0.04189D0, 0.03309D0, 0.02757D0,
54174 & 0.02089D0, 0.01686D0, 0.01408D0, 0.01153D0, 0.00956D0,
54175 & 0.00796D0, 0.00662D0, 0.00548D0, 0.00451D0, 0.00369D0,
54176 & 0.00298D0, 0.00239D0, 0.00189D0, 0.00148D0, 0.00114D0,
54177 & 0.00087D0, 0.00066D0, 0.00049D0, 0.00037D0, 0.00026D0,
54178 & 0.00018D0, 0.00012D0, 0.00007D0, 0.00001D0, 0.00000D0,
54179 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54180 DATA (FMRS(1,5,I, 9),I=1,49)/
54181 & 0.51210D0, 0.43288D0, 0.36574D0, 0.33126D0, 0.30871D0,
54182 & 0.29222D0, 0.24594D0, 0.20601D0, 0.18499D0, 0.17091D0,
54183 & 0.16014D0, 0.12927D0, 0.10130D0, 0.08631D0, 0.07626D0,
54184 & 0.06885D0, 0.05833D0, 0.04813D0, 0.03783D0, 0.03141D0,
54185 & 0.02366D0, 0.01900D0, 0.01580D0, 0.01287D0, 0.01061D0,
54186 & 0.00880D0, 0.00728D0, 0.00600D0, 0.00491D0, 0.00401D0,
54187 & 0.00322D0, 0.00257D0, 0.00203D0, 0.00158D0, 0.00122D0,
54188 & 0.00093D0, 0.00070D0, 0.00052D0, 0.00039D0, 0.00028D0,
54189 & 0.00018D0, 0.00012D0, 0.00007D0, 0.00001D0, 0.00000D0,
54190 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54191 DATA (FMRS(1,5,I,10),I=1,49)/
54192 & 0.62615D0, 0.52524D0, 0.44038D0, 0.39709D0, 0.36888D0,
54193 & 0.34831D0, 0.29091D0, 0.24179D0, 0.21613D0, 0.19903D0,
54194 & 0.18601D0, 0.14895D0, 0.11579D0, 0.09820D0, 0.08649D0,
54195 & 0.07789D0, 0.06575D0, 0.05404D0, 0.04228D0, 0.03498D0,
54196 & 0.02621D0, 0.02095D0, 0.01734D0, 0.01405D0, 0.01153D0,
54197 & 0.00952D0, 0.00784D0, 0.00644D0, 0.00525D0, 0.00426D0,
54198 & 0.00342D0, 0.00272D0, 0.00213D0, 0.00166D0, 0.00127D0,
54199 & 0.00097D0, 0.00073D0, 0.00054D0, 0.00040D0, 0.00029D0,
54200 & 0.00019D0, 0.00013D0, 0.00007D0, 0.00001D0, 0.00000D0,
54201 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54202 DATA (FMRS(1,5,I,11),I=1,49)/
54203 & 0.72756D0, 0.60673D0, 0.50572D0, 0.45443D0, 0.42111D0,
54204 & 0.39687D0, 0.32951D0, 0.27226D0, 0.24251D0, 0.22276D0,
54205 & 0.20777D0, 0.16535D0, 0.12775D0, 0.10795D0, 0.09484D0,
54206 & 0.08524D0, 0.07175D0, 0.05879D0, 0.04583D0, 0.03782D0,
54207 & 0.02821D0, 0.02247D0, 0.01853D0, 0.01496D0, 0.01223D0,
54208 & 0.01005D0, 0.00826D0, 0.00676D0, 0.00549D0, 0.00445D0,
54209 & 0.00355D0, 0.00282D0, 0.00221D0, 0.00171D0, 0.00131D0,
54210 & 0.00099D0, 0.00074D0, 0.00055D0, 0.00041D0, 0.00029D0,
54211 & 0.00019D0, 0.00013D0, 0.00007D0, 0.00001D0, 0.00000D0,
54212 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54213 DATA (FMRS(1,5,I,12),I=1,49)/
54214 & 0.97596D0, 0.80419D0, 0.66232D0, 0.59100D0, 0.54494D0,
54215 & 0.51159D0, 0.41968D0, 0.34257D0, 0.30297D0, 0.27688D0,
54216 & 0.25720D0, 0.20210D0, 0.15417D0, 0.12932D0, 0.11303D0,
54217 & 0.10119D0, 0.08465D0, 0.06892D0, 0.05333D0, 0.04376D0,
54218 & 0.03235D0, 0.02557D0, 0.02094D0, 0.01675D0, 0.01359D0,
54219 & 0.01109D0, 0.00904D0, 0.00734D0, 0.00594D0, 0.00477D0,
54220 & 0.00379D0, 0.00299D0, 0.00233D0, 0.00179D0, 0.00137D0,
54221 & 0.00103D0, 0.00077D0, 0.00057D0, 0.00042D0, 0.00030D0,
54222 & 0.00019D0, 0.00013D0, 0.00007D0, 0.00001D0, 0.00000D0,
54223 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54224 DATA (FMRS(1,5,I,13),I=1,49)/
54225 & 1.22977D0, 1.00344D0, 0.81836D0, 0.72605D0, 0.66675D0,
54226 & 0.62396D0, 0.50684D0, 0.40963D0, 0.36016D0, 0.32776D0,
54227 & 0.30345D0, 0.23597D0, 0.17813D0, 0.14851D0, 0.12924D0,
54228 & 0.11531D0, 0.09599D0, 0.07773D0, 0.05977D0, 0.04882D0,
54229 & 0.03581D0, 0.02811D0, 0.02289D0, 0.01818D0, 0.01465D0,
54230 & 0.01187D0, 0.00963D0, 0.00777D0, 0.00625D0, 0.00500D0,
54231 & 0.00395D0, 0.00310D0, 0.00241D0, 0.00185D0, 0.00140D0,
54232 & 0.00105D0, 0.00078D0, 0.00058D0, 0.00043D0, 0.00031D0,
54233 & 0.00019D0, 0.00013D0, 0.00007D0, 0.00001D0, 0.00000D0,
54234 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54235 DATA (FMRS(1,5,I,14),I=1,49)/
54236 & 1.55816D0, 1.25825D0, 1.01555D0, 0.89552D0, 0.81883D0,
54237 & 0.76371D0, 0.61389D0, 0.49095D0, 0.42897D0, 0.38864D0,
54238 & 0.35854D0, 0.27572D0, 0.20581D0, 0.17047D0, 0.14766D0,
54239 & 0.13128D0, 0.10869D0, 0.08751D0, 0.06683D0, 0.05430D0,
54240 & 0.03950D0, 0.03078D0, 0.02489D0, 0.01962D0, 0.01569D0,
54241 & 0.01264D0, 0.01018D0, 0.00817D0, 0.00653D0, 0.00519D0,
54242 & 0.00408D0, 0.00319D0, 0.00246D0, 0.00188D0, 0.00142D0,
54243 & 0.00106D0, 0.00078D0, 0.00058D0, 0.00043D0, 0.00031D0,
54244 & 0.00019D0, 0.00012D0, 0.00007D0, 0.00001D0, 0.00000D0,
54245 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54246 DATA (FMRS(1,5,I,15),I=1,49)/
54247 & 1.94525D0, 1.55494D0, 1.24230D0, 1.08896D0, 0.99149D0,
54248 & 0.92172D0, 0.73335D0, 0.58046D0, 0.50409D0, 0.45471D0,
54249 & 0.41801D0, 0.31797D0, 0.23473D0, 0.19316D0, 0.16655D0,
54250 & 0.14754D0, 0.12149D0, 0.09725D0, 0.07376D0, 0.05961D0,
54251 & 0.04299D0, 0.03326D0, 0.02672D0, 0.02089D0, 0.01659D0,
54252 & 0.01327D0, 0.01061D0, 0.00847D0, 0.00673D0, 0.00532D0,
54253 & 0.00416D0, 0.00323D0, 0.00248D0, 0.00188D0, 0.00142D0,
54254 & 0.00105D0, 0.00077D0, 0.00057D0, 0.00042D0, 0.00031D0,
54255 & 0.00019D0, 0.00012D0, 0.00007D0, 0.00001D0, 0.00000D0,
54256 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54257 DATA (FMRS(1,5,I,16),I=1,49)/
54258 & 2.34531D0, 1.85826D0, 1.47159D0, 1.28330D0, 1.16416D0,
54259 & 1.07915D0, 0.85101D0, 0.66758D0, 0.57668D0, 0.51821D0,
54260 & 0.47495D0, 0.35786D0, 0.26164D0, 0.21408D0, 0.18385D0,
54261 & 0.16236D0, 0.13305D0, 0.10596D0, 0.07987D0, 0.06425D0,
54262 & 0.04599D0, 0.03535D0, 0.02822D0, 0.02192D0, 0.01729D0,
54263 & 0.01375D0, 0.01093D0, 0.00867D0, 0.00685D0, 0.00540D0,
54264 & 0.00420D0, 0.00325D0, 0.00248D0, 0.00188D0, 0.00141D0,
54265 & 0.00104D0, 0.00076D0, 0.00056D0, 0.00041D0, 0.00030D0,
54266 & 0.00018D0, 0.00011D0, 0.00006D0, 0.00001D0, 0.00000D0,
54267 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54268 DATA (FMRS(1,5,I,17),I=1,49)/
54269 & 2.80142D0, 2.20072D0, 1.72790D0, 1.49927D0, 1.35523D0,
54270 & 1.25280D0, 0.97945D0, 0.76167D0, 0.65458D0, 0.58603D0,
54271 & 0.53553D0, 0.39978D0, 0.28955D0, 0.23561D0, 0.20153D0,
54272 & 0.17743D0, 0.14473D0, 0.11467D0, 0.08591D0, 0.06880D0,
54273 & 0.04888D0, 0.03733D0, 0.02963D0, 0.02285D0, 0.01791D0,
54274 & 0.01415D0, 0.01119D0, 0.00883D0, 0.00694D0, 0.00544D0,
54275 & 0.00421D0, 0.00324D0, 0.00247D0, 0.00186D0, 0.00139D0,
54276 & 0.00102D0, 0.00075D0, 0.00055D0, 0.00040D0, 0.00029D0,
54277 & 0.00018D0, 0.00011D0, 0.00006D0, 0.00001D0, 0.00000D0,
54278 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54279 DATA (FMRS(1,5,I,18),I=1,49)/
54280 & 3.21652D0, 2.50960D0, 1.95700D0, 1.69126D0, 1.52443D0,
54281 & 1.40610D0, 1.09176D0, 0.84313D0, 0.72161D0, 0.64414D0,
54282 & 0.58724D0, 0.43516D0, 0.31280D0, 0.25339D0, 0.21606D0,
54283 & 0.18974D0, 0.15419D0, 0.12166D0, 0.09071D0, 0.07236D0,
54284 & 0.05109D0, 0.03882D0, 0.03067D0, 0.02352D0, 0.01834D0,
54285 & 0.01442D0, 0.01135D0, 0.00892D0, 0.00699D0, 0.00545D0,
54286 & 0.00421D0, 0.00322D0, 0.00245D0, 0.00184D0, 0.00137D0,
54287 & 0.00100D0, 0.00073D0, 0.00053D0, 0.00039D0, 0.00029D0,
54288 & 0.00017D0, 0.00010D0, 0.00006D0, 0.00001D0, 0.00000D0,
54289 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54290 DATA (FMRS(1,5,I,19),I=1,49)/
54291 & 3.76652D0, 2.91536D0, 2.25532D0, 1.93997D0, 1.74280D0,
54292 & 1.60338D0, 1.23496D0, 0.94601D0, 0.80577D0, 0.71678D0,
54293 & 0.65167D0, 0.47873D0, 0.34109D0, 0.27487D0, 0.23349D0,
54294 & 0.20445D0, 0.16541D0, 0.12988D0, 0.09628D0, 0.07646D0,
54295 & 0.05359D0, 0.04046D0, 0.03178D0, 0.02422D0, 0.01877D0,
54296 & 0.01467D0, 0.01149D0, 0.00898D0, 0.00700D0, 0.00543D0,
54297 & 0.00418D0, 0.00319D0, 0.00241D0, 0.00180D0, 0.00134D0,
54298 & 0.00098D0, 0.00071D0, 0.00052D0, 0.00038D0, 0.00028D0,
54299 & 0.00017D0, 0.00010D0, 0.00006D0, 0.00001D0, 0.00000D0,
54300 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54301 DATA (FMRS(1,5,I,20),I=1,49)/
54302 & 4.30575D0, 3.30993D0, 2.54302D0, 2.17866D0, 1.95165D0,
54303 & 1.79153D0, 1.37036D0, 1.04242D0, 0.88422D0, 0.78423D0,
54304 & 0.71130D0, 0.51866D0, 0.36673D0, 0.29419D0, 0.24910D0,
54305 & 0.21757D0, 0.17534D0, 0.13711D0, 0.10112D0, 0.07999D0,
54306 & 0.05571D0, 0.04184D0, 0.03270D0, 0.02477D0, 0.01909D0,
54307 & 0.01486D0, 0.01158D0, 0.00901D0, 0.00699D0, 0.00541D0,
54308 & 0.00414D0, 0.00315D0, 0.00237D0, 0.00177D0, 0.00131D0,
54309 & 0.00095D0, 0.00069D0, 0.00050D0, 0.00037D0, 0.00027D0,
54310 & 0.00016D0, 0.00009D0, 0.00005D0, 0.00001D0, 0.00000D0,
54311 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54312 DATA (FMRS(1,5,I,21),I=1,49)/
54313 & 4.82956D0, 3.69021D0, 2.81808D0, 2.40576D0, 2.14966D0,
54314 & 1.96944D0, 1.49728D0, 1.13198D0, 0.95669D0, 0.84628D0,
54315 & 0.76597D0, 0.55486D0, 0.38968D0, 0.31136D0, 0.26288D0,
54316 & 0.22909D0, 0.18399D0, 0.14333D0, 0.10523D0, 0.08295D0,
54317 & 0.05744D0, 0.04293D0, 0.03340D0, 0.02518D0, 0.01931D0,
54318 & 0.01496D0, 0.01161D0, 0.00900D0, 0.00696D0, 0.00536D0,
54319 & 0.00409D0, 0.00310D0, 0.00233D0, 0.00173D0, 0.00128D0,
54320 & 0.00093D0, 0.00067D0, 0.00049D0, 0.00036D0, 0.00027D0,
54321 & 0.00015D0, 0.00009D0, 0.00005D0, 0.00001D0, 0.00000D0,
54322 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54323 DATA (FMRS(1,5,I,22),I=1,49)/
54324 & 5.55546D0, 4.21326D0, 3.19353D0, 2.71436D0, 2.41786D0,
54325 & 2.20981D0, 1.66741D0, 1.25104D0, 1.05255D0, 0.92807D0,
54326 & 0.83783D0, 0.60198D0, 0.41926D0, 0.33333D0, 0.28043D0,
54327 & 0.24370D0, 0.19489D0, 0.15111D0, 0.11032D0, 0.08657D0,
54328 & 0.05953D0, 0.04421D0, 0.03422D0, 0.02563D0, 0.01955D0,
54329 & 0.01506D0, 0.01163D0, 0.00897D0, 0.00690D0, 0.00529D0,
54330 & 0.00403D0, 0.00304D0, 0.00227D0, 0.00168D0, 0.00124D0,
54331 & 0.00090D0, 0.00064D0, 0.00047D0, 0.00035D0, 0.00026D0,
54332 & 0.00015D0, 0.00008D0, 0.00005D0, 0.00001D0, 0.00000D0,
54333 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54334 DATA (FMRS(1,5,I,23),I=1,49)/
54335 & 6.30033D0, 4.74567D0, 3.57260D0, 3.02443D0, 2.68642D0,
54336 & 2.44984D0, 1.83585D0, 1.36787D0, 1.14612D0, 1.00758D0,
54337 & 0.90746D0, 0.64718D0, 0.44730D0, 0.35401D0, 0.29686D0,
54338 & 0.25731D0, 0.20497D0, 0.15824D0, 0.11492D0, 0.08982D0,
54339 & 0.06136D0, 0.04532D0, 0.03489D0, 0.02598D0, 0.01971D0,
54340 & 0.01511D0, 0.01161D0, 0.00892D0, 0.00683D0, 0.00522D0,
54341 & 0.00395D0, 0.00297D0, 0.00222D0, 0.00163D0, 0.00120D0,
54342 & 0.00087D0, 0.00062D0, 0.00045D0, 0.00034D0, 0.00025D0,
54343 & 0.00014D0, 0.00008D0, 0.00005D0, 0.00001D0, 0.00000D0,
54344 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54345 DATA (FMRS(1,5,I,24),I=1,49)/
54346 & 7.03684D0, 5.26796D0, 3.94145D0, 3.32468D0, 2.94556D0,
54347 & 2.68082D0, 1.99651D0, 1.47829D0, 1.23404D0, 1.08198D0,
54348 & 0.97239D0, 0.68884D0, 0.47281D0, 0.37266D0, 0.31157D0,
54349 & 0.26944D0, 0.21386D0, 0.16445D0, 0.11886D0, 0.09256D0,
54350 & 0.06285D0, 0.04618D0, 0.03539D0, 0.02621D0, 0.01979D0,
54351 & 0.01510D0, 0.01155D0, 0.00884D0, 0.00675D0, 0.00513D0,
54352 & 0.00387D0, 0.00290D0, 0.00216D0, 0.00159D0, 0.00116D0,
54353 & 0.00084D0, 0.00060D0, 0.00044D0, 0.00033D0, 0.00024D0,
54354 & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
54355 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54356 DATA (FMRS(1,5,I,25),I=1,49)/
54357 & 7.83575D0, 5.83079D0, 4.33631D0, 3.64485D0, 3.22112D0,
54358 & 2.92590D0, 2.16582D0, 1.59383D0, 1.32566D0, 1.15927D0,
54359 & 1.03966D0, 0.73165D0, 0.49881D0, 0.39156D0, 0.32642D0,
54360 & 0.28163D0, 0.22275D0, 0.17063D0, 0.12274D0, 0.09523D0,
54361 & 0.06428D0, 0.04699D0, 0.03585D0, 0.02642D0, 0.01984D0,
54362 & 0.01507D0, 0.01148D0, 0.00875D0, 0.00665D0, 0.00505D0,
54363 & 0.00380D0, 0.00284D0, 0.00210D0, 0.00154D0, 0.00112D0,
54364 & 0.00081D0, 0.00058D0, 0.00042D0, 0.00031D0, 0.00024D0,
54365 & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
54366 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54367 DATA (FMRS(1,5,I,26),I=1,49)/
54368 & 8.65815D0, 6.40607D0, 4.73699D0, 3.96832D0, 3.49865D0,
54369 & 3.17213D0, 2.33459D0, 1.70806D0, 1.41577D0, 1.23500D0,
54370 & 1.10538D0, 0.77305D0, 0.52365D0, 0.40947D0, 0.34040D0,
54371 & 0.29306D0, 0.23101D0, 0.17630D0, 0.12625D0, 0.09761D0,
54372 & 0.06550D0, 0.04766D0, 0.03620D0, 0.02654D0, 0.01984D0,
54373 & 0.01501D0, 0.01139D0, 0.00864D0, 0.00655D0, 0.00495D0,
54374 & 0.00371D0, 0.00276D0, 0.00204D0, 0.00149D0, 0.00108D0,
54375 & 0.00078D0, 0.00056D0, 0.00041D0, 0.00030D0, 0.00023D0,
54376 & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
54377 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54378 DATA (FMRS(1,5,I,27),I=1,49)/
54379 & 9.48773D0, 6.98283D0, 5.13620D0, 4.28942D0, 3.77342D0,
54380 & 3.41540D0, 2.50025D0, 1.81942D0, 1.50325D0, 1.30829D0,
54381 & 1.16884D0, 0.81270D0, 0.54722D0, 0.42638D0, 0.35354D0,
54382 & 0.30375D0, 0.23869D0, 0.18153D0, 0.12945D0, 0.09975D0,
54383 & 0.06658D0, 0.04823D0, 0.03648D0, 0.02662D0, 0.01982D0,
54384 & 0.01493D0, 0.01129D0, 0.00853D0, 0.00645D0, 0.00486D0,
54385 & 0.00363D0, 0.00270D0, 0.00199D0, 0.00145D0, 0.00105D0,
54386 & 0.00075D0, 0.00054D0, 0.00039D0, 0.00030D0, 0.00022D0,
54387 & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
54388 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54389 DATA (FMRS(1,5,I,28),I=1,49)/
54390 & 10.30763D0, 7.54945D0, 5.52601D0, 4.60181D0, 4.04004D0,
54391 & 3.65097D0, 2.65960D0, 1.92581D0, 1.58647D0, 1.37780D0,
54392 & 1.22885D0, 0.84989D0, 0.56911D0, 0.44198D0, 0.36560D0,
54393 & 0.31352D0, 0.24565D0, 0.18623D0, 0.13228D0, 0.10162D0,
54394 & 0.06750D0, 0.04868D0, 0.03669D0, 0.02666D0, 0.01976D0,
54395 & 0.01484D0, 0.01118D0, 0.00842D0, 0.00635D0, 0.00477D0,
54396 & 0.00355D0, 0.00263D0, 0.00193D0, 0.00141D0, 0.00102D0,
54397 & 0.00073D0, 0.00052D0, 0.00038D0, 0.00029D0, 0.00022D0,
54398 & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
54399 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54400 DATA (FMRS(1,5,I,29),I=1,49)/
54401 & 11.17527D0, 8.14579D0, 5.93397D0, 4.92768D0, 4.31749D0,
54402 & 3.89565D0, 2.82415D0, 2.03499D0, 1.67156D0, 1.44867D0,
54403 & 1.28991D0, 0.88743D0, 0.59103D0, 0.45751D0, 0.37756D0,
54404 & 0.32318D0, 0.25249D0, 0.19081D0, 0.13501D0, 0.10341D0,
54405 & 0.06835D0, 0.04909D0, 0.03686D0, 0.02667D0, 0.01969D0,
54406 & 0.01473D0, 0.01106D0, 0.00831D0, 0.00624D0, 0.00467D0,
54407 & 0.00347D0, 0.00257D0, 0.00188D0, 0.00136D0, 0.00099D0,
54408 & 0.00070D0, 0.00050D0, 0.00037D0, 0.00028D0, 0.00021D0,
54409 & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
54410 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54411 DATA (FMRS(1,5,I,30),I=1,49)/
54412 & 12.06456D0, 8.75358D0, 6.34740D0, 5.25678D0, 4.59701D0,
54413 & 4.14168D0, 2.98858D0, 2.14338D0, 1.75569D0, 1.51853D0,
54414 & 1.34994D0, 0.92405D0, 0.61221D0, 0.47241D0, 0.38898D0,
54415 & 0.33235D0, 0.25894D0, 0.19508D0, 0.13752D0, 0.10502D0,
54416 & 0.06908D0, 0.04942D0, 0.03697D0, 0.02664D0, 0.01960D0,
54417 & 0.01461D0, 0.01093D0, 0.00819D0, 0.00613D0, 0.00458D0,
54418 & 0.00339D0, 0.00250D0, 0.00183D0, 0.00132D0, 0.00095D0,
54419 & 0.00068D0, 0.00049D0, 0.00036D0, 0.00027D0, 0.00021D0,
54420 & 0.00014D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
54421 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54422 DATA (FMRS(1,5,I,31),I=1,49)/
54423 & 12.95374D0, 9.35831D0, 6.75669D0, 5.58162D0, 4.87232D0,
54424 & 4.38360D0, 3.14942D0, 2.24882D0, 1.83726D0, 1.58610D0,
54425 & 1.40790D0, 0.95916D0, 0.63237D0, 0.48653D0, 0.39975D0,
54426 & 0.34099D0, 0.26498D0, 0.19905D0, 0.13983D0, 0.10648D0,
54427 & 0.06974D0, 0.04970D0, 0.03705D0, 0.02660D0, 0.01950D0,
54428 & 0.01449D0, 0.01081D0, 0.00807D0, 0.00603D0, 0.00449D0,
54429 & 0.00332D0, 0.00244D0, 0.00178D0, 0.00129D0, 0.00093D0,
54430 & 0.00066D0, 0.00047D0, 0.00035D0, 0.00026D0, 0.00020D0,
54431 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
54432 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54433 DATA (FMRS(1,5,I,32),I=1,49)/
54434 & 13.81822D0, 9.94319D0, 7.15042D0, 5.89310D0, 5.13569D0,
54435 & 4.61461D0, 3.30209D0, 2.34827D0, 1.91389D0, 1.64940D0,
54436 & 1.46205D0, 0.99170D0, 0.65086D0, 0.49940D0, 0.40952D0,
54437 & 0.34877D0, 0.27037D0, 0.20256D0, 0.14182D0, 0.10773D0,
54438 & 0.07026D0, 0.04989D0, 0.03708D0, 0.02652D0, 0.01938D0,
54439 & 0.01436D0, 0.01068D0, 0.00795D0, 0.00592D0, 0.00440D0,
54440 & 0.00325D0, 0.00238D0, 0.00174D0, 0.00125D0, 0.00090D0,
54441 & 0.00064D0, 0.00046D0, 0.00034D0, 0.00026D0, 0.00020D0,
54442 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
54443 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54444 DATA (FMRS(1,5,I,33),I=1,49)/
54445 & 14.74174D0, 10.56553D0, 7.56770D0, 6.22245D0, 5.41371D0,
54446 & 4.85814D0, 3.46239D0, 2.45228D0, 1.99384D0, 1.71531D0,
54447 & 1.51837D0, 1.02539D0, 0.66993D0, 0.51263D0, 0.41953D0,
54448 & 0.35674D0, 0.27589D0, 0.20614D0, 0.14386D0, 0.10899D0,
54449 & 0.07078D0, 0.05009D0, 0.03711D0, 0.02645D0, 0.01927D0,
54450 & 0.01422D0, 0.01055D0, 0.00784D0, 0.00582D0, 0.00432D0,
54451 & 0.00318D0, 0.00233D0, 0.00169D0, 0.00122D0, 0.00087D0,
54452 & 0.00062D0, 0.00044D0, 0.00033D0, 0.00025D0, 0.00020D0,
54453 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
54454 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54455 DATA (FMRS(1,5,I,34),I=1,49)/
54456 & 15.66159D0, 11.18202D0, 7.97872D0, 6.54573D0, 5.68591D0,
54457 & 5.09611D0, 3.61802D0, 2.55254D0, 2.07056D0, 1.77835D0,
54458 & 1.57208D0, 1.05721D0, 0.68771D0, 0.52486D0, 0.42872D0,
54459 & 0.36401D0, 0.28085D0, 0.20931D0, 0.14560D0, 0.11004D0,
54460 & 0.07117D0, 0.05019D0, 0.03707D0, 0.02633D0, 0.01912D0,
54461 & 0.01408D0, 0.01041D0, 0.00771D0, 0.00572D0, 0.00423D0,
54462 & 0.00311D0, 0.00227D0, 0.00165D0, 0.00118D0, 0.00085D0,
54463 & 0.00060D0, 0.00043D0, 0.00032D0, 0.00025D0, 0.00020D0,
54464 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
54465 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54466 DATA (FMRS(1,5,I,35),I=1,49)/
54467 & 16.58568D0, 11.79905D0, 8.38856D0, 6.86738D0, 5.95633D0,
54468 & 5.33223D0, 3.77185D0, 2.65127D0, 2.14594D0, 1.84019D0,
54469 & 1.62469D0, 1.08825D0, 0.70498D0, 0.53670D0, 0.43761D0,
54470 & 0.37103D0, 0.28563D0, 0.21235D0, 0.14727D0, 0.11103D0,
54471 & 0.07154D0, 0.05029D0, 0.03704D0, 0.02622D0, 0.01898D0,
54472 & 0.01394D0, 0.01028D0, 0.00760D0, 0.00562D0, 0.00415D0,
54473 & 0.00304D0, 0.00222D0, 0.00161D0, 0.00115D0, 0.00082D0,
54474 & 0.00058D0, 0.00042D0, 0.00031D0, 0.00024D0, 0.00019D0,
54475 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
54476 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54477 DATA (FMRS(1,5,I,36),I=1,49)/
54478 & 17.48656D0, 12.39804D0, 8.78469D0, 7.17746D0, 6.21652D0,
54479 & 5.55909D0, 3.91895D0, 2.74520D0, 2.21743D0, 1.89869D0,
54480 & 1.67437D0, 1.11736D0, 0.72106D0, 0.54767D0, 0.44580D0,
54481 & 0.37747D0, 0.28999D0, 0.21509D0, 0.14875D0, 0.11190D0,
54482 & 0.07184D0, 0.05035D0, 0.03698D0, 0.02610D0, 0.01884D0,
54483 & 0.01380D0, 0.01016D0, 0.00749D0, 0.00553D0, 0.00407D0,
54484 & 0.00298D0, 0.00217D0, 0.00157D0, 0.00112D0, 0.00080D0,
54485 & 0.00057D0, 0.00041D0, 0.00031D0, 0.00024D0, 0.00019D0,
54486 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
54487 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54488 DATA (FMRS(1,5,I,37),I=1,49)/
54489 & 18.41889D0, 13.01534D0, 9.19117D0, 7.49481D0, 6.48233D0,
54490 & 5.79049D0, 4.06828D0, 2.84006D0, 2.28940D0, 1.95745D0,
54491 & 1.72416D0, 1.14634D0, 0.73693D0, 0.55843D0, 0.45379D0,
54492 & 0.38373D0, 0.29419D0, 0.21770D0, 0.15013D0, 0.11269D0,
54493 & 0.07209D0, 0.05037D0, 0.03690D0, 0.02596D0, 0.01869D0,
54494 & 0.01365D0, 0.01003D0, 0.00738D0, 0.00543D0, 0.00399D0,
54495 & 0.00291D0, 0.00212D0, 0.00153D0, 0.00109D0, 0.00078D0,
54496 & 0.00055D0, 0.00040D0, 0.00030D0, 0.00023D0, 0.00019D0,
54497 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00000D0,
54498 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54499 DATA (FMRS(1,5,I,38),I=1,49)/
54500 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54501 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54502 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54503 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54504 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54505 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54506 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54507 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54508 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54509 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54510 DATA (FMRS(1,6,I, 1),I=1,49)/
54511 & 0.44989D0, 0.39539D0, 0.34747D0, 0.32216D0, 0.30531D0,
54512 & 0.29285D0, 0.25722D0, 0.22578D0, 0.20909D0, 0.19792D0,
54513 & 0.18955D0, 0.16547D0, 0.14378D0, 0.13212D0, 0.12429D0,
54514 & 0.11845D0, 0.11003D0, 0.10150D0, 0.09208D0, 0.08532D0,
54515 & 0.07497D0, 0.06641D0, 0.05872D0, 0.04993D0, 0.04200D0,
54516 & 0.03492D0, 0.02867D0, 0.02327D0, 0.01867D0, 0.01463D0,
54517 & 0.01149D0, 0.00885D0, 0.00675D0, 0.00511D0, 0.00375D0,
54518 & 0.00275D0, 0.00200D0, 0.00140D0, 0.00092D0, 0.00067D0,
54519 & 0.00045D0, 0.00028D0, 0.00020D0, 0.00007D0, 0.00002D0,
54520 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54521 DATA (FMRS(1,6,I, 2),I=1,49)/
54522 & 0.46639D0, 0.41136D0, 0.36279D0, 0.33706D0, 0.31990D0,
54523 & 0.30719D0, 0.27073D0, 0.23840D0, 0.22115D0, 0.20956D0,
54524 & 0.20084D0, 0.17557D0, 0.15249D0, 0.13993D0, 0.13142D0,
54525 & 0.12504D0, 0.11578D0, 0.10635D0, 0.09591D0, 0.08845D0,
54526 & 0.07719D0, 0.06805D0, 0.05996D0, 0.05084D0, 0.04269D0,
54527 & 0.03544D0, 0.02909D0, 0.02361D0, 0.01895D0, 0.01488D0,
54528 & 0.01169D0, 0.00902D0, 0.00689D0, 0.00524D0, 0.00385D0,
54529 & 0.00283D0, 0.00206D0, 0.00146D0, 0.00096D0, 0.00071D0,
54530 & 0.00048D0, 0.00029D0, 0.00022D0, 0.00008D0, 0.00002D0,
54531 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54532 DATA (FMRS(1,6,I, 3),I=1,49)/
54533 & 0.50684D0, 0.44821D0, 0.39632D0, 0.36876D0, 0.35036D0,
54534 & 0.33670D0, 0.29743D0, 0.26242D0, 0.24363D0, 0.23094D0,
54535 & 0.22132D0, 0.19327D0, 0.16725D0, 0.15293D0, 0.14314D0,
54536 & 0.13576D0, 0.12501D0, 0.11402D0, 0.10188D0, 0.09328D0,
54537 & 0.08055D0, 0.07049D0, 0.06177D0, 0.05212D0, 0.04362D0,
54538 & 0.03613D0, 0.02960D0, 0.02400D0, 0.01926D0, 0.01513D0,
54539 & 0.01189D0, 0.00918D0, 0.00704D0, 0.00535D0, 0.00395D0,
54540 & 0.00290D0, 0.00211D0, 0.00152D0, 0.00101D0, 0.00074D0,
54541 & 0.00051D0, 0.00031D0, 0.00023D0, 0.00008D0, 0.00002D0,
54542 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54543 DATA (FMRS(1,6,I, 4),I=1,49)/
54544 & 0.55058D0, 0.48672D0, 0.43021D0, 0.40019D0, 0.38014D0,
54545 & 0.36526D0, 0.32246D0, 0.28426D0, 0.26371D0, 0.24981D0,
54546 & 0.23922D0, 0.20826D0, 0.17939D0, 0.16343D0, 0.15249D0,
54547 & 0.14425D0, 0.13221D0, 0.11993D0, 0.10640D0, 0.09689D0,
54548 & 0.08300D0, 0.07224D0, 0.06305D0, 0.05299D0, 0.04421D0,
54549 & 0.03653D0, 0.02989D0, 0.02420D0, 0.01939D0, 0.01523D0,
54550 & 0.01197D0, 0.00924D0, 0.00709D0, 0.00537D0, 0.00399D0,
54551 & 0.00293D0, 0.00213D0, 0.00154D0, 0.00102D0, 0.00074D0,
54552 & 0.00053D0, 0.00032D0, 0.00024D0, 0.00009D0, 0.00002D0,
54553 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54554 DATA (FMRS(1,6,I, 5),I=1,49)/
54555 & 0.61607D0, 0.54291D0, 0.47835D0, 0.44415D0, 0.42133D0,
54556 & 0.40441D0, 0.35583D0, 0.31254D0, 0.28927D0, 0.27353D0,
54557 & 0.26150D0, 0.22639D0, 0.19363D0, 0.17555D0, 0.16316D0,
54558 & 0.15384D0, 0.14026D0, 0.12643D0, 0.11130D0, 0.10077D0,
54559 & 0.08558D0, 0.07403D0, 0.06431D0, 0.05381D0, 0.04474D0,
54560 & 0.03686D0, 0.03008D0, 0.02432D0, 0.01945D0, 0.01528D0,
54561 & 0.01199D0, 0.00925D0, 0.00709D0, 0.00537D0, 0.00398D0,
54562 & 0.00293D0, 0.00214D0, 0.00154D0, 0.00103D0, 0.00074D0,
54563 & 0.00052D0, 0.00032D0, 0.00024D0, 0.00008D0, 0.00002D0,
54564 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54565 DATA (FMRS(1,6,I, 6),I=1,49)/
54566 & 0.68336D0, 0.60005D0, 0.52679D0, 0.48807D0, 0.46228D0,
54567 & 0.44318D0, 0.38846D0, 0.33984D0, 0.31375D0, 0.29611D0,
54568 & 0.28263D0, 0.24332D0, 0.20674D0, 0.18660D0, 0.17283D0,
54569 & 0.16249D0, 0.14745D0, 0.13219D0, 0.11560D0, 0.10414D0,
54570 & 0.08779D0, 0.07555D0, 0.06535D0, 0.05447D0, 0.04515D0,
54571 & 0.03709D0, 0.03021D0, 0.02439D0, 0.01946D0, 0.01528D0,
54572 & 0.01197D0, 0.00923D0, 0.00707D0, 0.00536D0, 0.00396D0,
54573 & 0.00291D0, 0.00213D0, 0.00154D0, 0.00103D0, 0.00073D0,
54574 & 0.00051D0, 0.00032D0, 0.00023D0, 0.00008D0, 0.00002D0,
54575 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54576 DATA (FMRS(1,6,I, 7),I=1,49)/
54577 & 0.76355D0, 0.66723D0, 0.58292D0, 0.53852D0, 0.50902D0,
54578 & 0.48721D0, 0.42490D0, 0.36978D0, 0.34030D0, 0.32042D0,
54579 & 0.30522D0, 0.26107D0, 0.22021D0, 0.19782D0, 0.18257D0,
54580 & 0.17114D0, 0.15457D0, 0.13784D0, 0.11976D0, 0.10736D0,
54581 & 0.08987D0, 0.07693D0, 0.06629D0, 0.05503D0, 0.04547D0,
54582 & 0.03726D0, 0.03027D0, 0.02439D0, 0.01942D0, 0.01523D0,
54583 & 0.01190D0, 0.00918D0, 0.00701D0, 0.00533D0, 0.00392D0,
54584 & 0.00287D0, 0.00209D0, 0.00153D0, 0.00101D0, 0.00073D0,
54585 & 0.00050D0, 0.00032D0, 0.00022D0, 0.00007D0, 0.00002D0,
54586 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54587 DATA (FMRS(1,6,I, 8),I=1,49)/
54588 & 0.86343D0, 0.75010D0, 0.65144D0, 0.59973D0, 0.56547D0,
54589 & 0.54018D0, 0.46822D0, 0.40492D0, 0.37123D0, 0.34856D0,
54590 & 0.33127D0, 0.28125D0, 0.23529D0, 0.21028D0, 0.19331D0,
54591 & 0.18063D0, 0.16233D0, 0.14394D0, 0.12420D0, 0.11077D0,
54592 & 0.09202D0, 0.07835D0, 0.06722D0, 0.05555D0, 0.04575D0,
54593 & 0.03737D0, 0.03028D0, 0.02434D0, 0.01934D0, 0.01514D0,
54594 & 0.01181D0, 0.00909D0, 0.00694D0, 0.00526D0, 0.00387D0,
54595 & 0.00282D0, 0.00206D0, 0.00150D0, 0.00100D0, 0.00072D0,
54596 & 0.00049D0, 0.00031D0, 0.00021D0, 0.00008D0, 0.00002D0,
54597 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54598 DATA (FMRS(1,6,I, 9),I=1,49)/
54599 & 0.96361D0, 0.83251D0, 0.71897D0, 0.65971D0, 0.62055D0,
54600 & 0.59171D0, 0.50993D0, 0.43838D0, 0.40047D0, 0.37504D0,
54601 & 0.35567D0, 0.29991D0, 0.24906D0, 0.22156D0, 0.20298D0,
54602 & 0.18914D0, 0.16924D0, 0.14933D0, 0.12809D0, 0.11373D0,
54603 & 0.09387D0, 0.07954D0, 0.06798D0, 0.05596D0, 0.04595D0,
54604 & 0.03743D0, 0.03026D0, 0.02427D0, 0.01926D0, 0.01505D0,
54605 & 0.01172D0, 0.00900D0, 0.00687D0, 0.00519D0, 0.00383D0,
54606 & 0.00278D0, 0.00203D0, 0.00148D0, 0.00098D0, 0.00071D0,
54607 & 0.00048D0, 0.00031D0, 0.00021D0, 0.00008D0, 0.00002D0,
54608 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54609 DATA (FMRS(1,6,I,10),I=1,49)/
54610 & 1.07479D0, 0.92315D0, 0.79255D0, 0.72469D0, 0.67997D0,
54611 & 0.64711D0, 0.55427D0, 0.47353D0, 0.43097D0, 0.40251D0,
54612 & 0.38089D0, 0.31894D0, 0.26290D0, 0.23280D0, 0.21256D0,
54613 & 0.19753D0, 0.17599D0, 0.15455D0, 0.13181D0, 0.11654D0,
54614 & 0.09559D0, 0.08062D0, 0.06865D0, 0.05629D0, 0.04608D0,
54615 & 0.03743D0, 0.03019D0, 0.02416D0, 0.01913D0, 0.01493D0,
54616 & 0.01161D0, 0.00890D0, 0.00677D0, 0.00511D0, 0.00377D0,
54617 & 0.00274D0, 0.00200D0, 0.00145D0, 0.00096D0, 0.00068D0,
54618 & 0.00046D0, 0.00030D0, 0.00020D0, 0.00008D0, 0.00002D0,
54619 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54620 DATA (FMRS(1,6,I,11),I=1,49)/
54621 & 1.17232D0, 1.00213D0, 0.85623D0, 0.78069D0, 0.73104D0,
54622 & 0.69461D0, 0.59200D0, 0.50321D0, 0.45658D0, 0.42550D0,
54623 & 0.40194D0, 0.33467D0, 0.27424D0, 0.24195D0, 0.22032D0,
54624 & 0.20431D0, 0.18142D0, 0.15872D0, 0.13477D0, 0.11875D0,
54625 & 0.09692D0, 0.08144D0, 0.06915D0, 0.05653D0, 0.04615D0,
54626 & 0.03741D0, 0.03011D0, 0.02406D0, 0.01902D0, 0.01482D0,
54627 & 0.01152D0, 0.00881D0, 0.00669D0, 0.00505D0, 0.00371D0,
54628 & 0.00270D0, 0.00197D0, 0.00143D0, 0.00094D0, 0.00066D0,
54629 & 0.00045D0, 0.00029D0, 0.00020D0, 0.00008D0, 0.00002D0,
54630 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54631 DATA (FMRS(1,6,I,12),I=1,49)/
54632 & 1.41135D0, 1.19389D0, 1.00931D0, 0.91452D0, 0.85253D0,
54633 & 0.80723D0, 0.68048D0, 0.57199D0, 0.51554D0, 0.47813D0,
54634 & 0.44992D0, 0.37007D0, 0.29939D0, 0.26209D0, 0.23729D0,
54635 & 0.21905D0, 0.19312D0, 0.16764D0, 0.14100D0, 0.12337D0,
54636 & 0.09965D0, 0.08309D0, 0.07010D0, 0.05694D0, 0.04624D0,
54637 & 0.03729D0, 0.02989D0, 0.02378D0, 0.01873D0, 0.01456D0,
54638 & 0.01128D0, 0.00861D0, 0.00651D0, 0.00490D0, 0.00360D0,
54639 & 0.00260D0, 0.00189D0, 0.00137D0, 0.00090D0, 0.00062D0,
54640 & 0.00043D0, 0.00028D0, 0.00019D0, 0.00007D0, 0.00002D0,
54641 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54642 DATA (FMRS(1,6,I,13),I=1,49)/
54643 & 1.65256D0, 1.38522D0, 1.16028D0, 1.04559D0, 0.97092D0,
54644 & 0.91653D0, 0.76529D0, 0.63704D0, 0.57085D0, 0.52722D0,
54645 & 0.49446D0, 0.40243D0, 0.32201D0, 0.28002D0, 0.25230D0,
54646 & 0.23200D0, 0.20332D0, 0.17533D0, 0.14629D0, 0.12724D0,
54647 & 0.10187D0, 0.08438D0, 0.07080D0, 0.05719D0, 0.04622D0,
54648 & 0.03712D0, 0.02965D0, 0.02350D0, 0.01845D0, 0.01430D0,
54649 & 0.01104D0, 0.00841D0, 0.00634D0, 0.00476D0, 0.00349D0,
54650 & 0.00251D0, 0.00182D0, 0.00132D0, 0.00086D0, 0.00060D0,
54651 & 0.00042D0, 0.00026D0, 0.00018D0, 0.00006D0, 0.00002D0,
54652 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54653 DATA (FMRS(1,6,I,14),I=1,49)/
54654 & 1.96387D0, 1.62942D0, 1.35081D0, 1.20988D0, 1.11860D0,
54655 & 1.05236D0, 0.86939D0, 0.71589D0, 0.63738D0, 0.58593D0,
54656 & 0.54750D0, 0.44041D0, 0.34815D0, 0.30054D0, 0.26935D0,
54657 & 0.24663D0, 0.21473D0, 0.18383D0, 0.15206D0, 0.13140D0,
54658 & 0.10419D0, 0.08567D0, 0.07145D0, 0.05736D0, 0.04609D0,
54659 & 0.03684D0, 0.02930D0, 0.02313D0, 0.01809D0, 0.01398D0,
54660 & 0.01074D0, 0.00816D0, 0.00615D0, 0.00459D0, 0.00334D0,
54661 & 0.00240D0, 0.00174D0, 0.00125D0, 0.00082D0, 0.00057D0,
54662 & 0.00038D0, 0.00024D0, 0.00016D0, 0.00006D0, 0.00002D0,
54663 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54664 DATA (FMRS(1,6,I,15),I=1,49)/
54665 & 2.33902D0, 1.92024D0, 1.57497D0, 1.40179D0, 1.29021D0,
54666 & 1.20956D0, 0.98833D0, 0.80477D0, 0.71175D0, 0.65116D0,
54667 & 0.60614D0, 0.48174D0, 0.37612D0, 0.32226D0, 0.28724D0,
54668 & 0.26188D0, 0.22649D0, 0.19248D0, 0.15783D0, 0.13549D0,
54669 & 0.10637D0, 0.08680D0, 0.07195D0, 0.05738D0, 0.04585D0,
54670 & 0.03646D0, 0.02886D0, 0.02269D0, 0.01768D0, 0.01360D0,
54671 & 0.01043D0, 0.00789D0, 0.00592D0, 0.00441D0, 0.00321D0,
54672 & 0.00230D0, 0.00166D0, 0.00118D0, 0.00078D0, 0.00054D0,
54673 & 0.00037D0, 0.00022D0, 0.00015D0, 0.00006D0, 0.00002D0,
54674 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54675 DATA (FMRS(1,6,I,16),I=1,49)/
54676 & 2.72482D0, 2.21608D0, 1.80052D0, 1.59364D0, 1.46096D0,
54677 & 1.36541D0, 1.10490D0, 0.89086D0, 0.78327D0, 0.71357D0,
54678 & 0.66200D0, 0.52058D0, 0.40200D0, 0.34217D0, 0.30354D0,
54679 & 0.27569D0, 0.23704D0, 0.20015D0, 0.16285D0, 0.13900D0,
54680 & 0.10817D0, 0.08767D0, 0.07227D0, 0.05729D0, 0.04554D0,
54681 & 0.03606D0, 0.02842D0, 0.02227D0, 0.01728D0, 0.01326D0,
54682 & 0.01012D0, 0.00763D0, 0.00571D0, 0.00425D0, 0.00307D0,
54683 & 0.00219D0, 0.00158D0, 0.00112D0, 0.00073D0, 0.00051D0,
54684 & 0.00035D0, 0.00021D0, 0.00014D0, 0.00005D0, 0.00002D0,
54685 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54686 DATA (FMRS(1,6,I,17),I=1,49)/
54687 & 3.16184D0, 2.54784D0, 2.05090D0, 1.80533D0, 1.64858D0,
54688 & 1.53608D0, 1.23122D0, 0.98314D0, 0.85944D0, 0.77972D0,
54689 & 0.72099D0, 0.56109D0, 0.42865D0, 0.36249D0, 0.32006D0,
54690 & 0.28962D0, 0.24759D0, 0.20774D0, 0.16775D0, 0.14236D0,
54691 & 0.10984D0, 0.08843D0, 0.07249D0, 0.05712D0, 0.04518D0,
54692 & 0.03560D0, 0.02794D0, 0.02182D0, 0.01686D0, 0.01291D0,
54693 & 0.00980D0, 0.00737D0, 0.00550D0, 0.00408D0, 0.00294D0,
54694 & 0.00209D0, 0.00150D0, 0.00107D0, 0.00069D0, 0.00049D0,
54695 & 0.00034D0, 0.00019D0, 0.00014D0, 0.00005D0, 0.00001D0,
54696 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54697 DATA (FMRS(1,6,I,18),I=1,49)/
54698 & 3.56226D0, 2.84906D0, 2.27616D0, 1.99475D0, 1.81581D0,
54699 & 1.68774D0, 1.34241D0, 1.06358D0, 0.92544D0, 0.83679D0,
54700 & 0.77171D0, 0.59551D0, 0.45100D0, 0.37940D0, 0.33372D0,
54701 & 0.30107D0, 0.25620D0, 0.21386D0, 0.17164D0, 0.14499D0,
54702 & 0.11108D0, 0.08895D0, 0.07258D0, 0.05692D0, 0.04483D0,
54703 & 0.03518D0, 0.02753D0, 0.02142D0, 0.01651D0, 0.01260D0,
54704 & 0.00954D0, 0.00717D0, 0.00532D0, 0.00393D0, 0.00284D0,
54705 & 0.00201D0, 0.00144D0, 0.00103D0, 0.00066D0, 0.00045D0,
54706 & 0.00032D0, 0.00018D0, 0.00013D0, 0.00004D0, 0.00001D0,
54707 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54708 DATA (FMRS(1,6,I,19),I=1,49)/
54709 & 4.09416D0, 3.24567D0, 2.57011D0, 2.24065D0, 2.03209D0,
54710 & 1.88332D0, 1.48448D0, 1.16540D0, 1.00850D0, 0.90831D0,
54711 & 0.83504D0, 0.63803D0, 0.47827D0, 0.39987D0, 0.35015D0,
54712 & 0.31478D0, 0.26640D0, 0.22104D0, 0.17612D0, 0.14797D0,
54713 & 0.11241D0, 0.08943D0, 0.07259D0, 0.05659D0, 0.04434D0,
54714 & 0.03464D0, 0.02699D0, 0.02092D0, 0.01606D0, 0.01221D0,
54715 & 0.00922D0, 0.00691D0, 0.00511D0, 0.00375D0, 0.00271D0,
54716 & 0.00191D0, 0.00136D0, 0.00097D0, 0.00063D0, 0.00043D0,
54717 & 0.00030D0, 0.00017D0, 0.00012D0, 0.00004D0, 0.00001D0,
54718 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54719 DATA (FMRS(1,6,I,20),I=1,49)/
54720 & 4.61257D0, 3.62885D0, 2.85161D0, 2.47491D0, 2.23738D0,
54721 & 2.06842D0, 1.61774D0, 1.26001D0, 1.08527D0, 0.97415D0,
54722 & 0.89315D0, 0.67662D0, 0.50274D0, 0.41811D0, 0.36471D0,
54723 & 0.32688D0, 0.27534D0, 0.22728D0, 0.17996D0, 0.15048D0,
54724 & 0.11349D0, 0.08979D0, 0.07253D0, 0.05626D0, 0.04389D0,
54725 & 0.03414D0, 0.02651D0, 0.02047D0, 0.01566D0, 0.01187D0,
54726 & 0.00894D0, 0.00668D0, 0.00493D0, 0.00361D0, 0.00261D0,
54727 & 0.00182D0, 0.00129D0, 0.00093D0, 0.00059D0, 0.00040D0,
54728 & 0.00028D0, 0.00016D0, 0.00011D0, 0.00004D0, 0.00001D0,
54729 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54730 DATA (FMRS(1,6,I,21),I=1,49)/
54731 & 5.12222D0, 4.00261D0, 3.12404D0, 2.70057D0, 2.43446D0,
54732 & 2.24566D0, 1.74429D0, 1.34911D0, 1.15718D0, 1.03559D0,
54733 & 0.94721D0, 0.71215D0, 0.52500D0, 0.43455D0, 0.37776D0,
54734 & 0.33766D0, 0.28323D0, 0.23271D0, 0.18324D0, 0.15257D0,
54735 & 0.11432D0, 0.08998D0, 0.07237D0, 0.05588D0, 0.04342D0,
54736 & 0.03365D0, 0.02604D0, 0.02004D0, 0.01529D0, 0.01156D0,
54737 & 0.00869D0, 0.00646D0, 0.00477D0, 0.00348D0, 0.00251D0,
54738 & 0.00175D0, 0.00124D0, 0.00088D0, 0.00057D0, 0.00038D0,
54739 & 0.00026D0, 0.00015D0, 0.00010D0, 0.00004D0, 0.00001D0,
54740 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54741 DATA (FMRS(1,6,I,22),I=1,49)/
54742 & 5.82554D0, 4.51423D0, 3.49391D0, 3.00548D0, 2.69986D0,
54743 & 2.48370D0, 1.91285D0, 1.46678D0, 1.25167D0, 1.11601D0,
54744 & 1.01775D0, 0.75806D0, 0.55345D0, 0.45543D0, 0.39424D0,
54745 & 0.35121D0, 0.29307D0, 0.23942D0, 0.18722D0, 0.15507D0,
54746 & 0.11526D0, 0.09014D0, 0.07211D0, 0.05536D0, 0.04279D0,
54747 & 0.03301D0, 0.02543D0, 0.01950D0, 0.01483D0, 0.01117D0,
54748 & 0.00837D0, 0.00620D0, 0.00456D0, 0.00332D0, 0.00238D0,
54749 & 0.00166D0, 0.00117D0, 0.00083D0, 0.00053D0, 0.00035D0,
54750 & 0.00024D0, 0.00015D0, 0.00010D0, 0.00003D0, 0.00001D0,
54751 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54752 DATA (FMRS(1,6,I,23),I=1,49)/
54753 & 6.54676D0, 5.03439D0, 3.86673D0, 3.31126D0, 2.96506D0,
54754 & 2.72090D0, 2.07933D0, 1.58195D0, 1.34364D0, 1.19398D0,
54755 & 1.08591D0, 0.80195D0, 0.58033D0, 0.47501D0, 0.40960D0,
54756 & 0.36377D0, 0.30212D0, 0.24551D0, 0.19078D0, 0.15726D0,
54757 & 0.11602D0, 0.09021D0, 0.07181D0, 0.05483D0, 0.04218D0,
54758 & 0.03240D0, 0.02486D0, 0.01900D0, 0.01440D0, 0.01081D0,
54759 & 0.00808D0, 0.00597D0, 0.00437D0, 0.00317D0, 0.00227D0,
54760 & 0.00157D0, 0.00111D0, 0.00080D0, 0.00050D0, 0.00034D0,
54761 & 0.00022D0, 0.00014D0, 0.00009D0, 0.00003D0, 0.00001D0,
54762 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54763 DATA (FMRS(1,6,I,24),I=1,49)/
54764 & 7.26565D0, 5.54876D0, 4.23247D0, 3.60982D0, 3.22311D0,
54765 & 2.95109D0, 2.23956D0, 1.69183D0, 1.43093D0, 1.26769D0,
54766 & 1.15015D0, 0.84286D0, 0.60508D0, 0.49288D0, 0.42351D0,
54767 & 0.37509D0, 0.31017D0, 0.25086D0, 0.19381D0, 0.15905D0,
54768 & 0.11655D0, 0.09013D0, 0.07142D0, 0.05426D0, 0.04157D0,
54769 & 0.03180D0, 0.02431D0, 0.01852D0, 0.01399D0, 0.01048D0,
54770 & 0.00780D0, 0.00574D0, 0.00419D0, 0.00304D0, 0.00217D0,
54771 & 0.00149D0, 0.00106D0, 0.00075D0, 0.00048D0, 0.00032D0,
54772 & 0.00021D0, 0.00013D0, 0.00009D0, 0.00003D0, 0.00001D0,
54773 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54774 DATA (FMRS(1,6,I,25),I=1,49)/
54775 & 8.04192D0, 6.10017D0, 4.62168D0, 3.92618D0, 3.49572D0,
54776 & 3.19370D0, 2.40717D0, 1.80591D0, 1.52114D0, 1.34361D0,
54777 & 1.21613D0, 0.88453D0, 0.63003D0, 0.51078D0, 0.43739D0,
54778 & 0.38633D0, 0.31813D0, 0.25609D0, 0.19674D0, 0.16076D0,
54779 & 0.11701D0, 0.09001D0, 0.07101D0, 0.05368D0, 0.04095D0,
54780 & 0.03121D0, 0.02377D0, 0.01805D0, 0.01359D0, 0.01015D0,
54781 & 0.00753D0, 0.00553D0, 0.00402D0, 0.00291D0, 0.00207D0,
54782 & 0.00142D0, 0.00101D0, 0.00071D0, 0.00045D0, 0.00030D0,
54783 & 0.00020D0, 0.00012D0, 0.00008D0, 0.00003D0, 0.00001D0,
54784 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54785 DATA (FMRS(1,6,I,26),I=1,49)/
54786 & 8.84513D0, 6.66663D0, 5.01863D0, 4.24745D0, 3.77171D0,
54787 & 3.43873D0, 2.57518D0, 1.91937D0, 1.61043D0, 1.41849D0,
54788 & 1.28102D0, 0.92509D0, 0.65405D0, 0.52788D0, 0.45056D0,
54789 & 0.39694D0, 0.32555D0, 0.26091D0, 0.19936D0, 0.16223D0,
54790 & 0.11732D0, 0.08979D0, 0.07053D0, 0.05307D0, 0.04031D0,
54791 & 0.03061D0, 0.02325D0, 0.01759D0, 0.01321D0, 0.00982D0,
54792 & 0.00728D0, 0.00532D0, 0.00387D0, 0.00279D0, 0.00197D0,
54793 & 0.00136D0, 0.00096D0, 0.00067D0, 0.00043D0, 0.00029D0,
54794 & 0.00019D0, 0.00011D0, 0.00007D0, 0.00003D0, 0.00001D0,
54795 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54796 DATA (FMRS(1,6,I,27),I=1,49)/
54797 & 9.65435D0, 7.23356D0, 5.41328D0, 4.56560D0, 4.04426D0,
54798 & 3.68017D0, 2.73960D0, 2.02962D0, 1.69683D0, 1.49072D0,
54799 & 1.34344D0, 0.96379D0, 0.67674D0, 0.54393D0, 0.46286D0,
54800 & 0.40680D0, 0.33241D0, 0.26531D0, 0.20171D0, 0.16351D0,
54801 & 0.11755D0, 0.08953D0, 0.07005D0, 0.05247D0, 0.03970D0,
54802 & 0.03004D0, 0.02275D0, 0.01715D0, 0.01284D0, 0.00953D0,
54803 & 0.00704D0, 0.00513D0, 0.00373D0, 0.00268D0, 0.00189D0,
54804 & 0.00130D0, 0.00092D0, 0.00064D0, 0.00040D0, 0.00027D0,
54805 & 0.00018D0, 0.00010D0, 0.00007D0, 0.00002D0, 0.00001D0,
54806 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54807 DATA (FMRS(1,6,I,28),I=1,49)/
54808 & 10.45602D0, 7.79175D0, 5.79941D0, 4.87575D0, 4.30926D0,
54809 & 3.91444D0, 2.89810D0, 2.13519D0, 1.77921D0, 1.55938D0,
54810 & 1.40263D0, 1.00018D0, 0.69787D0, 0.55877D0, 0.47417D0,
54811 & 0.41582D0, 0.33862D0, 0.26925D0, 0.20376D0, 0.16459D0,
54812 & 0.11767D0, 0.08923D0, 0.06955D0, 0.05189D0, 0.03911D0,
54813 & 0.02950D0, 0.02227D0, 0.01675D0, 0.01249D0, 0.00926D0,
54814 & 0.00681D0, 0.00496D0, 0.00359D0, 0.00258D0, 0.00181D0,
54815 & 0.00125D0, 0.00088D0, 0.00062D0, 0.00038D0, 0.00026D0,
54816 & 0.00017D0, 0.00010D0, 0.00007D0, 0.00002D0, 0.00001D0,
54817 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54818 DATA (FMRS(1,6,I,29),I=1,49)/
54819 & 11.30416D0, 8.37884D0, 6.20316D0, 5.19892D0, 4.58469D0,
54820 & 4.15747D0, 3.06152D0, 2.24335D0, 1.86330D0, 1.62927D0,
54821 & 1.46273D0, 1.03685D0, 0.71898D0, 0.57351D0, 0.48535D0,
54822 & 0.42471D0, 0.34469D0, 0.27305D0, 0.20570D0, 0.16558D0,
54823 & 0.11773D0, 0.08889D0, 0.06902D0, 0.05129D0, 0.03852D0,
54824 & 0.02896D0, 0.02179D0, 0.01634D0, 0.01216D0, 0.00899D0,
54825 & 0.00659D0, 0.00479D0, 0.00347D0, 0.00248D0, 0.00174D0,
54826 & 0.00119D0, 0.00084D0, 0.00059D0, 0.00036D0, 0.00024D0,
54827 & 0.00016D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00001D0,
54828 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54829 DATA (FMRS(1,6,I,30),I=1,49)/
54830 & 12.17534D0, 8.97841D0, 6.61310D0, 5.52592D0, 4.86271D0,
54831 & 4.40230D0, 3.22516D0, 2.35097D0, 1.94663D0, 1.69833D0,
54832 & 1.52199D0, 1.07270D0, 0.73942D0, 0.58770D0, 0.49605D0,
54833 & 0.43317D0, 0.35042D0, 0.27659D0, 0.20745D0, 0.16642D0,
54834 & 0.11771D0, 0.08850D0, 0.06847D0, 0.05068D0, 0.03793D0,
54835 & 0.02842D0, 0.02132D0, 0.01595D0, 0.01184D0, 0.00872D0,
54836 & 0.00639D0, 0.00464D0, 0.00334D0, 0.00238D0, 0.00167D0,
54837 & 0.00115D0, 0.00081D0, 0.00056D0, 0.00034D0, 0.00023D0,
54838 & 0.00015D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00000D0,
54839 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54840 DATA (FMRS(1,6,I,31),I=1,49)/
54841 & 13.04562D0, 9.57419D0, 7.01826D0, 5.84808D0, 5.13599D0,
54842 & 4.64254D0, 3.38483D0, 2.45538D0, 2.02720D0, 1.76492D0,
54843 & 1.57901D0, 1.10697D0, 0.75881D0, 0.60107D0, 0.50610D0,
54844 & 0.44109D0, 0.35574D0, 0.27985D0, 0.20903D0, 0.16716D0,
54845 & 0.11764D0, 0.08810D0, 0.06793D0, 0.05010D0, 0.03737D0,
54846 & 0.02791D0, 0.02089D0, 0.01558D0, 0.01154D0, 0.00848D0,
54847 & 0.00620D0, 0.00450D0, 0.00323D0, 0.00230D0, 0.00160D0,
54848 & 0.00110D0, 0.00077D0, 0.00053D0, 0.00032D0, 0.00022D0,
54849 & 0.00015D0, 0.00008D0, 0.00006D0, 0.00002D0, 0.00000D0,
54850 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54851 DATA (FMRS(1,6,I,32),I=1,49)/
54852 & 13.89443D0, 10.15226D0, 7.40931D0, 6.15805D0, 5.39834D0,
54853 & 4.87276D0, 3.53699D0, 2.55429D0, 2.10325D0, 1.82761D0,
54854 & 1.63256D0, 1.13890D0, 0.77669D0, 0.61332D0, 0.51524D0,
54855 & 0.44825D0, 0.36050D0, 0.28271D0, 0.21036D0, 0.16773D0,
54856 & 0.11750D0, 0.08767D0, 0.06738D0, 0.04952D0, 0.03683D0,
54857 & 0.02743D0, 0.02048D0, 0.01524D0, 0.01125D0, 0.00826D0,
54858 & 0.00603D0, 0.00436D0, 0.00312D0, 0.00222D0, 0.00155D0,
54859 & 0.00106D0, 0.00074D0, 0.00051D0, 0.00031D0, 0.00021D0,
54860 & 0.00014D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00001D0,
54861 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54862 DATA (FMRS(1,6,I,33),I=1,49)/
54863 & 14.79866D0, 10.76526D0, 7.82209D0, 6.48437D0, 5.67399D0,
54864 & 5.11430D0, 3.69589D0, 2.65710D0, 2.18207D0, 1.89245D0,
54865 & 1.68785D0, 1.17170D0, 0.79496D0, 0.62581D0, 0.52453D0,
54866 & 0.45551D0, 0.36532D0, 0.28560D0, 0.21171D0, 0.16831D0,
54867 & 0.11736D0, 0.08724D0, 0.06684D0, 0.04896D0, 0.03630D0,
54868 & 0.02696D0, 0.02007D0, 0.01490D0, 0.01098D0, 0.00805D0,
54869 & 0.00586D0, 0.00423D0, 0.00302D0, 0.00214D0, 0.00150D0,
54870 & 0.00102D0, 0.00071D0, 0.00049D0, 0.00030D0, 0.00020D0,
54871 & 0.00013D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00001D0,
54872 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54873 DATA (FMRS(1,6,I,34),I=1,49)/
54874 & 15.70368D0, 11.37564D0, 8.23095D0, 6.80656D0, 5.94554D0,
54875 & 5.35181D0, 3.85123D0, 2.75698D0, 2.25835D0, 1.95501D0,
54876 & 1.74107D0, 1.20298D0, 0.81219D0, 0.63747D0, 0.53315D0,
54877 & 0.46219D0, 0.36968D0, 0.28814D0, 0.21281D0, 0.16870D0,
54878 & 0.11711D0, 0.08674D0, 0.06626D0, 0.04836D0, 0.03575D0,
54879 & 0.02649D0, 0.01967D0, 0.01456D0, 0.01071D0, 0.00784D0,
54880 & 0.00568D0, 0.00409D0, 0.00292D0, 0.00207D0, 0.00144D0,
54881 & 0.00098D0, 0.00068D0, 0.00047D0, 0.00029D0, 0.00019D0,
54882 & 0.00012D0, 0.00007D0, 0.00005D0, 0.00002D0, 0.00000D0,
54883 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54884 DATA (FMRS(1,6,I,35),I=1,49)/
54885 & 16.61098D0, 11.98498D0, 8.63737D0, 7.12604D0, 6.21432D0,
54886 & 5.58657D0, 4.00413D0, 2.85486D0, 2.33290D0, 2.01603D0,
54887 & 1.79291D0, 1.23331D0, 0.82880D0, 0.64868D0, 0.54141D0,
54888 & 0.46858D0, 0.37384D0, 0.29056D0, 0.21385D0, 0.16907D0,
54889 & 0.11687D0, 0.08628D0, 0.06571D0, 0.04780D0, 0.03525D0,
54890 & 0.02604D0, 0.01929D0, 0.01425D0, 0.01046D0, 0.00764D0,
54891 & 0.00552D0, 0.00397D0, 0.00283D0, 0.00200D0, 0.00139D0,
54892 & 0.00095D0, 0.00066D0, 0.00045D0, 0.00028D0, 0.00019D0,
54893 & 0.00012D0, 0.00007D0, 0.00005D0, 0.00002D0, 0.00000D0,
54894 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54895 DATA (FMRS(1,6,I,36),I=1,49)/
54896 & 17.49641D0, 12.57703D0, 9.03053D0, 7.43428D0, 6.47316D0,
54897 & 5.81232D0, 4.15045D0, 2.94807D0, 2.40367D0, 2.07383D0,
54898 & 1.84191D0, 1.26179D0, 0.84428D0, 0.65906D0, 0.54902D0,
54899 & 0.47444D0, 0.37762D0, 0.29271D0, 0.21474D0, 0.16935D0,
54900 & 0.11660D0, 0.08580D0, 0.06517D0, 0.04726D0, 0.03476D0,
54901 & 0.02562D0, 0.01894D0, 0.01396D0, 0.01022D0, 0.00745D0,
54902 & 0.00538D0, 0.00386D0, 0.00274D0, 0.00194D0, 0.00135D0,
54903 & 0.00092D0, 0.00063D0, 0.00044D0, 0.00027D0, 0.00018D0,
54904 & 0.00011D0, 0.00007D0, 0.00005D0, 0.00002D0, 0.00000D0,
54905 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54906 DATA (FMRS(1,6,I,37),I=1,49)/
54907 & 18.41415D0, 13.18812D0, 9.43458D0, 7.75025D0, 6.73800D0,
54908 & 6.04297D0, 4.29926D0, 3.04240D0, 2.47507D0, 2.13202D0,
54909 & 1.89114D0, 1.29020D0, 0.85959D0, 0.66927D0, 0.55646D0,
54910 & 0.48015D0, 0.38126D0, 0.29476D0, 0.21554D0, 0.16955D0,
54911 & 0.11628D0, 0.08530D0, 0.06461D0, 0.04672D0, 0.03427D0,
54912 & 0.02520D0, 0.01858D0, 0.01367D0, 0.00999D0, 0.00727D0,
54913 & 0.00525D0, 0.00375D0, 0.00266D0, 0.00188D0, 0.00131D0,
54914 & 0.00088D0, 0.00061D0, 0.00042D0, 0.00026D0, 0.00017D0,
54915 & 0.00011D0, 0.00006D0, 0.00004D0, 0.00001D0, 0.00000D0,
54916 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54917 DATA (FMRS(1,6,I,38),I=1,49)/
54918 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54919 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54920 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54921 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54922 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54923 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54924 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54925 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54926 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54927 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54928 DATA (FMRS(1,7,I, 1),I=1,49)/
54929 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54930 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54931 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54932 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54933 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54934 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54935 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54936 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54937 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54938 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54939 DATA (FMRS(1,7,I, 2),I=1,49)/
54940 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54941 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54942 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54943 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54944 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54945 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54946 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54947 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54948 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54949 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54950 DATA (FMRS(1,7,I, 3),I=1,49)/
54951 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54952 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54953 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54954 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54955 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54956 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54957 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54958 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54959 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54960 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54961 DATA (FMRS(1,7,I, 4),I=1,49)/
54962 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54963 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54964 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54965 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54966 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54967 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54968 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54969 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54970 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54971 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54972 DATA (FMRS(1,7,I, 5),I=1,49)/
54973 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54974 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54975 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54976 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54977 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54978 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54979 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54980 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54981 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54982 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54983 DATA (FMRS(1,7,I, 6),I=1,49)/
54984 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54985 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54986 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54987 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54988 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54989 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54990 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54991 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54992 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54993 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
54994 DATA (FMRS(1,7,I, 7),I=1,49)/
54995 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54996 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
54997 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
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/
55005 DATA (FMRS(1,7,I, 8),I=1,49)/
55006 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55007 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55008 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55009 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55010 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55011 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55012 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55013 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55014 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55015 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55016 DATA (FMRS(1,7,I, 9),I=1,49)/
55017 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55018 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55019 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55020 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55021 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55022 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55023 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55024 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55025 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55026 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55027 DATA (FMRS(1,7,I,10),I=1,49)/
55028 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55029 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55030 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55031 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55032 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55033 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55034 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55035 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55036 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55037 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55038 DATA (FMRS(1,7,I,11),I=1,49)/
55039 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55040 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55041 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55042 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55043 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55044 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55045 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55046 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55047 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55048 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55049 DATA (FMRS(1,7,I,12),I=1,49)/
55050 & 0.00042D0, 0.00036D0, 0.00032D0, 0.00030D0, 0.00028D0,
55051 & 0.00027D0, 0.00023D0, 0.00020D0, 0.00019D0, 0.00018D0,
55052 & 0.00017D0, 0.00014D0, 0.00012D0, 0.00011D0, 0.00010D0,
55053 & 0.00009D0, 0.00008D0, 0.00007D0, 0.00006D0, 0.00005D0,
55054 & 0.00005D0, 0.00004D0, 0.00003D0, 0.00003D0, 0.00003D0,
55055 & 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00001D0,
55056 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0,
55057 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55058 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55059 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55060 DATA (FMRS(1,7,I,13),I=1,49)/
55061 & 0.21520D0, 0.16773D0, 0.13065D0, 0.11283D0, 0.10165D0,
55062 & 0.09372D0, 0.07266D0, 0.05600D0, 0.04786D0, 0.04266D0,
55063 & 0.03883D0, 0.02862D0, 0.02044D0, 0.01649D0, 0.01402D0,
55064 & 0.01228D0, 0.00994D0, 0.00781D0, 0.00579D0, 0.00460D0,
55065 & 0.00322D0, 0.00243D0, 0.00191D0, 0.00146D0, 0.00114D0,
55066 & 0.00089D0, 0.00070D0, 0.00055D0, 0.00043D0, 0.00034D0,
55067 & 0.00026D0, 0.00020D0, 0.00015D0, 0.00011D0, 0.00009D0,
55068 & 0.00006D0, 0.00005D0, 0.00003D0, 0.00002D0, 0.00001D0,
55069 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55070 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55071 DATA (FMRS(1,7,I,14),I=1,49)/
55072 & 0.62424D0, 0.48455D0, 0.37589D0, 0.32385D0, 0.29126D0,
55073 & 0.26818D0, 0.20706D0, 0.15892D0, 0.13546D0, 0.12053D0,
55074 & 0.10954D0, 0.08034D0, 0.05707D0, 0.04589D0, 0.03892D0,
55075 & 0.03403D0, 0.02747D0, 0.02151D0, 0.01589D0, 0.01258D0,
55076 & 0.00876D0, 0.00658D0, 0.00515D0, 0.00391D0, 0.00303D0,
55077 & 0.00236D0, 0.00185D0, 0.00144D0, 0.00112D0, 0.00088D0,
55078 & 0.00067D0, 0.00051D0, 0.00039D0, 0.00029D0, 0.00022D0,
55079 & 0.00016D0, 0.00011D0, 0.00008D0, 0.00006D0, 0.00004D0,
55080 & 0.00002D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55081 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55082 DATA (FMRS(1,7,I,15),I=1,49)/
55083 & 1.00765D0, 0.77678D0, 0.59844D0, 0.51350D0, 0.46049D0,
55084 & 0.42306D0, 0.32436D0, 0.24719D0, 0.20981D0, 0.18611D0,
55085 & 0.16874D0, 0.12279D0, 0.08652D0, 0.06923D0, 0.05850D0,
55086 & 0.05102D0, 0.04100D0, 0.03196D0, 0.02347D0, 0.01849D0,
55087 & 0.01279D0, 0.00955D0, 0.00743D0, 0.00560D0, 0.00430D0,
55088 & 0.00334D0, 0.00260D0, 0.00202D0, 0.00157D0, 0.00121D0,
55089 & 0.00093D0, 0.00071D0, 0.00053D0, 0.00040D0, 0.00029D0,
55090 & 0.00021D0, 0.00015D0, 0.00011D0, 0.00007D0, 0.00005D0,
55091 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55092 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55093 DATA (FMRS(1,7,I,16),I=1,49)/
55094 & 1.42250D0, 1.08981D0, 0.83442D0, 0.71339D0, 0.63810D0,
55095 & 0.58505D0, 0.44575D0, 0.33755D0, 0.28542D0, 0.25249D0,
55096 & 0.22841D0, 0.16506D0, 0.11545D0, 0.09197D0, 0.07747D0,
55097 & 0.06738D0, 0.05394D0, 0.04186D0, 0.03057D0, 0.02399D0,
55098 & 0.01648D0, 0.01223D0, 0.00946D0, 0.00708D0, 0.00541D0,
55099 & 0.00417D0, 0.00323D0, 0.00250D0, 0.00193D0, 0.00149D0,
55100 & 0.00113D0, 0.00086D0, 0.00064D0, 0.00048D0, 0.00035D0,
55101 & 0.00026D0, 0.00018D0, 0.00013D0, 0.00009D0, 0.00005D0,
55102 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55103 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55104 DATA (FMRS(1,7,I,17),I=1,49)/
55105 & 1.90329D0, 1.44918D0, 1.10274D0, 0.93938D0, 0.83807D0,
55106 & 0.76686D0, 0.58064D0, 0.43692D0, 0.36805D0, 0.32470D0,
55107 & 0.29309D0, 0.21032D0, 0.14604D0, 0.11582D0, 0.09725D0,
55108 & 0.08437D0, 0.06728D0, 0.05198D0, 0.03776D0, 0.02950D0,
55109 & 0.02012D0, 0.01485D0, 0.01142D0, 0.00850D0, 0.00645D0,
55110 & 0.00494D0, 0.00381D0, 0.00293D0, 0.00225D0, 0.00172D0,
55111 & 0.00131D0, 0.00098D0, 0.00073D0, 0.00054D0, 0.00040D0,
55112 & 0.00029D0, 0.00021D0, 0.00014D0, 0.00010D0, 0.00006D0,
55113 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55114 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55115 DATA (FMRS(1,7,I,18),I=1,49)/
55116 & 2.33137D0, 1.76616D0, 1.33713D0, 1.13567D0, 1.01106D0,
55117 & 0.92363D0, 0.69576D0, 0.52083D0, 0.43738D0, 0.38501D0,
55118 & 0.34690D0, 0.24753D0, 0.17085D0, 0.13502D0, 0.11307D0,
55119 & 0.09789D0, 0.07781D0, 0.05991D0, 0.04333D0, 0.03374D0,
55120 & 0.02288D0, 0.01680D0, 0.01286D0, 0.00952D0, 0.00719D0,
55121 & 0.00549D0, 0.00420D0, 0.00322D0, 0.00246D0, 0.00188D0,
55122 & 0.00142D0, 0.00107D0, 0.00079D0, 0.00059D0, 0.00043D0,
55123 & 0.00031D0, 0.00022D0, 0.00015D0, 0.00010D0, 0.00006D0,
55124 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55125 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55126 DATA (FMRS(1,7,I,19),I=1,49)/
55127 & 2.89798D0, 2.18213D0, 1.64207D0, 1.38971D0, 1.23410D0,
55128 & 1.12518D0, 0.84241D0, 0.62670D0, 0.52435D0, 0.46034D0,
55129 & 0.41389D0, 0.29333D0, 0.20103D0, 0.15819D0, 0.13206D0,
55130 & 0.11405D0, 0.09031D0, 0.06924D0, 0.04982D0, 0.03863D0,
55131 & 0.02602D0, 0.01899D0, 0.01446D0, 0.01064D0, 0.00798D0,
55132 & 0.00606D0, 0.00462D0, 0.00352D0, 0.00268D0, 0.00204D0,
55133 & 0.00153D0, 0.00115D0, 0.00085D0, 0.00062D0, 0.00046D0,
55134 & 0.00034D0, 0.00024D0, 0.00016D0, 0.00010D0, 0.00006D0,
55135 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55136 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55137 DATA (FMRS(1,7,I,20),I=1,49)/
55138 & 3.45978D0, 2.59142D0, 1.93977D0, 1.63658D0, 1.45012D0,
55139 & 1.31987D0, 0.98290D0, 0.72728D0, 0.60655D0, 0.53126D0,
55140 & 0.47676D0, 0.33590D0, 0.22879D0, 0.17936D0, 0.14933D0,
55141 & 0.12869D0, 0.10156D0, 0.07757D0, 0.05556D0, 0.04293D0,
55142 & 0.02875D0, 0.02087D0, 0.01582D0, 0.01157D0, 0.00864D0,
55143 & 0.00653D0, 0.00495D0, 0.00376D0, 0.00285D0, 0.00216D0,
55144 & 0.00162D0, 0.00120D0, 0.00089D0, 0.00065D0, 0.00048D0,
55145 & 0.00035D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
55146 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55147 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55148 DATA (FMRS(1,7,I,21),I=1,49)/
55149 & 3.99390D0, 2.97724D0, 2.21795D0, 1.86604D0, 1.65015D0,
55150 & 1.49961D0, 1.11138D0, 0.81834D0, 0.68051D0, 0.59480D0,
55151 & 0.53289D0, 0.37345D0, 0.25296D0, 0.19764D0, 0.16415D0,
55152 & 0.14119D0, 0.11109D0, 0.08457D0, 0.06032D0, 0.04645D0,
55153 & 0.03094D0, 0.02236D0, 0.01688D0, 0.01228D0, 0.00913D0,
55154 & 0.00687D0, 0.00519D0, 0.00392D0, 0.00296D0, 0.00223D0,
55155 & 0.00167D0, 0.00124D0, 0.00091D0, 0.00067D0, 0.00049D0,
55156 & 0.00036D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
55157 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55158 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55159 DATA (FMRS(1,7,I,22),I=1,49)/
55160 & 4.74104D0, 3.51318D0, 2.60162D0, 2.18119D0, 1.92405D0,
55161 & 1.74515D0, 1.28558D0, 0.94085D0, 0.77956D0, 0.67959D0,
55162 & 0.60758D0, 0.42298D0, 0.28453D0, 0.22138D0, 0.18331D0,
55163 & 0.15728D0, 0.12329D0, 0.09346D0, 0.06632D0, 0.05087D0,
55164 & 0.03366D0, 0.02418D0, 0.01815D0, 0.01313D0, 0.00971D0,
55165 & 0.00726D0, 0.00546D0, 0.00411D0, 0.00309D0, 0.00232D0,
55166 & 0.00172D0, 0.00128D0, 0.00094D0, 0.00068D0, 0.00049D0,
55167 & 0.00036D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0,
55168 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55169 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55170 DATA (FMRS(1,7,I,23),I=1,49)/
55171 & 5.50879D0, 4.05964D0, 2.98973D0, 2.49849D0, 2.19888D0,
55172 & 1.99086D0, 1.45844D0, 1.06135D0, 0.87646D0, 0.76222D0,
55173 & 0.68014D0, 0.47060D0, 0.31455D0, 0.24380D0, 0.20130D0,
55174 & 0.17233D0, 0.13462D0, 0.10166D0, 0.07179D0, 0.05486D0,
55175 & 0.03607D0, 0.02577D0, 0.01926D0, 0.01386D0, 0.01019D0,
55176 & 0.00758D0, 0.00568D0, 0.00425D0, 0.00318D0, 0.00238D0,
55177 & 0.00176D0, 0.00130D0, 0.00095D0, 0.00069D0, 0.00050D0,
55178 & 0.00037D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0,
55179 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55180 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55181 DATA (FMRS(1,7,I,24),I=1,49)/
55182 & 6.25919D0, 4.58931D0, 3.36270D0, 2.80183D0, 2.46064D0,
55183 & 2.22421D0, 1.62105D0, 1.17360D0, 0.96617D0, 0.83838D0,
55184 & 0.74677D0, 0.51381D0, 0.34143D0, 0.26369D0, 0.21716D0,
55185 & 0.18553D0, 0.14447D0, 0.10870D0, 0.07643D0, 0.05820D0,
55186 & 0.03805D0, 0.02705D0, 0.02012D0, 0.01441D0, 0.01054D0,
55187 & 0.00781D0, 0.00582D0, 0.00434D0, 0.00324D0, 0.00241D0,
55188 & 0.00178D0, 0.00131D0, 0.00095D0, 0.00069D0, 0.00050D0,
55189 & 0.00037D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0,
55190 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55191 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55192 DATA (FMRS(1,7,I,25),I=1,49)/
55193 & 7.07966D0, 5.16501D0, 3.76564D0, 3.12838D0, 2.74171D0,
55194 & 2.47426D0, 1.79422D0, 1.29235D0, 1.06071D0, 0.91840D0,
55195 & 0.81663D0, 0.55877D0, 0.36917D0, 0.28412D0, 0.23339D0,
55196 & 0.19900D0, 0.15447D0, 0.11582D0, 0.08108D0, 0.06153D0,
55197 & 0.03999D0, 0.02830D0, 0.02096D0, 0.01493D0, 0.01087D0,
55198 & 0.00803D0, 0.00595D0, 0.00442D0, 0.00329D0, 0.00244D0,
55199 & 0.00180D0, 0.00131D0, 0.00096D0, 0.00069D0, 0.00050D0,
55200 & 0.00036D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0,
55201 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55202 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55203 DATA (FMRS(1,7,I,26),I=1,49)/
55204 & 7.91829D0, 5.74916D0, 4.17141D0, 3.45573D0, 3.02255D0,
55205 & 2.72346D0, 1.96537D0, 1.40870D0, 1.15285D0, 0.99608D0,
55206 & 0.88421D0, 0.60182D0, 0.39541D0, 0.30330D0, 0.24854D0,
55207 & 0.21150D0, 0.16368D0, 0.12231D0, 0.08527D0, 0.06448D0,
55208 & 0.04169D0, 0.02937D0, 0.02165D0, 0.01535D0, 0.01113D0,
55209 & 0.00818D0, 0.00604D0, 0.00447D0, 0.00331D0, 0.00245D0,
55210 & 0.00180D0, 0.00131D0, 0.00095D0, 0.00068D0, 0.00049D0,
55211 & 0.00036D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0,
55212 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55213 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55214 DATA (FMRS(1,7,I,27),I=1,49)/
55215 & 8.76657D0, 6.33661D0, 4.57707D0, 3.78184D0, 3.30161D0,
55216 & 2.97059D0, 2.13403D0, 1.52261D0, 1.24269D0, 1.07161D0,
55217 & 0.94977D0, 0.64324D0, 0.42046D0, 0.32150D0, 0.26285D0,
55218 & 0.22328D0, 0.17230D0, 0.12835D0, 0.08912D0, 0.06719D0,
55219 & 0.04322D0, 0.03031D0, 0.02226D0, 0.01571D0, 0.01134D0,
55220 & 0.00830D0, 0.00611D0, 0.00451D0, 0.00333D0, 0.00245D0,
55221 & 0.00180D0, 0.00131D0, 0.00095D0, 0.00068D0, 0.00048D0,
55222 & 0.00036D0, 0.00026D0, 0.00017D0, 0.00010D0, 0.00006D0,
55223 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55224 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55225 DATA (FMRS(1,7,I,28),I=1,49)/
55226 & 9.60252D0, 6.91204D0, 4.97199D0, 4.09813D0, 3.57154D0,
55227 & 3.20914D0, 2.29574D0, 1.63105D0, 1.32784D0, 1.14296D0,
55228 & 1.01154D0, 0.68194D0, 0.44362D0, 0.33823D0, 0.27595D0,
55229 & 0.23401D0, 0.18011D0, 0.13377D0, 0.09255D0, 0.06957D0,
55230 & 0.04454D0, 0.03111D0, 0.02277D0, 0.01600D0, 0.01150D0,
55231 & 0.00839D0, 0.00616D0, 0.00453D0, 0.00333D0, 0.00245D0,
55232 & 0.00179D0, 0.00130D0, 0.00094D0, 0.00067D0, 0.00048D0,
55233 & 0.00035D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
55234 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55235 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55236 DATA (FMRS(1,7,I,29),I=1,49)/
55237 & 10.48807D0, 7.51842D0, 5.38590D0, 4.42859D0, 3.85291D0,
55238 & 3.45734D0, 2.46302D0, 1.74255D0, 1.41507D0, 1.21586D0,
55239 & 1.07451D0, 0.72111D0, 0.46688D0, 0.35494D0, 0.28897D0,
55240 & 0.24464D0, 0.18781D0, 0.13908D0, 0.09587D0, 0.07187D0,
55241 & 0.04579D0, 0.03185D0, 0.02323D0, 0.01626D0, 0.01165D0,
55242 & 0.00847D0, 0.00619D0, 0.00454D0, 0.00333D0, 0.00244D0,
55243 & 0.00178D0, 0.00129D0, 0.00093D0, 0.00066D0, 0.00047D0,
55244 & 0.00035D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
55245 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55246 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55247 DATA (FMRS(1,7,I,30),I=1,49)/
55248 & 11.39334D0, 8.13482D0, 5.80422D0, 4.76138D0, 4.13555D0,
55249 & 3.70617D0, 2.62967D0, 1.85288D0, 1.50103D0, 1.28747D0,
55250 & 1.13621D0, 0.75917D0, 0.48927D0, 0.37093D0, 0.30137D0,
55251 & 0.25473D0, 0.19506D0, 0.14404D0, 0.09894D0, 0.07396D0,
55252 & 0.04691D0, 0.03251D0, 0.02363D0, 0.01647D0, 0.01175D0,
55253 & 0.00851D0, 0.00621D0, 0.00454D0, 0.00332D0, 0.00243D0,
55254 & 0.00176D0, 0.00127D0, 0.00091D0, 0.00065D0, 0.00046D0,
55255 & 0.00034D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
55256 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55257 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55258 DATA (FMRS(1,7,I,31),I=1,49)/
55259 & 12.30020D0, 8.74942D0, 6.21933D0, 5.09070D0, 4.41468D0,
55260 & 3.95152D0, 2.79315D0, 1.96055D0, 1.58465D0, 1.35697D0,
55261 & 1.19598D0, 0.79580D0, 0.51068D0, 0.38615D0, 0.31314D0,
55262 & 0.26427D0, 0.20189D0, 0.14868D0, 0.10179D0, 0.07589D0,
55263 & 0.04793D0, 0.03309D0, 0.02397D0, 0.01665D0, 0.01184D0,
55264 & 0.00855D0, 0.00621D0, 0.00453D0, 0.00330D0, 0.00241D0,
55265 & 0.00174D0, 0.00126D0, 0.00090D0, 0.00064D0, 0.00046D0,
55266 & 0.00034D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
55267 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55268 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55269 DATA (FMRS(1,7,I,32),I=1,49)/
55270 & 13.17835D0, 9.34137D0, 6.61692D0, 5.40505D0, 4.68045D0,
55271 & 4.18467D0, 2.94753D0, 2.06155D0, 1.66276D0, 1.42169D0,
55272 & 1.25150D0, 0.82954D0, 0.53019D0, 0.39993D0, 0.32374D0,
55273 & 0.27283D0, 0.20796D0, 0.15278D0, 0.10427D0, 0.07755D0,
55274 & 0.04878D0, 0.03356D0, 0.02424D0, 0.01677D0, 0.01189D0,
55275 & 0.00856D0, 0.00621D0, 0.00451D0, 0.00328D0, 0.00239D0,
55276 & 0.00173D0, 0.00124D0, 0.00089D0, 0.00063D0, 0.00045D0,
55277 & 0.00033D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
55278 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55279 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55280 DATA (FMRS(1,7,I,33),I=1,49)/
55281 & 14.12059D0, 9.97430D0, 7.04054D0, 5.73929D0, 4.96264D0,
55282 & 4.43195D0, 3.11069D0, 2.16791D0, 1.74484D0, 1.48959D0,
55283 & 1.30967D0, 0.86476D0, 0.55049D0, 0.41422D0, 0.33471D0,
55284 & 0.28168D0, 0.21423D0, 0.15699D0, 0.10682D0, 0.07925D0,
55285 & 0.04965D0, 0.03404D0, 0.02451D0, 0.01690D0, 0.01194D0,
55286 & 0.00857D0, 0.00620D0, 0.00449D0, 0.00326D0, 0.00237D0,
55287 & 0.00171D0, 0.00123D0, 0.00088D0, 0.00062D0, 0.00044D0,
55288 & 0.00032D0, 0.00025D0, 0.00017D0, 0.00010D0, 0.00006D0,
55289 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55290 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55291 DATA (FMRS(1,7,I,34),I=1,49)/
55292 & 15.05309D0, 10.59701D0, 7.45476D0, 6.06488D0, 5.23678D0,
55293 & 4.67164D0, 3.26773D0, 2.26948D0, 1.82284D0, 1.55389D0,
55294 & 1.36460D0, 0.89767D0, 0.56921D0, 0.42730D0, 0.34468D0,
55295 & 0.28967D0, 0.21983D0, 0.16070D0, 0.10902D0, 0.08069D0,
55296 & 0.05036D0, 0.03441D0, 0.02470D0, 0.01698D0, 0.01196D0,
55297 & 0.00856D0, 0.00617D0, 0.00446D0, 0.00323D0, 0.00234D0,
55298 & 0.00168D0, 0.00121D0, 0.00086D0, 0.00061D0, 0.00043D0,
55299 & 0.00032D0, 0.00024D0, 0.00017D0, 0.00010D0, 0.00006D0,
55300 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55301 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55302 DATA (FMRS(1,7,I,35),I=1,49)/
55303 & 15.99294D0, 11.22254D0, 7.86947D0, 6.39022D0, 5.51032D0,
55304 & 4.91055D0, 3.42373D0, 2.37005D0, 1.89992D0, 1.61733D0,
55305 & 1.41872D0, 0.92998D0, 0.58753D0, 0.44006D0, 0.35440D0,
55306 & 0.29744D0, 0.22527D0, 0.16430D0, 0.11114D0, 0.08207D0,
55307 & 0.05103D0, 0.03476D0, 0.02489D0, 0.01705D0, 0.01198D0,
55308 & 0.00855D0, 0.00615D0, 0.00444D0, 0.00321D0, 0.00232D0,
55309 & 0.00166D0, 0.00119D0, 0.00085D0, 0.00060D0, 0.00042D0,
55310 & 0.00031D0, 0.00024D0, 0.00017D0, 0.00010D0, 0.00006D0,
55311 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55312 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55313 DATA (FMRS(1,7,I,36),I=1,49)/
55314 & 16.90825D0, 11.82917D0, 8.26989D0, 6.70353D0, 5.77324D0,
55315 & 5.13985D0, 3.57272D0, 2.46560D0, 1.97292D0, 1.67727D0,
55316 & 1.46976D0, 0.96025D0, 0.60456D0, 0.45187D0, 0.36334D0,
55317 & 0.30458D0, 0.23023D0, 0.16756D0, 0.11304D0, 0.08330D0,
55318 & 0.05162D0, 0.03506D0, 0.02503D0, 0.01710D0, 0.01198D0,
55319 & 0.00853D0, 0.00612D0, 0.00440D0, 0.00318D0, 0.00229D0,
55320 & 0.00164D0, 0.00117D0, 0.00083D0, 0.00059D0, 0.00042D0,
55321 & 0.00031D0, 0.00024D0, 0.00017D0, 0.00010D0, 0.00006D0,
55322 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55323 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55324 DATA (FMRS(1,7,I,37),I=1,49)/
55325 & 17.85379D0, 12.45318D0, 8.67996D0, 7.02354D0, 6.04126D0,
55326 & 5.37323D0, 3.72362D0, 2.56187D0, 2.04622D0, 1.73730D0,
55327 & 1.52078D0, 0.99029D0, 0.62133D0, 0.46343D0, 0.37206D0,
55328 & 0.31151D0, 0.23502D0, 0.17068D0, 0.11483D0, 0.08444D0,
55329 & 0.05214D0, 0.03531D0, 0.02515D0, 0.01713D0, 0.01196D0,
55330 & 0.00850D0, 0.00608D0, 0.00437D0, 0.00315D0, 0.00226D0,
55331 & 0.00162D0, 0.00115D0, 0.00082D0, 0.00058D0, 0.00041D0,
55332 & 0.00030D0, 0.00024D0, 0.00017D0, 0.00010D0, 0.00006D0,
55333 & 0.00003D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
55334 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55335 DATA (FMRS(1,7,I,38),I=1,49)/
55336 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55337 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55338 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55339 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55340 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55341 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55342 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55343 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55344 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55345 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55346 DATA (FMRS(1,8,I, 1),I=1,49)/
55347 & 0.88043D0, 0.77333D0, 0.67888D0, 0.62888D0, 0.59555D0,
55348 & 0.57086D0, 0.50019D0, 0.43775D0, 0.40464D0, 0.38254D0,
55349 & 0.36610D0, 0.31885D0, 0.27689D0, 0.25464D0, 0.23989D0,
55350 & 0.22903D0, 0.21364D0, 0.19859D0, 0.18303D0, 0.17273D0,
55351 & 0.15826D0, 0.14656D0, 0.13527D0, 0.12062D0, 0.10522D0,
55352 & 0.08955D0, 0.07420D0, 0.05981D0, 0.04692D0, 0.03554D0,
55353 & 0.02630D0, 0.01878D0, 0.01298D0, 0.00870D0, 0.00554D0,
55354 & 0.00339D0, 0.00198D0, 0.00110D0, 0.00049D0, 0.00026D0,
55355 & 0.00012D0, 0.00002D0, 0.00002D0, 0.00000D0, -0.00001D0,
55356 & -0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
55357 DATA (FMRS(1,8,I, 2),I=1,49)/
55358 & 0.89442D0, 0.78714D0, 0.69235D0, 0.64208D0, 0.60853D0,
55359 & 0.58367D0, 0.51236D0, 0.44919D0, 0.41561D0, 0.39314D0,
55360 & 0.37639D0, 0.32808D0, 0.28485D0, 0.26176D0, 0.24637D0,
55361 & 0.23501D0, 0.21882D0, 0.20291D0, 0.18634D0, 0.17532D0,
55362 & 0.15979D0, 0.14730D0, 0.13538D0, 0.12014D0, 0.10435D0,
55363 & 0.08847D0, 0.07306D0, 0.05873D0, 0.04595D0, 0.03477D0,
55364 & 0.02571D0, 0.01837D0, 0.01273D0, 0.00855D0, 0.00550D0,
55365 & 0.00340D0, 0.00204D0, 0.00117D0, 0.00055D0, 0.00031D0,
55366 & 0.00017D0, 0.00006D0, 0.00005D0, 0.00001D0, 0.00000D0,
55367 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55368 DATA (FMRS(1,8,I, 3),I=1,49)/
55369 & 0.93116D0, 0.82082D0, 0.72315D0, 0.67127D0, 0.63662D0,
55370 & 0.61092D0, 0.53708D0, 0.47148D0, 0.43647D0, 0.41299D0,
55371 & 0.39541D0, 0.34450D0, 0.29850D0, 0.27374D0, 0.25714D0,
55372 & 0.24483D0, 0.22722D0, 0.20981D0, 0.19154D0, 0.17933D0,
55373 & 0.16210D0, 0.14837D0, 0.13550D0, 0.11937D0, 0.10300D0,
55374 & 0.08681D0, 0.07133D0, 0.05711D0, 0.04449D0, 0.03362D0,
55375 & 0.02480D0, 0.01774D0, 0.01234D0, 0.00831D0, 0.00539D0,
55376 & 0.00338D0, 0.00208D0, 0.00122D0, 0.00062D0, 0.00038D0,
55377 & 0.00022D0, 0.00010D0, 0.00007D0, 0.00002D0, 0.00001D0,
55378 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55379 DATA (FMRS(1,8,I, 4),I=1,49)/
55380 & 0.97222D0, 0.85703D0, 0.75505D0, 0.70088D0, 0.66470D0,
55381 & 0.63785D0, 0.56070D0, 0.49207D0, 0.45539D0, 0.43075D0,
55382 & 0.41225D0, 0.35857D0, 0.30984D0, 0.28350D0, 0.26581D0,
55383 & 0.25266D0, 0.23382D0, 0.21514D0, 0.19549D0, 0.18234D0,
55384 & 0.16379D0, 0.14912D0, 0.13552D0, 0.11873D0, 0.10198D0,
55385 & 0.08556D0, 0.07005D0, 0.05591D0, 0.04344D0, 0.03278D0,
55386 & 0.02413D0, 0.01727D0, 0.01201D0, 0.00813D0, 0.00530D0,
55387 & 0.00334D0, 0.00207D0, 0.00123D0, 0.00065D0, 0.00042D0,
55388 & 0.00025D0, 0.00012D0, 0.00009D0, 0.00002D0, 0.00002D0,
55389 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55390 DATA (FMRS(1,8,I, 5),I=1,49)/
55391 & 1.03488D0, 0.91080D0, 0.80113D0, 0.74294D0, 0.70410D0,
55392 & 0.67529D0, 0.59258D0, 0.51904D0, 0.47974D0, 0.45332D0,
55393 & 0.43343D0, 0.37573D0, 0.32325D0, 0.29486D0, 0.27577D0,
55394 & 0.26158D0, 0.24123D0, 0.22104D0, 0.19979D0, 0.18555D0,
55395 & 0.16552D0, 0.14984D0, 0.13548D0, 0.11801D0, 0.10084D0,
55396 & 0.08422D0, 0.06865D0, 0.05459D0, 0.04229D0, 0.03183D0,
55397 & 0.02342D0, 0.01674D0, 0.01163D0, 0.00790D0, 0.00517D0,
55398 & 0.00326D0, 0.00204D0, 0.00126D0, 0.00069D0, 0.00044D0,
55399 & 0.00027D0, 0.00014D0, 0.00010D0, 0.00004D0, 0.00001D0,
55400 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55401 DATA (FMRS(1,8,I, 6),I=1,49)/
55402 & 1.09976D0, 0.96588D0, 0.84779D0, 0.78524D0, 0.74353D0,
55403 & 0.71261D0, 0.62395D0, 0.54523D0, 0.50318D0, 0.47492D0,
55404 & 0.45362D0, 0.39183D0, 0.33563D0, 0.30525D0, 0.28482D0,
55405 & 0.26964D0, 0.24787D0, 0.22628D0, 0.20357D0, 0.18835D0,
55406 & 0.16700D0, 0.15043D0, 0.13540D0, 0.11734D0, 0.09983D0,
55407 & 0.08303D0, 0.06744D0, 0.05346D0, 0.04131D0, 0.03103D0,
55408 & 0.02280D0, 0.01628D0, 0.01131D0, 0.00768D0, 0.00506D0,
55409 & 0.00319D0, 0.00201D0, 0.00126D0, 0.00071D0, 0.00044D0,
55410 & 0.00028D0, 0.00015D0, 0.00010D0, 0.00005D0, 0.00001D0,
55411 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55412 DATA (FMRS(1,8,I, 7),I=1,49)/
55413 & 1.17764D0, 1.03108D0, 0.90223D0, 0.83415D0, 0.78882D0,
55414 & 0.75526D0, 0.65918D0, 0.57411D0, 0.52875D0, 0.49829D0,
55415 & 0.47532D0, 0.40880D0, 0.34842D0, 0.31585D0, 0.29397D0,
55416 & 0.27773D0, 0.25447D0, 0.23144D0, 0.20722D0, 0.19102D0,
55417 & 0.16837D0, 0.15091D0, 0.13525D0, 0.11665D0, 0.09880D0,
55418 & 0.08184D0, 0.06625D0, 0.05236D0, 0.04036D0, 0.03026D0,
55419 & 0.02219D0, 0.01583D0, 0.01099D0, 0.00745D0, 0.00494D0,
55420 & 0.00313D0, 0.00199D0, 0.00124D0, 0.00071D0, 0.00044D0,
55421 & 0.00028D0, 0.00014D0, 0.00011D0, 0.00005D0, 0.00001D0,
55422 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55423 DATA (FMRS(1,8,I, 8),I=1,49)/
55424 & 1.27508D0, 1.11188D0, 0.96899D0, 0.89374D0, 0.84374D0,
55425 & 0.80677D0, 0.70124D0, 0.60814D0, 0.55864D0, 0.52545D0,
55426 & 0.50042D0, 0.42815D0, 0.36279D0, 0.32765D0, 0.30409D0,
55427 & 0.28664D0, 0.26167D0, 0.23701D0, 0.21111D0, 0.19383D0,
55428 & 0.16977D0, 0.15136D0, 0.13503D0, 0.11586D0, 0.09768D0,
55429 & 0.08056D0, 0.06499D0, 0.05119D0, 0.03935D0, 0.02943D0,
55430 & 0.02154D0, 0.01534D0, 0.01065D0, 0.00723D0, 0.00480D0,
55431 & 0.00305D0, 0.00194D0, 0.00121D0, 0.00071D0, 0.00043D0,
55432 & 0.00029D0, 0.00014D0, 0.00011D0, 0.00005D0, 0.00001D0,
55433 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55434 DATA (FMRS(1,8,I, 9),I=1,49)/
55435 & 1.37316D0, 1.19249D0, 1.03498D0, 0.95232D0, 0.89751D0,
55436 & 0.85705D0, 0.74185D0, 0.64064D0, 0.58699D0, 0.55108D0,
55437 & 0.52402D0, 0.44610D0, 0.37594D0, 0.33836D0, 0.31323D0,
55438 & 0.29464D0, 0.26809D0, 0.24193D0, 0.21452D0, 0.19627D0,
55439 & 0.17094D0, 0.15171D0, 0.13480D0, 0.11515D0, 0.09667D0,
55440 & 0.07946D0, 0.06388D0, 0.05018D0, 0.03847D0, 0.02871D0,
55441 & 0.02099D0, 0.01493D0, 0.01036D0, 0.00705D0, 0.00466D0,
55442 & 0.00297D0, 0.00189D0, 0.00119D0, 0.00071D0, 0.00043D0,
55443 & 0.00029D0, 0.00015D0, 0.00010D0, 0.00005D0, 0.00002D0,
55444 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55445 DATA (FMRS(1,8,I,10),I=1,49)/
55446 & 1.48232D0, 1.28141D0, 1.10710D0, 1.01596D0, 0.95567D0,
55447 & 0.91125D0, 0.78516D0, 0.67489D0, 0.61664D0, 0.57774D0,
55448 & 0.54846D0, 0.46445D0, 0.38919D0, 0.34906D0, 0.32230D0,
55449 & 0.30254D0, 0.27439D0, 0.24670D0, 0.21778D0, 0.19857D0,
55450 & 0.17201D0, 0.15198D0, 0.13451D0, 0.11441D0, 0.09567D0,
55451 & 0.07837D0, 0.06280D0, 0.04920D0, 0.03762D0, 0.02802D0,
55452 & 0.02045D0, 0.01454D0, 0.01009D0, 0.00685D0, 0.00453D0,
55453 & 0.00289D0, 0.00185D0, 0.00117D0, 0.00069D0, 0.00044D0,
55454 & 0.00029D0, 0.00015D0, 0.00011D0, 0.00004D0, 0.00002D0,
55455 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55456 DATA (FMRS(1,8,I,11),I=1,49)/
55457 & 1.57825D0, 1.35904D0, 1.16962D0, 1.07091D0, 1.00575D0,
55458 & 0.95780D0, 0.82207D0, 0.70384D0, 0.64159D0, 0.60009D0,
55459 & 0.56890D0, 0.47964D0, 0.40007D0, 0.35779D0, 0.32966D0,
55460 & 0.30893D0, 0.27945D0, 0.25052D0, 0.22036D0, 0.20038D0,
55461 & 0.17283D0, 0.15216D0, 0.13426D0, 0.11380D0, 0.09487D0,
55462 & 0.07750D0, 0.06195D0, 0.04843D0, 0.03696D0, 0.02748D0,
55463 & 0.02002D0, 0.01423D0, 0.00988D0, 0.00669D0, 0.00443D0,
55464 & 0.00283D0, 0.00181D0, 0.00116D0, 0.00068D0, 0.00044D0,
55465 & 0.00028D0, 0.00016D0, 0.00011D0, 0.00004D0, 0.00001D0,
55466 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55467 DATA (FMRS(1,8,I,12),I=1,49)/
55468 & 1.81391D0, 1.54794D0, 1.32027D0, 1.20251D0, 1.12515D0,
55469 & 1.06843D0, 0.90882D0, 0.77111D0, 0.69913D0, 0.65138D0,
55470 & 0.61560D0, 0.51392D0, 0.42424D0, 0.37702D0, 0.34578D0,
55471 & 0.32285D0, 0.29039D0, 0.25868D0, 0.22580D0, 0.20412D0,
55472 & 0.17445D0, 0.15244D0, 0.13361D0, 0.11242D0, 0.09312D0,
55473 & 0.07561D0, 0.06012D0, 0.04679D0, 0.03556D0, 0.02636D0,
55474 & 0.01913D0, 0.01356D0, 0.00940D0, 0.00637D0, 0.00422D0,
55475 & 0.00270D0, 0.00172D0, 0.00112D0, 0.00066D0, 0.00042D0,
55476 & 0.00027D0, 0.00016D0, 0.00011D0, 0.00004D0, 0.00001D0,
55477 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55478 DATA (FMRS(1,8,I,13),I=1,49)/
55479 & 2.05224D0, 1.73683D0, 1.46916D0, 1.33169D0, 1.24177D0,
55480 & 1.17604D0, 0.99216D0, 0.83488D0, 0.75325D0, 0.69933D0,
55481 & 0.65905D0, 0.54532D0, 0.44603D0, 0.39419D0, 0.36006D0,
55482 & 0.33511D0, 0.29992D0, 0.26571D0, 0.23041D0, 0.20724D0,
55483 & 0.17571D0, 0.15255D0, 0.13296D0, 0.11116D0, 0.09157D0,
55484 & 0.07397D0, 0.05855D0, 0.04538D0, 0.03436D0, 0.02540D0,
55485 & 0.01839D0, 0.01299D0, 0.00900D0, 0.00610D0, 0.00403D0,
55486 & 0.00259D0, 0.00165D0, 0.00107D0, 0.00064D0, 0.00040D0,
55487 & 0.00027D0, 0.00015D0, 0.00011D0, 0.00004D0, 0.00001D0,
55488 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55489 DATA (FMRS(1,8,I,14),I=1,49)/
55490 & 2.36037D0, 1.97834D0, 1.65740D0, 1.49390D0, 1.38749D0,
55491 & 1.31001D0, 1.09465D0, 0.91231D0, 0.81846D0, 0.75678D0,
55492 & 0.71089D0, 0.58224D0, 0.47125D0, 0.41385D0, 0.37630D0,
55493 & 0.34896D0, 0.31058D0, 0.27348D0, 0.23541D0, 0.21054D0,
55494 & 0.17694D0, 0.15252D0, 0.13212D0, 0.10968D0, 0.08980D0,
55495 & 0.07213D0, 0.05680D0, 0.04381D0, 0.03304D0, 0.02434D0,
55496 & 0.01758D0, 0.01241D0, 0.00857D0, 0.00582D0, 0.00382D0,
55497 & 0.00247D0, 0.00159D0, 0.00103D0, 0.00060D0, 0.00038D0,
55498 & 0.00026D0, 0.00014D0, 0.00011D0, 0.00004D0, 0.00001D0,
55499 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55500 DATA (FMRS(1,8,I,15),I=1,49)/
55501 & 2.73224D0, 2.26638D0, 1.87922D0, 1.68367D0, 1.55710D0,
55502 & 1.46530D0, 1.21194D0, 0.99975D0, 0.89148D0, 0.82073D0,
55503 & 0.76831D0, 0.62250D0, 0.49828D0, 0.43470D0, 0.39338D0,
55504 & 0.36342D0, 0.32158D0, 0.28138D0, 0.24036D0, 0.21374D0,
55505 & 0.17800D0, 0.15230D0, 0.13108D0, 0.10804D0, 0.08789D0,
55506 & 0.07017D0, 0.05499D0, 0.04222D0, 0.03170D0, 0.02325D0,
55507 & 0.01673D0, 0.01178D0, 0.00810D0, 0.00551D0, 0.00361D0,
55508 & 0.00232D0, 0.00150D0, 0.00098D0, 0.00058D0, 0.00036D0,
55509 & 0.00025D0, 0.00014D0, 0.00010D0, 0.00004D0, 0.00001D0,
55510 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55511 DATA (FMRS(1,8,I,16),I=1,49)/
55512 & 3.11511D0, 2.55975D0, 2.10267D0, 1.87361D0, 1.72607D0,
55513 & 1.61945D0, 1.32704D0, 1.08455D0, 0.96180D0, 0.88200D0,
55514 & 0.82308D0, 0.66038D0, 0.52333D0, 0.45384D0, 0.40893D0,
55515 & 0.37652D0, 0.33144D0, 0.28836D0, 0.24465D0, 0.21643D0,
55516 & 0.17877D0, 0.15196D0, 0.13002D0, 0.10649D0, 0.08613D0,
55517 & 0.06841D0, 0.05335D0, 0.04078D0, 0.03051D0, 0.02230D0,
55518 & 0.01601D0, 0.01123D0, 0.00772D0, 0.00522D0, 0.00344D0,
55519 & 0.00221D0, 0.00143D0, 0.00094D0, 0.00056D0, 0.00035D0,
55520 & 0.00023D0, 0.00014D0, 0.00009D0, 0.00004D0, 0.00001D0,
55521 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55522 DATA (FMRS(1,8,I,17),I=1,49)/
55523 & 3.54920D0, 2.88904D0, 2.35096D0, 2.08340D0, 1.91191D0,
55524 & 1.78843D0, 1.45191D0, 1.17555D0, 1.03678D0, 0.94701D0,
55525 & 0.88099D0, 0.69993D0, 0.54914D0, 0.47339D0, 0.42472D0,
55526 & 0.38973D0, 0.34130D0, 0.29525D0, 0.24881D0, 0.21897D0,
55527 & 0.17941D0, 0.15149D0, 0.12887D0, 0.10488D0, 0.08433D0,
55528 & 0.06664D0, 0.05172D0, 0.03936D0, 0.02933D0, 0.02138D0,
55529 & 0.01531D0, 0.01070D0, 0.00735D0, 0.00494D0, 0.00327D0,
55530 & 0.00210D0, 0.00135D0, 0.00089D0, 0.00053D0, 0.00034D0,
55531 & 0.00022D0, 0.00013D0, 0.00009D0, 0.00004D0, 0.00001D0,
55532 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55533 DATA (FMRS(1,8,I,18),I=1,49)/
55534 & 3.94722D0, 3.18825D0, 2.57451D0, 2.27128D0, 2.07769D0,
55535 & 1.93872D0, 1.56191D0, 1.25495D0, 1.10181D0, 1.00316D0,
55536 & 0.93081D0, 0.73357D0, 0.57081D0, 0.48966D0, 0.43777D0,
55537 & 0.40060D0, 0.34934D0, 0.30080D0, 0.25209D0, 0.22090D0,
55538 & 0.17980D0, 0.15100D0, 0.12785D0, 0.10349D0, 0.08283D0,
55539 & 0.06518D0, 0.05037D0, 0.03822D0, 0.02839D0, 0.02063D0,
55540 & 0.01472D0, 0.01026D0, 0.00705D0, 0.00475D0, 0.00313D0,
55541 & 0.00200D0, 0.00129D0, 0.00084D0, 0.00049D0, 0.00033D0,
55542 & 0.00020D0, 0.00013D0, 0.00009D0, 0.00003D0, 0.00001D0,
55543 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55544 DATA (FMRS(1,8,I,19),I=1,49)/
55545 & 4.47623D0, 3.58243D0, 2.86642D0, 2.51532D0, 2.29224D0,
55546 & 2.13264D0, 1.70256D0, 1.35552D0, 1.18371D0, 1.07357D0,
55547 & 0.99309D0, 0.77516D0, 0.59726D0, 0.50937D0, 0.45348D0,
55548 & 0.41360D0, 0.35886D0, 0.30730D0, 0.25582D0, 0.22304D0,
55549 & 0.18010D0, 0.15028D0, 0.12653D0, 0.10177D0, 0.08099D0,
55550 & 0.06341D0, 0.04879D0, 0.03686D0, 0.02728D0, 0.01973D0,
55551 & 0.01404D0, 0.00977D0, 0.00668D0, 0.00449D0, 0.00295D0,
55552 & 0.00189D0, 0.00122D0, 0.00079D0, 0.00046D0, 0.00031D0,
55553 & 0.00019D0, 0.00011D0, 0.00008D0, 0.00003D0, 0.00001D0,
55554 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55555 DATA (FMRS(1,8,I,20),I=1,49)/
55556 & 4.99213D0, 3.96349D0, 3.14614D0, 2.74797D0, 2.49601D0,
55557 & 2.31631D0, 1.83458D0, 1.44905D0, 1.25946D0, 1.13844D0,
55558 & 1.05027D0, 0.81294D0, 0.62102D0, 0.52694D0, 0.46740D0,
55559 & 0.42508D0, 0.36719D0, 0.31292D0, 0.25900D0, 0.22482D0,
55560 & 0.18028D0, 0.14958D0, 0.12531D0, 0.10024D0, 0.07938D0,
55561 & 0.06186D0, 0.04742D0, 0.03568D0, 0.02633D0, 0.01896D0,
55562 & 0.01347D0, 0.00937D0, 0.00636D0, 0.00427D0, 0.00280D0,
55563 & 0.00180D0, 0.00116D0, 0.00076D0, 0.00045D0, 0.00029D0,
55564 & 0.00019D0, 0.00009D0, 0.00007D0, 0.00003D0, 0.00001D0,
55565 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55566 DATA (FMRS(1,8,I,21),I=1,49)/
55567 & 5.49949D0, 4.33534D0, 3.41695D0, 2.97216D0, 2.69173D0,
55568 & 2.49225D0, 1.96002D0, 1.53717D0, 1.33047D0, 1.19901D0,
55569 & 1.10350D0, 0.84773D0, 0.64263D0, 0.54279D0, 0.47988D0,
55570 & 0.43530D0, 0.37453D0, 0.31778D0, 0.26166D0, 0.22622D0,
55571 & 0.18027D0, 0.14882D0, 0.12412D0, 0.09878D0, 0.07788D0,
55572 & 0.06045D0, 0.04618D0, 0.03463D0, 0.02546D0, 0.01831D0,
55573 & 0.01296D0, 0.00899D0, 0.00611D0, 0.00409D0, 0.00268D0,
55574 & 0.00172D0, 0.00111D0, 0.00073D0, 0.00045D0, 0.00028D0,
55575 & 0.00018D0, 0.00010D0, 0.00007D0, 0.00003D0, 0.00001D0,
55576 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55577 DATA (FMRS(1,8,I,22),I=1,49)/
55578 & 6.19994D0, 4.84455D0, 3.78480D0, 3.27524D0, 2.95541D0,
55579 & 2.72867D0, 2.12718D0, 1.65361D0, 1.42381D0, 1.27834D0,
55580 & 1.17300D0, 0.89272D0, 0.67027D0, 0.56291D0, 0.49563D0,
55581 & 0.44814D0, 0.38367D0, 0.32378D0, 0.26487D0, 0.22786D0,
55582 & 0.18016D0, 0.14778D0, 0.12256D0, 0.09693D0, 0.07601D0,
55583 & 0.05870D0, 0.04463D0, 0.03333D0, 0.02440D0, 0.01750D0,
55584 & 0.01234D0, 0.00854D0, 0.00580D0, 0.00388D0, 0.00253D0,
55585 & 0.00162D0, 0.00104D0, 0.00069D0, 0.00042D0, 0.00026D0,
55586 & 0.00018D0, 0.00010D0, 0.00006D0, 0.00003D0, 0.00001D0,
55587 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55588 DATA (FMRS(1,8,I,23),I=1,49)/
55589 & 6.91850D0, 5.36248D0, 4.15576D0, 3.57933D0, 3.21903D0,
55590 & 2.96436D0, 2.29236D0, 1.76765D0, 1.51472D0, 1.35530D0,
55591 & 1.24020D0, 0.93576D0, 0.69640D0, 0.58179D0, 0.51031D0,
55592 & 0.46004D0, 0.39207D0, 0.32922D0, 0.26771D0, 0.22925D0,
55593 & 0.17994D0, 0.14672D0, 0.12105D0, 0.09521D0, 0.07427D0,
55594 & 0.05708D0, 0.04320D0, 0.03213D0, 0.02345D0, 0.01676D0,
55595 & 0.01179D0, 0.00813D0, 0.00551D0, 0.00368D0, 0.00240D0,
55596 & 0.00152D0, 0.00099D0, 0.00064D0, 0.00039D0, 0.00024D0,
55597 & 0.00017D0, 0.00009D0, 0.00006D0, 0.00003D0, 0.00001D0,
55598 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55599 DATA (FMRS(1,8,I,24),I=1,49)/
55600 & 7.63491D0, 5.87479D0, 4.51976D0, 3.87632D0, 3.47562D0,
55601 & 3.19317D0, 2.45140D0, 1.87649D0, 1.60104D0, 1.42808D0,
55602 & 1.30355D0, 0.97589D0, 0.72045D0, 0.59900D0, 0.52360D0,
55603 & 0.47074D0, 0.39952D0, 0.33394D0, 0.27005D0, 0.23029D0,
55604 & 0.17956D0, 0.14561D0, 0.11956D0, 0.09355D0, 0.07262D0,
55605 & 0.05557D0, 0.04190D0, 0.03105D0, 0.02258D0, 0.01609D0,
55606 & 0.01128D0, 0.00777D0, 0.00525D0, 0.00350D0, 0.00227D0,
55607 & 0.00145D0, 0.00095D0, 0.00060D0, 0.00036D0, 0.00023D0,
55608 & 0.00015D0, 0.00008D0, 0.00006D0, 0.00003D0, 0.00001D0,
55609 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55610 DATA (FMRS(1,8,I,25),I=1,49)/
55611 & 8.40875D0, 6.42416D0, 4.90727D0, 4.19114D0, 3.74679D0,
55612 & 3.43441D0, 2.61784D0, 1.98954D0, 1.69029D0, 1.50308D0,
55613 & 1.36865D0, 1.01677D0, 0.74472D0, 0.61626D0, 0.53686D0,
55614 & 0.48138D0, 0.40687D0, 0.33856D0, 0.27230D0, 0.23124D0,
55615 & 0.17912D0, 0.14448D0, 0.11807D0, 0.09190D0, 0.07100D0,
55616 & 0.05410D0, 0.04063D0, 0.03001D0, 0.02174D0, 0.01545D0,
55617 & 0.01080D0, 0.00742D0, 0.00500D0, 0.00332D0, 0.00215D0,
55618 & 0.00138D0, 0.00091D0, 0.00056D0, 0.00034D0, 0.00022D0,
55619 & 0.00014D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00001D0,
55620 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55621 DATA (FMRS(1,8,I,26),I=1,49)/
55622 & 9.20959D0, 6.98865D0, 5.30257D0, 4.51092D0, 4.02140D0,
55623 & 3.67813D0, 2.78472D0, 2.10201D0, 1.77866D0, 1.57708D0,
55624 & 1.43269D0, 1.05659D0, 0.76808D0, 0.63273D0, 0.54942D0,
55625 & 0.49139D0, 0.41371D0, 0.34277D0, 0.27426D0, 0.23197D0,
55626 & 0.17855D0, 0.14327D0, 0.11656D0, 0.09025D0, 0.06944D0,
55627 & 0.05268D0, 0.03941D0, 0.02899D0, 0.02094D0, 0.01485D0,
55628 & 0.01035D0, 0.00708D0, 0.00476D0, 0.00316D0, 0.00205D0,
55629 & 0.00131D0, 0.00085D0, 0.00054D0, 0.00031D0, 0.00021D0,
55630 & 0.00013D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00001D0,
55631 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55632 DATA (FMRS(1,8,I,27),I=1,49)/
55633 & 10.01660D0, 7.55374D0, 5.69567D0, 4.82767D0, 4.29265D0,
55634 & 3.91834D0, 2.94808D0, 2.21134D0, 1.86419D0, 1.64848D0,
55635 & 1.49433D0, 1.09459D0, 0.79015D0, 0.64820D0, 0.56116D0,
55636 & 0.50070D0, 0.42001D0, 0.34660D0, 0.27598D0, 0.23256D0,
55637 & 0.17794D0, 0.14210D0, 0.11511D0, 0.08871D0, 0.06797D0,
55638 & 0.05137D0, 0.03829D0, 0.02806D0, 0.02022D0, 0.01430D0,
55639 & 0.00994D0, 0.00679D0, 0.00455D0, 0.00301D0, 0.00196D0,
55640 & 0.00124D0, 0.00081D0, 0.00052D0, 0.00030D0, 0.00020D0,
55641 & 0.00013D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00001D0,
55642 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55643 DATA (FMRS(1,8,I,28),I=1,49)/
55644 & 10.81622D0, 8.11020D0, 6.08037D0, 5.13653D0, 4.55643D0,
55645 & 4.15146D0, 3.10560D0, 2.31605D0, 1.94577D0, 1.71637D0,
55646 & 1.55278D0, 1.13032D0, 0.81070D0, 0.66250D0, 0.57195D0,
55647 & 0.50921D0, 0.42571D0, 0.35000D0, 0.27744D0, 0.23299D0,
55648 & 0.17730D0, 0.14094D0, 0.11373D0, 0.08726D0, 0.06658D0,
55649 & 0.05015D0, 0.03725D0, 0.02723D0, 0.01957D0, 0.01380D0,
55650 & 0.00957D0, 0.00653D0, 0.00437D0, 0.00288D0, 0.00188D0,
55651 & 0.00119D0, 0.00077D0, 0.00050D0, 0.00029D0, 0.00019D0,
55652 & 0.00012D0, 0.00007D0, 0.00005D0, 0.00002D0, 0.00001D0,
55653 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55654 DATA (FMRS(1,8,I,29),I=1,49)/
55655 & 11.66230D0, 8.69558D0, 6.48269D0, 5.45841D0, 4.83067D0,
55656 & 4.39335D0, 3.26805D0, 2.42336D0, 2.02906D0, 1.78549D0,
55657 & 1.61215D0, 1.16634D0, 0.83123D0, 0.67669D0, 0.58260D0,
55658 & 0.51757D0, 0.43126D0, 0.35327D0, 0.27879D0, 0.23332D0,
55659 & 0.17659D0, 0.13975D0, 0.11233D0, 0.08581D0, 0.06521D0,
55660 & 0.04895D0, 0.03623D0, 0.02642D0, 0.01893D0, 0.01332D0,
55661 & 0.00922D0, 0.00628D0, 0.00420D0, 0.00276D0, 0.00179D0,
55662 & 0.00113D0, 0.00073D0, 0.00048D0, 0.00028D0, 0.00018D0,
55663 & 0.00012D0, 0.00007D0, 0.00004D0, 0.00001D0, 0.00001D0,
55664 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55665 DATA (FMRS(1,8,I,30),I=1,49)/
55666 & 12.53147D0, 9.29349D0, 6.89124D0, 5.78416D0, 5.10752D0,
55667 & 4.63707D0, 3.43073D0, 2.53015D0, 2.11162D0, 1.85381D0,
55668 & 1.67070D0, 1.20157D0, 0.85112D0, 0.69035D0, 0.59278D0,
55669 & 0.52552D0, 0.43648D0, 0.35628D0, 0.27996D0, 0.23352D0,
55670 & 0.17581D0, 0.13853D0, 0.11093D0, 0.08439D0, 0.06389D0,
55671 & 0.04778D0, 0.03525D0, 0.02563D0, 0.01832D0, 0.01286D0,
55672 & 0.00888D0, 0.00603D0, 0.00403D0, 0.00265D0, 0.00171D0,
55673 & 0.00109D0, 0.00070D0, 0.00046D0, 0.00026D0, 0.00017D0,
55674 & 0.00011D0, 0.00006D0, 0.00004D0, 0.00001D0, 0.00000D0,
55675 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55676 DATA (FMRS(1,8,I,31),I=1,49)/
55677 & 13.39986D0, 9.88770D0, 7.29509D0, 6.10513D0, 5.37969D0,
55678 & 4.87627D0, 3.58951D0, 2.63377D0, 2.19145D0, 1.91971D0,
55679 & 1.72706D0, 1.23525D0, 0.86997D0, 0.70322D0, 0.60234D0,
55680 & 0.53296D0, 0.44131D0, 0.35903D0, 0.28099D0, 0.23364D0,
55681 & 0.17503D0, 0.13736D0, 0.10960D0, 0.08305D0, 0.06264D0,
55682 & 0.04669D0, 0.03435D0, 0.02491D0, 0.01775D0, 0.01244D0,
55683 & 0.00857D0, 0.00581D0, 0.00387D0, 0.00255D0, 0.00164D0,
55684 & 0.00105D0, 0.00067D0, 0.00044D0, 0.00025D0, 0.00016D0,
55685 & 0.00011D0, 0.00006D0, 0.00004D0, 0.00002D0, 0.00000D0,
55686 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55687 DATA (FMRS(1,8,I,32),I=1,49)/
55688 & 14.24690D0, 10.46430D0, 7.68491D0, 6.41400D0, 5.64102D0,
55689 & 5.10551D0, 3.74084D0, 2.73196D0, 2.26682D0, 1.98174D0,
55690 & 1.77998D0, 1.26662D0, 0.88736D0, 0.71501D0, 0.61103D0,
55691 & 0.53966D0, 0.44562D0, 0.36142D0, 0.28180D0, 0.23363D0,
55692 & 0.17423D0, 0.13620D0, 0.10832D0, 0.08177D0, 0.06147D0,
55693 & 0.04567D0, 0.03352D0, 0.02425D0, 0.01724D0, 0.01204D0,
55694 & 0.00828D0, 0.00559D0, 0.00373D0, 0.00245D0, 0.00158D0,
55695 & 0.00099D0, 0.00065D0, 0.00042D0, 0.00024D0, 0.00015D0,
55696 & 0.00010D0, 0.00006D0, 0.00004D0, 0.00002D0, 0.00000D0,
55697 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55698 DATA (FMRS(1,8,I,33),I=1,49)/
55699 & 15.14936D0, 11.07583D0, 8.09647D0, 6.73922D0, 5.91564D0,
55700 & 5.34608D0, 3.89891D0, 2.83403D0, 2.34496D0, 2.04593D0,
55701 & 1.83464D0, 1.29886D0, 0.90513D0, 0.72701D0, 0.61986D0,
55702 & 0.54647D0, 0.44998D0, 0.36383D0, 0.28262D0, 0.23362D0,
55703 & 0.17343D0, 0.13505D0, 0.10704D0, 0.08050D0, 0.06032D0,
55704 & 0.04468D0, 0.03270D0, 0.02360D0, 0.01675D0, 0.01165D0,
55705 & 0.00800D0, 0.00538D0, 0.00360D0, 0.00236D0, 0.00153D0,
55706 & 0.00094D0, 0.00062D0, 0.00040D0, 0.00024D0, 0.00014D0,
55707 & 0.00010D0, 0.00005D0, 0.00004D0, 0.00002D0, 0.00000D0,
55708 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55709 DATA (FMRS(1,8,I,34),I=1,49)/
55710 & 16.05264D0, 11.68476D0, 8.50413D0, 7.06033D0, 6.18619D0,
55711 & 5.58264D0, 4.05344D0, 2.93321D0, 2.42057D0, 2.10785D0,
55712 & 1.88726D0, 1.32960D0, 0.92187D0, 0.73821D0, 0.62802D0,
55713 & 0.55270D0, 0.45389D0, 0.36590D0, 0.28320D0, 0.23345D0,
55714 & 0.17251D0, 0.13385D0, 0.10575D0, 0.07924D0, 0.05918D0,
55715 & 0.04371D0, 0.03189D0, 0.02297D0, 0.01625D0, 0.01129D0,
55716 & 0.00773D0, 0.00520D0, 0.00346D0, 0.00227D0, 0.00146D0,
55717 & 0.00090D0, 0.00059D0, 0.00038D0, 0.00022D0, 0.00014D0,
55718 & 0.00009D0, 0.00005D0, 0.00004D0, 0.00001D0, 0.00000D0,
55719 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55720 DATA (FMRS(1,8,I,35),I=1,49)/
55721 & 16.95831D0, 12.29275D0, 8.90942D0, 7.37879D0, 6.45402D0,
55722 & 5.81651D0, 4.20556D0, 3.03041D0, 2.49449D0, 2.16827D0,
55723 & 1.93852D0, 1.35941D0, 0.93802D0, 0.74899D0, 0.63586D0,
55724 & 0.55868D0, 0.45763D0, 0.36787D0, 0.28375D0, 0.23328D0,
55725 & 0.17165D0, 0.13272D0, 0.10453D0, 0.07807D0, 0.05811D0,
55726 & 0.04281D0, 0.03114D0, 0.02238D0, 0.01579D0, 0.01096D0,
55727 & 0.00748D0, 0.00503D0, 0.00334D0, 0.00218D0, 0.00141D0,
55728 & 0.00087D0, 0.00056D0, 0.00036D0, 0.00021D0, 0.00013D0,
55729 & 0.00009D0, 0.00005D0, 0.00004D0, 0.00001D0, 0.00000D0,
55730 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55731 DATA (FMRS(1,8,I,36),I=1,49)/
55732 & 17.84218D0, 12.88352D0, 9.30151D0, 7.68607D0, 6.71197D0,
55733 & 6.04141D0, 4.35117D0, 3.12299D0, 2.56467D0, 2.22550D0,
55734 & 1.98697D0, 1.38741D0, 0.95307D0, 0.75895D0, 0.64306D0,
55735 & 0.56414D0, 0.46100D0, 0.36960D0, 0.28418D0, 0.23305D0,
55736 & 0.17079D0, 0.13162D0, 0.10337D0, 0.07695D0, 0.05711D0,
55737 & 0.04196D0, 0.03045D0, 0.02184D0, 0.01537D0, 0.01065D0,
55738 & 0.00725D0, 0.00488D0, 0.00323D0, 0.00211D0, 0.00135D0,
55739 & 0.00084D0, 0.00054D0, 0.00035D0, 0.00020D0, 0.00012D0,
55740 & 0.00009D0, 0.00005D0, 0.00003D0, 0.00001D0, 0.00000D0,
55741 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55742 DATA (FMRS(1,8,I,37),I=1,49)/
55743 & 18.75837D0, 13.49331D0, 9.70449D0, 8.00107D0, 6.97591D0,
55744 & 6.27121D0, 4.49926D0, 3.21668D0, 2.63548D0, 2.28312D0,
55745 & 2.03566D0, 1.41534D0, 0.96795D0, 0.76874D0, 0.65009D0,
55746 & 0.56943D0, 0.46423D0, 0.37122D0, 0.28450D0, 0.23274D0,
55747 & 0.16989D0, 0.13050D0, 0.10219D0, 0.07583D0, 0.05612D0,
55748 & 0.04112D0, 0.02978D0, 0.02129D0, 0.01496D0, 0.01035D0,
55749 & 0.00703D0, 0.00473D0, 0.00312D0, 0.00203D0, 0.00130D0,
55750 & 0.00081D0, 0.00052D0, 0.00034D0, 0.00019D0, 0.00012D0,
55751 & 0.00008D0, 0.00005D0, 0.00003D0, 0.00001D0, 0.00000D0,
55752 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55753 DATA (FMRS(1,8,I,38),I=1,49)/
55754 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55755 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55756 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55757 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55758 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55759 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55760 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55761 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55762 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
55763 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
55764 DATA (FMRS(2,1,I, 1),I=1,49)/
55765 & 0.01616D0, 0.01968D0, 0.02397D0, 0.02690D0, 0.02921D0,
55766 & 0.03113D0, 0.03797D0, 0.04639D0, 0.05222D0, 0.05685D0,
55767 & 0.06076D0, 0.07508D0, 0.09409D0, 0.10852D0, 0.12095D0,
55768 & 0.13220D0, 0.15265D0, 0.18041D0, 0.22265D0, 0.26180D0,
55769 & 0.33338D0, 0.39710D0, 0.45318D0, 0.51262D0, 0.56037D0,
55770 & 0.59685D0, 0.62256D0, 0.63820D0, 0.64458D0, 0.64218D0,
55771 & 0.63256D0, 0.61605D0, 0.59381D0, 0.56668D0, 0.53544D0,
55772 & 0.50113D0, 0.46441D0, 0.42608D0, 0.38703D0, 0.34764D0,
55773 & 0.30873D0, 0.27101D0, 0.23457D0, 0.16829D0, 0.11224D0,
55774 & 0.06802D0, 0.03588D0, 0.00449D0, 0.00000D0/
55775 DATA (FMRS(2,1,I, 2),I=1,49)/
55776 & 0.01632D0, 0.01989D0, 0.02423D0, 0.02721D0, 0.02954D0,
55777 & 0.03149D0, 0.03843D0, 0.04698D0, 0.05290D0, 0.05761D0,
55778 & 0.06159D0, 0.07621D0, 0.09566D0, 0.11046D0, 0.12320D0,
55779 & 0.13473D0, 0.15566D0, 0.18401D0, 0.22694D0, 0.26649D0,
55780 & 0.33826D0, 0.40154D0, 0.45671D0, 0.51456D0, 0.56041D0,
55781 & 0.59481D0, 0.61838D0, 0.63191D0, 0.63628D0, 0.63211D0,
55782 & 0.62085D0, 0.60298D0, 0.57964D0, 0.55165D0, 0.51988D0,
55783 & 0.48526D0, 0.44851D0, 0.41042D0, 0.37182D0, 0.33308D0,
55784 & 0.29500D0, 0.25823D0, 0.22287D0, 0.15893D0, 0.10532D0,
55785 & 0.06336D0, 0.03315D0, 0.00405D0, 0.00000D0/
55786 DATA (FMRS(2,1,I, 3),I=1,49)/
55787 & 0.01657D0, 0.02020D0, 0.02463D0, 0.02767D0, 0.03005D0,
55788 & 0.03204D0, 0.03912D0, 0.04786D0, 0.05393D0, 0.05876D0,
55789 & 0.06285D0, 0.07791D0, 0.09803D0, 0.11338D0, 0.12658D0,
55790 & 0.13853D0, 0.16018D0, 0.18937D0, 0.23326D0, 0.27335D0,
55791 & 0.34527D0, 0.40778D0, 0.46152D0, 0.51696D0, 0.55995D0,
55792 & 0.59126D0, 0.61170D0, 0.62221D0, 0.62369D0, 0.61697D0,
55793 & 0.60343D0, 0.58371D0, 0.55889D0, 0.52978D0, 0.49735D0,
55794 & 0.46237D0, 0.42568D0, 0.38804D0, 0.35014D0, 0.31246D0,
55795 & 0.27562D0, 0.24027D0, 0.20650D0, 0.14595D0, 0.09580D0,
55796 & 0.05701D0, 0.02946D0, 0.00347D0, 0.00000D0/
55797 DATA (FMRS(2,1,I, 4),I=1,49)/
55798 & 0.01676D0, 0.02044D0, 0.02493D0, 0.02801D0, 0.03042D0,
55799 & 0.03244D0, 0.03964D0, 0.04852D0, 0.05470D0, 0.05962D0,
55800 & 0.06379D0, 0.07918D0, 0.09980D0, 0.11554D0, 0.12909D0,
55801 & 0.14134D0, 0.16349D0, 0.19329D0, 0.23784D0, 0.27828D0,
55802 & 0.35023D0, 0.41207D0, 0.46471D0, 0.51833D0, 0.55923D0,
55803 & 0.58830D0, 0.60648D0, 0.61486D0, 0.61433D0, 0.60584D0,
55804 & 0.59072D0, 0.56980D0, 0.54398D0, 0.51418D0, 0.48131D0,
55805 & 0.44619D0, 0.40966D0, 0.37236D0, 0.33505D0, 0.29814D0,
55806 & 0.26220D0, 0.22791D0, 0.19528D0, 0.13713D0, 0.08936D0,
55807 & 0.05277D0, 0.02703D0, 0.00310D0, 0.00000D0/
55808 DATA (FMRS(2,1,I, 5),I=1,49)/
55809 & 0.01695D0, 0.02068D0, 0.02524D0, 0.02837D0, 0.03082D0,
55810 & 0.03287D0, 0.04018D0, 0.04922D0, 0.05552D0, 0.06053D0,
55811 & 0.06480D0, 0.08053D0, 0.10168D0, 0.11784D0, 0.13174D0,
55812 & 0.14430D0, 0.16698D0, 0.19737D0, 0.24257D0, 0.28331D0,
55813 & 0.35517D0, 0.41625D0, 0.46767D0, 0.51932D0, 0.55801D0,
55814 & 0.58472D0, 0.60061D0, 0.60677D0, 0.60420D0, 0.59394D0,
55815 & 0.57732D0, 0.55511D0, 0.52831D0, 0.49795D0, 0.46473D0,
55816 & 0.42958D0, 0.39324D0, 0.35636D0, 0.31976D0, 0.28363D0,
55817 & 0.24869D0, 0.21549D0, 0.18405D0, 0.12838D0, 0.08307D0,
55818 & 0.04866D0, 0.02468D0, 0.00276D0, 0.00000D0/
55819 DATA (FMRS(2,1,I, 6),I=1,49)/
55820 & 0.01712D0, 0.02090D0, 0.02552D0, 0.02868D0, 0.03117D0,
55821 & 0.03325D0, 0.04066D0, 0.04984D0, 0.05623D0, 0.06133D0,
55822 & 0.06568D0, 0.08172D0, 0.10333D0, 0.11984D0, 0.13405D0,
55823 & 0.14688D0, 0.17001D0, 0.20090D0, 0.24663D0, 0.28761D0,
55824 & 0.35934D0, 0.41972D0, 0.47004D0, 0.51998D0, 0.55675D0,
55825 & 0.58145D0, 0.59540D0, 0.59970D0, 0.59545D0, 0.58373D0,
55826 & 0.56587D0, 0.54263D0, 0.51509D0, 0.48426D0, 0.45082D0,
55827 & 0.41570D0, 0.37956D0, 0.34309D0, 0.30710D0, 0.27167D0,
55828 & 0.23758D0, 0.20532D0, 0.17488D0, 0.12129D0, 0.07799D0,
55829 & 0.04537D0, 0.02283D0, 0.00249D0, 0.00000D0/
55830 DATA (FMRS(2,1,I, 7),I=1,49)/
55831 & 0.01728D0, 0.02111D0, 0.02578D0, 0.02899D0, 0.03151D0,
55832 & 0.03361D0, 0.04113D0, 0.05044D0, 0.05693D0, 0.06211D0,
55833 & 0.06653D0, 0.08287D0, 0.10492D0, 0.12178D0, 0.13628D0,
55834 & 0.14936D0, 0.17290D0, 0.20425D0, 0.25045D0, 0.29164D0,
55835 & 0.36316D0, 0.42280D0, 0.47203D0, 0.52030D0, 0.55522D0,
55836 & 0.57804D0, 0.59016D0, 0.59271D0, 0.58692D0, 0.57390D0,
55837 & 0.55488D0, 0.53075D0, 0.50265D0, 0.47135D0, 0.43776D0,
55838 & 0.40267D0, 0.36679D0, 0.33078D0, 0.29535D0, 0.26064D0,
55839 & 0.22735D0, 0.19600D0, 0.16649D0, 0.11484D0, 0.07339D0,
55840 & 0.04241D0, 0.02117D0, 0.00226D0, 0.00000D0/
55841 DATA (FMRS(2,1,I, 8),I=1,49)/
55842 & 0.01745D0, 0.02133D0, 0.02606D0, 0.02931D0, 0.03187D0,
55843 & 0.03400D0, 0.04163D0, 0.05108D0, 0.05768D0, 0.06295D0,
55844 & 0.06745D0, 0.08411D0, 0.10662D0, 0.12385D0, 0.13865D0,
55845 & 0.15200D0, 0.17596D0, 0.20780D0, 0.25445D0, 0.29582D0,
55846 & 0.36707D0, 0.42589D0, 0.47392D0, 0.52041D0, 0.55338D0,
55847 & 0.57422D0, 0.58442D0, 0.58519D0, 0.57783D0, 0.56344D0,
55848 & 0.54329D0, 0.51831D0, 0.48960D0, 0.45793D0, 0.42423D0,
55849 & 0.38922D0, 0.35366D0, 0.31814D0, 0.28333D0, 0.24940D0,
55850 & 0.21696D0, 0.18656D0, 0.15803D0, 0.10837D0, 0.06882D0,
55851 & 0.03949D0, 0.01956D0, 0.00204D0, 0.00000D0/
55852 DATA (FMRS(2,1,I, 9),I=1,49)/
55853 & 0.01760D0, 0.02152D0, 0.02631D0, 0.02960D0, 0.03218D0,
55854 & 0.03434D0, 0.04207D0, 0.05164D0, 0.05833D0, 0.06368D0,
55855 & 0.06825D0, 0.08519D0, 0.10811D0, 0.12566D0, 0.14073D0,
55856 & 0.15430D0, 0.17863D0, 0.21087D0, 0.25789D0, 0.29938D0,
55857 & 0.37036D0, 0.42844D0, 0.47541D0, 0.52034D0, 0.55162D0,
55858 & 0.57077D0, 0.57932D0, 0.57861D0, 0.56993D0, 0.55438D0,
55859 & 0.53332D0, 0.50767D0, 0.47844D0, 0.44653D0, 0.41277D0,
55860 & 0.37787D0, 0.34261D0, 0.30753D0, 0.27327D0, 0.24001D0,
55861 & 0.20832D0, 0.17873D0, 0.15102D0, 0.10304D0, 0.06508D0,
55862 & 0.03712D0, 0.01826D0, 0.00186D0, 0.00000D0/
55863 DATA (FMRS(2,1,I,10),I=1,49)/
55864 & 0.01775D0, 0.02171D0, 0.02655D0, 0.02988D0, 0.03249D0,
55865 & 0.03468D0, 0.04249D0, 0.05219D0, 0.05897D0, 0.06440D0,
55866 & 0.06904D0, 0.08625D0, 0.10956D0, 0.12741D0, 0.14273D0,
55867 & 0.15651D0, 0.18119D0, 0.21379D0, 0.26115D0, 0.30273D0,
55868 & 0.37339D0, 0.43070D0, 0.47663D0, 0.52004D0, 0.54971D0,
55869 & 0.56723D0, 0.57424D0, 0.57214D0, 0.56221D0, 0.54564D0,
55870 & 0.52375D0, 0.49748D0, 0.46783D0, 0.43572D0, 0.40192D0,
55871 & 0.36718D0, 0.33221D0, 0.29755D0, 0.26385D0, 0.23124D0,
55872 & 0.20028D0, 0.17145D0, 0.14454D0, 0.09813D0, 0.06166D0,
55873 & 0.03497D0, 0.01708D0, 0.00171D0, 0.00000D0/
55874 DATA (FMRS(2,1,I,11),I=1,49)/
55875 & 0.01786D0, 0.02185D0, 0.02674D0, 0.03010D0, 0.03274D0,
55876 & 0.03494D0, 0.04284D0, 0.05263D0, 0.05949D0, 0.06497D0,
55877 & 0.06967D0, 0.08709D0, 0.11072D0, 0.12880D0, 0.14432D0,
55878 & 0.15827D0, 0.18322D0, 0.21609D0, 0.26371D0, 0.30535D0,
55879 & 0.37572D0, 0.43240D0, 0.47751D0, 0.51970D0, 0.54811D0,
55880 & 0.56435D0, 0.57017D0, 0.56701D0, 0.55612D0, 0.53878D0,
55881 & 0.51626D0, 0.48950D0, 0.45957D0, 0.42732D0, 0.39351D0,
55882 & 0.35893D0, 0.32420D0, 0.28986D0, 0.25663D0, 0.22452D0,
55883 & 0.19414D0, 0.16588D0, 0.13961D0, 0.09442D0, 0.05909D0,
55884 & 0.03336D0, 0.01621D0, 0.00160D0, 0.00000D0/
55885 DATA (FMRS(2,1,I,12),I=1,49)/
55886 & 0.01811D0, 0.02217D0, 0.02715D0, 0.03057D0, 0.03326D0,
55887 & 0.03551D0, 0.04357D0, 0.05358D0, 0.06059D0, 0.06620D0,
55888 & 0.07102D0, 0.08890D0, 0.11320D0, 0.13179D0, 0.14772D0,
55889 & 0.16201D0, 0.18751D0, 0.22095D0, 0.26905D0, 0.31076D0,
55890 & 0.38043D0, 0.43573D0, 0.47902D0, 0.51865D0, 0.54434D0,
55891 & 0.55794D0, 0.56131D0, 0.55592D0, 0.54308D0, 0.52418D0,
55892 & 0.50041D0, 0.47277D0, 0.44227D0, 0.40979D0, 0.37605D0,
55893 & 0.34185D0, 0.30765D0, 0.27411D0, 0.24188D0, 0.21085D0,
55894 & 0.18166D0, 0.15463D0, 0.12966D0, 0.08698D0, 0.05397D0,
55895 & 0.03017D0, 0.01449D0, 0.00138D0, 0.00000D0/
55896 DATA (FMRS(2,1,I,13),I=1,49)/
55897 & 0.01832D0, 0.02245D0, 0.02751D0, 0.03099D0, 0.03372D0,
55898 & 0.03601D0, 0.04421D0, 0.05440D0, 0.06155D0, 0.06727D0,
55899 & 0.07220D0, 0.09048D0, 0.11535D0, 0.13437D0, 0.15065D0,
55900 & 0.16524D0, 0.19119D0, 0.22510D0, 0.27356D0, 0.31528D0,
55901 & 0.38427D0, 0.43832D0, 0.48002D0, 0.51742D0, 0.54081D0,
55902 & 0.55220D0, 0.55352D0, 0.54629D0, 0.53189D0, 0.51174D0,
55903 & 0.48699D0, 0.45870D0, 0.42778D0, 0.39517D0, 0.36159D0,
55904 & 0.32774D0, 0.29406D0, 0.26124D0, 0.22984D0, 0.19975D0,
55905 & 0.17155D0, 0.14556D0, 0.12166D0, 0.08107D0, 0.04993D0,
55906 & 0.02767D0, 0.01316D0, 0.00122D0, 0.00000D0/
55907 DATA (FMRS(2,1,I,14),I=1,49)/
55908 & 0.01856D0, 0.02276D0, 0.02791D0, 0.03145D0, 0.03424D0,
55909 & 0.03657D0, 0.04493D0, 0.05533D0, 0.06263D0, 0.06849D0,
55910 & 0.07353D0, 0.09227D0, 0.11778D0, 0.13727D0, 0.15393D0,
55911 & 0.16884D0, 0.19528D0, 0.22966D0, 0.27847D0, 0.32014D0,
55912 & 0.38833D0, 0.44089D0, 0.48079D0, 0.51572D0, 0.53660D0,
55913 & 0.54555D0, 0.54466D0, 0.53550D0, 0.51948D0, 0.49806D0,
55914 & 0.47232D0, 0.44337D0, 0.41209D0, 0.37941D0, 0.34606D0,
55915 & 0.31264D0, 0.27962D0, 0.24761D0, 0.21707D0, 0.18804D0,
55916 & 0.16093D0, 0.13609D0, 0.11331D0, 0.07496D0, 0.04577D0,
55917 & 0.02513D0, 0.01183D0, 0.00106D0, 0.00000D0/
55918 DATA (FMRS(2,1,I,15),I=1,49)/
55919 & 0.01882D0, 0.02309D0, 0.02833D0, 0.03194D0, 0.03478D0,
55920 & 0.03716D0, 0.04569D0, 0.05632D0, 0.06378D0, 0.06977D0,
55921 & 0.07493D0, 0.09414D0, 0.12031D0, 0.14028D0, 0.15732D0,
55922 & 0.17254D0, 0.19946D0, 0.23430D0, 0.28337D0, 0.32492D0,
55923 & 0.39212D0, 0.44309D0, 0.48109D0, 0.51344D0, 0.53176D0,
55924 & 0.53830D0, 0.53520D0, 0.52410D0, 0.50654D0, 0.48389D0,
55925 & 0.45725D0, 0.42772D0, 0.39621D0, 0.36351D0, 0.33050D0,
55926 & 0.29757D0, 0.26525D0, 0.23404D0, 0.20451D0, 0.17653D0,
55927 & 0.15059D0, 0.12691D0, 0.10526D0, 0.06909D0, 0.04183D0,
55928 & 0.02276D0, 0.01059D0, 0.00092D0, 0.00000D0/
55929 DATA (FMRS(2,1,I,16),I=1,49)/
55930 & 0.01904D0, 0.02338D0, 0.02872D0, 0.03239D0, 0.03528D0,
55931 & 0.03770D0, 0.04639D0, 0.05722D0, 0.06483D0, 0.07094D0,
55932 & 0.07621D0, 0.09585D0, 0.12261D0, 0.14301D0, 0.16039D0,
55933 & 0.17588D0, 0.20321D0, 0.23842D0, 0.28769D0, 0.32908D0,
55934 & 0.39530D0, 0.44481D0, 0.48105D0, 0.51110D0, 0.52712D0,
55935 & 0.53155D0, 0.52655D0, 0.51382D0, 0.49491D0, 0.47126D0,
55936 & 0.44390D0, 0.41395D0, 0.38228D0, 0.34968D0, 0.31695D0,
55937 & 0.28453D0, 0.25288D0, 0.22245D0, 0.19380D0, 0.16677D0,
55938 & 0.14180D0, 0.11912D0, 0.09847D0, 0.06418D0, 0.03856D0,
55939 & 0.02081D0, 0.00959D0, 0.00081D0, 0.00000D0/
55940 DATA (FMRS(2,1,I,17),I=1,49)/
55941 & 0.01928D0, 0.02369D0, 0.02911D0, 0.03284D0, 0.03578D0,
55942 & 0.03825D0, 0.04709D0, 0.05813D0, 0.06589D0, 0.07213D0,
55943 & 0.07751D0, 0.09758D0, 0.12493D0, 0.14576D0, 0.16348D0,
55944 & 0.17924D0, 0.20696D0, 0.24251D0, 0.29193D0, 0.33312D0,
55945 & 0.39831D0, 0.44629D0, 0.48077D0, 0.50852D0, 0.52228D0,
55946 & 0.52463D0, 0.51781D0, 0.50355D0, 0.48335D0, 0.45879D0,
55947 & 0.43078D0, 0.40049D0, 0.36872D0, 0.33629D0, 0.30386D0,
55948 & 0.27197D0, 0.24101D0, 0.21137D0, 0.18360D0, 0.15751D0,
55949 & 0.13349D0, 0.11178D0, 0.09210D0, 0.05961D0, 0.03555D0,
55950 & 0.01901D0, 0.00868D0, 0.00071D0, 0.00000D0/
55951 DATA (FMRS(2,1,I,18),I=1,49)/
55952 & 0.01947D0, 0.02394D0, 0.02943D0, 0.03322D0, 0.03621D0,
55953 & 0.03871D0, 0.04769D0, 0.05889D0, 0.06678D0, 0.07312D0,
55954 & 0.07860D0, 0.09903D0, 0.12687D0, 0.14804D0, 0.16603D0,
55955 & 0.18199D0, 0.21002D0, 0.24583D0, 0.29534D0, 0.33632D0,
55956 & 0.40060D0, 0.44729D0, 0.48029D0, 0.50614D0, 0.51810D0,
55957 & 0.51876D0, 0.51049D0, 0.49502D0, 0.47387D0, 0.44861D0,
55958 & 0.42013D0, 0.38960D0, 0.35780D0, 0.32553D0, 0.29342D0,
55959 & 0.26197D0, 0.23158D0, 0.20258D0, 0.17557D0, 0.15022D0,
55960 & 0.12699D0, 0.10608D0, 0.08715D0, 0.05607D0, 0.03324D0,
55961 & 0.01765D0, 0.00799D0, 0.00064D0, 0.00000D0/
55962 DATA (FMRS(2,1,I,19),I=1,49)/
55963 & 0.01970D0, 0.02424D0, 0.02983D0, 0.03369D0, 0.03672D0,
55964 & 0.03927D0, 0.04841D0, 0.05983D0, 0.06787D0, 0.07433D0,
55965 & 0.07993D0, 0.10079D0, 0.12921D0, 0.15080D0, 0.16909D0,
55966 & 0.18531D0, 0.21368D0, 0.24977D0, 0.29932D0, 0.34002D0,
55967 & 0.40312D0, 0.44820D0, 0.47944D0, 0.50301D0, 0.51281D0,
55968 & 0.51154D0, 0.50156D0, 0.48470D0, 0.46252D0, 0.43645D0,
55969 & 0.40748D0, 0.37672D0, 0.34495D0, 0.31293D0, 0.28123D0,
55970 & 0.25036D0, 0.22064D0, 0.19244D0, 0.16630D0, 0.14187D0,
55971 & 0.11955D0, 0.09954D0, 0.08152D0, 0.05209D0, 0.03065D0,
55972 & 0.01614D0, 0.00723D0, 0.00056D0, 0.00000D0/
55973 DATA (FMRS(2,1,I,20),I=1,49)/
55974 & 0.01991D0, 0.02452D0, 0.03019D0, 0.03410D0, 0.03718D0,
55975 & 0.03977D0, 0.04905D0, 0.06066D0, 0.06884D0, 0.07541D0,
55976 & 0.08111D0, 0.10235D0, 0.13129D0, 0.15323D0, 0.17180D0,
55977 & 0.18822D0, 0.21689D0, 0.25320D0, 0.30276D0, 0.34318D0,
55978 & 0.40521D0, 0.44885D0, 0.47855D0, 0.50013D0, 0.50806D0,
55979 & 0.50515D0, 0.49374D0, 0.47571D0, 0.45269D0, 0.42596D0,
55980 & 0.39662D0, 0.36569D0, 0.33399D0, 0.30222D0, 0.27090D0,
55981 & 0.24056D0, 0.21144D0, 0.18393D0, 0.15855D0, 0.13491D0,
55982 & 0.11336D0, 0.09413D0, 0.07687D0, 0.04883D0, 0.02854D0,
55983 & 0.01493D0, 0.00663D0, 0.00051D0, 0.00000D0/
55984 DATA (FMRS(2,1,I,21),I=1,49)/
55985 & 0.02011D0, 0.02477D0, 0.03051D0, 0.03448D0, 0.03760D0,
55986 & 0.04023D0, 0.04965D0, 0.06143D0, 0.06973D0, 0.07641D0,
55987 & 0.08220D0, 0.10379D0, 0.13319D0, 0.15544D0, 0.17424D0,
55988 & 0.19085D0, 0.21976D0, 0.25625D0, 0.30577D0, 0.34590D0,
55989 & 0.40689D0, 0.44921D0, 0.47746D0, 0.49725D0, 0.50352D0,
55990 & 0.49914D0, 0.48649D0, 0.46748D0, 0.44367D0, 0.41645D0,
55991 & 0.38678D0, 0.35582D0, 0.32417D0, 0.29264D0, 0.26169D0,
55992 & 0.23187D0, 0.20335D0, 0.17646D0, 0.15176D0, 0.12881D0,
55993 & 0.10798D0, 0.08943D0, 0.07284D0, 0.04602D0, 0.02675D0,
55994 & 0.01389D0, 0.00613D0, 0.00046D0, 0.00000D0/
55995 DATA (FMRS(2,1,I,22),I=1,49)/
55996 & 0.02035D0, 0.02509D0, 0.03093D0, 0.03496D0, 0.03814D0,
55997 & 0.04081D0, 0.05040D0, 0.06241D0, 0.07087D0, 0.07768D0,
55998 & 0.08359D0, 0.10562D0, 0.13559D0, 0.15824D0, 0.17734D0,
55999 & 0.19417D0, 0.22338D0, 0.26006D0, 0.30949D0, 0.34920D0,
56000 & 0.40885D0, 0.44948D0, 0.47592D0, 0.49348D0, 0.49770D0,
56001 & 0.49152D0, 0.47736D0, 0.45716D0, 0.43246D0, 0.40467D0,
56002 & 0.37468D0, 0.34367D0, 0.31217D0, 0.28097D0, 0.25052D0,
56003 & 0.22133D0, 0.19355D0, 0.16747D0, 0.14359D0, 0.12150D0,
56004 & 0.10155D0, 0.08384D0, 0.06806D0, 0.04272D0, 0.02464D0,
56005 & 0.01269D0, 0.00554D0, 0.00040D0, 0.00000D0/
56006 DATA (FMRS(2,1,I,23),I=1,49)/
56007 & 0.02058D0, 0.02539D0, 0.03132D0, 0.03542D0, 0.03865D0,
56008 & 0.04137D0, 0.05112D0, 0.06333D0, 0.07195D0, 0.07888D0,
56009 & 0.08490D0, 0.10735D0, 0.13786D0, 0.16087D0, 0.18023D0,
56010 & 0.19726D0, 0.22673D0, 0.26356D0, 0.31287D0, 0.35216D0,
56011 & 0.41052D0, 0.44953D0, 0.47430D0, 0.48980D0, 0.49215D0,
56012 & 0.48435D0, 0.46885D0, 0.44758D0, 0.42215D0, 0.39387D0,
56013 & 0.36366D0, 0.33261D0, 0.30132D0, 0.27045D0, 0.24050D0,
56014 & 0.21190D0, 0.18476D0, 0.15947D0, 0.13635D0, 0.11504D0,
56015 & 0.09587D0, 0.07894D0, 0.06387D0, 0.03984D0, 0.02282D0,
56016 & 0.01167D0, 0.00505D0, 0.00036D0, 0.00000D0/
56017 DATA (FMRS(2,1,I,24),I=1,49)/
56018 & 0.02080D0, 0.02568D0, 0.03170D0, 0.03585D0, 0.03914D0,
56019 & 0.04189D0, 0.05180D0, 0.06421D0, 0.07296D0, 0.08001D0,
56020 & 0.08614D0, 0.10897D0, 0.13997D0, 0.16330D0, 0.18290D0,
56021 & 0.20010D0, 0.22978D0, 0.26672D0, 0.31586D0, 0.35473D0,
56022 & 0.41182D0, 0.44931D0, 0.47248D0, 0.48612D0, 0.48676D0,
56023 & 0.47750D0, 0.46081D0, 0.43866D0, 0.41258D0, 0.38389D0,
56024 & 0.35352D0, 0.32245D0, 0.29140D0, 0.26089D0, 0.23143D0,
56025 & 0.20340D0, 0.17690D0, 0.15229D0, 0.12990D0, 0.10931D0,
56026 & 0.09084D0, 0.07461D0, 0.06021D0, 0.03734D0, 0.02125D0,
56027 & 0.01078D0, 0.00462D0, 0.00032D0, 0.00000D0/
56028 DATA (FMRS(2,1,I,25),I=1,49)/
56029 & 0.02102D0, 0.02596D0, 0.03207D0, 0.03629D0, 0.03962D0,
56030 & 0.04242D0, 0.05248D0, 0.06508D0, 0.07398D0, 0.08115D0,
56031 & 0.08738D0, 0.11059D0, 0.14207D0, 0.16573D0, 0.18556D0,
56032 & 0.20292D0, 0.23281D0, 0.26985D0, 0.31879D0, 0.35722D0,
56033 & 0.41303D0, 0.44900D0, 0.47060D0, 0.48240D0, 0.48138D0,
56034 & 0.47074D0, 0.45292D0, 0.42993D0, 0.40324D0, 0.37421D0,
56035 & 0.34370D0, 0.31266D0, 0.28186D0, 0.25172D0, 0.22275D0,
56036 & 0.19528D0, 0.16943D0, 0.14547D0, 0.12379D0, 0.10391D0,
56037 & 0.08611D0, 0.07055D0, 0.05678D0, 0.03501D0, 0.01980D0,
56038 & 0.00997D0, 0.00424D0, 0.00029D0, 0.00000D0/
56039 DATA (FMRS(2,1,I,26),I=1,49)/
56040 & 0.02124D0, 0.02625D0, 0.03244D0, 0.03672D0, 0.04010D0,
56041 & 0.04294D0, 0.05315D0, 0.06595D0, 0.07499D0, 0.08227D0,
56042 & 0.08860D0, 0.11218D0, 0.14413D0, 0.16809D0, 0.18813D0,
56043 & 0.20564D0, 0.23571D0, 0.27281D0, 0.32152D0, 0.35948D0,
56044 & 0.41398D0, 0.44847D0, 0.46857D0, 0.47858D0, 0.47599D0,
56045 & 0.46404D0, 0.44519D0, 0.42139D0, 0.39420D0, 0.36490D0,
56046 & 0.33431D0, 0.30337D0, 0.27282D0, 0.24304D0, 0.21455D0,
56047 & 0.18765D0, 0.16244D0, 0.13911D0, 0.11808D0, 0.09890D0,
56048 & 0.08174D0, 0.06681D0, 0.05361D0, 0.03286D0, 0.01847D0,
56049 & 0.00924D0, 0.00390D0, 0.00026D0, 0.00000D0/
56050 DATA (FMRS(2,1,I,27),I=1,49)/
56051 & 0.02145D0, 0.02652D0, 0.03279D0, 0.03713D0, 0.04055D0,
56052 & 0.04343D0, 0.05378D0, 0.06677D0, 0.07594D0, 0.08333D0,
56053 & 0.08975D0, 0.11368D0, 0.14607D0, 0.17031D0, 0.19054D0,
56054 & 0.20819D0, 0.23841D0, 0.27555D0, 0.32402D0, 0.36153D0,
56055 & 0.41478D0, 0.44786D0, 0.46655D0, 0.47490D0, 0.47088D0,
56056 & 0.45773D0, 0.43795D0, 0.41346D0, 0.38583D0, 0.35628D0,
56057 & 0.32564D0, 0.29483D0, 0.26454D0, 0.23512D0, 0.20709D0,
56058 & 0.18074D0, 0.15610D0, 0.13337D0, 0.11295D0, 0.09439D0,
56059 & 0.07783D0, 0.06346D0, 0.05079D0, 0.03096D0, 0.01730D0,
56060 & 0.00860D0, 0.00360D0, 0.00023D0, 0.00000D0/
56061 DATA (FMRS(2,1,I,28),I=1,49)/
56062 & 0.02164D0, 0.02677D0, 0.03312D0, 0.03751D0, 0.04098D0,
56063 & 0.04390D0, 0.05439D0, 0.06755D0, 0.07684D0, 0.08433D0,
56064 & 0.09084D0, 0.11510D0, 0.14789D0, 0.17239D0, 0.19279D0,
56065 & 0.21056D0, 0.24091D0, 0.27806D0, 0.32630D0, 0.36334D0,
56066 & 0.41540D0, 0.44716D0, 0.46451D0, 0.47135D0, 0.46602D0,
56067 & 0.45177D0, 0.43117D0, 0.40606D0, 0.37805D0, 0.34829D0,
56068 & 0.31763D0, 0.28699D0, 0.25693D0, 0.22788D0, 0.20031D0,
56069 & 0.17447D0, 0.15036D0, 0.12818D0, 0.10834D0, 0.09032D0,
56070 & 0.07432D0, 0.06046D0, 0.04827D0, 0.02929D0, 0.01628D0,
56071 & 0.00804D0, 0.00334D0, 0.00021D0, 0.00000D0/
56072 DATA (FMRS(2,1,I,29),I=1,49)/
56073 & 0.02184D0, 0.02703D0, 0.03346D0, 0.03790D0, 0.04142D0,
56074 & 0.04437D0, 0.05500D0, 0.06833D0, 0.07775D0, 0.08534D0,
56075 & 0.09195D0, 0.11653D0, 0.14972D0, 0.17447D0, 0.19503D0,
56076 & 0.21292D0, 0.24339D0, 0.28054D0, 0.32851D0, 0.36507D0,
56077 & 0.41592D0, 0.44635D0, 0.46240D0, 0.46773D0, 0.46111D0,
56078 & 0.44581D0, 0.42442D0, 0.39875D0, 0.37037D0, 0.34044D0,
56079 & 0.30980D0, 0.27932D0, 0.24952D0, 0.22085D0, 0.19375D0,
56080 & 0.16840D0, 0.14482D0, 0.12320D0, 0.10392D0, 0.08643D0,
56081 & 0.07097D0, 0.05759D0, 0.04588D0, 0.02770D0, 0.01531D0,
56082 & 0.00752D0, 0.00311D0, 0.00019D0, 0.00000D0/
56083 DATA (FMRS(2,1,I,30),I=1,49)/
56084 & 0.02204D0, 0.02729D0, 0.03379D0, 0.03829D0, 0.04185D0,
56085 & 0.04484D0, 0.05560D0, 0.06911D0, 0.07865D0, 0.08634D0,
56086 & 0.09303D0, 0.11793D0, 0.15151D0, 0.17649D0, 0.19722D0,
56087 & 0.21521D0, 0.24577D0, 0.28291D0, 0.33057D0, 0.36667D0,
56088 & 0.41631D0, 0.44543D0, 0.46021D0, 0.46408D0, 0.45622D0,
56089 & 0.43995D0, 0.41780D0, 0.39163D0, 0.36293D0, 0.33287D0,
56090 & 0.30229D0, 0.27195D0, 0.24246D0, 0.21416D0, 0.18750D0,
56091 & 0.16265D0, 0.13957D0, 0.11850D0, 0.09976D0, 0.08278D0,
56092 & 0.06783D0, 0.05492D0, 0.04366D0, 0.02623D0, 0.01442D0,
56093 & 0.00705D0, 0.00289D0, 0.00017D0, 0.00000D0/
56094 DATA (FMRS(2,1,I,31),I=1,49)/
56095 & 0.02222D0, 0.02753D0, 0.03410D0, 0.03866D0, 0.04226D0,
56096 & 0.04528D0, 0.05617D0, 0.06985D0, 0.07951D0, 0.08729D0,
56097 & 0.09407D0, 0.11927D0, 0.15320D0, 0.17841D0, 0.19928D0,
56098 & 0.21737D0, 0.24802D0, 0.28513D0, 0.33249D0, 0.36812D0,
56099 & 0.41660D0, 0.44449D0, 0.45808D0, 0.46059D0, 0.45160D0,
56100 & 0.43442D0, 0.41159D0, 0.38497D0, 0.35599D0, 0.32584D0,
56101 & 0.29532D0, 0.26514D0, 0.23594D0, 0.20800D0, 0.18176D0,
56102 & 0.15738D0, 0.13478D0, 0.11421D0, 0.09597D0, 0.07947D0,
56103 & 0.06498D0, 0.05251D0, 0.04166D0, 0.02491D0, 0.01363D0,
56104 & 0.00662D0, 0.00270D0, 0.00016D0, 0.00000D0/
56105 DATA (FMRS(2,1,I,32),I=1,49)/
56106 & 0.02240D0, 0.02776D0, 0.03441D0, 0.03901D0, 0.04265D0,
56107 & 0.04571D0, 0.05672D0, 0.07055D0, 0.08032D0, 0.08819D0,
56108 & 0.09505D0, 0.12053D0, 0.15480D0, 0.18021D0, 0.20120D0,
56109 & 0.21937D0, 0.25009D0, 0.28716D0, 0.33421D0, 0.36938D0,
56110 & 0.41675D0, 0.44346D0, 0.45593D0, 0.45721D0, 0.44717D0,
56111 & 0.42917D0, 0.40572D0, 0.37869D0, 0.34947D0, 0.31928D0,
56112 & 0.28882D0, 0.25885D0, 0.22992D0, 0.20233D0, 0.17646D0,
56113 & 0.15252D0, 0.13038D0, 0.11028D0, 0.09251D0, 0.07647D0,
56114 & 0.06240D0, 0.05033D0, 0.03984D0, 0.02372D0, 0.01293D0,
56115 & 0.00625D0, 0.00253D0, 0.00015D0, 0.00000D0/
56116 DATA (FMRS(2,1,I,33),I=1,49)/
56117 & 0.02258D0, 0.02800D0, 0.03471D0, 0.03936D0, 0.04304D0,
56118 & 0.04613D0, 0.05727D0, 0.07126D0, 0.08114D0, 0.08911D0,
56119 & 0.09604D0, 0.12181D0, 0.15642D0, 0.18202D0, 0.20315D0,
56120 & 0.22140D0, 0.25219D0, 0.28920D0, 0.33594D0, 0.37065D0,
56121 & 0.41690D0, 0.44243D0, 0.45378D0, 0.45384D0, 0.44278D0,
56122 & 0.42397D0, 0.39993D0, 0.37250D0, 0.34307D0, 0.31283D0,
56123 & 0.28245D0, 0.25269D0, 0.22404D0, 0.19681D0, 0.17131D0,
56124 & 0.14780D0, 0.12613D0, 0.10648D0, 0.08918D0, 0.07357D0,
56125 & 0.05991D0, 0.04824D0, 0.03811D0, 0.02259D0, 0.01226D0,
56126 & 0.00589D0, 0.00237D0, 0.00014D0, 0.00000D0/
56127 DATA (FMRS(2,1,I,34),I=1,49)/
56128 & 0.02276D0, 0.02823D0, 0.03502D0, 0.03972D0, 0.04344D0,
56129 & 0.04656D0, 0.05782D0, 0.07197D0, 0.08196D0, 0.09001D0,
56130 & 0.09702D0, 0.12306D0, 0.15799D0, 0.18378D0, 0.20502D0,
56131 & 0.22334D0, 0.25418D0, 0.29111D0, 0.33751D0, 0.37174D0,
56132 & 0.41686D0, 0.44123D0, 0.45149D0, 0.45035D0, 0.43832D0,
56133 & 0.41874D0, 0.39416D0, 0.36638D0, 0.33679D0, 0.30651D0,
56134 & 0.27625D0, 0.24670D0, 0.21831D0, 0.19144D0, 0.16636D0,
56135 & 0.14329D0, 0.12204D0, 0.10286D0, 0.08597D0, 0.07080D0,
56136 & 0.05755D0, 0.04624D0, 0.03646D0, 0.02153D0, 0.01162D0,
56137 & 0.00556D0, 0.00222D0, 0.00012D0, 0.00000D0/
56138 DATA (FMRS(2,1,I,35),I=1,49)/
56139 & 0.02294D0, 0.02846D0, 0.03531D0, 0.04006D0, 0.04381D0,
56140 & 0.04697D0, 0.05834D0, 0.07264D0, 0.08274D0, 0.09087D0,
56141 & 0.09796D0, 0.12426D0, 0.15949D0, 0.18547D0, 0.20682D0,
56142 & 0.22520D0, 0.25608D0, 0.29293D0, 0.33900D0, 0.37277D0,
56143 & 0.41683D0, 0.44010D0, 0.44933D0, 0.44706D0, 0.43413D0,
56144 & 0.41383D0, 0.38877D0, 0.36068D0, 0.33093D0, 0.30063D0,
56145 & 0.27049D0, 0.24114D0, 0.21302D0, 0.18649D0, 0.16180D0,
56146 & 0.13914D0, 0.11828D0, 0.09955D0, 0.08303D0, 0.06826D0,
56147 & 0.05540D0, 0.04443D0, 0.03497D0, 0.02057D0, 0.01106D0,
56148 & 0.00526D0, 0.00209D0, 0.00012D0, 0.00000D0/
56149 DATA (FMRS(2,1,I,36),I=1,49)/
56150 & 0.02310D0, 0.02867D0, 0.03558D0, 0.04038D0, 0.04417D0,
56151 & 0.04736D0, 0.05885D0, 0.07328D0, 0.08348D0, 0.09170D0,
56152 & 0.09885D0, 0.12540D0, 0.16092D0, 0.18705D0, 0.20850D0,
56153 & 0.22693D0, 0.25784D0, 0.29461D0, 0.34036D0, 0.37368D0,
56154 & 0.41672D0, 0.43895D0, 0.44722D0, 0.44390D0, 0.43013D0,
56155 & 0.40920D0, 0.38369D0, 0.35531D0, 0.32545D0, 0.29515D0,
56156 & 0.26511D0, 0.23598D0, 0.20812D0, 0.18191D0, 0.15758D0,
56157 & 0.13530D0, 0.11483D0, 0.09649D0, 0.08034D0, 0.06595D0,
56158 & 0.05344D0, 0.04278D0, 0.03361D0, 0.01970D0, 0.01054D0,
56159 & 0.00499D0, 0.00197D0, 0.00011D0, 0.00000D0/
56160 DATA (FMRS(2,1,I,37),I=1,49)/
56161 & 0.02327D0, 0.02889D0, 0.03587D0, 0.04071D0, 0.04453D0,
56162 & 0.04775D0, 0.05935D0, 0.07393D0, 0.08423D0, 0.09253D0,
56163 & 0.09975D0, 0.12655D0, 0.16235D0, 0.18864D0, 0.21018D0,
56164 & 0.22866D0, 0.25959D0, 0.29626D0, 0.34166D0, 0.37452D0,
56165 & 0.41652D0, 0.43771D0, 0.44502D0, 0.44067D0, 0.42606D0,
56166 & 0.40453D0, 0.37859D0, 0.34994D0, 0.31996D0, 0.28968D0,
56167 & 0.25976D0, 0.23084D0, 0.20328D0, 0.17738D0, 0.15341D0,
56168 & 0.13150D0, 0.11145D0, 0.09348D0, 0.07773D0, 0.06369D0,
56169 & 0.05153D0, 0.04117D0, 0.03229D0, 0.01885D0, 0.01005D0,
56170 & 0.00474D0, 0.00186D0, 0.00010D0, 0.00000D0/
56171 DATA (FMRS(2,1,I,38),I=1,49)/
56172 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56173 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56174 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56175 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56176 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56177 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56178 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56179 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56180 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56181 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56182 DATA (FMRS(2,2,I, 1),I=1,49)/
56183 & 0.00683D0, 0.00832D0, 0.01013D0, 0.01138D0, 0.01237D0,
56184 & 0.01320D0, 0.01619D0, 0.02004D0, 0.02286D0, 0.02522D0,
56185 & 0.02744D0, 0.03623D0, 0.04952D0, 0.06032D0, 0.06982D0,
56186 & 0.07843D0, 0.09385D0, 0.11395D0, 0.14220D0, 0.16592D0,
56187 & 0.20382D0, 0.23228D0, 0.25344D0, 0.27158D0, 0.28216D0,
56188 & 0.28647D0, 0.28570D0, 0.28068D0, 0.27216D0, 0.26127D0,
56189 & 0.24773D0, 0.23281D0, 0.21663D0, 0.19968D0, 0.18252D0,
56190 & 0.16522D0, 0.14809D0, 0.13153D0, 0.11576D0, 0.10050D0,
56191 & 0.08631D0, 0.07335D0, 0.06127D0, 0.04098D0, 0.02531D0,
56192 & 0.01409D0, 0.00672D0, 0.00064D0, 0.00000D0/
56193 DATA (FMRS(2,2,I, 2),I=1,49)/
56194 & 0.00687D0, 0.00838D0, 0.01023D0, 0.01151D0, 0.01252D0,
56195 & 0.01336D0, 0.01643D0, 0.02037D0, 0.02327D0, 0.02569D0,
56196 & 0.02797D0, 0.03698D0, 0.05059D0, 0.06162D0, 0.07129D0,
56197 & 0.08004D0, 0.09567D0, 0.11595D0, 0.14429D0, 0.16793D0,
56198 & 0.20539D0, 0.23318D0, 0.25356D0, 0.27069D0, 0.28025D0,
56199 & 0.28363D0, 0.28200D0, 0.27624D0, 0.26713D0, 0.25572D0,
56200 & 0.24185D0, 0.22669D0, 0.21040D0, 0.19345D0, 0.17637D0,
56201 & 0.15928D0, 0.14242D0, 0.12615D0, 0.11076D0, 0.09591D0,
56202 & 0.08215D0, 0.06963D0, 0.05800D0, 0.03856D0, 0.02367D0,
56203 & 0.01309D0, 0.00619D0, 0.00057D0, 0.00000D0/
56204 DATA (FMRS(2,2,I, 3),I=1,49)/
56205 & 0.00693D0, 0.00848D0, 0.01038D0, 0.01170D0, 0.01274D0,
56206 & 0.01362D0, 0.01679D0, 0.02088D0, 0.02389D0, 0.02641D0,
56207 & 0.02877D0, 0.03812D0, 0.05220D0, 0.06356D0, 0.07349D0,
56208 & 0.08244D0, 0.09836D0, 0.11888D0, 0.14732D0, 0.17082D0,
56209 & 0.20757D0, 0.23434D0, 0.25356D0, 0.26918D0, 0.27725D0,
56210 & 0.27927D0, 0.27642D0, 0.26960D0, 0.25969D0, 0.24758D0,
56211 & 0.23327D0, 0.21778D0, 0.20136D0, 0.18446D0, 0.16756D0,
56212 & 0.15079D0, 0.13434D0, 0.11852D0, 0.10371D0, 0.08946D0,
56213 & 0.07631D0, 0.06442D0, 0.05345D0, 0.03522D0, 0.02142D0,
56214 & 0.01172D0, 0.00548D0, 0.00049D0, 0.00000D0/
56215 DATA (FMRS(2,2,I, 4),I=1,49)/
56216 & 0.00697D0, 0.00855D0, 0.01050D0, 0.01184D0, 0.01291D0,
56217 & 0.01380D0, 0.01706D0, 0.02126D0, 0.02435D0, 0.02694D0,
56218 & 0.02937D0, 0.03897D0, 0.05339D0, 0.06499D0, 0.07510D0,
56219 & 0.08419D0, 0.10031D0, 0.12100D0, 0.14949D0, 0.17285D0,
56220 & 0.20905D0, 0.23506D0, 0.25342D0, 0.26794D0, 0.27493D0,
56221 & 0.27599D0, 0.27230D0, 0.26475D0, 0.25426D0, 0.24171D0,
56222 & 0.22712D0, 0.21140D0, 0.19495D0, 0.17811D0, 0.16138D0,
56223 & 0.14485D0, 0.12869D0, 0.11323D0, 0.09881D0, 0.08500D0,
56224 & 0.07230D0, 0.06086D0, 0.05034D0, 0.03297D0, 0.01992D0,
56225 & 0.01081D0, 0.00501D0, 0.00044D0, 0.00000D0/
56226 DATA (FMRS(2,2,I, 5),I=1,49)/
56227 & 0.00702D0, 0.00863D0, 0.01062D0, 0.01200D0, 0.01309D0,
56228 & 0.01401D0, 0.01735D0, 0.02167D0, 0.02485D0, 0.02751D0,
56229 & 0.03001D0, 0.03988D0, 0.05465D0, 0.06649D0, 0.07678D0,
56230 & 0.08602D0, 0.10233D0, 0.12317D0, 0.15168D0, 0.17488D0,
56231 & 0.21046D0, 0.23564D0, 0.25309D0, 0.26645D0, 0.27234D0,
56232 & 0.27243D0, 0.26786D0, 0.25959D0, 0.24854D0, 0.23557D0,
56233 & 0.22068D0, 0.20486D0, 0.18841D0, 0.17163D0, 0.15506D0,
56234 & 0.13880D0, 0.12296D0, 0.10788D0, 0.09387D0, 0.08052D0,
56235 & 0.06829D0, 0.05730D0, 0.04726D0, 0.03074D0, 0.01844D0,
56236 & 0.00993D0, 0.00456D0, 0.00039D0, 0.00000D0/
56237 DATA (FMRS(2,2,I, 6),I=1,49)/
56238 & 0.00706D0, 0.00870D0, 0.01073D0, 0.01213D0, 0.01325D0,
56239 & 0.01419D0, 0.01761D0, 0.02203D0, 0.02528D0, 0.02801D0,
56240 & 0.03057D0, 0.04067D0, 0.05575D0, 0.06780D0, 0.07825D0,
56241 & 0.08760D0, 0.10408D0, 0.12504D0, 0.15354D0, 0.17659D0,
56242 & 0.21162D0, 0.23607D0, 0.25274D0, 0.26511D0, 0.27006D0,
56243 & 0.26933D0, 0.26403D0, 0.25518D0, 0.24367D0, 0.23035D0,
56244 & 0.21525D0, 0.19935D0, 0.18289D0, 0.16620D0, 0.14980D0,
56245 & 0.13377D0, 0.11822D0, 0.10346D0, 0.08981D0, 0.07685D0,
56246 & 0.06502D0, 0.05441D0, 0.04475D0, 0.02894D0, 0.01725D0,
56247 & 0.00923D0, 0.00420D0, 0.00035D0, 0.00000D0/
56248 DATA (FMRS(2,2,I, 7),I=1,49)/
56249 & 0.00711D0, 0.00877D0, 0.01083D0, 0.01227D0, 0.01340D0,
56250 & 0.01436D0, 0.01785D0, 0.02237D0, 0.02570D0, 0.02850D0,
56251 & 0.03112D0, 0.04143D0, 0.05680D0, 0.06905D0, 0.07964D0,
56252 & 0.08911D0, 0.10573D0, 0.12679D0, 0.15527D0, 0.17816D0,
56253 & 0.21263D0, 0.23638D0, 0.25229D0, 0.26373D0, 0.26781D0,
56254 & 0.26630D0, 0.26033D0, 0.25095D0, 0.23903D0, 0.22536D0,
56255 & 0.21011D0, 0.19416D0, 0.17766D0, 0.16111D0, 0.14488D0,
56256 & 0.12910D0, 0.11382D0, 0.09936D0, 0.08606D0, 0.07347D0,
56257 & 0.06201D0, 0.05178D0, 0.04247D0, 0.02732D0, 0.01619D0,
56258 & 0.00860D0, 0.00389D0, 0.00031D0, 0.00000D0/
56259 DATA (FMRS(2,2,I, 8),I=1,49)/
56260 & 0.00716D0, 0.00885D0, 0.01095D0, 0.01241D0, 0.01357D0,
56261 & 0.01455D0, 0.01812D0, 0.02275D0, 0.02616D0, 0.02902D0,
56262 & 0.03170D0, 0.04225D0, 0.05792D0, 0.07038D0, 0.08112D0,
56263 & 0.09070D0, 0.10747D0, 0.12863D0, 0.15707D0, 0.17976D0,
56264 & 0.21362D0, 0.23661D0, 0.25172D0, 0.26218D0, 0.26535D0,
56265 & 0.26303D0, 0.25640D0, 0.24647D0, 0.23413D0, 0.22018D0,
56266 & 0.20477D0, 0.18875D0, 0.17228D0, 0.15585D0, 0.13983D0,
56267 & 0.12430D0, 0.10932D0, 0.09519D0, 0.08225D0, 0.07005D0,
56268 & 0.05898D0, 0.04912D0, 0.04018D0, 0.02570D0, 0.01514D0,
56269 & 0.00799D0, 0.00358D0, 0.00028D0, 0.00000D0/
56270 DATA (FMRS(2,2,I, 9),I=1,49)/
56271 & 0.00720D0, 0.00891D0, 0.01105D0, 0.01254D0, 0.01372D0,
56272 & 0.01472D0, 0.01836D0, 0.02308D0, 0.02656D0, 0.02948D0,
56273 & 0.03221D0, 0.04297D0, 0.05891D0, 0.07154D0, 0.08241D0,
56274 & 0.09208D0, 0.10897D0, 0.13020D0, 0.15860D0, 0.18111D0,
56275 & 0.21443D0, 0.23674D0, 0.25116D0, 0.26078D0, 0.26316D0,
56276 & 0.26017D0, 0.25299D0, 0.24260D0, 0.22991D0, 0.21577D0,
56277 & 0.20023D0, 0.18414D0, 0.16776D0, 0.15141D0, 0.13557D0,
56278 & 0.12027D0, 0.10555D0, 0.09171D0, 0.07908D0, 0.06721D0,
56279 & 0.05646D0, 0.04691D0, 0.03829D0, 0.02437D0, 0.01428D0,
56280 & 0.00749D0, 0.00333D0, 0.00026D0, 0.00000D0/
56281 DATA (FMRS(2,2,I,10),I=1,49)/
56282 & 0.00724D0, 0.00898D0, 0.01115D0, 0.01266D0, 0.01386D0,
56283 & 0.01488D0, 0.01859D0, 0.02340D0, 0.02695D0, 0.02993D0,
56284 & 0.03271D0, 0.04366D0, 0.05985D0, 0.07265D0, 0.08364D0,
56285 & 0.09340D0, 0.11040D0, 0.13168D0, 0.16002D0, 0.18235D0,
56286 & 0.21512D0, 0.23679D0, 0.25054D0, 0.25935D0, 0.26099D0,
56287 & 0.25738D0, 0.24967D0, 0.23885D0, 0.22588D0, 0.21153D0,
56288 & 0.19588D0, 0.17977D0, 0.16345D0, 0.14723D0, 0.13156D0,
56289 & 0.11648D0, 0.10202D0, 0.08846D0, 0.07613D0, 0.06457D0,
56290 & 0.05413D0, 0.04488D0, 0.03655D0, 0.02315D0, 0.01349D0,
56291 & 0.00703D0, 0.00311D0, 0.00024D0, 0.00000D0/
56292 DATA (FMRS(2,2,I,11),I=1,49)/
56293 & 0.00727D0, 0.00904D0, 0.01123D0, 0.01276D0, 0.01398D0,
56294 & 0.01501D0, 0.01877D0, 0.02366D0, 0.02727D0, 0.03029D0,
56295 & 0.03311D0, 0.04422D0, 0.06061D0, 0.07353D0, 0.08461D0,
56296 & 0.09444D0, 0.11152D0, 0.13285D0, 0.16112D0, 0.18330D0,
56297 & 0.21564D0, 0.23680D0, 0.25001D0, 0.25818D0, 0.25925D0,
56298 & 0.25517D0, 0.24705D0, 0.23591D0, 0.22272D0, 0.20821D0,
56299 & 0.19248D0, 0.17638D0, 0.16011D0, 0.14399D0, 0.12847D0,
56300 & 0.11356D0, 0.09932D0, 0.08597D0, 0.07388D0, 0.06256D0,
56301 & 0.05235D0, 0.04334D0, 0.03522D0, 0.02223D0, 0.01290D0,
56302 & 0.00670D0, 0.00295D0, 0.00022D0, 0.00000D0/
56303 DATA (FMRS(2,2,I,12),I=1,49)/
56304 & 0.00735D0, 0.00915D0, 0.01141D0, 0.01298D0, 0.01423D0,
56305 & 0.01529D0, 0.01917D0, 0.02422D0, 0.02794D0, 0.03106D0,
56306 & 0.03397D0, 0.04541D0, 0.06221D0, 0.07541D0, 0.08668D0,
56307 & 0.09664D0, 0.11388D0, 0.13528D0, 0.16340D0, 0.18523D0,
56308 & 0.21662D0, 0.23667D0, 0.24876D0, 0.25560D0, 0.25550D0,
56309 & 0.25041D0, 0.24145D0, 0.22968D0, 0.21606D0, 0.20125D0,
56310 & 0.18540D0, 0.16932D0, 0.15319D0, 0.13731D0, 0.12210D0,
56311 & 0.10759D0, 0.09378D0, 0.08090D0, 0.06929D0, 0.05847D0,
56312 & 0.04874D0, 0.04022D0, 0.03256D0, 0.02039D0, 0.01173D0,
56313 & 0.00603D0, 0.00263D0, 0.00019D0, 0.00000D0/
56314 DATA (FMRS(2,2,I,13),I=1,49)/
56315 & 0.00742D0, 0.00926D0, 0.01156D0, 0.01317D0, 0.01446D0,
56316 & 0.01554D0, 0.01952D0, 0.02471D0, 0.02853D0, 0.03173D0,
56317 & 0.03472D0, 0.04644D0, 0.06360D0, 0.07703D0, 0.08845D0,
56318 & 0.09852D0, 0.11589D0, 0.13732D0, 0.16529D0, 0.18680D0,
56319 & 0.21735D0, 0.23643D0, 0.24757D0, 0.25329D0, 0.25220D0,
56320 & 0.24629D0, 0.23665D0, 0.22439D0, 0.21043D0, 0.19540D0,
56321 & 0.17949D0, 0.16343D0, 0.14746D0, 0.13180D0, 0.11686D0,
56322 & 0.10269D0, 0.08926D0, 0.07677D0, 0.06556D0, 0.05517D0,
56323 & 0.04584D0, 0.03772D0, 0.03044D0, 0.01893D0, 0.01082D0,
56324 & 0.00551D0, 0.00238D0, 0.00017D0, 0.00000D0/
56325 DATA (FMRS(2,2,I,14),I=1,49)/
56326 & 0.00750D0, 0.00938D0, 0.01173D0, 0.01339D0, 0.01471D0,
56327 & 0.01583D0, 0.01992D0, 0.02526D0, 0.02920D0, 0.03250D0,
56328 & 0.03557D0, 0.04761D0, 0.06516D0, 0.07882D0, 0.09041D0,
56329 & 0.10060D0, 0.11809D0, 0.13955D0, 0.16731D0, 0.18846D0,
56330 & 0.21802D0, 0.23605D0, 0.24613D0, 0.25062D0, 0.24846D0,
56331 & 0.24169D0, 0.23135D0, 0.21858D0, 0.20428D0, 0.18902D0,
56332 & 0.17309D0, 0.15708D0, 0.14130D0, 0.12590D0, 0.11127D0,
56333 & 0.09745D0, 0.08445D0, 0.07239D0, 0.06165D0, 0.05170D0,
56334 & 0.04281D0, 0.03511D0, 0.02824D0, 0.01743D0, 0.00988D0,
56335 & 0.00499D0, 0.00213D0, 0.00015D0, 0.00000D0/
56336 DATA (FMRS(2,2,I,15),I=1,49)/
56337 & 0.00758D0, 0.00950D0, 0.01192D0, 0.01362D0, 0.01498D0,
56338 & 0.01613D0, 0.02034D0, 0.02584D0, 0.02990D0, 0.03330D0,
56339 & 0.03646D0, 0.04882D0, 0.06676D0, 0.08067D0, 0.09242D0,
56340 & 0.10271D0, 0.12031D0, 0.14177D0, 0.16927D0, 0.19002D0,
56341 & 0.21855D0, 0.23546D0, 0.24445D0, 0.24771D0, 0.24448D0,
56342 & 0.23683D0, 0.22584D0, 0.21262D0, 0.19799D0, 0.18255D0,
56343 & 0.16661D0, 0.15073D0, 0.13511D0, 0.12003D0, 0.10571D0,
56344 & 0.09233D0, 0.07973D0, 0.06812D0, 0.05781D0, 0.04834D0,
56345 & 0.03990D0, 0.03259D0, 0.02612D0, 0.01599D0, 0.00899D0,
56346 & 0.00450D0, 0.00190D0, 0.00013D0, 0.00000D0/
56347 DATA (FMRS(2,2,I,16),I=1,49)/
56348 & 0.00766D0, 0.00962D0, 0.01210D0, 0.01384D0, 0.01522D0,
56349 & 0.01640D0, 0.02073D0, 0.02638D0, 0.03055D0, 0.03403D0,
56350 & 0.03728D0, 0.04992D0, 0.06822D0, 0.08234D0, 0.09422D0,
56351 & 0.10460D0, 0.12228D0, 0.14371D0, 0.17097D0, 0.19133D0,
56352 & 0.21891D0, 0.23481D0, 0.24283D0, 0.24499D0, 0.24085D0,
56353 & 0.23246D0, 0.22090D0, 0.20727D0, 0.19242D0, 0.17687D0,
56354 & 0.16094D0, 0.14517D0, 0.12974D0, 0.11493D0, 0.10094D0,
56355 & 0.08792D0, 0.07568D0, 0.06448D0, 0.05456D0, 0.04548D0,
56356 & 0.03743D0, 0.03047D0, 0.02435D0, 0.01480D0, 0.00826D0,
56357 & 0.00410D0, 0.00171D0, 0.00011D0, 0.00000D0/
56358 DATA (FMRS(2,2,I,17),I=1,49)/
56359 & 0.00775D0, 0.00975D0, 0.01228D0, 0.01406D0, 0.01548D0,
56360 & 0.01669D0, 0.02112D0, 0.02692D0, 0.03120D0, 0.03478D0,
56361 & 0.03810D0, 0.05104D0, 0.06968D0, 0.08400D0, 0.09602D0,
56362 & 0.10648D0, 0.12423D0, 0.14563D0, 0.17261D0, 0.19256D0,
56363 & 0.21918D0, 0.23405D0, 0.24112D0, 0.24221D0, 0.23719D0,
56364 & 0.22809D0, 0.21600D0, 0.20198D0, 0.18694D0, 0.17130D0,
56365 & 0.15541D0, 0.13976D0, 0.12455D0, 0.11000D0, 0.09636D0,
56366 & 0.08368D0, 0.07182D0, 0.06101D0, 0.05149D0, 0.04278D0,
56367 & 0.03510D0, 0.02849D0, 0.02269D0, 0.01370D0, 0.00759D0,
56368 & 0.00374D0, 0.00155D0, 0.00010D0, 0.00000D0/
56369 DATA (FMRS(2,2,I,18),I=1,49)/
56370 & 0.00782D0, 0.00985D0, 0.01243D0, 0.01424D0, 0.01569D0,
56371 & 0.01692D0, 0.02146D0, 0.02738D0, 0.03175D0, 0.03540D0,
56372 & 0.03879D0, 0.05197D0, 0.07089D0, 0.08537D0, 0.09749D0,
56373 & 0.10801D0, 0.12581D0, 0.14716D0, 0.17390D0, 0.19349D0,
56374 & 0.21930D0, 0.23333D0, 0.23963D0, 0.23986D0, 0.23413D0,
56375 & 0.22447D0, 0.21197D0, 0.19769D0, 0.18248D0, 0.16678D0,
56376 & 0.15094D0, 0.13543D0, 0.12040D0, 0.10608D0, 0.09270D0,
56377 & 0.08031D0, 0.06878D0, 0.05828D0, 0.04908D0, 0.04068D0,
56378 & 0.03329D0, 0.02694D0, 0.02140D0, 0.01285D0, 0.00708D0,
56379 & 0.00346D0, 0.00142D0, 0.00009D0, 0.00000D0/
56380 DATA (FMRS(2,2,I,19),I=1,49)/
56381 & 0.00791D0, 0.00998D0, 0.01261D0, 0.01447D0, 0.01595D0,
56382 & 0.01722D0, 0.02186D0, 0.02794D0, 0.03242D0, 0.03616D0,
56383 & 0.03963D0, 0.05310D0, 0.07234D0, 0.08702D0, 0.09924D0,
56384 & 0.10983D0, 0.12767D0, 0.14895D0, 0.17537D0, 0.19453D0,
56385 & 0.21933D0, 0.23238D0, 0.23773D0, 0.23696D0, 0.23039D0,
56386 & 0.22010D0, 0.20715D0, 0.19257D0, 0.17716D0, 0.16147D0,
56387 & 0.14570D0, 0.13034D0, 0.11556D0, 0.10152D0, 0.08847D0,
56388 & 0.07643D0, 0.06526D0, 0.05515D0, 0.04631D0, 0.03827D0,
56389 & 0.03122D0, 0.02519D0, 0.01995D0, 0.01190D0, 0.00650D0,
56390 & 0.00315D0, 0.00128D0, 0.00008D0, 0.00000D0/
56391 DATA (FMRS(2,2,I,20),I=1,49)/
56392 & 0.00799D0, 0.01010D0, 0.01278D0, 0.01467D0, 0.01619D0,
56393 & 0.01748D0, 0.02223D0, 0.02844D0, 0.03302D0, 0.03684D0,
56394 & 0.04038D0, 0.05409D0, 0.07362D0, 0.08846D0, 0.10078D0,
56395 & 0.11143D0, 0.12930D0, 0.15050D0, 0.17662D0, 0.19539D0,
56396 & 0.21931D0, 0.23148D0, 0.23602D0, 0.23438D0, 0.22712D0,
56397 & 0.21628D0, 0.20296D0, 0.18814D0, 0.17260D0, 0.15692D0,
56398 & 0.14124D0, 0.12600D0, 0.11146D0, 0.09768D0, 0.08490D0,
56399 & 0.07317D0, 0.06233D0, 0.05253D0, 0.04400D0, 0.03627D0,
56400 & 0.02950D0, 0.02375D0, 0.01875D0, 0.01112D0, 0.00604D0,
56401 & 0.00291D0, 0.00117D0, 0.00007D0, 0.00000D0/
56402 DATA (FMRS(2,2,I,21),I=1,49)/
56403 & 0.00806D0, 0.01021D0, 0.01293D0, 0.01486D0, 0.01641D0,
56404 & 0.01772D0, 0.02256D0, 0.02890D0, 0.03357D0, 0.03747D0,
56405 & 0.04106D0, 0.05501D0, 0.07479D0, 0.08976D0, 0.10217D0,
56406 & 0.11285D0, 0.13073D0, 0.15184D0, 0.17768D0, 0.19608D0,
56407 & 0.21918D0, 0.23055D0, 0.23436D0, 0.23195D0, 0.22407D0,
56408 & 0.21277D0, 0.19913D0, 0.18411D0, 0.16851D0, 0.15282D0,
56409 & 0.13724D0, 0.12215D0, 0.10780D0, 0.09426D0, 0.08175D0,
56410 & 0.07030D0, 0.05975D0, 0.05024D0, 0.04199D0, 0.03453D0,
56411 & 0.02802D0, 0.02251D0, 0.01772D0, 0.01045D0, 0.00564D0,
56412 & 0.00270D0, 0.00108D0, 0.00006D0, 0.00000D0/
56413 DATA (FMRS(2,2,I,22),I=1,49)/
56414 & 0.00816D0, 0.01035D0, 0.01313D0, 0.01511D0, 0.01669D0,
56415 & 0.01803D0, 0.02299D0, 0.02949D0, 0.03427D0, 0.03826D0,
56416 & 0.04194D0, 0.05616D0, 0.07626D0, 0.09141D0, 0.10390D0,
56417 & 0.11463D0, 0.13252D0, 0.15350D0, 0.17897D0, 0.19689D0,
56418 & 0.21895D0, 0.22932D0, 0.23223D0, 0.22887D0, 0.22024D0,
56419 & 0.20839D0, 0.19437D0, 0.17913D0, 0.16346D0, 0.14778D0,
56420 & 0.13233D0, 0.11744D0, 0.10335D0, 0.09011D0, 0.07794D0,
56421 & 0.06684D0, 0.05665D0, 0.04749D0, 0.03958D0, 0.03245D0,
56422 & 0.02625D0, 0.02103D0, 0.01650D0, 0.00967D0, 0.00518D0,
56423 & 0.00246D0, 0.00097D0, 0.00005D0, 0.00000D0/
56424 DATA (FMRS(2,2,I,23),I=1,49)/
56425 & 0.00826D0, 0.01049D0, 0.01333D0, 0.01534D0, 0.01695D0,
56426 & 0.01833D0, 0.02340D0, 0.03004D0, 0.03494D0, 0.03901D0,
56427 & 0.04276D0, 0.05725D0, 0.07764D0, 0.09293D0, 0.10551D0,
56428 & 0.11628D0, 0.13416D0, 0.15502D0, 0.18011D0, 0.19758D0,
56429 & 0.21867D0, 0.22812D0, 0.23018D0, 0.22598D0, 0.21667D0,
56430 & 0.20434D0, 0.19000D0, 0.17460D0, 0.15883D0, 0.14320D0,
56431 & 0.12787D0, 0.11321D0, 0.09934D0, 0.08640D0, 0.07454D0,
56432 & 0.06376D0, 0.05389D0, 0.04504D0, 0.03744D0, 0.03063D0,
56433 & 0.02471D0, 0.01973D0, 0.01544D0, 0.00899D0, 0.00479D0,
56434 & 0.00225D0, 0.00088D0, 0.00005D0, 0.00000D0/
56435 DATA (FMRS(2,2,I,24),I=1,49)/
56436 & 0.00835D0, 0.01062D0, 0.01351D0, 0.01556D0, 0.01721D0,
56437 & 0.01861D0, 0.02378D0, 0.03057D0, 0.03556D0, 0.03972D0,
56438 & 0.04354D0, 0.05827D0, 0.07891D0, 0.09434D0, 0.10698D0,
56439 & 0.11778D0, 0.13564D0, 0.15636D0, 0.18108D0, 0.19811D0,
56440 & 0.21829D0, 0.22687D0, 0.22819D0, 0.22319D0, 0.21330D0,
56441 & 0.20053D0, 0.18593D0, 0.17036D0, 0.15459D0, 0.13902D0,
56442 & 0.12383D0, 0.10936D0, 0.09573D0, 0.08306D0, 0.07149D0,
56443 & 0.06100D0, 0.05144D0, 0.04289D0, 0.03556D0, 0.02901D0,
56444 & 0.02335D0, 0.01859D0, 0.01451D0, 0.00840D0, 0.00444D0,
56445 & 0.00208D0, 0.00081D0, 0.00004D0, 0.00000D0/
56446 DATA (FMRS(2,2,I,25),I=1,49)/
56447 & 0.00844D0, 0.01075D0, 0.01369D0, 0.01578D0, 0.01746D0,
56448 & 0.01889D0, 0.02417D0, 0.03109D0, 0.03619D0, 0.04043D0,
56449 & 0.04431D0, 0.05929D0, 0.08018D0, 0.09573D0, 0.10844D0,
56450 & 0.11926D0, 0.13709D0, 0.15767D0, 0.18202D0, 0.19861D0,
56451 & 0.21788D0, 0.22561D0, 0.22620D0, 0.22044D0, 0.20998D0,
56452 & 0.19681D0, 0.18196D0, 0.16625D0, 0.15048D0, 0.13499D0,
56453 & 0.11994D0, 0.10567D0, 0.09228D0, 0.07987D0, 0.06858D0,
56454 & 0.05838D0, 0.04911D0, 0.04085D0, 0.03379D0, 0.02749D0,
56455 & 0.02207D0, 0.01753D0, 0.01364D0, 0.00785D0, 0.00413D0,
56456 & 0.00192D0, 0.00074D0, 0.00004D0, 0.00000D0/
56457 DATA (FMRS(2,2,I,26),I=1,49)/
56458 & 0.00853D0, 0.01088D0, 0.01388D0, 0.01600D0, 0.01772D0,
56459 & 0.01917D0, 0.02456D0, 0.03161D0, 0.03680D0, 0.04112D0,
56460 & 0.04508D0, 0.06028D0, 0.08140D0, 0.09707D0, 0.10983D0,
56461 & 0.12067D0, 0.13846D0, 0.15889D0, 0.18286D0, 0.19901D0,
56462 & 0.21739D0, 0.22430D0, 0.22419D0, 0.21773D0, 0.20672D0,
56463 & 0.19320D0, 0.17811D0, 0.16233D0, 0.14654D0, 0.13113D0,
56464 & 0.11622D0, 0.10216D0, 0.08901D0, 0.07686D0, 0.06584D0,
56465 & 0.05592D0, 0.04692D0, 0.03894D0, 0.03214D0, 0.02608D0,
56466 & 0.02089D0, 0.01655D0, 0.01285D0, 0.00735D0, 0.00384D0,
56467 & 0.00177D0, 0.00068D0, 0.00003D0, 0.00000D0/
56468 DATA (FMRS(2,2,I,27),I=1,49)/
56469 & 0.00862D0, 0.01100D0, 0.01405D0, 0.01622D0, 0.01796D0,
56470 & 0.01944D0, 0.02492D0, 0.03211D0, 0.03739D0, 0.04178D0,
56471 & 0.04580D0, 0.06121D0, 0.08256D0, 0.09833D0, 0.11114D0,
56472 & 0.12198D0, 0.13974D0, 0.16000D0, 0.18361D0, 0.19934D0,
56473 & 0.21688D0, 0.22303D0, 0.22227D0, 0.21516D0, 0.20368D0,
56474 & 0.18983D0, 0.17455D0, 0.15870D0, 0.14292D0, 0.12759D0,
56475 & 0.11282D0, 0.09895D0, 0.08604D0, 0.07413D0, 0.06336D0,
56476 & 0.05370D0, 0.04495D0, 0.03722D0, 0.03066D0, 0.02482D0,
56477 & 0.01983D0, 0.01568D0, 0.01214D0, 0.00691D0, 0.00359D0,
56478 & 0.00164D0, 0.00063D0, 0.00003D0, 0.00000D0/
56479 DATA (FMRS(2,2,I,28),I=1,49)/
56480 & 0.00871D0, 0.01113D0, 0.01422D0, 0.01642D0, 0.01819D0,
56481 & 0.01970D0, 0.02527D0, 0.03257D0, 0.03795D0, 0.04240D0,
56482 & 0.04648D0, 0.06209D0, 0.08364D0, 0.09950D0, 0.11235D0,
56483 & 0.12320D0, 0.14090D0, 0.16101D0, 0.18426D0, 0.19960D0,
56484 & 0.21635D0, 0.22178D0, 0.22043D0, 0.21273D0, 0.20082D0,
56485 & 0.18670D0, 0.17123D0, 0.15532D0, 0.13957D0, 0.12434D0,
56486 & 0.10972D0, 0.09602D0, 0.08332D0, 0.07164D0, 0.06111D0,
56487 & 0.05170D0, 0.04318D0, 0.03568D0, 0.02933D0, 0.02371D0,
56488 & 0.01889D0, 0.01491D0, 0.01151D0, 0.00652D0, 0.00337D0,
56489 & 0.00153D0, 0.00058D0, 0.00003D0, 0.00000D0/
56490 DATA (FMRS(2,2,I,29),I=1,49)/
56491 & 0.00880D0, 0.01125D0, 0.01439D0, 0.01662D0, 0.01842D0,
56492 & 0.01995D0, 0.02562D0, 0.03305D0, 0.03850D0, 0.04303D0,
56493 & 0.04716D0, 0.06297D0, 0.08471D0, 0.10067D0, 0.11354D0,
56494 & 0.12440D0, 0.14205D0, 0.16199D0, 0.18487D0, 0.19981D0,
56495 & 0.21577D0, 0.22050D0, 0.21856D0, 0.21030D0, 0.19797D0,
56496 & 0.18358D0, 0.16796D0, 0.15200D0, 0.13629D0, 0.12116D0,
56497 & 0.10670D0, 0.09318D0, 0.08069D0, 0.06924D0, 0.05894D0,
56498 & 0.04976D0, 0.04148D0, 0.03421D0, 0.02806D0, 0.02263D0,
56499 & 0.01799D0, 0.01417D0, 0.01091D0, 0.00615D0, 0.00316D0,
56500 & 0.00143D0, 0.00054D0, 0.00003D0, 0.00000D0/
56501 DATA (FMRS(2,2,I,30),I=1,49)/
56502 & 0.00889D0, 0.01137D0, 0.01456D0, 0.01683D0, 0.01865D0,
56503 & 0.02021D0, 0.02596D0, 0.03351D0, 0.03906D0, 0.04365D0,
56504 & 0.04784D0, 0.06384D0, 0.08576D0, 0.10180D0, 0.11470D0,
56505 & 0.12555D0, 0.14314D0, 0.16292D0, 0.18544D0, 0.19997D0,
56506 & 0.21516D0, 0.21921D0, 0.21670D0, 0.20790D0, 0.19518D0,
56507 & 0.18054D0, 0.16480D0, 0.14880D0, 0.13314D0, 0.11810D0,
56508 & 0.10380D0, 0.09048D0, 0.07819D0, 0.06696D0, 0.05688D0,
56509 & 0.04793D0, 0.03987D0, 0.03282D0, 0.02686D0, 0.02162D0,
56510 & 0.01715D0, 0.01347D0, 0.01036D0, 0.00581D0, 0.00297D0,
56511 & 0.00134D0, 0.00050D0, 0.00002D0, 0.00000D0/
56512 DATA (FMRS(2,2,I,31),I=1,49)/
56513 & 0.00897D0, 0.01149D0, 0.01472D0, 0.01702D0, 0.01887D0,
56514 & 0.02045D0, 0.02630D0, 0.03396D0, 0.03958D0, 0.04424D0,
56515 & 0.04848D0, 0.06466D0, 0.08676D0, 0.10286D0, 0.11579D0,
56516 & 0.12663D0, 0.14416D0, 0.16377D0, 0.18594D0, 0.20009D0,
56517 & 0.21455D0, 0.21797D0, 0.21493D0, 0.20563D0, 0.19256D0,
56518 & 0.17769D0, 0.16185D0, 0.14582D0, 0.13021D0, 0.11528D0,
56519 & 0.10112D0, 0.08798D0, 0.07588D0, 0.06486D0, 0.05500D0,
56520 & 0.04626D0, 0.03841D0, 0.03155D0, 0.02578D0, 0.02071D0,
56521 & 0.01640D0, 0.01285D0, 0.00986D0, 0.00551D0, 0.00280D0,
56522 & 0.00125D0, 0.00046D0, 0.00002D0, 0.00000D0/
56523 DATA (FMRS(2,2,I,32),I=1,49)/
56524 & 0.00905D0, 0.01160D0, 0.01487D0, 0.01721D0, 0.01909D0,
56525 & 0.02069D0, 0.02661D0, 0.03438D0, 0.04008D0, 0.04480D0,
56526 & 0.04909D0, 0.06543D0, 0.08768D0, 0.10385D0, 0.11679D0,
56527 & 0.12763D0, 0.14509D0, 0.16454D0, 0.18637D0, 0.20016D0,
56528 & 0.21393D0, 0.21676D0, 0.21323D0, 0.20346D0, 0.19008D0,
56529 & 0.17502D0, 0.15909D0, 0.14304D0, 0.12749D0, 0.11266D0,
56530 & 0.09863D0, 0.08567D0, 0.07376D0, 0.06293D0, 0.05328D0,
56531 & 0.04474D0, 0.03708D0, 0.03039D0, 0.02479D0, 0.01988D0,
56532 & 0.01572D0, 0.01229D0, 0.00941D0, 0.00524D0, 0.00265D0,
56533 & 0.00118D0, 0.00043D0, 0.00002D0, 0.00000D0/
56534 DATA (FMRS(2,2,I,33),I=1,49)/
56535 & 0.00914D0, 0.01172D0, 0.01503D0, 0.01740D0, 0.01930D0,
56536 & 0.02092D0, 0.02693D0, 0.03481D0, 0.04058D0, 0.04536D0,
56537 & 0.04970D0, 0.06621D0, 0.08862D0, 0.10485D0, 0.11781D0,
56538 & 0.12863D0, 0.14602D0, 0.16531D0, 0.18679D0, 0.20022D0,
56539 & 0.21330D0, 0.21555D0, 0.21154D0, 0.20131D0, 0.18763D0,
56540 & 0.17238D0, 0.15637D0, 0.14031D0, 0.12482D0, 0.11010D0,
56541 & 0.09620D0, 0.08342D0, 0.07168D0, 0.06106D0, 0.05161D0,
56542 & 0.04326D0, 0.03580D0, 0.02928D0, 0.02384D0, 0.01908D0,
56543 & 0.01506D0, 0.01176D0, 0.00899D0, 0.00498D0, 0.00251D0,
56544 & 0.00111D0, 0.00041D0, 0.00002D0, 0.00000D0/
56545 DATA (FMRS(2,2,I,34),I=1,49)/
56546 & 0.00922D0, 0.01183D0, 0.01519D0, 0.01758D0, 0.01951D0,
56547 & 0.02116D0, 0.02725D0, 0.03523D0, 0.04108D0, 0.04592D0,
56548 & 0.05030D0, 0.06698D0, 0.08953D0, 0.10581D0, 0.11878D0,
56549 & 0.12959D0, 0.14690D0, 0.16601D0, 0.18715D0, 0.20021D0,
56550 & 0.21262D0, 0.21429D0, 0.20982D0, 0.19916D0, 0.18519D0,
56551 & 0.16977D0, 0.15369D0, 0.13763D0, 0.12221D0, 0.10760D0,
56552 & 0.09385D0, 0.08123D0, 0.06969D0, 0.05926D0, 0.05001D0,
56553 & 0.04183D0, 0.03456D0, 0.02822D0, 0.02295D0, 0.01833D0,
56554 & 0.01444D0, 0.01126D0, 0.00858D0, 0.00473D0, 0.00238D0,
56555 & 0.00105D0, 0.00038D0, 0.00002D0, 0.00000D0/
56556 DATA (FMRS(2,2,I,35),I=1,49)/
56557 & 0.00930D0, 0.01194D0, 0.01534D0, 0.01777D0, 0.01972D0,
56558 & 0.02138D0, 0.02755D0, 0.03564D0, 0.04156D0, 0.04645D0,
56559 & 0.05088D0, 0.06771D0, 0.09039D0, 0.10673D0, 0.11970D0,
56560 & 0.13050D0, 0.14773D0, 0.16667D0, 0.18748D0, 0.20020D0,
56561 & 0.21197D0, 0.21309D0, 0.20820D0, 0.19714D0, 0.18290D0,
56562 & 0.16734D0, 0.15119D0, 0.13514D0, 0.11978D0, 0.10528D0,
56563 & 0.09167D0, 0.07922D0, 0.06786D0, 0.05760D0, 0.04853D0,
56564 & 0.04052D0, 0.03343D0, 0.02726D0, 0.02213D0, 0.01765D0,
56565 & 0.01387D0, 0.01080D0, 0.00822D0, 0.00451D0, 0.00226D0,
56566 & 0.00099D0, 0.00036D0, 0.00002D0, 0.00000D0/
56567 DATA (FMRS(2,2,I,36),I=1,49)/
56568 & 0.00938D0, 0.01205D0, 0.01549D0, 0.01794D0, 0.01992D0,
56569 & 0.02160D0, 0.02784D0, 0.03602D0, 0.04201D0, 0.04696D0,
56570 & 0.05143D0, 0.06840D0, 0.09121D0, 0.10758D0, 0.12056D0,
56571 & 0.13134D0, 0.14849D0, 0.16728D0, 0.18776D0, 0.20016D0,
56572 & 0.21132D0, 0.21194D0, 0.20664D0, 0.19522D0, 0.18074D0,
56573 & 0.16504D0, 0.14884D0, 0.13281D0, 0.11752D0, 0.10313D0,
56574 & 0.08965D0, 0.07735D0, 0.06616D0, 0.05608D0, 0.04717D0,
56575 & 0.03933D0, 0.03239D0, 0.02637D0, 0.02137D0, 0.01702D0,
56576 & 0.01336D0, 0.01038D0, 0.00788D0, 0.00431D0, 0.00215D0,
56577 & 0.00094D0, 0.00034D0, 0.00001D0, 0.00000D0/
56578 DATA (FMRS(2,2,I,37),I=1,49)/
56579 & 0.00946D0, 0.01216D0, 0.01563D0, 0.01812D0, 0.02011D0,
56580 & 0.02182D0, 0.02814D0, 0.03641D0, 0.04247D0, 0.04747D0,
56581 & 0.05199D0, 0.06909D0, 0.09202D0, 0.10844D0, 0.12142D0,
56582 & 0.13217D0, 0.14925D0, 0.16786D0, 0.18802D0, 0.20008D0,
56583 & 0.21063D0, 0.21075D0, 0.20506D0, 0.19327D0, 0.17856D0,
56584 & 0.16274D0, 0.14648D0, 0.13048D0, 0.11526D0, 0.10099D0,
56585 & 0.08766D0, 0.07551D0, 0.06448D0, 0.05458D0, 0.04583D0,
56586 & 0.03816D0, 0.03137D0, 0.02550D0, 0.02064D0, 0.01641D0,
56587 & 0.01285D0, 0.00997D0, 0.00756D0, 0.00412D0, 0.00204D0,
56588 & 0.00089D0, 0.00032D0, 0.00001D0, 0.00000D0/
56589 DATA (FMRS(2,2,I,38),I=1,49)/
56590 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56591 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56592 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56593 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56594 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56595 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56596 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56597 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56598 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
56599 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
56600 DATA (FMRS(2,3,I, 1),I=1,49)/
56601 & 2.49594D0, 2.59678D0, 2.70121D0, 2.76381D0, 2.80882D0,
56602 & 2.84400D0, 2.95410D0, 3.06293D0, 3.12376D0, 3.16433D0,
56603 & 3.19612D0, 3.26381D0, 3.24185D0, 3.15396D0, 3.04339D0,
56604 & 2.92461D0, 2.68378D0, 2.34265D0, 1.85814D0, 1.47710D0,
56605 & 0.96403D0, 0.68739D0, 0.56164D0, 0.53053D0, 0.57114D0,
56606 & 0.63752D0, 0.70266D0, 0.75190D0, 0.77864D0, 0.78165D0,
56607 & 0.76223D0, 0.72410D0, 0.67143D0, 0.60861D0, 0.54010D0,
56608 & 0.46946D0, 0.39966D0, 0.33340D0, 0.27271D0, 0.21796D0,
56609 & 0.17035D0, 0.13022D0, 0.09678D0, 0.04919D0, 0.02174D0,
56610 & 0.00799D0, 0.00226D0, 0.00004D0, 0.00000D0/
56611 DATA (FMRS(2,3,I, 2),I=1,49)/
56612 & 4.92533D0, 4.79050D0, 4.65910D0, 4.58370D0, 4.53079D0,
56613 & 4.49006D0, 4.36491D0, 4.24084D0, 4.16793D0, 4.11560D0,
56614 & 4.07957D0, 3.94076D0, 3.72768D0, 3.53640D0, 3.35786D0,
56615 & 3.19001D0, 2.88282D0, 2.48367D0, 1.95213D0, 1.55132D0,
56616 & 1.02835D0, 0.75268D0, 0.62744D0, 0.59181D0, 0.62218D0,
56617 & 0.67462D0, 0.72413D0, 0.75779D0, 0.77032D0, 0.76124D0,
56618 & 0.73236D0, 0.68747D0, 0.63069D0, 0.56612D0, 0.49789D0,
56619 & 0.42912D0, 0.36239D0, 0.29993D0, 0.24354D0, 0.19324D0,
56620 & 0.14994D0, 0.11382D0, 0.08400D0, 0.04209D0, 0.01833D0,
56621 & 0.00664D0, 0.00185D0, 0.00003D0, 0.00000D0/
56622 DATA (FMRS(2,3,I, 3),I=1,49)/
56623 & 9.56993D0, 8.80858D0, 8.10702D0, 7.72221D0, 7.45989D0,
56624 & 7.26226D0, 6.67868D0, 6.13604D0, 5.83460D0, 5.62657D0,
56625 & 5.47187D0, 4.98498D0, 4.45878D0, 4.10350D0, 3.81920D0,
56626 & 3.57625D0, 3.16921D0, 2.68460D0, 2.08542D0, 1.65674D0,
56627 & 1.11953D0, 0.84374D0, 0.71690D0, 0.67195D0, 0.68567D0,
56628 & 0.71718D0, 0.74433D0, 0.75653D0, 0.75014D0, 0.72558D0,
56629 & 0.68509D0, 0.63243D0, 0.57149D0, 0.50592D0, 0.43925D0,
56630 & 0.37400D0, 0.31223D0, 0.25550D0, 0.20529D0, 0.16120D0,
56631 & 0.12380D0, 0.09303D0, 0.06796D0, 0.03337D0, 0.01425D0,
56632 & 0.00506D0, 0.00138D0, 0.00002D0, 0.00000D0/
56633 DATA (FMRS(2,3,I, 4),I=1,49)/
56634 & 13.80940D0, 12.36505D0, 11.07010D0, 10.37511D0, 9.90777D0,
56635 & 9.55916D0, 8.54772D0, 7.63175D0, 7.13319D0, 6.79336D0,
56636 & 6.53831D0, 5.76591D0, 4.99154D0, 4.51033D0, 4.14636D0,
56637 & 3.84778D0, 3.36791D0, 2.82235D0, 2.17611D0, 1.72845D0,
56638 & 1.18134D0, 0.90432D0, 0.77478D0, 0.72147D0, 0.72239D0,
56639 & 0.73883D0, 0.75059D0, 0.74861D0, 0.73014D0, 0.69610D0,
56640 & 0.64889D0, 0.59216D0, 0.52949D0, 0.46423D0, 0.39938D0,
56641 & 0.33717D0, 0.27919D0, 0.22665D0, 0.18078D0, 0.14088D0,
56642 & 0.10742D0, 0.08015D0, 0.05814D0, 0.02814D0, 0.01185D0,
56643 & 0.00415D0, 0.00112D0, 0.00002D0, 0.00000D0/
56644 DATA (FMRS(2,3,I, 5),I=1,49)/
56645 & 18.88911D0, 16.54105D0, 14.48190D0, 13.39606D0, 12.67388D0,
56646 & 12.13950D0, 10.61083D0, 9.25560D0, 8.52999D0, 8.04031D0,
56647 & 7.67199D0, 6.58349D0, 5.54112D0, 4.92668D0, 4.47939D0,
56648 & 4.12305D0, 3.56848D0, 2.96102D0, 2.26733D0, 1.80038D0,
56649 & 1.24179D0, 0.96142D0, 0.82726D0, 0.76409D0, 0.75165D0,
56650 & 0.75317D0, 0.75022D0, 0.73504D0, 0.70570D0, 0.66340D0,
56651 & 0.61066D0, 0.55093D0, 0.48745D0, 0.42321D0, 0.36077D0,
56652 & 0.30193D0, 0.24792D0, 0.19962D0, 0.15797D0, 0.12220D0,
56653 & 0.09245D0, 0.06850D0, 0.04934D0, 0.02353D0, 0.00976D0,
56654 & 0.00337D0, 0.00090D0, 0.00002D0, 0.00000D0/
56655 DATA (FMRS(2,3,I, 6),I=1,49)/
56656 & 24.17862D0, 20.81157D0, 17.90894D0, 16.39907D0, 15.40344D0,
56657 & 14.67132D0, 12.59987D0, 10.79385D0, 9.83948D0, 9.20057D0,
56658 & 8.72036D0, 7.32519D0, 6.02998D0, 5.29291D0, 4.77007D0,
56659 & 4.36196D0, 3.74120D0, 3.07968D0, 2.34504D0, 1.86151D0,
56660 & 1.29269D0, 1.00884D0, 0.87005D0, 0.79769D0, 0.77342D0,
56661 & 0.76224D0, 0.74721D0, 0.72151D0, 0.68376D0, 0.63535D0,
56662 & 0.57871D0, 0.51714D0, 0.45352D0, 0.39051D0, 0.33033D0,
56663 & 0.27444D0, 0.22374D0, 0.17892D0, 0.14065D0, 0.10811D0,
56664 & 0.08127D0, 0.05985D0, 0.04284D0, 0.02018D0, 0.00827D0,
56665 & 0.00283D0, 0.00075D0, 0.00001D0, 0.00000D0/
56666 DATA (FMRS(2,3,I, 7),I=1,49)/
56667 & 29.73861D0, 25.23818D0, 21.41267D0, 19.44500D0, 18.15658D0,
56668 & 17.21404D0, 14.57125D0, 12.29875D0, 11.11092D0, 10.32111D0,
56669 & 9.72854D0, 8.02926D0, 6.48794D0, 5.63342D0, 5.03891D0,
56670 & 4.58210D0, 3.89945D0, 3.18799D0, 2.41570D0, 1.91680D0,
56671 & 1.33767D0, 1.04936D0, 0.90523D0, 0.82366D0, 0.78841D0,
56672 & 0.76591D0, 0.74039D0, 0.70578D0, 0.66114D0, 0.60793D0,
56673 & 0.54844D0, 0.48585D0, 0.42265D0, 0.36114D0, 0.30329D0,
56674 & 0.25030D0, 0.20271D0, 0.16106D0, 0.12587D0, 0.09616D0,
56675 & 0.07187D0, 0.05262D0, 0.03744D0, 0.01745D0, 0.00707D0,
56676 & 0.00239D0, 0.00063D0, 0.00001D0, 0.00000D0/
56677 DATA (FMRS(2,3,I, 8),I=1,49)/
56678 & 36.41777D0, 30.48425D0, 25.50925D0, 22.97827D0, 21.33235D0,
56679 & 20.13434D0, 16.80486D0, 13.98059D0, 12.52029D0, 11.55588D0,
56680 & 10.83420D0, 8.78991D0, 6.97511D0, 5.99232D0, 5.32046D0,
56681 & 4.81154D0, 4.06330D0, 3.29938D0, 2.48793D0, 1.97297D0,
56682 & 1.38262D0, 1.08896D0, 0.93866D0, 0.84707D0, 0.80034D0,
56683 & 0.76640D0, 0.73057D0, 0.68748D0, 0.63647D0, 0.57905D0,
56684 & 0.51730D0, 0.45416D0, 0.39180D0, 0.33216D0, 0.27689D0,
56685 & 0.22693D0, 0.18251D0, 0.14405D0, 0.11189D0, 0.08494D0,
56686 & 0.06310D0, 0.04592D0, 0.03248D0, 0.01496D0, 0.00600D0,
56687 & 0.00201D0, 0.00052D0, 0.00001D0, 0.00000D0/
56688 DATA (FMRS(2,3,I, 9),I=1,49)/
56689 & 42.89913D0, 35.51439D0, 29.39055D0, 26.30256D0, 24.30551D0,
56690 & 22.85784D0, 18.86316D0, 15.51177D0, 13.79420D0, 12.66617D0,
56691 & 11.82423D0, 9.46212D0, 7.39982D0, 6.30264D0, 5.56252D0,
56692 & 5.00794D0, 4.20275D0, 3.39360D0, 2.54868D0, 2.01994D0,
56693 & 1.41958D0, 1.12075D0, 0.96469D0, 0.86425D0, 0.80777D0,
56694 & 0.76439D0, 0.72030D0, 0.67061D0, 0.61480D0, 0.55436D0,
56695 & 0.49120D0, 0.42796D0, 0.36659D0, 0.30874D0, 0.25576D0,
56696 & 0.20835D0, 0.16660D0, 0.13075D0, 0.10101D0, 0.07629D0,
56697 & 0.05637D0, 0.04082D0, 0.02872D0, 0.01310D0, 0.00521D0,
56698 & 0.00173D0, 0.00045D0, 0.00001D0, 0.00000D0/
56699 DATA (FMRS(2,3,I,10),I=1,49)/
56700 & 49.61974D0, 40.67585D0, 33.33157D0, 29.65726D0, 27.29273D0,
56701 & 25.58490D0, 20.90223D0, 17.01226D0, 15.03449D0, 13.74211D0,
56702 & 12.78005D0, 10.10345D0, 7.80003D0, 6.59295D0, 5.78776D0,
56703 & 5.18997D0, 4.33113D0, 3.47979D0, 2.60379D0, 2.06215D0,
56704 & 1.45191D0, 1.14765D0, 0.98577D0, 0.87686D0, 0.81144D0,
56705 & 0.75966D0, 0.70838D0, 0.65310D0, 0.59339D0, 0.53065D0,
56706 & 0.46666D0, 0.40372D0, 0.34354D0, 0.28753D0, 0.23679D0,
56707 & 0.19183D0, 0.15254D0, 0.11910D0, 0.09155D0, 0.06880D0,
56708 & 0.05059D0, 0.03647D0, 0.02554D0, 0.01155D0, 0.00456D0,
56709 & 0.00150D0, 0.00039D0, 0.00001D0, 0.00000D0/
56710 DATA (FMRS(2,3,I,11),I=1,49)/
56711 & 55.39180D0, 45.07076D0, 36.65840D0, 32.47479D0, 29.79258D0,
56712 & 27.86062D0, 22.58892D0, 18.24235D0, 16.04583D0, 14.61602D0,
56713 & 13.55394D0, 10.61757D0, 8.11747D0, 6.82180D0, 5.96451D0,
56714 & 5.33234D0, 4.43100D0, 3.54652D0, 2.64619D0, 2.09446D0,
56715 & 1.47626D0, 1.16746D0, 1.00084D0, 0.88523D0, 0.81292D0,
56716 & 0.75482D0, 0.69824D0, 0.63893D0, 0.57653D0, 0.51229D0,
56717 & 0.44790D0, 0.38538D0, 0.32625D0, 0.27173D0, 0.22275D0,
56718 & 0.17969D0, 0.14226D0, 0.11063D0, 0.08472D0, 0.06341D0,
56719 & 0.04647D0, 0.03337D0, 0.02328D0, 0.01046D0, 0.00410D0,
56720 & 0.00135D0, 0.00035D0, 0.00001D0, 0.00000D0/
56721 DATA (FMRS(2,3,I,12),I=1,49)/
56722 & 68.81419D0, 55.16745D0, 44.20809D0, 38.82247D0, 35.39534D0,
56723 & 32.94036D0, 26.30577D0, 20.91710D0, 18.22705D0, 16.48958D0,
56724 & 15.20488D0, 11.69679D0, 8.77186D0, 7.28789D0, 6.32113D0,
56725 & 5.61724D0, 4.62839D0, 3.67636D0, 2.72714D0, 2.15522D0,
56726 & 1.52072D0, 1.20219D0, 1.02548D0, 0.89610D0, 0.81011D0,
56727 & 0.73981D0, 0.67337D0, 0.60686D0, 0.53995D0, 0.47362D0,
56728 & 0.40911D0, 0.34808D0, 0.29158D0, 0.24046D0, 0.19523D0,
56729 & 0.15609D0, 0.12251D0, 0.09445D0, 0.07178D0, 0.05329D0,
56730 & 0.03875D0, 0.02763D0, 0.01914D0, 0.00848D0, 0.00328D0,
56731 & 0.00107D0, 0.00027D0, 0.00001D0, 0.00000D0/
56732 DATA (FMRS(2,3,I,13),I=1,49)/
56733 & 81.72071D0, 64.73620D0, 51.25830D0, 44.69851D0, 40.54929D0,
56734 & 37.59021D0, 29.65526D0, 23.28836D0, 20.14139D0, 18.12166D0,
56735 & 16.63424D0, 12.61228D0, 9.31401D0, 7.66787D0, 6.60816D0,
56736 & 5.84402D0, 4.78269D0, 3.77556D0, 2.78721D0, 2.19932D0,
56737 & 1.55169D0, 1.22492D0, 1.03973D0, 0.89912D0, 0.80240D0,
56738 & 0.72291D0, 0.64937D0, 0.57800D0, 0.50838D0, 0.44121D0,
56739 & 0.37732D0, 0.31807D0, 0.26412D0, 0.21603D0, 0.17402D0,
56740 & 0.13809D0, 0.10760D0, 0.08235D0, 0.06220D0, 0.04588D0,
56741 & 0.03314D0, 0.02349D0, 0.01618D0, 0.00709D0, 0.00272D0,
56742 & 0.00088D0, 0.00022D0, 0.00001D0, 0.00000D0/
56743 DATA (FMRS(2,3,I,14),I=1,49)/
56744 & 97.52657D0, 76.29261D0, 59.65305D0, 51.63612D0, 46.59734D0,
56745 & 43.02061D0, 33.50751D0, 25.97167D0, 22.28590D0, 19.93624D0,
56746 & 18.21366D0, 13.60275D0, 9.88582D0, 8.06142D0, 6.90102D0,
56747 & 6.07241D0, 4.93443D0, 3.87015D0, 2.84210D0, 2.23830D0,
56748 & 1.57740D0, 1.24193D0, 1.04776D0, 0.89562D0, 0.78827D0,
56749 & 0.70003D0, 0.62012D0, 0.54473D0, 0.47326D0, 0.40608D0,
56750 & 0.34362D0, 0.28678D0, 0.23589D0, 0.19121D0, 0.15279D0,
56751 & 0.12024D0, 0.09296D0, 0.07060D0, 0.05295D0, 0.03880D0,
56752 & 0.02782D0, 0.01961D0, 0.01341D0, 0.00581D0, 0.00221D0,
56753 & 0.00071D0, 0.00018D0, 0.00000D0, 0.00000D0/
56754 DATA (FMRS(2,3,I,15),I=1,49)/
56755 & 115.42858D0, 89.21046D0, 68.91241D0, 59.22810D0, 53.17852D0,
56756 & 48.90368D0, 37.62299D0, 28.79719D0, 24.52433D0, 21.81818D0,
56757 & 19.84305D0, 14.60749D0, 10.45530D0, 8.44881D0, 7.18665D0,
56758 & 6.29326D0, 5.07912D0, 3.95881D0, 2.89174D0, 2.27205D0,
56759 & 1.59726D0, 1.25251D0, 1.04935D0, 0.88634D0, 0.76946D0,
56760 & 0.67380D0, 0.58880D0, 0.51059D0, 0.43833D0, 0.37190D0,
56761 & 0.31141D0, 0.25732D0, 0.20974D0, 0.16850D0, 0.13349D0,
56762 & 0.10422D0, 0.07994D0, 0.06028D0, 0.04489D0, 0.03267D0,
56763 & 0.02328D0, 0.01630D0, 0.01109D0, 0.00475D0, 0.00179D0,
56764 & 0.00057D0, 0.00015D0, 0.00000D0, 0.00000D0/
56765 DATA (FMRS(2,3,I,16),I=1,49)/
56766 & 133.20726D0,101.88441D0, 77.88580D0, 66.53202D0, 59.47687D0,
56767 & 54.51081D0, 41.49468D0, 31.41946D0, 26.58451D0, 23.53963D0,
56768 & 21.32609D0, 15.50695D0, 10.95547D0, 8.78473D0, 7.43186D0,
56769 & 6.48132D0, 5.20052D0, 4.03146D0, 2.93090D0, 2.29753D0,
56770 & 1.61041D0, 1.25744D0, 1.04659D0, 0.87462D0, 0.75027D0,
56771 & 0.64906D0, 0.56054D0, 0.48074D0, 0.40844D0, 0.34317D0,
56772 & 0.28476D0, 0.23329D0, 0.18860D0, 0.15037D0, 0.11827D0,
56773 & 0.09171D0, 0.06985D0, 0.05235D0, 0.03876D0, 0.02805D0,
56774 & 0.01988D0, 0.01385D0, 0.00937D0, 0.00398D0, 0.00150D0,
56775 & 0.00048D0, 0.00012D0, 0.00000D0, 0.00000D0/
56776 DATA (FMRS(2,3,I,17),I=1,49)/
56777 & 152.75288D0,115.66533D0, 87.53463D0, 74.33386D0, 66.17272D0,
56778 & 60.44971D0, 45.54741D0, 34.13087D0, 28.69873D0, 25.29647D0,
56779 & 22.83273D0, 16.40709D0, 11.44748D0, 9.11138D0, 7.66812D0,
56780 & 6.66113D0, 5.31487D0, 4.09842D0, 2.96558D0, 2.31899D0,
56781 & 1.61977D0, 1.25878D0, 1.04063D0, 0.86046D0, 0.72956D0,
56782 & 0.62377D0, 0.53260D0, 0.45191D0, 0.38010D0, 0.31636D0,
56783 & 0.26019D0, 0.21141D0, 0.16955D0, 0.13419D0, 0.10481D0,
56784 & 0.08073D0, 0.06109D0, 0.04550D0, 0.03350D0, 0.02411D0,
56785 & 0.01700D0, 0.01178D0, 0.00794D0, 0.00335D0, 0.00125D0,
56786 & 0.00040D0, 0.00010D0, 0.00000D0, 0.00000D0/
56787 DATA (FMRS(2,3,I,18),I=1,49)/
56788 & 170.01192D0,127.71370D0, 95.88535D0, 81.04548D0, 71.90795D0,
56789 & 65.51928D0, 48.96956D0, 36.39437D0, 30.45131D0, 26.74517D0,
56790 & 24.06967D0, 17.13549D0, 11.83889D0, 9.36824D0, 7.85201D0,
56791 & 6.79985D0, 5.40144D0, 4.14772D0, 2.98965D0, 2.33267D0,
56792 & 1.62383D0, 1.25653D0, 1.03280D0, 0.84662D0, 0.71111D0,
56793 & 0.60235D0, 0.50969D0, 0.42880D0, 0.35778D0, 0.29558D0,
56794 & 0.24138D0, 0.19483D0, 0.15529D0, 0.12217D0, 0.09488D0,
56795 & 0.07271D0, 0.05474D0, 0.04057D0, 0.02974D0, 0.02131D0,
56796 & 0.01497D0, 0.01034D0, 0.00694D0, 0.00291D0, 0.00108D0,
56797 & 0.00035D0, 0.00009D0, 0.00000D0, 0.00000D0/
56798 DATA (FMRS(2,3,I,19),I=1,49)/
56799 & 192.21783D0,143.06714D0,106.42301D0, 89.46533D0, 79.07272D0,
56800 & 71.83153D0, 53.18588D0, 39.15232D0, 32.57201D0, 28.48916D0,
56801 & 25.55252D0, 17.99626D0, 12.29353D0, 9.66291D0, 8.06074D0,
56802 & 6.95556D0, 5.49677D0, 4.20023D0, 3.01333D0, 2.34451D0,
56803 & 1.62470D0, 1.25025D0, 1.02039D0, 0.82787D0, 0.68779D0,
56804 & 0.57628D0, 0.48256D0, 0.40194D0, 0.33226D0, 0.27214D0,
56805 & 0.22041D0, 0.17653D0, 0.13970D0, 0.10915D0, 0.08422D0,
56806 & 0.06416D0, 0.04803D0, 0.03538D0, 0.02582D0, 0.01841D0,
56807 & 0.01287D0, 0.00885D0, 0.00592D0, 0.00247D0, 0.00092D0,
56808 & 0.00029D0, 0.00008D0, 0.00000D0, 0.00000D0/
56809 DATA (FMRS(2,3,I,20),I=1,49)/
56810 & 213.34880D0,157.54303D0,116.26574D0, 97.28644D0, 85.70139D0,
56811 & 77.65329D0, 57.03621D0, 41.64487D0, 34.47643D0, 30.04790D0,
56812 & 26.87277D0, 18.75275D0, 12.68704D0, 9.91527D0, 8.23788D0,
56813 & 7.08656D0, 5.57571D0, 4.24254D0, 3.03117D0, 2.35234D0,
56814 & 1.62325D0, 1.24282D0, 1.00799D0, 0.81051D0, 0.66705D0,
56815 & 0.55370D0, 0.45951D0, 0.37948D0, 0.31121D0, 0.25302D0,
56816 & 0.20347D0, 0.16190D0, 0.12732D0, 0.09891D0, 0.07590D0,
56817 & 0.05752D0, 0.04285D0, 0.03141D0, 0.02283D0, 0.01621D0,
56818 & 0.01129D0, 0.00774D0, 0.00517D0, 0.00215D0, 0.00079D0,
56819 & 0.00025D0, 0.00007D0, 0.00000D0, 0.00000D0/
56820 DATA (FMRS(2,3,I,21),I=1,49)/
56821 & 233.39284D0,171.15466D0,125.43786D0,104.53514D0, 91.82097D0,
56822 & 83.01126D0, 60.54451D0, 43.89167D0, 36.18145D0, 31.43626D0,
56823 & 28.04374D0, 19.41375D0, 13.02433D0, 10.12820D0, 8.38525D0,
56824 & 7.19405D0, 5.63853D0, 4.27419D0, 3.04230D0, 2.35510D0,
56825 & 1.61821D0, 1.23292D0, 0.99418D0, 0.79299D0, 0.64721D0,
56826 & 0.53284D0, 0.43872D0, 0.35966D0, 0.29291D0, 0.23658D0,
56827 & 0.18910D0, 0.14961D0, 0.11702D0, 0.09045D0, 0.06907D0,
56828 & 0.05212D0, 0.03865D0, 0.02823D0, 0.02044D0, 0.01446D0,
56829 & 0.01004D0, 0.00687D0, 0.00457D0, 0.00189D0, 0.00070D0,
56830 & 0.00022D0, 0.00006D0, 0.00000D0, 0.00000D0/
56831 DATA (FMRS(2,3,I,22),I=1,49)/
56832 & 260.44016D0,189.36696D0,137.60457D0,114.10131D0, 99.86725D0,
56833 & 90.03576D0, 65.10178D0, 46.78208D0, 38.36169D0, 33.20363D0,
56834 & 29.52871D0, 20.24143D0, 13.44020D0, 10.38777D0, 8.56307D0,
56835 & 7.32250D0, 5.71195D0, 4.30962D0, 3.05294D0, 2.35572D0,
56836 & 1.60960D0, 1.21865D0, 0.97551D0, 0.77034D0, 0.62226D0,
56837 & 0.50716D0, 0.41356D0, 0.33596D0, 0.27128D0, 0.21734D0,
56838 & 0.17244D0, 0.13547D0, 0.10527D0, 0.08085D0, 0.06139D0,
56839 & 0.04607D0, 0.03398D0, 0.02471D0, 0.01781D0, 0.01255D0,
56840 & 0.00868D0, 0.00593D0, 0.00393D0, 0.00162D0, 0.00060D0,
56841 & 0.00019D0, 0.00005D0, 0.00000D0, 0.00000D0/
56842 DATA (FMRS(2,3,I,23),I=1,49)/
56843 & 287.44696D0,207.38838D0,149.53354D0,123.42919D0,107.68206D0,
56844 & 96.83708D0, 69.47065D0, 49.52397D0, 40.41636D0, 34.86102D0,
56845 & 30.91543D0, 21.00356D0, 13.81644D0, 10.61949D0, 8.71986D0,
56846 & 7.43441D0, 5.77408D0, 4.33783D0, 3.05923D0, 2.35324D0,
56847 & 1.59919D0, 1.20346D0, 0.95679D0, 0.74861D0, 0.59903D0,
56848 & 0.48379D0, 0.39106D0, 0.31505D0, 0.25241D0, 0.20076D0,
56849 & 0.15822D0, 0.12352D0, 0.09541D0, 0.07286D0, 0.05504D0,
56850 & 0.04110D0, 0.03018D0, 0.02185D0, 0.01570D0, 0.01103D0,
56851 & 0.00760D0, 0.00518D0, 0.00342D0, 0.00141D0, 0.00052D0,
56852 & 0.00017D0, 0.00004D0, 0.00000D0, 0.00000D0/
56853 DATA (FMRS(2,3,I,24),I=1,49)/
56854 & 313.51825D0,224.63136D0,160.84229D0,132.22295D0,115.01953D0,
56855 & 103.20245D0, 73.51698D0, 52.03463D0, 42.28400D0, 36.35911D0,
56856 & 32.16307D0, 21.67765D0, 14.14149D0, 10.81558D0, 8.84983D0,
56857 & 7.52509D0, 5.82169D0, 4.35654D0, 3.05952D0, 2.34629D0,
56858 & 1.58590D0, 1.18656D0, 0.93734D0, 0.72724D0, 0.57702D0,
56859 & 0.46218D0, 0.37070D0, 0.29646D0, 0.23590D0, 0.18642D0,
56860 & 0.14603D0, 0.11337D0, 0.08712D0, 0.06621D0, 0.04979D0,
56861 & 0.03702D0, 0.02708D0, 0.01953D0, 0.01399D0, 0.00980D0,
56862 & 0.00674D0, 0.00458D0, 0.00302D0, 0.00124D0, 0.00046D0,
56863 & 0.00015D0, 0.00004D0, 0.00000D0, 0.00000D0/
56864 DATA (FMRS(2,3,I,25),I=1,49)/
56865 & 341.15173D0,242.77290D0,172.65150D0,141.36496D0,122.62321D0,
56866 & 109.78229D0, 77.66644D0, 54.58787D0, 44.17350D0, 37.86890D0,
56867 & 33.41642D0, 22.34751D0, 14.46016D0, 11.00588D0, 8.97477D0,
56868 & 7.61137D0, 5.86592D0, 4.37273D0, 3.05810D0, 2.33803D0,
56869 & 1.57177D0, 1.16920D0, 0.91780D0, 0.70620D0, 0.55570D0,
56870 & 0.44154D0, 0.35145D0, 0.27905D0, 0.22057D0, 0.17322D0,
56871 & 0.13490D0, 0.10417D0, 0.07964D0, 0.06025D0, 0.04510D0,
56872 & 0.03340D0, 0.02434D0, 0.01749D0, 0.01249D0, 0.00873D0,
56873 & 0.00599D0, 0.00406D0, 0.00268D0, 0.00110D0, 0.00041D0,
56874 & 0.00013D0, 0.00004D0, 0.00000D0, 0.00000D0/
56875 DATA (FMRS(2,3,I,26),I=1,49)/
56876 & 368.98822D0,260.90195D0,184.35516D0,150.38000D0,130.09390D0,
56877 & 116.22827D0, 81.69344D0, 57.04021D0, 45.97627D0, 39.30195D0,
56878 & 34.60083D0, 22.97047D0, 14.74975D0, 11.17543D0, 9.08370D0,
56879 & 7.68467D0, 5.90104D0, 4.38251D0, 3.05244D0, 2.32659D0,
56880 & 1.55551D0, 1.15047D0, 0.89759D0, 0.68521D0, 0.53495D0,
56881 & 0.42187D0, 0.33342D0, 0.26295D0, 0.20656D0, 0.16128D0,
56882 & 0.12493D0, 0.09597D0, 0.07303D0, 0.05500D0, 0.04100D0,
56883 & 0.03027D0, 0.02198D0, 0.01575D0, 0.01122D0, 0.00782D0,
56884 & 0.00536D0, 0.00363D0, 0.00239D0, 0.00098D0, 0.00036D0,
56885 & 0.00012D0, 0.00003D0, 0.00000D0, 0.00000D0/
56886 DATA (FMRS(2,3,I,27),I=1,49)/
56887 & 396.49847D0,278.69458D0,195.76036D0,159.12776D0,137.32101D0,
56888 & 122.44904D0, 85.54959D0, 59.36906D0, 47.67925D0, 40.65031D0,
56889 & 35.71157D0, 23.54779D0, 15.01388D0, 11.32784D0, 9.18018D0,
56890 & 7.74858D0, 5.93008D0, 4.38884D0, 3.04508D0, 2.31422D0,
56891 & 1.53913D0, 1.13220D0, 0.87829D0, 0.66558D0, 0.51586D0,
56892 & 0.40401D0, 0.31721D0, 0.24862D0, 0.19419D0, 0.15083D0,
56893 & 0.11625D0, 0.08889D0, 0.06736D0, 0.05053D0, 0.03753D0,
56894 & 0.02761D0, 0.01999D0, 0.01428D0, 0.01015D0, 0.00707D0,
56895 & 0.00483D0, 0.00327D0, 0.00215D0, 0.00088D0, 0.00033D0,
56896 & 0.00011D0, 0.00003D0, 0.00000D0, 0.00000D0/
56897 DATA (FMRS(2,3,I,28),I=1,49)/
56898 & 423.18488D0,295.83777D0,206.67247D0,167.46211D0,144.18538D0,
56899 & 128.34305D0, 89.17443D0, 61.53922D0, 49.25727D0, 41.89430D0,
56900 & 36.73269D0, 24.07136D0, 15.24876D0, 11.46075D0, 9.26257D0,
56901 & 7.80186D0, 5.95221D0, 4.39115D0, 3.03561D0, 2.30059D0,
56902 & 1.52239D0, 1.11417D0, 0.85969D0, 0.64709D0, 0.49822D0,
56903 & 0.38776D0, 0.30261D0, 0.23584D0, 0.18326D0, 0.14166D0,
56904 & 0.10869D0, 0.08277D0, 0.06247D0, 0.04670D0, 0.03458D0,
56905 & 0.02536D0, 0.01831D0, 0.01305D0, 0.00927D0, 0.00644D0,
56906 & 0.00439D0, 0.00297D0, 0.00195D0, 0.00080D0, 0.00030D0,
56907 & 0.00010D0, 0.00003D0, 0.00000D0, 0.00000D0/
56908 DATA (FMRS(2,3,I,29),I=1,49)/
56909 & 450.92862D0,313.54996D0,217.87523D0,175.98549D0,151.18591D0,
56910 & 134.34097D0, 92.83694D0, 63.71518D0, 50.83173D0, 43.13081D0,
56911 & 37.74429D0, 24.58404D0, 15.47489D0, 11.58672D0, 9.33925D0,
56912 & 7.85026D0, 5.97071D0, 4.39081D0, 3.02434D0, 2.28559D0,
56913 & 1.50481D0, 1.09565D0, 0.84093D0, 0.62877D0, 0.48096D0,
56914 & 0.37201D0, 0.28863D0, 0.22371D0, 0.17297D0, 0.13307D0,
56915 & 0.10166D0, 0.07711D0, 0.05798D0, 0.04320D0, 0.03189D0,
56916 & 0.02332D0, 0.01680D0, 0.01195D0, 0.00847D0, 0.00587D0,
56917 & 0.00400D0, 0.00270D0, 0.00178D0, 0.00073D0, 0.00027D0,
56918 & 0.00009D0, 0.00002D0, 0.00000D0, 0.00000D0/
56919 DATA (FMRS(2,3,I,30),I=1,49)/
56920 & 478.88074D0,331.28183D0,229.01660D0,184.42841D0,158.10007D0,
56921 & 140.25114D0, 96.41853D0, 65.82523D0, 52.35015D0, 44.31818D0,
56922 & 38.71195D0, 25.06767D0, 15.68364D0, 11.70050D0, 9.40671D0,
56923 & 7.89123D0, 5.98412D0, 4.38708D0, 3.01099D0, 2.26914D0,
56924 & 1.48646D0, 1.07684D0, 0.82225D0, 0.61085D0, 0.46437D0,
56925 & 0.35704D0, 0.27550D0, 0.21242D0, 0.16347D0, 0.12519D0,
56926 & 0.09525D0, 0.07197D0, 0.05394D0, 0.04005D0, 0.02949D0,
56927 & 0.02151D0, 0.01546D0, 0.01097D0, 0.00776D0, 0.00538D0,
56928 & 0.00366D0, 0.00247D0, 0.00162D0, 0.00067D0, 0.00025D0,
56929 & 0.00008D0, 0.00002D0, 0.00000D0, 0.00000D0/
56930 DATA (FMRS(2,3,I,31),I=1,49)/
56931 & 506.38092D0,348.62979D0,239.85460D0,192.61319D0,164.78622D0,
56932 & 145.95520D0, 99.85363D0, 67.83522D0, 53.79026D0, 45.44058D0,
56933 & 39.62410D0, 25.51892D0, 15.87554D0, 11.80362D0, 9.46678D0,
56934 & 7.92687D0, 5.99445D0, 4.38186D0, 2.99723D0, 2.25276D0,
56935 & 1.46868D0, 1.05889D0, 0.80464D0, 0.59419D0, 0.44909D0,
56936 & 0.34338D0, 0.26361D0, 0.20228D0, 0.15498D0, 0.11820D0,
56937 & 0.08960D0, 0.06746D0, 0.05040D0, 0.03731D0, 0.02741D0,
56938 & 0.01994D0, 0.01431D0, 0.01014D0, 0.00716D0, 0.00495D0,
56939 & 0.00337D0, 0.00227D0, 0.00149D0, 0.00061D0, 0.00023D0,
56940 & 0.00007D0, 0.00002D0, 0.00000D0, 0.00000D0/
56941 DATA (FMRS(2,3,I,32),I=1,49)/
56942 & 532.71063D0,365.14023D0,250.10423D0,200.32385D0,171.06720D0,
56943 & 151.30153D0,103.04897D0, 69.68893D0, 55.11074D0, 46.46502D0,
56944 & 40.45333D0, 25.92270D0, 16.04272D0, 11.89083D0, 9.51556D0,
56945 & 7.95409D0, 5.99947D0, 4.37358D0, 2.98195D0, 2.23557D0,
56946 & 1.45083D0, 1.04132D0, 0.78773D0, 0.57848D0, 0.43489D0,
56947 & 0.33086D0, 0.25280D0, 0.19316D0, 0.14738D0, 0.11200D0,
56948 & 0.08461D0, 0.06352D0, 0.04732D0, 0.03494D0, 0.02560D0,
56949 & 0.01860D0, 0.01332D0, 0.00942D0, 0.00665D0, 0.00459D0,
56950 & 0.00312D0, 0.00210D0, 0.00138D0, 0.00057D0, 0.00021D0,
56951 & 0.00007D0, 0.00002D0, 0.00000D0, 0.00000D0/
56952 DATA (FMRS(2,3,I,33),I=1,49)/
56953 & 560.44952D0,382.45715D0,260.80753D0,208.35481D0,177.59706D0,
56954 & 156.85155D0,106.35128D0, 71.59602D0, 56.46558D0, 47.51407D0,
56955 & 41.30114D0, 26.33344D0, 16.21190D0, 11.97881D0, 9.56466D0,
56956 & 7.98144D0, 6.00450D0, 4.36531D0, 2.96673D0, 2.21850D0,
56957 & 1.43317D0, 1.02401D0, 0.77116D0, 0.56317D0, 0.42112D0,
56958 & 0.31878D0, 0.24243D0, 0.18443D0, 0.14015D0, 0.10612D0,
56959 & 0.07989D0, 0.05980D0, 0.04442D0, 0.03272D0, 0.02392D0,
56960 & 0.01734D0, 0.01239D0, 0.00875D0, 0.00617D0, 0.00426D0,
56961 & 0.00289D0, 0.00195D0, 0.00128D0, 0.00052D0, 0.00020D0,
56962 & 0.00006D0, 0.00002D0, 0.00000D0, 0.00000D0/
56963 DATA (FMRS(2,3,I,34),I=1,49)/
56964 & 587.66711D0,399.34082D0,271.17145D0,216.09799D0,183.87283D0,
56965 & 162.17198D0,109.48943D0, 73.38959D0, 57.73061D0, 48.48780D0,
56966 & 42.08379D0, 26.70440D0, 16.35846D0, 12.05124D0, 9.60203D0,
56967 & 7.99942D0, 6.00308D0, 4.35260D0, 2.94870D0, 2.19937D0,
56968 & 1.41431D0, 1.00609D0, 0.75435D0, 0.54797D0, 0.40769D0,
56969 & 0.30718D0, 0.23257D0, 0.17622D0, 0.13341D0, 0.10068D0,
56970 & 0.07556D0, 0.05639D0, 0.04179D0, 0.03071D0, 0.02240D0,
56971 & 0.01621D0, 0.01157D0, 0.00816D0, 0.00575D0, 0.00396D0,
56972 & 0.00269D0, 0.00181D0, 0.00119D0, 0.00049D0, 0.00018D0,
56973 & 0.00006D0, 0.00002D0, 0.00000D0, 0.00000D0/
56974 DATA (FMRS(2,3,I,35),I=1,49)/
56975 & 614.66376D0,416.01791D0,281.36646D0,223.69629D0,190.02084D0,
56976 & 167.37685D0,112.54659D0, 75.12943D0, 58.95456D0, 49.42817D0,
56977 & 42.83852D0, 27.06040D0, 16.49837D0, 12.12015D0, 9.63748D0,
56978 & 8.01641D0, 6.00168D0, 4.34055D0, 2.93168D0, 2.18137D0,
56979 & 1.39666D0, 0.98938D0, 0.73876D0, 0.53395D0, 0.39535D0,
56980 & 0.29658D0, 0.22360D0, 0.16878D0, 0.12732D0, 0.09577D0,
56981 & 0.07167D0, 0.05334D0, 0.03944D0, 0.02892D0, 0.02106D0,
56982 & 0.01521D0, 0.01085D0, 0.00764D0, 0.00537D0, 0.00370D0,
56983 & 0.00251D0, 0.00169D0, 0.00111D0, 0.00046D0, 0.00017D0,
56984 & 0.00006D0, 0.00002D0, 0.00000D0, 0.00000D0/
56985 DATA (FMRS(2,3,I,36),I=1,49)/
56986 & 640.64490D0,431.98953D0,291.07977D0,230.91319D0,195.84616D0,
56987 & 172.29993D0,115.42027D0, 76.75350D0, 60.09168D0, 50.29848D0,
56988 & 43.53482D0, 27.38445D0, 16.62263D0, 12.17943D0, 9.66642D0,
56989 & 8.02868D0, 5.99763D0, 4.32731D0, 2.91439D0, 2.16350D0,
56990 & 1.37952D0, 0.97339D0, 0.72400D0, 0.52085D0, 0.38394D0,
56991 & 0.28684D0, 0.21543D0, 0.16204D0, 0.12184D0, 0.09139D0,
56992 & 0.06820D0, 0.05064D0, 0.03736D0, 0.02734D0, 0.01987D0,
56993 & 0.01434D0, 0.01021D0, 0.00718D0, 0.00505D0, 0.00348D0,
56994 & 0.00236D0, 0.00159D0, 0.00104D0, 0.00043D0, 0.00016D0,
56995 & 0.00005D0, 0.00001D0, 0.00000D0, 0.00000D0/
56996 DATA (FMRS(2,3,I,37),I=1,49)/
56997 & 667.19971D0,448.23413D0,300.90906D0,238.19307D0,201.70891D0,
56998 & 177.24495D0,118.28902D0, 78.36304D0, 61.21302D0, 51.15329D0,
56999 & 44.21644D0, 27.69705D0, 16.73916D0, 12.23290D0, 9.69072D0,
57000 & 8.03703D0, 5.99069D0, 4.31202D0, 2.89571D0, 2.14460D0,
57001 & 1.36178D0, 0.95706D0, 0.70912D0, 0.50779D0, 0.37268D0,
57002 & 0.27731D0, 0.20750D0, 0.15552D0, 0.11658D0, 0.08719D0,
57003 & 0.06491D0, 0.04808D0, 0.03540D0, 0.02586D0, 0.01877D0,
57004 & 0.01352D0, 0.00961D0, 0.00676D0, 0.00475D0, 0.00327D0,
57005 & 0.00222D0, 0.00149D0, 0.00098D0, 0.00040D0, 0.00015D0,
57006 & 0.00005D0, 0.00001D0, 0.00000D0, 0.00000D0/
57007 DATA (FMRS(2,3,I,38),I=1,49)/
57008 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57009 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57010 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57011 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57012 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57013 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57014 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57015 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57016 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57017 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57018 DATA (FMRS(2,4,I, 1),I=1,49)/
57019 & 0.96883D0, 0.83010D0, 0.71060D0, 0.64853D0, 0.60767D0,
57020 & 0.57770D0, 0.49346D0, 0.42161D0, 0.38501D0, 0.36146D0,
57021 & 0.34535D0, 0.30095D0, 0.26559D0, 0.24803D0, 0.23669D0,
57022 & 0.22831D0, 0.21597D0, 0.20255D0, 0.18524D0, 0.17029D0,
57023 & 0.14323D0, 0.11890D0, 0.09745D0, 0.07499D0, 0.05725D0,
57024 & 0.04365D0, 0.03351D0, 0.02602D0, 0.02043D0, 0.01653D0,
57025 & 0.01318D0, 0.01067D0, 0.00853D0, 0.00671D0, 0.00530D0,
57026 & 0.00405D0, 0.00296D0, 0.00217D0, 0.00162D0, 0.00103D0,
57027 & 0.00065D0, 0.00047D0, 0.00023D0, 0.00008D0, 0.00004D0,
57028 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57029 DATA (FMRS(2,4,I, 2),I=1,49)/
57030 & 0.97285D0, 0.83723D0, 0.71985D0, 0.65865D0, 0.61827D0,
57031 & 0.58859D0, 0.50491D0, 0.43319D0, 0.39649D0, 0.37279D0,
57032 & 0.35657D0, 0.31149D0, 0.27487D0, 0.25626D0, 0.24402D0,
57033 & 0.23487D0, 0.22125D0, 0.20637D0, 0.18739D0, 0.17135D0,
57034 & 0.14312D0, 0.11837D0, 0.09689D0, 0.07465D0, 0.05719D0,
57035 & 0.04386D0, 0.03391D0, 0.02652D0, 0.02098D0, 0.01703D0,
57036 & 0.01365D0, 0.01107D0, 0.00885D0, 0.00698D0, 0.00550D0,
57037 & 0.00421D0, 0.00309D0, 0.00226D0, 0.00169D0, 0.00108D0,
57038 & 0.00069D0, 0.00049D0, 0.00025D0, 0.00010D0, 0.00003D0,
57039 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
57040 DATA (FMRS(2,4,I, 3),I=1,49)/
57041 & 0.99630D0, 0.86193D0, 0.74498D0, 0.68373D0, 0.64319D0,
57042 & 0.61334D0, 0.52882D0, 0.45586D0, 0.41827D0, 0.39388D0,
57043 & 0.37707D0, 0.32984D0, 0.29034D0, 0.26968D0, 0.25582D0,
57044 & 0.24531D0, 0.22956D0, 0.21234D0, 0.19077D0, 0.17310D0,
57045 & 0.14315D0, 0.11778D0, 0.09624D0, 0.07426D0, 0.05716D0,
57046 & 0.04417D0, 0.03445D0, 0.02716D0, 0.02168D0, 0.01765D0,
57047 & 0.01422D0, 0.01151D0, 0.00919D0, 0.00726D0, 0.00569D0,
57048 & 0.00437D0, 0.00323D0, 0.00233D0, 0.00177D0, 0.00113D0,
57049 & 0.00072D0, 0.00052D0, 0.00028D0, 0.00011D0, 0.00003D0,
57050 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
57051 DATA (FMRS(2,4,I, 4),I=1,49)/
57052 & 1.02892D0, 0.89240D0, 0.77327D0, 0.71073D0, 0.66929D0,
57053 & 0.63873D0, 0.55202D0, 0.47687D0, 0.43798D0, 0.41263D0,
57054 & 0.39503D0, 0.34528D0, 0.30287D0, 0.28033D0, 0.26505D0,
57055 & 0.25342D0, 0.23594D0, 0.21688D0, 0.19336D0, 0.17449D0,
57056 & 0.14328D0, 0.11746D0, 0.09586D0, 0.07403D0, 0.05716D0,
57057 & 0.04437D0, 0.03479D0, 0.02755D0, 0.02207D0, 0.01800D0,
57058 & 0.01451D0, 0.01172D0, 0.00935D0, 0.00736D0, 0.00577D0,
57059 & 0.00444D0, 0.00328D0, 0.00236D0, 0.00178D0, 0.00114D0,
57060 & 0.00075D0, 0.00052D0, 0.00029D0, 0.00011D0, 0.00004D0,
57061 & 0.00003D0, 0.00000D0, 0.00000D0, 0.00000D0/
57062 DATA (FMRS(2,4,I, 5),I=1,49)/
57063 & 1.08451D0, 0.94133D0, 0.81630D0, 0.75061D0, 0.70706D0,
57064 & 0.67493D0, 0.58367D0, 0.50437D0, 0.46318D0, 0.43623D0,
57065 & 0.41737D0, 0.36373D0, 0.31732D0, 0.29240D0, 0.27539D0,
57066 & 0.26243D0, 0.24295D0, 0.22186D0, 0.19623D0, 0.17608D0,
57067 & 0.14355D0, 0.11725D0, 0.09556D0, 0.07384D0, 0.05715D0,
57068 & 0.04453D0, 0.03504D0, 0.02784D0, 0.02236D0, 0.01824D0,
57069 & 0.01470D0, 0.01187D0, 0.00949D0, 0.00742D0, 0.00580D0,
57070 & 0.00445D0, 0.00328D0, 0.00235D0, 0.00175D0, 0.00116D0,
57071 & 0.00074D0, 0.00053D0, 0.00029D0, 0.00011D0, 0.00004D0,
57072 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
57073 DATA (FMRS(2,4,I, 6),I=1,49)/
57074 & 1.14357D0, 0.99242D0, 0.86045D0, 0.79114D0, 0.74518D0,
57075 & 0.71127D0, 0.61492D0, 0.53108D0, 0.48742D0, 0.45878D0,
57076 & 0.43857D0, 0.38094D0, 0.33056D0, 0.30333D0, 0.28470D0,
57077 & 0.27048D0, 0.24918D0, 0.22626D0, 0.19875D0, 0.17749D0,
57078 & 0.14383D0, 0.11711D0, 0.09533D0, 0.07370D0, 0.05713D0,
57079 & 0.04464D0, 0.03521D0, 0.02805D0, 0.02256D0, 0.01839D0,
57080 & 0.01482D0, 0.01197D0, 0.00955D0, 0.00745D0, 0.00580D0,
57081 & 0.00443D0, 0.00326D0, 0.00233D0, 0.00174D0, 0.00116D0,
57082 & 0.00074D0, 0.00053D0, 0.00029D0, 0.00011D0, 0.00004D0,
57083 & 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0/
57084 DATA (FMRS(2,4,I, 7),I=1,49)/
57085 & 1.21691D0, 1.05450D0, 0.91294D0, 0.83868D0, 0.78948D0,
57086 & 0.75319D0, 0.65015D0, 0.56049D0, 0.51374D0, 0.48302D0,
57087 & 0.46120D0, 0.39885D0, 0.34401D0, 0.31429D0, 0.29395D0,
57088 & 0.27845D0, 0.25529D0, 0.23055D0, 0.20123D0, 0.17890D0,
57089 & 0.14416D0, 0.11703D0, 0.09514D0, 0.07357D0, 0.05711D0,
57090 & 0.04471D0, 0.03532D0, 0.02818D0, 0.02268D0, 0.01846D0,
57091 & 0.01487D0, 0.01199D0, 0.00952D0, 0.00742D0, 0.00577D0,
57092 & 0.00441D0, 0.00322D0, 0.00229D0, 0.00172D0, 0.00114D0,
57093 & 0.00072D0, 0.00051D0, 0.00029D0, 0.00010D0, 0.00004D0,
57094 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57095 DATA (FMRS(2,4,I, 8),I=1,49)/
57096 & 1.31000D0, 1.13230D0, 0.97784D0, 0.89699D0, 0.84348D0,
57097 & 0.80406D0, 0.69226D0, 0.59511D0, 0.54444D0, 0.51110D0,
57098 & 0.48726D0, 0.41913D0, 0.35898D0, 0.32638D0, 0.30408D0,
57099 & 0.28713D0, 0.26192D0, 0.23518D0, 0.20389D0, 0.18042D0,
57100 & 0.14454D0, 0.11697D0, 0.09497D0, 0.07342D0, 0.05705D0,
57101 & 0.04474D0, 0.03539D0, 0.02827D0, 0.02275D0, 0.01851D0,
57102 & 0.01488D0, 0.01197D0, 0.00947D0, 0.00737D0, 0.00571D0,
57103 & 0.00437D0, 0.00318D0, 0.00224D0, 0.00169D0, 0.00111D0,
57104 & 0.00070D0, 0.00049D0, 0.00029D0, 0.00010D0, 0.00004D0,
57105 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57106 DATA (FMRS(2,4,I, 9),I=1,49)/
57107 & 1.40457D0, 1.21051D0, 1.04237D0, 0.95458D0, 0.89657D0,
57108 & 0.85387D0, 0.73299D0, 0.62815D0, 0.57350D0, 0.53752D0,
57109 & 0.51167D0, 0.43783D0, 0.37258D0, 0.33726D0, 0.31316D0,
57110 & 0.29488D0, 0.26778D0, 0.23925D0, 0.20624D0, 0.18177D0,
57111 & 0.14489D0, 0.11694D0, 0.09483D0, 0.07330D0, 0.05698D0,
57112 & 0.04474D0, 0.03543D0, 0.02831D0, 0.02277D0, 0.01852D0,
57113 & 0.01487D0, 0.01192D0, 0.00942D0, 0.00732D0, 0.00564D0,
57114 & 0.00433D0, 0.00313D0, 0.00219D0, 0.00166D0, 0.00109D0,
57115 & 0.00068D0, 0.00049D0, 0.00028D0, 0.00010D0, 0.00003D0,
57116 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57117 DATA (FMRS(2,4,I,10),I=1,49)/
57118 & 1.51092D0, 1.29750D0, 1.11331D0, 1.01744D0, 0.95421D0,
57119 & 0.90772D0, 0.77643D0, 0.66288D0, 0.60378D0, 0.56488D0,
57120 & 0.53682D0, 0.45681D0, 0.38616D0, 0.34803D0, 0.32208D0,
57121 & 0.30246D0, 0.27350D0, 0.24321D0, 0.20851D0, 0.18308D0,
57122 & 0.14525D0, 0.11692D0, 0.09469D0, 0.07316D0, 0.05689D0,
57123 & 0.04470D0, 0.03541D0, 0.02828D0, 0.02274D0, 0.01846D0,
57124 & 0.01479D0, 0.01184D0, 0.00933D0, 0.00722D0, 0.00556D0,
57125 & 0.00426D0, 0.00307D0, 0.00215D0, 0.00161D0, 0.00106D0,
57126 & 0.00067D0, 0.00048D0, 0.00027D0, 0.00010D0, 0.00003D0,
57127 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57128 DATA (FMRS(2,4,I,11),I=1,49)/
57129 & 1.60472D0, 1.37368D0, 1.17498D0, 1.07183D0, 1.00391D0,
57130 & 0.95405D0, 0.81348D0, 0.69224D0, 0.62923D0, 0.58777D0,
57131 & 0.55781D0, 0.47247D0, 0.39725D0, 0.35677D0, 0.32928D0,
57132 & 0.30856D0, 0.27807D0, 0.24637D0, 0.21032D0, 0.18413D0,
57133 & 0.14554D0, 0.11692D0, 0.09459D0, 0.07304D0, 0.05681D0,
57134 & 0.04465D0, 0.03537D0, 0.02823D0, 0.02270D0, 0.01839D0,
57135 & 0.01471D0, 0.01176D0, 0.00923D0, 0.00712D0, 0.00549D0,
57136 & 0.00419D0, 0.00301D0, 0.00213D0, 0.00157D0, 0.00105D0,
57137 & 0.00065D0, 0.00047D0, 0.00027D0, 0.00010D0, 0.00004D0,
57138 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57139 DATA (FMRS(2,4,I,12),I=1,49)/
57140 & 1.83637D0, 1.55987D0, 1.32404D0, 1.20242D0, 1.12267D0,
57141 & 1.06429D0, 0.90056D0, 0.76032D0, 0.68777D0, 0.64012D0,
57142 & 0.60555D0, 0.50757D0, 0.42172D0, 0.37588D0, 0.34496D0,
57143 & 0.32177D0, 0.28792D0, 0.25312D0, 0.21417D0, 0.18636D0,
57144 & 0.14617D0, 0.11691D0, 0.09435D0, 0.07276D0, 0.05658D0,
57145 & 0.04447D0, 0.03521D0, 0.02807D0, 0.02254D0, 0.01819D0,
57146 & 0.01452D0, 0.01154D0, 0.00905D0, 0.00695D0, 0.00533D0,
57147 & 0.00404D0, 0.00292D0, 0.00205D0, 0.00149D0, 0.00100D0,
57148 & 0.00062D0, 0.00045D0, 0.00024D0, 0.00010D0, 0.00003D0,
57149 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57150 DATA (FMRS(2,4,I,13),I=1,49)/
57151 & 2.07152D0, 1.74663D0, 1.47172D0, 1.33085D0, 1.23884D0,
57152 & 1.17167D0, 0.98420D0, 0.82476D0, 0.74268D0, 0.68890D0,
57153 & 0.64981D0, 0.53955D0, 0.44363D0, 0.39281D0, 0.35874D0,
57154 & 0.33333D0, 0.29647D0, 0.25893D0, 0.21746D0, 0.18826D0,
57155 & 0.14670D0, 0.11688D0, 0.09412D0, 0.07248D0, 0.05632D0,
57156 & 0.04424D0, 0.03500D0, 0.02787D0, 0.02234D0, 0.01798D0,
57157 & 0.01431D0, 0.01132D0, 0.00886D0, 0.00679D0, 0.00517D0,
57158 & 0.00390D0, 0.00284D0, 0.00195D0, 0.00143D0, 0.00095D0,
57159 & 0.00059D0, 0.00043D0, 0.00023D0, 0.00009D0, 0.00002D0,
57160 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57161 DATA (FMRS(2,4,I,14),I=1,49)/
57162 & 2.37643D0, 1.98603D0, 1.65879D0, 1.49235D0, 1.38415D0,
57163 & 1.30543D0, 1.08702D0, 0.90288D0, 0.80867D0, 0.74716D0,
57164 & 0.70240D0, 0.57696D0, 0.46881D0, 0.41209D0, 0.37432D0,
57165 & 0.34632D0, 0.30599D0, 0.26535D0, 0.22106D0, 0.19032D0,
57166 & 0.14723D0, 0.11682D0, 0.09381D0, 0.07211D0, 0.05596D0,
57167 & 0.04392D0, 0.03471D0, 0.02757D0, 0.02204D0, 0.01767D0,
57168 & 0.01400D0, 0.01105D0, 0.00862D0, 0.00657D0, 0.00496D0,
57169 & 0.00374D0, 0.00270D0, 0.00182D0, 0.00137D0, 0.00090D0,
57170 & 0.00057D0, 0.00039D0, 0.00023D0, 0.00007D0, 0.00002D0,
57171 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57172 DATA (FMRS(2,4,I,15),I=1,49)/
57173 & 2.74566D0, 2.27231D0, 1.87960D0, 1.68150D0, 1.55338D0,
57174 & 1.46052D0, 1.20454D0, 0.99082D0, 0.88227D0, 0.81170D0,
57175 & 0.76034D0, 0.61745D0, 0.49560D0, 0.43237D0, 0.39059D0,
57176 & 0.35980D0, 0.31580D0, 0.27191D0, 0.22470D0, 0.19238D0,
57177 & 0.14774D0, 0.11669D0, 0.09344D0, 0.07165D0, 0.05549D0,
57178 & 0.04347D0, 0.03429D0, 0.02720D0, 0.02166D0, 0.01729D0,
57179 & 0.01366D0, 0.01073D0, 0.00832D0, 0.00636D0, 0.00476D0,
57180 & 0.00357D0, 0.00255D0, 0.00175D0, 0.00131D0, 0.00086D0,
57181 & 0.00052D0, 0.00037D0, 0.00021D0, 0.00007D0, 0.00002D0,
57182 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57183 DATA (FMRS(2,4,I,16),I=1,49)/
57184 & 3.12622D0, 2.56414D0, 2.10216D0, 1.87087D0, 1.72199D0,
57185 & 1.61445D0, 1.31978D0, 1.07596D0, 0.95298D0, 0.87335D0,
57186 & 0.81544D0, 0.65540D0, 0.52031D0, 0.45090D0, 0.40535D0,
57187 & 0.37197D0, 0.32458D0, 0.27772D0, 0.22787D0, 0.19414D0,
57188 & 0.14813D0, 0.11651D0, 0.09303D0, 0.07117D0, 0.05501D0,
57189 & 0.04302D0, 0.03385D0, 0.02678D0, 0.02128D0, 0.01692D0,
57190 & 0.01332D0, 0.01043D0, 0.00806D0, 0.00611D0, 0.00459D0,
57191 & 0.00341D0, 0.00242D0, 0.00166D0, 0.00123D0, 0.00082D0,
57192 & 0.00050D0, 0.00034D0, 0.00020D0, 0.00006D0, 0.00003D0,
57193 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57194 DATA (FMRS(2,4,I,17),I=1,49)/
57195 & 3.55799D0, 2.89188D0, 2.34954D0, 2.08007D0, 1.90742D0,
57196 & 1.78316D0, 1.44470D0, 1.16721D0, 1.02825D0, 0.93863D0,
57197 & 0.87356D0, 0.69490D0, 0.54567D0, 0.46976D0, 0.42028D0,
57198 & 0.38422D0, 0.33334D0, 0.28346D0, 0.23097D0, 0.19583D0,
57199 & 0.14845D0, 0.11627D0, 0.09257D0, 0.07063D0, 0.05448D0,
57200 & 0.04252D0, 0.03337D0, 0.02631D0, 0.02087D0, 0.01652D0,
57201 & 0.01297D0, 0.01012D0, 0.00778D0, 0.00585D0, 0.00440D0,
57202 & 0.00326D0, 0.00231D0, 0.00157D0, 0.00115D0, 0.00076D0,
57203 & 0.00047D0, 0.00031D0, 0.00019D0, 0.00006D0, 0.00003D0,
57204 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57205 DATA (FMRS(2,4,I,18),I=1,49)/
57206 & 3.95423D0, 3.18985D0, 2.57232D0, 2.26740D0, 2.07281D0,
57207 & 1.93314D0, 1.55464D0, 1.24668D0, 1.09337D0, 0.99486D0,
57208 & 0.92342D0, 0.72838D0, 0.56689D0, 0.48541D0, 0.43260D0,
57209 & 0.39429D0, 0.34049D0, 0.28810D0, 0.23344D0, 0.19715D0,
57210 & 0.14866D0, 0.11602D0, 0.09214D0, 0.07013D0, 0.05399D0,
57211 & 0.04205D0, 0.03295D0, 0.02591D0, 0.02050D0, 0.01618D0,
57212 & 0.01266D0, 0.00984D0, 0.00753D0, 0.00565D0, 0.00424D0,
57213 & 0.00314D0, 0.00221D0, 0.00150D0, 0.00109D0, 0.00072D0,
57214 & 0.00043D0, 0.00030D0, 0.00018D0, 0.00006D0, 0.00002D0,
57215 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57216 DATA (FMRS(2,4,I,19),I=1,49)/
57217 & 4.48113D0, 3.58253D0, 2.86323D0, 2.51070D0, 2.28676D0,
57218 & 2.12659D0, 1.69508D0, 1.34718D0, 1.17523D0, 1.06522D0,
57219 & 0.98559D0, 0.76963D0, 0.59272D0, 0.50431D0, 0.44739D0,
57220 & 0.40630D0, 0.34895D0, 0.29355D0, 0.23628D0, 0.19863D0,
57221 & 0.14882D0, 0.11566D0, 0.09156D0, 0.06947D0, 0.05334D0,
57222 & 0.04144D0, 0.03238D0, 0.02540D0, 0.02000D0, 0.01574D0,
57223 & 0.01227D0, 0.00950D0, 0.00724D0, 0.00541D0, 0.00404D0,
57224 & 0.00298D0, 0.00211D0, 0.00142D0, 0.00103D0, 0.00067D0,
57225 & 0.00041D0, 0.00028D0, 0.00016D0, 0.00006D0, 0.00002D0,
57226 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57227 DATA (FMRS(2,4,I,20),I=1,49)/
57228 & 4.99499D0, 3.96212D0, 3.14196D0, 2.74258D0, 2.48991D0,
57229 & 2.30973D0, 1.82681D0, 1.44056D0, 1.25085D0, 1.12995D0,
57230 & 1.04258D0, 0.80704D0, 0.61586D0, 0.52113D0, 0.46048D0,
57231 & 0.41689D0, 0.35636D0, 0.29827D0, 0.23871D0, 0.19986D0,
57232 & 0.14892D0, 0.11531D0, 0.09101D0, 0.06887D0, 0.05276D0,
57233 & 0.04087D0, 0.03186D0, 0.02494D0, 0.01954D0, 0.01534D0,
57234 & 0.01192D0, 0.00921D0, 0.00699D0, 0.00520D0, 0.00387D0,
57235 & 0.00284D0, 0.00201D0, 0.00135D0, 0.00099D0, 0.00063D0,
57236 & 0.00039D0, 0.00027D0, 0.00014D0, 0.00005D0, 0.00002D0,
57237 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57238 DATA (FMRS(2,4,I,21),I=1,49)/
57239 & 5.50061D0, 4.33261D0, 3.41176D0, 2.96594D0, 2.68491D0,
57240 & 2.48503D0, 1.95181D0, 1.52837D0, 1.32157D0, 1.19023D0,
57241 & 1.09549D0, 0.84140D0, 0.63686D0, 0.53627D0, 0.47219D0,
57242 & 0.42632D0, 0.36291D0, 0.30239D0, 0.24078D0, 0.20086D0,
57243 & 0.14892D0, 0.11489D0, 0.09045D0, 0.06826D0, 0.05215D0,
57244 & 0.04031D0, 0.03135D0, 0.02446D0, 0.01914D0, 0.01497D0,
57245 & 0.01162D0, 0.00892D0, 0.00678D0, 0.00502D0, 0.00373D0,
57246 & 0.00273D0, 0.00191D0, 0.00128D0, 0.00093D0, 0.00060D0,
57247 & 0.00037D0, 0.00026D0, 0.00014D0, 0.00005D0, 0.00001D0,
57248 & 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57249 DATA (FMRS(2,4,I,22),I=1,49)/
57250 & 6.19859D0, 4.83989D0, 3.77815D0, 3.26780D0, 2.94753D0,
57251 & 2.72049D0, 2.11828D0, 1.64429D0, 1.41443D0, 1.26909D0,
57252 & 1.16448D0, 0.88574D0, 0.66367D0, 0.55547D0, 0.48697D0,
57253 & 0.43816D0, 0.37106D0, 0.30748D0, 0.24329D0, 0.20204D0,
57254 & 0.14885D0, 0.11433D0, 0.08969D0, 0.06745D0, 0.05136D0,
57255 & 0.03959D0, 0.03069D0, 0.02386D0, 0.01861D0, 0.01451D0,
57256 & 0.01121D0, 0.00856D0, 0.00649D0, 0.00480D0, 0.00355D0,
57257 & 0.00258D0, 0.00180D0, 0.00120D0, 0.00087D0, 0.00057D0,
57258 & 0.00034D0, 0.00024D0, 0.00013D0, 0.00004D0, 0.00001D0,
57259 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57260 DATA (FMRS(2,4,I,23),I=1,49)/
57261 & 6.91462D0, 5.35579D0, 4.14753D0, 3.57056D0, 3.20996D0,
57262 & 2.95511D0, 2.28266D0, 1.75769D0, 1.50477D0, 1.34548D0,
57263 & 1.23109D0, 0.92809D0, 0.68898D0, 0.57345D0, 0.50073D0,
57264 & 0.44914D0, 0.37855D0, 0.31211D0, 0.24552D0, 0.20305D0,
57265 & 0.14871D0, 0.11376D0, 0.08894D0, 0.06666D0, 0.05060D0,
57266 & 0.03890D0, 0.03007D0, 0.02332D0, 0.01811D0, 0.01408D0,
57267 & 0.01081D0, 0.00824D0, 0.00620D0, 0.00458D0, 0.00337D0,
57268 & 0.00246D0, 0.00171D0, 0.00112D0, 0.00082D0, 0.00053D0,
57269 & 0.00032D0, 0.00022D0, 0.00013D0, 0.00004D0, 0.00001D0,
57270 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57271 DATA (FMRS(2,4,I,24),I=1,49)/
57272 & 7.62855D0, 5.86601D0, 4.50985D0, 3.86607D0, 3.46522D0,
57273 & 3.18268D0, 2.44073D0, 1.86575D0, 1.59038D0, 1.41758D0,
57274 & 1.29375D0, 0.96750D0, 0.71223D0, 0.58984D0, 0.51319D0,
57275 & 0.45902D0, 0.38523D0, 0.31616D0, 0.24739D0, 0.20383D0,
57276 & 0.14846D0, 0.11312D0, 0.08817D0, 0.06586D0, 0.04986D0,
57277 & 0.03821D0, 0.02946D0, 0.02275D0, 0.01763D0, 0.01365D0,
57278 & 0.01046D0, 0.00797D0, 0.00597D0, 0.00439D0, 0.00323D0,
57279 & 0.00235D0, 0.00162D0, 0.00107D0, 0.00078D0, 0.00051D0,
57280 & 0.00031D0, 0.00021D0, 0.00012D0, 0.00003D0, 0.00001D0,
57281 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57282 DATA (FMRS(2,4,I,25),I=1,49)/
57283 & 8.39955D0, 6.41302D0, 4.89545D0, 4.17923D0, 3.73489D0,
57284 & 3.42253D0, 2.60607D0, 1.97793D0, 1.67884D0, 1.49183D0,
57285 & 1.35810D0, 1.00761D0, 0.73567D0, 0.60627D0, 0.52562D0,
57286 & 0.46884D0, 0.39183D0, 0.32012D0, 0.24919D0, 0.20455D0,
57287 & 0.14818D0, 0.11246D0, 0.08739D0, 0.06506D0, 0.04911D0,
57288 & 0.03752D0, 0.02885D0, 0.02220D0, 0.01716D0, 0.01324D0,
57289 & 0.01012D0, 0.00771D0, 0.00575D0, 0.00422D0, 0.00309D0,
57290 & 0.00225D0, 0.00154D0, 0.00103D0, 0.00074D0, 0.00048D0,
57291 & 0.00030D0, 0.00020D0, 0.00010D0, 0.00002D0, 0.00001D0,
57292 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57293 DATA (FMRS(2,4,I,26),I=1,49)/
57294 & 9.19737D0, 6.97494D0, 5.28863D0, 4.49714D0, 4.00779D0,
57295 & 3.66466D0, 2.77170D0, 2.08938D0, 1.76629D0, 1.56497D0,
57296 & 1.42130D0, 1.04661D0, 0.75821D0, 0.62194D0, 0.53740D0,
57297 & 0.47810D0, 0.39797D0, 0.32376D0, 0.25078D0, 0.20510D0,
57298 & 0.14782D0, 0.11174D0, 0.08657D0, 0.06424D0, 0.04835D0,
57299 & 0.03684D0, 0.02824D0, 0.02168D0, 0.01670D0, 0.01284D0,
57300 & 0.00977D0, 0.00742D0, 0.00552D0, 0.00404D0, 0.00296D0,
57301 & 0.00214D0, 0.00146D0, 0.00097D0, 0.00071D0, 0.00044D0,
57302 & 0.00028D0, 0.00017D0, 0.00010D0, 0.00003D0, 0.00001D0,
57303 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57304 DATA (FMRS(2,4,I,27),I=1,49)/
57305 & 10.00116D0, 7.53729D0, 5.67949D0, 4.81192D0, 4.27724D0,
57306 & 3.90320D0, 2.93374D0, 2.19765D0, 1.85088D0, 1.63549D0,
57307 & 1.48207D0, 1.08380D0, 0.77950D0, 0.63664D0, 0.54841D0,
57308 & 0.48671D0, 0.40364D0, 0.32707D0, 0.25218D0, 0.20556D0,
57309 & 0.14742D0, 0.11104D0, 0.08576D0, 0.06344D0, 0.04762D0,
57310 & 0.03619D0, 0.02766D0, 0.02119D0, 0.01627D0, 0.01248D0,
57311 & 0.00947D0, 0.00716D0, 0.00532D0, 0.00389D0, 0.00284D0,
57312 & 0.00205D0, 0.00139D0, 0.00092D0, 0.00068D0, 0.00042D0,
57313 & 0.00026D0, 0.00016D0, 0.00009D0, 0.00003D0, 0.00001D0,
57314 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57315 DATA (FMRS(2,4,I,28),I=1,49)/
57316 & 10.79744D0, 8.09092D0, 6.06186D0, 5.11871D0, 4.53915D0,
57317 & 4.13458D0, 3.08987D0, 2.30126D0, 1.93148D0, 1.70248D0,
57318 & 1.53966D0, 1.11875D0, 0.79931D0, 0.65024D0, 0.55853D0,
57319 & 0.49459D0, 0.40879D0, 0.33003D0, 0.25337D0, 0.20589D0,
57320 & 0.14698D0, 0.11033D0, 0.08498D0, 0.06267D0, 0.04691D0,
57321 & 0.03557D0, 0.02711D0, 0.02071D0, 0.01586D0, 0.01214D0,
57322 & 0.00920D0, 0.00692D0, 0.00514D0, 0.00376D0, 0.00272D0,
57323 & 0.00196D0, 0.00133D0, 0.00087D0, 0.00064D0, 0.00040D0,
57324 & 0.00025D0, 0.00016D0, 0.00009D0, 0.00003D0, 0.00001D0,
57325 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57326 DATA (FMRS(2,4,I,29),I=1,49)/
57327 & 11.63983D0, 8.67317D0, 6.46161D0, 5.43834D0, 4.81133D0,
57328 & 4.37457D0, 3.25082D0, 2.40738D0, 2.01373D0, 1.77063D0,
57329 & 1.59811D0, 1.15395D0, 0.81909D0, 0.66374D0, 0.56853D0,
57330 & 0.50235D0, 0.41381D0, 0.33288D0, 0.25448D0, 0.20616D0,
57331 & 0.14650D0, 0.10959D0, 0.08417D0, 0.06189D0, 0.04620D0,
57332 & 0.03495D0, 0.02656D0, 0.02024D0, 0.01545D0, 0.01181D0,
57333 & 0.00893D0, 0.00670D0, 0.00496D0, 0.00362D0, 0.00261D0,
57334 & 0.00187D0, 0.00127D0, 0.00083D0, 0.00060D0, 0.00038D0,
57335 & 0.00023D0, 0.00015D0, 0.00008D0, 0.00003D0, 0.00001D0,
57336 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57337 DATA (FMRS(2,4,I,30),I=1,49)/
57338 & 12.50504D0, 9.26774D0, 6.86743D0, 5.76168D0, 5.08599D0,
57339 & 4.61626D0, 3.41191D0, 2.51292D0, 2.09519D0, 1.83795D0,
57340 & 1.65570D0, 1.18836D0, 0.83825D0, 0.67674D0, 0.57810D0,
57341 & 0.50972D0, 0.41855D0, 0.33552D0, 0.25546D0, 0.20633D0,
57342 & 0.14597D0, 0.10882D0, 0.08334D0, 0.06111D0, 0.04550D0,
57343 & 0.03432D0, 0.02602D0, 0.01977D0, 0.01507D0, 0.01148D0,
57344 & 0.00865D0, 0.00649D0, 0.00478D0, 0.00347D0, 0.00250D0,
57345 & 0.00177D0, 0.00121D0, 0.00078D0, 0.00056D0, 0.00036D0,
57346 & 0.00022D0, 0.00014D0, 0.00008D0, 0.00002D0, 0.00001D0,
57347 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57348 DATA (FMRS(2,4,I,31),I=1,49)/
57349 & 13.36928D0, 9.85846D0, 7.26844D0, 6.08018D0, 5.35592D0,
57350 & 4.85338D0, 3.56907D0, 2.61529D0, 2.17393D0, 1.90285D0,
57351 & 1.71111D0, 1.22123D0, 0.85642D0, 0.68899D0, 0.58709D0,
57352 & 0.51663D0, 0.42295D0, 0.33794D0, 0.25632D0, 0.20644D0,
57353 & 0.14544D0, 0.10808D0, 0.08256D0, 0.06036D0, 0.04483D0,
57354 & 0.03373D0, 0.02551D0, 0.01933D0, 0.01470D0, 0.01117D0,
57355 & 0.00840D0, 0.00629D0, 0.00462D0, 0.00334D0, 0.00240D0,
57356 & 0.00170D0, 0.00116D0, 0.00075D0, 0.00053D0, 0.00034D0,
57357 & 0.00021D0, 0.00014D0, 0.00007D0, 0.00002D0, 0.00001D0,
57358 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57359 DATA (FMRS(2,4,I,32),I=1,49)/
57360 & 14.21204D0, 10.43149D0, 7.65538D0, 6.38652D0, 5.61495D0,
57361 & 5.08051D0, 3.71876D0, 2.71221D0, 2.24821D0, 1.96390D0,
57362 & 1.76311D0, 1.25185D0, 0.87317D0, 0.70020D0, 0.59526D0,
57363 & 0.52288D0, 0.42687D0, 0.34005D0, 0.25702D0, 0.20645D0,
57364 & 0.14487D0, 0.10733D0, 0.08179D0, 0.05963D0, 0.04417D0,
57365 & 0.03317D0, 0.02503D0, 0.01893D0, 0.01436D0, 0.01089D0,
57366 & 0.00816D0, 0.00610D0, 0.00447D0, 0.00322D0, 0.00232D0,
57367 & 0.00164D0, 0.00111D0, 0.00072D0, 0.00051D0, 0.00033D0,
57368 & 0.00020D0, 0.00013D0, 0.00007D0, 0.00002D0, 0.00001D0,
57369 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57370 DATA (FMRS(2,4,I,33),I=1,49)/
57371 & 15.10980D0, 11.03912D0, 8.06381D0, 6.70901D0, 5.88712D0,
57372 & 5.31881D0, 3.87508D0, 2.81294D0, 2.32519D0, 2.02704D0,
57373 & 1.81681D0, 1.28330D0, 0.89029D0, 0.71163D0, 0.60357D0,
57374 & 0.52922D0, 0.43085D0, 0.34218D0, 0.25771D0, 0.20646D0,
57375 & 0.14430D0, 0.10659D0, 0.08103D0, 0.05890D0, 0.04353D0,
57376 & 0.03261D0, 0.02455D0, 0.01854D0, 0.01403D0, 0.01061D0,
57377 & 0.00794D0, 0.00591D0, 0.00432D0, 0.00310D0, 0.00224D0,
57378 & 0.00159D0, 0.00107D0, 0.00069D0, 0.00049D0, 0.00032D0,
57379 & 0.00019D0, 0.00012D0, 0.00006D0, 0.00002D0, 0.00001D0,
57380 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57381 DATA (FMRS(2,4,I,34),I=1,49)/
57382 & 16.00814D0, 11.64399D0, 8.46821D0, 7.02730D0, 6.15513D0,
57383 & 5.55303D0, 4.02783D0, 2.91076D0, 2.39965D0, 2.08793D0,
57384 & 1.86846D0, 1.31328D0, 0.90643D0, 0.72231D0, 0.61128D0,
57385 & 0.53505D0, 0.43443D0, 0.34403D0, 0.25822D0, 0.20634D0,
57386 & 0.14366D0, 0.10580D0, 0.08022D0, 0.05817D0, 0.04288D0,
57387 & 0.03206D0, 0.02408D0, 0.01814D0, 0.01369D0, 0.01034D0,
57388 & 0.00771D0, 0.00572D0, 0.00418D0, 0.00300D0, 0.00216D0,
57389 & 0.00152D0, 0.00103D0, 0.00065D0, 0.00048D0, 0.00031D0,
57390 & 0.00018D0, 0.00012D0, 0.00006D0, 0.00002D0, 0.00001D0,
57391 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57392 DATA (FMRS(2,4,I,35),I=1,49)/
57393 & 16.90871D0, 12.24779D0, 8.87019D0, 7.34290D0, 6.42039D0,
57394 & 5.78454D0, 4.17816D0, 3.00661D0, 2.47242D0, 2.14733D0,
57395 & 1.91876D0, 1.34235D0, 0.92199D0, 0.73258D0, 0.61867D0,
57396 & 0.54063D0, 0.43786D0, 0.34580D0, 0.25870D0, 0.20622D0,
57397 & 0.14305D0, 0.10506D0, 0.07947D0, 0.05749D0, 0.04228D0,
57398 & 0.03154D0, 0.02364D0, 0.01777D0, 0.01338D0, 0.01009D0,
57399 & 0.00750D0, 0.00555D0, 0.00406D0, 0.00290D0, 0.00208D0,
57400 & 0.00145D0, 0.00100D0, 0.00062D0, 0.00047D0, 0.00030D0,
57401 & 0.00017D0, 0.00012D0, 0.00005D0, 0.00002D0, 0.00000D0,
57402 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57403 DATA (FMRS(2,4,I,36),I=1,49)/
57404 & 17.78739D0, 12.83436D0, 9.25897D0, 7.64732D0, 6.67578D0,
57405 & 6.00710D0, 4.32199D0, 3.09786D0, 2.54148D0, 2.20357D0,
57406 & 1.96631D0, 1.36964D0, 0.93649D0, 0.74208D0, 0.62547D0,
57407 & 0.54573D0, 0.44096D0, 0.34736D0, 0.25907D0, 0.20605D0,
57408 & 0.14244D0, 0.10433D0, 0.07874D0, 0.05683D0, 0.04170D0,
57409 & 0.03105D0, 0.02321D0, 0.01741D0, 0.01309D0, 0.00985D0,
57410 & 0.00731D0, 0.00540D0, 0.00394D0, 0.00282D0, 0.00201D0,
57411 & 0.00140D0, 0.00096D0, 0.00060D0, 0.00045D0, 0.00029D0,
57412 & 0.00016D0, 0.00012D0, 0.00005D0, 0.00001D0, 0.00000D0,
57413 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57414 DATA (FMRS(2,4,I,37),I=1,49)/
57415 & 18.69798D0, 13.43965D0, 9.65843D0, 7.95932D0, 6.93703D0,
57416 & 6.23444D0, 4.46823D0, 3.19019D0, 2.61115D0, 2.26017D0,
57417 & 2.01407D0, 1.39688D0, 0.95084D0, 0.75143D0, 0.63213D0,
57418 & 0.55070D0, 0.44393D0, 0.34881D0, 0.25937D0, 0.20581D0,
57419 & 0.14178D0, 0.10356D0, 0.07799D0, 0.05614D0, 0.04110D0,
57420 & 0.03053D0, 0.02278D0, 0.01705D0, 0.01280D0, 0.00961D0,
57421 & 0.00713D0, 0.00525D0, 0.00382D0, 0.00273D0, 0.00195D0,
57422 & 0.00136D0, 0.00092D0, 0.00058D0, 0.00043D0, 0.00028D0,
57423 & 0.00015D0, 0.00011D0, 0.00005D0, 0.00001D0, 0.00000D0,
57424 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57425 DATA (FMRS(2,4,I,38),I=1,49)/
57426 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57427 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57428 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57429 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57430 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57431 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57432 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57433 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57434 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57435 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57436 DATA (FMRS(2,5,I, 1),I=1,49)/
57437 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57438 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57439 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57440 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57441 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57442 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57443 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57444 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57445 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57446 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57447 DATA (FMRS(2,5,I, 2),I=1,49)/
57448 & 0.00003D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0,
57449 & 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0,
57450 & 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0,
57451 & 0.00002D0, 0.00002D0, 0.00001D0, 0.00001D0, 0.00001D0,
57452 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0,
57453 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0,
57454 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0,
57455 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57456 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57457 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57458 DATA (FMRS(2,5,I, 3),I=1,49)/
57459 & 0.02821D0, 0.02609D0, 0.02411D0, 0.02301D0, 0.02226D0,
57460 & 0.02169D0, 0.01996D0, 0.01827D0, 0.01727D0, 0.01654D0,
57461 & 0.01595D0, 0.01400D0, 0.01174D0, 0.01027D0, 0.00917D0,
57462 & 0.00829D0, 0.00696D0, 0.00558D0, 0.00415D0, 0.00329D0,
57463 & 0.00239D0, 0.00200D0, 0.00182D0, 0.00170D0, 0.00161D0,
57464 & 0.00151D0, 0.00140D0, 0.00127D0, 0.00113D0, 0.00099D0,
57465 & 0.00084D0, 0.00071D0, 0.00058D0, 0.00047D0, 0.00038D0,
57466 & 0.00029D0, 0.00023D0, 0.00017D0, 0.00013D0, 0.00009D0,
57467 & 0.00006D0, 0.00004D0, 0.00003D0, 0.00001D0, 0.00000D0,
57468 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57469 DATA (FMRS(2,5,I, 4),I=1,49)/
57470 & 0.07423D0, 0.06794D0, 0.06215D0, 0.05896D0, 0.05679D0,
57471 & 0.05514D0, 0.05023D0, 0.04550D0, 0.04276D0, 0.04079D0,
57472 & 0.03919D0, 0.03404D0, 0.02827D0, 0.02460D0, 0.02188D0,
57473 & 0.01974D0, 0.01650D0, 0.01320D0, 0.00980D0, 0.00778D0,
57474 & 0.00567D0, 0.00475D0, 0.00430D0, 0.00399D0, 0.00376D0,
57475 & 0.00351D0, 0.00322D0, 0.00290D0, 0.00256D0, 0.00223D0,
57476 & 0.00189D0, 0.00158D0, 0.00129D0, 0.00104D0, 0.00083D0,
57477 & 0.00064D0, 0.00049D0, 0.00037D0, 0.00027D0, 0.00020D0,
57478 & 0.00014D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00000D0,
57479 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57480 DATA (FMRS(2,5,I, 5),I=1,49)/
57481 & 0.13335D0, 0.12014D0, 0.10818D0, 0.10170D0, 0.09731D0,
57482 & 0.09401D0, 0.08430D0, 0.07519D0, 0.07001D0, 0.06635D0,
57483 & 0.06344D0, 0.05426D0, 0.04442D0, 0.03837D0, 0.03396D0,
57484 & 0.03053D0, 0.02541D0, 0.02025D0, 0.01501D0, 0.01192D0,
57485 & 0.00870D0, 0.00726D0, 0.00654D0, 0.00602D0, 0.00561D0,
57486 & 0.00519D0, 0.00472D0, 0.00422D0, 0.00370D0, 0.00319D0,
57487 & 0.00269D0, 0.00224D0, 0.00183D0, 0.00146D0, 0.00116D0,
57488 & 0.00089D0, 0.00068D0, 0.00051D0, 0.00038D0, 0.00027D0,
57489 & 0.00019D0, 0.00013D0, 0.00008D0, 0.00003D0, 0.00000D0,
57490 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57491 DATA (FMRS(2,5,I, 6),I=1,49)/
57492 & 0.20163D0, 0.17920D0, 0.15918D0, 0.14846D0, 0.14125D0,
57493 & 0.13587D0, 0.12018D0, 0.10574D0, 0.09768D0, 0.09205D0,
57494 & 0.08763D0, 0.07395D0, 0.05979D0, 0.05130D0, 0.04521D0,
57495 & 0.04052D0, 0.03360D0, 0.02669D0, 0.01976D0, 0.01569D0,
57496 & 0.01145D0, 0.00954D0, 0.00855D0, 0.00780D0, 0.00720D0,
57497 & 0.00661D0, 0.00597D0, 0.00530D0, 0.00461D0, 0.00396D0,
57498 & 0.00333D0, 0.00275D0, 0.00223D0, 0.00178D0, 0.00140D0,
57499 & 0.00108D0, 0.00082D0, 0.00061D0, 0.00045D0, 0.00032D0,
57500 & 0.00022D0, 0.00015D0, 0.00010D0, 0.00003D0, 0.00000D0,
57501 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57502 DATA (FMRS(2,5,I, 7),I=1,49)/
57503 & 0.27774D0, 0.24395D0, 0.21415D0, 0.19835D0, 0.18780D0,
57504 & 0.17996D0, 0.15730D0, 0.13677D0, 0.12547D0, 0.11766D0,
57505 & 0.11157D0, 0.09303D0, 0.07437D0, 0.06341D0, 0.05566D0,
57506 & 0.04974D0, 0.04109D0, 0.03255D0, 0.02405D0, 0.01909D0,
57507 & 0.01394D0, 0.01158D0, 0.01033D0, 0.00936D0, 0.00857D0,
57508 & 0.00780D0, 0.00699D0, 0.00616D0, 0.00533D0, 0.00455D0,
57509 & 0.00380D0, 0.00313D0, 0.00253D0, 0.00201D0, 0.00157D0,
57510 & 0.00121D0, 0.00091D0, 0.00068D0, 0.00050D0, 0.00036D0,
57511 & 0.00024D0, 0.00016D0, 0.00011D0, 0.00003D0, 0.00000D0,
57512 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57513 DATA (FMRS(2,5,I, 8),I=1,49)/
57514 & 0.37644D0, 0.32674D0, 0.28346D0, 0.26073D0, 0.24565D0,
57515 & 0.23449D0, 0.20256D0, 0.17404D0, 0.15854D0, 0.14793D0,
57516 & 0.13972D0, 0.11511D0, 0.09095D0, 0.07707D0, 0.06738D0,
57517 & 0.06004D0, 0.04941D0, 0.03901D0, 0.02877D0, 0.02283D0,
57518 & 0.01667D0, 0.01381D0, 0.01226D0, 0.01101D0, 0.01000D0,
57519 & 0.00902D0, 0.00803D0, 0.00703D0, 0.00604D0, 0.00513D0,
57520 & 0.00426D0, 0.00349D0, 0.00280D0, 0.00222D0, 0.00173D0,
57521 & 0.00132D0, 0.00099D0, 0.00074D0, 0.00054D0, 0.00039D0,
57522 & 0.00026D0, 0.00017D0, 0.00011D0, 0.00003D0, 0.00000D0,
57523 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57524 DATA (FMRS(2,5,I, 9),I=1,49)/
57525 & 0.47784D0, 0.41072D0, 0.35284D0, 0.32270D0, 0.30279D0,
57526 & 0.28813D0, 0.24646D0, 0.20968D0, 0.18991D0, 0.17647D0,
57527 & 0.16612D0, 0.13548D0, 0.10603D0, 0.08938D0, 0.07787D0,
57528 & 0.06921D0, 0.05678D0, 0.04472D0, 0.03292D0, 0.02612D0,
57529 & 0.01906D0, 0.01575D0, 0.01392D0, 0.01241D0, 0.01119D0,
57530 & 0.01003D0, 0.00887D0, 0.00772D0, 0.00660D0, 0.00557D0,
57531 & 0.00461D0, 0.00376D0, 0.00301D0, 0.00237D0, 0.00184D0,
57532 & 0.00140D0, 0.00105D0, 0.00077D0, 0.00057D0, 0.00041D0,
57533 & 0.00027D0, 0.00018D0, 0.00011D0, 0.00003D0, 0.00000D0,
57534 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57535 DATA (FMRS(2,5,I,10),I=1,49)/
57536 & 0.58781D0, 0.50078D0, 0.42641D0, 0.38796D0, 0.36269D0,
57537 & 0.34414D0, 0.29176D0, 0.24601D0, 0.22164D0, 0.20518D0,
57538 & 0.19257D0, 0.15561D0, 0.12070D0, 0.10126D0, 0.08794D0,
57539 & 0.07799D0, 0.06379D0, 0.05011D0, 0.03684D0, 0.02922D0,
57540 & 0.02130D0, 0.01755D0, 0.01544D0, 0.01368D0, 0.01225D0,
57541 & 0.01090D0, 0.00959D0, 0.00830D0, 0.00706D0, 0.00594D0,
57542 & 0.00489D0, 0.00397D0, 0.00316D0, 0.00248D0, 0.00192D0,
57543 & 0.00146D0, 0.00109D0, 0.00080D0, 0.00059D0, 0.00042D0,
57544 & 0.00027D0, 0.00018D0, 0.00012D0, 0.00003D0, 0.00000D0,
57545 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57546 DATA (FMRS(2,5,I,11),I=1,49)/
57547 & 0.68602D0, 0.58051D0, 0.49095D0, 0.44491D0, 0.41476D0,
57548 & 0.39269D0, 0.33066D0, 0.27690D0, 0.24847D0, 0.22936D0,
57549 & 0.21477D0, 0.17232D0, 0.13275D0, 0.11095D0, 0.09613D0,
57550 & 0.08510D0, 0.06944D0, 0.05445D0, 0.03997D0, 0.03169D0,
57551 & 0.02308D0, 0.01898D0, 0.01663D0, 0.01466D0, 0.01306D0,
57552 & 0.01157D0, 0.01013D0, 0.00872D0, 0.00740D0, 0.00620D0,
57553 & 0.00508D0, 0.00411D0, 0.00327D0, 0.00256D0, 0.00197D0,
57554 & 0.00149D0, 0.00111D0, 0.00081D0, 0.00060D0, 0.00042D0,
57555 & 0.00028D0, 0.00018D0, 0.00012D0, 0.00003D0, 0.00000D0,
57556 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57557 DATA (FMRS(2,5,I,12),I=1,49)/
57558 & 0.92772D0, 0.77438D0, 0.64603D0, 0.58078D0, 0.53835D0,
57559 & 0.50746D0, 0.42147D0, 0.34811D0, 0.30983D0, 0.28433D0,
57560 & 0.26501D0, 0.20960D0, 0.15924D0, 0.13208D0, 0.11385D0,
57561 & 0.10043D0, 0.08155D0, 0.06370D0, 0.04663D0, 0.03692D0,
57562 & 0.02683D0, 0.02195D0, 0.01909D0, 0.01665D0, 0.01467D0,
57563 & 0.01287D0, 0.01115D0, 0.00952D0, 0.00801D0, 0.00666D0,
57564 & 0.00542D0, 0.00436D0, 0.00344D0, 0.00268D0, 0.00205D0,
57565 & 0.00155D0, 0.00115D0, 0.00083D0, 0.00061D0, 0.00043D0,
57566 & 0.00028D0, 0.00018D0, 0.00011D0, 0.00003D0, 0.00000D0,
57567 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57568 DATA (FMRS(2,5,I,13),I=1,49)/
57569 & 1.17595D0, 0.97076D0, 0.80093D0, 0.71538D0, 0.66007D0,
57570 & 0.61997D0, 0.50921D0, 0.41588D0, 0.36771D0, 0.33586D0,
57571 & 0.31184D0, 0.24377D0, 0.18310D0, 0.15092D0, 0.12956D0,
57572 & 0.11394D0, 0.09216D0, 0.07174D0, 0.05238D0, 0.04143D0,
57573 & 0.03003D0, 0.02446D0, 0.02114D0, 0.01827D0, 0.01595D0,
57574 & 0.01387D0, 0.01193D0, 0.01011D0, 0.00845D0, 0.00698D0,
57575 & 0.00565D0, 0.00451D0, 0.00355D0, 0.00275D0, 0.00209D0,
57576 & 0.00157D0, 0.00116D0, 0.00084D0, 0.00061D0, 0.00043D0,
57577 & 0.00028D0, 0.00018D0, 0.00011D0, 0.00003D0, 0.00000D0,
57578 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57579 DATA (FMRS(2,5,I,14),I=1,49)/
57580 & 1.49839D0, 1.22261D0, 0.99703D0, 0.88447D0, 0.81213D0,
57581 & 0.75993D0, 0.61688D0, 0.49791D0, 0.43718D0, 0.39731D0,
57582 & 0.36742D0, 0.28369D0, 0.21052D0, 0.17237D0, 0.14732D0,
57583 & 0.12915D0, 0.10402D0, 0.08067D0, 0.05873D0, 0.04638D0,
57584 & 0.03352D0, 0.02715D0, 0.02331D0, 0.01995D0, 0.01725D0,
57585 & 0.01486D0, 0.01267D0, 0.01065D0, 0.00884D0, 0.00725D0,
57586 & 0.00583D0, 0.00463D0, 0.00362D0, 0.00279D0, 0.00211D0,
57587 & 0.00158D0, 0.00116D0, 0.00083D0, 0.00061D0, 0.00043D0,
57588 & 0.00027D0, 0.00018D0, 0.00011D0, 0.00003D0, 0.00000D0,
57589 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57590 DATA (FMRS(2,5,I,15),I=1,49)/
57591 & 1.87945D0, 1.51634D0, 1.22268D0, 1.07750D0, 0.98475D0,
57592 & 0.91809D0, 0.73686D0, 0.58798D0, 0.51279D0, 0.46377D0,
57593 & 0.42722D0, 0.32591D0, 0.23902D0, 0.19443D0, 0.16545D0,
57594 & 0.14459D0, 0.11596D0, 0.08960D0, 0.06503D0, 0.05127D0,
57595 & 0.03691D0, 0.02973D0, 0.02534D0, 0.02147D0, 0.01838D0,
57596 & 0.01569D0, 0.01327D0, 0.01107D0, 0.00912D0, 0.00743D0,
57597 & 0.00594D0, 0.00469D0, 0.00364D0, 0.00279D0, 0.00210D0,
57598 & 0.00156D0, 0.00114D0, 0.00082D0, 0.00059D0, 0.00041D0,
57599 & 0.00026D0, 0.00017D0, 0.00010D0, 0.00003D0, 0.00000D0,
57600 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57601 DATA (FMRS(2,5,I,16),I=1,49)/
57602 & 2.27429D0, 1.81716D0, 1.45106D0, 1.27151D0, 1.15736D0,
57603 & 1.07564D0, 0.85491D0, 0.67549D0, 0.58568D0, 0.52749D0,
57604 & 0.48429D0, 0.36563D0, 0.26542D0, 0.21469D0, 0.18200D0,
57605 & 0.15862D0, 0.12673D0, 0.09760D0, 0.07063D0, 0.05559D0,
57606 & 0.03988D0, 0.03195D0, 0.02705D0, 0.02273D0, 0.01930D0,
57607 & 0.01634D0, 0.01371D0, 0.01136D0, 0.00930D0, 0.00753D0,
57608 & 0.00599D0, 0.00470D0, 0.00364D0, 0.00277D0, 0.00208D0,
57609 & 0.00154D0, 0.00112D0, 0.00080D0, 0.00058D0, 0.00040D0,
57610 & 0.00025D0, 0.00016D0, 0.00010D0, 0.00003D0, 0.00000D0,
57611 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57612 DATA (FMRS(2,5,I,17),I=1,49)/
57613 & 2.72539D0, 2.15724D0, 1.70653D0, 1.48715D0, 1.34837D0,
57614 & 1.24937D0, 0.98364D0, 0.76983D0, 0.66373D0, 0.59537D0,
57615 & 0.54484D0, 0.40724D0, 0.29272D0, 0.23547D0, 0.19888D0,
57616 & 0.17287D0, 0.13761D0, 0.10564D0, 0.07622D0, 0.05987D0,
57617 & 0.04278D0, 0.03409D0, 0.02869D0, 0.02390D0, 0.02012D0,
57618 & 0.01691D0, 0.01408D0, 0.01159D0, 0.00943D0, 0.00759D0,
57619 & 0.00600D0, 0.00469D0, 0.00361D0, 0.00273D0, 0.00204D0,
57620 & 0.00151D0, 0.00109D0, 0.00078D0, 0.00056D0, 0.00039D0,
57621 & 0.00024D0, 0.00015D0, 0.00009D0, 0.00003D0, 0.00000D0,
57622 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57623 DATA (FMRS(2,5,I,18),I=1,49)/
57624 & 3.13641D0, 2.46418D0, 1.93488D0, 1.67881D0, 1.51744D0,
57625 & 1.40264D0, 1.09608D0, 0.85138D0, 0.73076D0, 0.65340D0,
57626 & 0.59642D0, 0.44225D0, 0.31539D0, 0.25259D0, 0.21272D0,
57627 & 0.18450D0, 0.14644D0, 0.11211D0, 0.08069D0, 0.06328D0,
57628 & 0.04506D0, 0.03575D0, 0.02993D0, 0.02476D0, 0.02070D0,
57629 & 0.01729D0, 0.01432D0, 0.01172D0, 0.00949D0, 0.00760D0,
57630 & 0.00598D0, 0.00466D0, 0.00357D0, 0.00269D0, 0.00201D0,
57631 & 0.00147D0, 0.00106D0, 0.00075D0, 0.00054D0, 0.00038D0,
57632 & 0.00023D0, 0.00015D0, 0.00009D0, 0.00003D0, 0.00000D0,
57633 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57634 DATA (FMRS(2,5,I,19),I=1,49)/
57635 & 3.68153D0, 2.86757D0, 2.23222D0, 1.92702D0, 1.73553D0,
57636 & 1.59976D0, 1.23927D0, 0.95419D0, 0.81477D0, 0.72581D0,
57637 & 0.66053D0, 0.48527D0, 0.34292D0, 0.27324D0, 0.22931D0,
57638 & 0.19839D0, 0.15691D0, 0.11975D0, 0.08593D0, 0.06725D0,
57639 & 0.04768D0, 0.03762D0, 0.03130D0, 0.02569D0, 0.02130D0,
57640 & 0.01766D0, 0.01453D0, 0.01182D0, 0.00951D0, 0.00757D0,
57641 & 0.00594D0, 0.00459D0, 0.00350D0, 0.00264D0, 0.00195D0,
57642 & 0.00143D0, 0.00103D0, 0.00072D0, 0.00052D0, 0.00036D0,
57643 & 0.00022D0, 0.00014D0, 0.00008D0, 0.00003D0, 0.00000D0,
57644 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57645 DATA (FMRS(2,5,I,20),I=1,49)/
57646 & 4.21665D0, 3.26014D0, 2.51906D0, 2.16522D0, 1.94405D0,
57647 & 1.78768D0, 1.37455D0, 1.05042D0, 0.89295D0, 0.79293D0,
57648 & 0.71977D0, 0.52460D0, 0.36780D0, 0.29178D0, 0.24415D0,
57649 & 0.21076D0, 0.16620D0, 0.12648D0, 0.09052D0, 0.07070D0,
57650 & 0.04993D0, 0.03920D0, 0.03244D0, 0.02644D0, 0.02178D0,
57651 & 0.01794D0, 0.01467D0, 0.01187D0, 0.00951D0, 0.00753D0,
57652 & 0.00588D0, 0.00453D0, 0.00344D0, 0.00258D0, 0.00191D0,
57653 & 0.00139D0, 0.00099D0, 0.00070D0, 0.00050D0, 0.00035D0,
57654 & 0.00021D0, 0.00013D0, 0.00008D0, 0.00003D0, 0.00000D0,
57655 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57656 DATA (FMRS(2,5,I,21),I=1,49)/
57657 & 4.73651D0, 3.63839D0, 2.79314D0, 2.39169D0, 2.14159D0,
57658 & 1.96521D0, 1.50121D0, 1.13968D0, 0.96506D0, 0.85456D0,
57659 & 0.77398D0, 0.56020D0, 0.39006D0, 0.30823D0, 0.25724D0,
57660 & 0.22164D0, 0.17431D0, 0.13232D0, 0.09445D0, 0.07364D0,
57661 & 0.05181D0, 0.04050D0, 0.03335D0, 0.02701D0, 0.02212D0,
57662 & 0.01812D0, 0.01474D0, 0.01187D0, 0.00946D0, 0.00747D0,
57663 & 0.00580D0, 0.00446D0, 0.00337D0, 0.00252D0, 0.00185D0,
57664 & 0.00135D0, 0.00096D0, 0.00068D0, 0.00049D0, 0.00034D0,
57665 & 0.00020D0, 0.00013D0, 0.00007D0, 0.00003D0, 0.00000D0,
57666 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57667 DATA (FMRS(2,5,I,22),I=1,49)/
57668 & 5.45753D0, 4.15887D0, 3.16726D0, 2.69936D0, 2.40907D0,
57669 & 2.20495D0, 1.67083D0, 1.25820D0, 1.06032D0, 0.93568D0,
57670 & 0.84511D0, 0.60646D0, 0.41869D0, 0.32928D0, 0.27391D0,
57671 & 0.23544D0, 0.18455D0, 0.13964D0, 0.09936D0, 0.07728D0,
57672 & 0.05411D0, 0.04206D0, 0.03442D0, 0.02766D0, 0.02248D0,
57673 & 0.01829D0, 0.01478D0, 0.01184D0, 0.00938D0, 0.00736D0,
57674 & 0.00570D0, 0.00435D0, 0.00328D0, 0.00244D0, 0.00179D0,
57675 & 0.00129D0, 0.00092D0, 0.00065D0, 0.00046D0, 0.00032D0,
57676 & 0.00019D0, 0.00012D0, 0.00007D0, 0.00003D0, 0.00000D0,
57677 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57678 DATA (FMRS(2,5,I,23),I=1,49)/
57679 & 6.19783D0, 4.68879D0, 3.54494D0, 3.00840D0, 2.67675D0,
57680 & 2.44420D0, 1.83862D0, 1.37436D0, 1.15316D0, 1.01443D0,
57681 & 0.91394D0, 0.65074D0, 0.44579D0, 0.34906D0, 0.28951D0,
57682 & 0.24830D0, 0.19403D0, 0.14639D0, 0.10384D0, 0.08058D0,
57683 & 0.05616D0, 0.04343D0, 0.03534D0, 0.02820D0, 0.02276D0,
57684 & 0.01841D0, 0.01478D0, 0.01177D0, 0.00929D0, 0.00725D0,
57685 & 0.00558D0, 0.00425D0, 0.00319D0, 0.00236D0, 0.00173D0,
57686 & 0.00124D0, 0.00088D0, 0.00062D0, 0.00044D0, 0.00031D0,
57687 & 0.00018D0, 0.00011D0, 0.00007D0, 0.00003D0, 0.00000D0,
57688 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57689 DATA (FMRS(2,5,I,24),I=1,49)/
57690 & 6.92966D0, 5.20839D0, 3.91218D0, 3.30740D0, 2.93482D0,
57691 & 2.67420D0, 1.99847D0, 1.48399D0, 1.24028D0, 1.08801D0,
57692 & 0.97803D0, 0.69152D0, 0.47043D0, 0.36691D0, 0.30350D0,
57693 & 0.25978D0, 0.20243D0, 0.15231D0, 0.10773D0, 0.08341D0,
57694 & 0.05788D0, 0.04454D0, 0.03605D0, 0.02858D0, 0.02293D0,
57695 & 0.01844D0, 0.01473D0, 0.01167D0, 0.00917D0, 0.00713D0,
57696 & 0.00547D0, 0.00415D0, 0.00310D0, 0.00229D0, 0.00167D0,
57697 & 0.00120D0, 0.00085D0, 0.00059D0, 0.00043D0, 0.00030D0,
57698 & 0.00017D0, 0.00011D0, 0.00006D0, 0.00003D0, 0.00000D0,
57699 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57700 DATA (FMRS(2,5,I,25),I=1,49)/
57701 & 7.72396D0, 5.76848D0, 4.30532D0, 3.62618D0, 3.20915D0,
57702 & 2.91815D0, 2.16681D0, 1.59861D0, 1.33097D0, 1.16435D0,
57703 & 1.04435D0, 0.73337D0, 0.49551D0, 0.38498D0, 0.31761D0,
57704 & 0.27133D0, 0.21084D0, 0.15821D0, 0.11158D0, 0.08620D0,
57705 & 0.05955D0, 0.04560D0, 0.03673D0, 0.02893D0, 0.02307D0,
57706 & 0.01845D0, 0.01466D0, 0.01156D0, 0.00904D0, 0.00700D0,
57707 & 0.00535D0, 0.00404D0, 0.00301D0, 0.00221D0, 0.00161D0,
57708 & 0.00115D0, 0.00081D0, 0.00057D0, 0.00041D0, 0.00028D0,
57709 & 0.00017D0, 0.00010D0, 0.00006D0, 0.00003D0, 0.00000D0,
57710 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57711 DATA (FMRS(2,5,I,26),I=1,49)/
57712 & 8.54145D0, 6.34073D0, 4.70401D0, 3.94803D0, 3.48525D0,
57713 & 3.16305D0, 2.33446D0, 1.71181D0, 1.42007D0, 1.23908D0,
57714 & 1.10907D0, 0.77380D0, 0.51947D0, 0.40212D0, 0.33092D0,
57715 & 0.28218D0, 0.21869D0, 0.16367D0, 0.11510D0, 0.08871D0,
57716 & 0.06103D0, 0.04651D0, 0.03727D0, 0.02918D0, 0.02314D0,
57717 & 0.01840D0, 0.01456D0, 0.01142D0, 0.00889D0, 0.00686D0,
57718 & 0.00522D0, 0.00393D0, 0.00292D0, 0.00214D0, 0.00155D0,
57719 & 0.00111D0, 0.00078D0, 0.00054D0, 0.00039D0, 0.00027D0,
57720 & 0.00016D0, 0.00009D0, 0.00005D0, 0.00003D0, 0.00000D0,
57721 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57722 DATA (FMRS(2,5,I,27),I=1,49)/
57723 & 9.36625D0, 6.91445D0, 5.10115D0, 4.26741D0, 3.75848D0,
57724 & 3.40490D0, 2.49891D0, 1.82207D0, 1.50649D0, 1.31134D0,
57725 & 1.17150D0, 0.81249D0, 0.54219D0, 0.41829D0, 0.34343D0,
57726 & 0.29234D0, 0.22601D0, 0.16873D0, 0.11834D0, 0.09101D0,
57727 & 0.06235D0, 0.04731D0, 0.03774D0, 0.02938D0, 0.02318D0,
57728 & 0.01834D0, 0.01444D0, 0.01128D0, 0.00875D0, 0.00672D0,
57729 & 0.00510D0, 0.00383D0, 0.00283D0, 0.00207D0, 0.00150D0,
57730 & 0.00107D0, 0.00075D0, 0.00052D0, 0.00038D0, 0.00026D0,
57731 & 0.00015D0, 0.00009D0, 0.00005D0, 0.00003D0, 0.00000D0,
57732 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57733 DATA (FMRS(2,5,I,28),I=1,49)/
57734 & 10.18132D0, 7.47793D0, 5.48877D0, 4.57798D0, 4.02345D0,
57735 & 3.63894D0, 2.65699D0, 1.92733D0, 1.58864D0, 1.37981D0,
57736 & 1.23051D0, 0.84875D0, 0.56329D0, 0.43322D0, 0.35493D0,
57737 & 0.30165D0, 0.23267D0, 0.17330D0, 0.12123D0, 0.09305D0,
57738 & 0.06349D0, 0.04798D0, 0.03811D0, 0.02952D0, 0.02317D0,
57739 & 0.01825D0, 0.01431D0, 0.01114D0, 0.00861D0, 0.00659D0,
57740 & 0.00498D0, 0.00373D0, 0.00275D0, 0.00201D0, 0.00145D0,
57741 & 0.00103D0, 0.00072D0, 0.00050D0, 0.00036D0, 0.00026D0,
57742 & 0.00014D0, 0.00008D0, 0.00005D0, 0.00003D0, 0.00000D0,
57743 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57744 DATA (FMRS(2,5,I,29),I=1,49)/
57745 & 11.04388D0, 8.07089D0, 5.89435D0, 4.90182D0, 4.29909D0,
57746 & 3.88193D0, 2.82014D0, 2.03528D0, 1.67258D0, 1.44958D0,
57747 & 1.29048D0, 0.88533D0, 0.58442D0, 0.44808D0, 0.36634D0,
57748 & 0.31085D0, 0.23922D0, 0.17778D0, 0.12404D0, 0.09501D0,
57749 & 0.06457D0, 0.04859D0, 0.03843D0, 0.02962D0, 0.02314D0,
57750 & 0.01814D0, 0.01416D0, 0.01098D0, 0.00846D0, 0.00645D0,
57751 & 0.00486D0, 0.00363D0, 0.00267D0, 0.00194D0, 0.00140D0,
57752 & 0.00099D0, 0.00069D0, 0.00048D0, 0.00035D0, 0.00025D0,
57753 & 0.00014D0, 0.00008D0, 0.00005D0, 0.00003D0, 0.00000D0,
57754 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57755 DATA (FMRS(2,5,I,30),I=1,49)/
57756 & 11.92777D0, 8.67505D0, 6.30518D0, 5.22873D0, 4.57663D0,
57757 & 4.12613D0, 2.98306D0, 2.14237D0, 1.75551D0, 1.51831D0,
57758 & 1.34943D0, 0.92100D0, 0.60483D0, 0.46237D0, 0.37725D0,
57759 & 0.31962D0, 0.24543D0, 0.18198D0, 0.12665D0, 0.09681D0,
57760 & 0.06554D0, 0.04912D0, 0.03869D0, 0.02967D0, 0.02307D0,
57761 & 0.01801D0, 0.01401D0, 0.01082D0, 0.00830D0, 0.00632D0,
57762 & 0.00475D0, 0.00353D0, 0.00259D0, 0.00188D0, 0.00135D0,
57763 & 0.00095D0, 0.00066D0, 0.00047D0, 0.00034D0, 0.00024D0,
57764 & 0.00014D0, 0.00008D0, 0.00004D0, 0.00002D0, 0.00000D0,
57765 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57766 DATA (FMRS(2,5,I,31),I=1,49)/
57767 & 12.81161D0, 9.27611D0, 6.71181D0, 5.55130D0, 4.84990D0,
57768 & 4.36615D0, 3.14234D0, 2.24650D0, 1.83587D0, 1.58474D0,
57769 & 1.40629D0, 0.95519D0, 0.62425D0, 0.47590D0, 0.38756D0,
57770 & 0.32788D0, 0.25125D0, 0.18591D0, 0.12907D0, 0.09846D0,
57771 & 0.06642D0, 0.04959D0, 0.03891D0, 0.02970D0, 0.02299D0,
57772 & 0.01788D0, 0.01385D0, 0.01067D0, 0.00816D0, 0.00619D0,
57773 & 0.00464D0, 0.00344D0, 0.00252D0, 0.00182D0, 0.00130D0,
57774 & 0.00092D0, 0.00064D0, 0.00045D0, 0.00033D0, 0.00023D0,
57775 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00002D0, 0.00000D0,
57776 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57777 DATA (FMRS(2,5,I,32),I=1,49)/
57778 & 13.67059D0, 9.85720D0, 7.10279D0, 5.86046D0, 5.11119D0,
57779 & 4.59523D0, 3.29346D0, 2.34466D0, 1.91134D0, 1.64694D0,
57780 & 1.45941D0, 0.98687D0, 0.64209D0, 0.48825D0, 0.39691D0,
57781 & 0.33535D0, 0.25648D0, 0.18940D0, 0.13119D0, 0.09990D0,
57782 & 0.06714D0, 0.04995D0, 0.03906D0, 0.02968D0, 0.02289D0,
57783 & 0.01773D0, 0.01369D0, 0.01051D0, 0.00801D0, 0.00606D0,
57784 & 0.00453D0, 0.00335D0, 0.00245D0, 0.00177D0, 0.00126D0,
57785 & 0.00089D0, 0.00062D0, 0.00043D0, 0.00032D0, 0.00023D0,
57786 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00002D0, 0.00000D0,
57787 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57788 DATA (FMRS(2,5,I,33),I=1,49)/
57789 & 14.58850D0, 10.47558D0, 7.51716D0, 6.18731D0, 5.38695D0,
57790 & 4.83668D0, 3.45207D0, 2.44727D0, 1.99002D0, 1.71168D0,
57791 & 1.51462D0, 1.01965D0, 0.66046D0, 0.50094D0, 0.40651D0,
57792 & 0.34300D0, 0.26182D0, 0.19296D0, 0.13335D0, 0.10136D0,
57793 & 0.06788D0, 0.05032D0, 0.03921D0, 0.02967D0, 0.02278D0,
57794 & 0.01759D0, 0.01353D0, 0.01035D0, 0.00787D0, 0.00594D0,
57795 & 0.00443D0, 0.00327D0, 0.00238D0, 0.00172D0, 0.00122D0,
57796 & 0.00086D0, 0.00060D0, 0.00042D0, 0.00031D0, 0.00022D0,
57797 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00002D0, 0.00000D0,
57798 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57799 DATA (FMRS(2,5,I,34),I=1,49)/
57800 & 15.50215D0, 11.08776D0, 7.92505D0, 6.50796D0, 5.65681D0,
57801 & 5.07248D0, 3.60600D0, 2.54615D0, 2.06552D0, 1.77359D0,
57802 & 1.56726D0, 1.05062D0, 0.67763D0, 0.51270D0, 0.41535D0,
57803 & 0.35001D0, 0.26666D0, 0.19615D0, 0.13524D0, 0.10260D0,
57804 & 0.06847D0, 0.05058D0, 0.03928D0, 0.02960D0, 0.02264D0,
57805 & 0.01742D0, 0.01336D0, 0.01019D0, 0.00772D0, 0.00581D0,
57806 & 0.00432D0, 0.00318D0, 0.00232D0, 0.00166D0, 0.00118D0,
57807 & 0.00083D0, 0.00058D0, 0.00041D0, 0.00030D0, 0.00022D0,
57808 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00002D0, 0.00000D0,
57809 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57810 DATA (FMRS(2,5,I,35),I=1,49)/
57811 & 16.42021D0, 11.70052D0, 8.33176D0, 6.82695D0, 5.92484D0,
57812 & 5.30641D0, 3.75809D0, 2.64348D0, 2.13966D0, 1.83429D0,
57813 & 1.61881D0, 1.08081D0, 0.69429D0, 0.52409D0, 0.42389D0,
57814 & 0.35678D0, 0.27133D0, 0.19921D0, 0.13706D0, 0.10380D0,
57815 & 0.06904D0, 0.05083D0, 0.03934D0, 0.02953D0, 0.02251D0,
57816 & 0.01726D0, 0.01320D0, 0.01004D0, 0.00759D0, 0.00569D0,
57817 & 0.00422D0, 0.00310D0, 0.00225D0, 0.00162D0, 0.00115D0,
57818 & 0.00080D0, 0.00056D0, 0.00039D0, 0.00029D0, 0.00021D0,
57819 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00002D0, 0.00000D0,
57820 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57821 DATA (FMRS(2,5,I,36),I=1,49)/
57822 & 17.31499D0, 12.29519D0, 8.72473D0, 7.13436D0, 6.18265D0,
57823 & 5.53107D0, 3.90347D0, 2.73604D0, 2.20994D0, 1.89170D0,
57824 & 1.66747D0, 1.10914D0, 0.70980D0, 0.53464D0, 0.43178D0,
57825 & 0.36300D0, 0.27560D0, 0.20200D0, 0.13869D0, 0.10485D0,
57826 & 0.06952D0, 0.05103D0, 0.03937D0, 0.02945D0, 0.02237D0,
57827 & 0.01710D0, 0.01303D0, 0.00989D0, 0.00746D0, 0.00558D0,
57828 & 0.00413D0, 0.00303D0, 0.00220D0, 0.00157D0, 0.00111D0,
57829 & 0.00078D0, 0.00054D0, 0.00038D0, 0.00028D0, 0.00021D0,
57830 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00002D0, 0.00000D0,
57831 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57832 DATA (FMRS(2,5,I,37),I=1,49)/
57833 & 18.24071D0, 12.90782D0, 9.12782D0, 7.44886D0, 6.44591D0,
57834 & 5.76014D0, 4.05101D0, 2.82949D0, 2.28068D0, 1.94934D0,
57835 & 1.71624D0, 1.13734D0, 0.72513D0, 0.54501D0, 0.43949D0,
57836 & 0.36907D0, 0.27974D0, 0.20467D0, 0.14023D0, 0.10583D0,
57837 & 0.06996D0, 0.05118D0, 0.03937D0, 0.02934D0, 0.02221D0,
57838 & 0.01693D0, 0.01286D0, 0.00973D0, 0.00732D0, 0.00547D0,
57839 & 0.00404D0, 0.00296D0, 0.00214D0, 0.00153D0, 0.00108D0,
57840 & 0.00076D0, 0.00052D0, 0.00037D0, 0.00027D0, 0.00020D0,
57841 & 0.00013D0, 0.00007D0, 0.00004D0, 0.00002D0, 0.00000D0,
57842 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57843 DATA (FMRS(2,5,I,38),I=1,49)/
57844 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57845 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57846 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57847 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57848 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57849 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57850 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57851 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57852 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
57853 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57854 DATA (FMRS(2,6,I, 1),I=1,49)/
57855 & 0.49855D0, 0.42587D0, 0.36389D0, 0.33197D0, 0.31109D0,
57856 & 0.29584D0, 0.25332D0, 0.21750D0, 0.19938D0, 0.18774D0,
57857 & 0.17961D0, 0.15726D0, 0.13904D0, 0.12982D0, 0.12379D0,
57858 & 0.11933D0, 0.11282D0, 0.10593D0, 0.09760D0, 0.09090D0,
57859 & 0.07946D0, 0.06933D0, 0.06013D0, 0.04980D0, 0.04078D0,
57860 & 0.03302D0, 0.02641D0, 0.02091D0, 0.01639D0, 0.01253D0,
57861 & 0.00964D0, 0.00728D0, 0.00545D0, 0.00406D0, 0.00291D0,
57862 & 0.00211D0, 0.00151D0, 0.00106D0, 0.00067D0, 0.00051D0,
57863 & 0.00036D0, 0.00020D0, 0.00015D0, 0.00005D0, 0.00001D0,
57864 & -0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0/
57865 DATA (FMRS(2,6,I, 2),I=1,49)/
57866 & 0.50643D0, 0.43610D0, 0.37562D0, 0.34428D0, 0.32368D0,
57867 & 0.30859D0, 0.26628D0, 0.23029D0, 0.21194D0, 0.20007D0,
57868 & 0.19176D0, 0.16857D0, 0.14897D0, 0.13868D0, 0.13176D0,
57869 & 0.12655D0, 0.11883D0, 0.11060D0, 0.10078D0, 0.09314D0,
57870 & 0.08065D0, 0.07007D0, 0.06069D0, 0.05033D0, 0.04135D0,
57871 & 0.03363D0, 0.02706D0, 0.02157D0, 0.01702D0, 0.01315D0,
57872 & 0.01020D0, 0.00777D0, 0.00589D0, 0.00442D0, 0.00323D0,
57873 & 0.00236D0, 0.00171D0, 0.00122D0, 0.00079D0, 0.00059D0,
57874 & 0.00042D0, 0.00024D0, 0.00018D0, 0.00006D0, 0.00002D0,
57875 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57876 DATA (FMRS(2,6,I, 3),I=1,49)/
57877 & 0.53555D0, 0.46535D0, 0.40441D0, 0.37256D0, 0.35153D0,
57878 & 0.33606D0, 0.29238D0, 0.25475D0, 0.23531D0, 0.22262D0,
57879 & 0.21361D0, 0.18804D0, 0.16542D0, 0.15305D0, 0.14451D0,
57880 & 0.13799D0, 0.12824D0, 0.11785D0, 0.10571D0, 0.09664D0,
57881 & 0.08259D0, 0.07132D0, 0.06165D0, 0.05118D0, 0.04219D0,
57882 & 0.03449D0, 0.02794D0, 0.02243D0, 0.01784D0, 0.01392D0,
57883 & 0.01089D0, 0.00837D0, 0.00641D0, 0.00486D0, 0.00360D0,
57884 & 0.00265D0, 0.00193D0, 0.00138D0, 0.00092D0, 0.00067D0,
57885 & 0.00048D0, 0.00029D0, 0.00022D0, 0.00008D0, 0.00002D0,
57886 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57887 DATA (FMRS(2,6,I, 4),I=1,49)/
57888 & 0.57226D0, 0.49911D0, 0.43533D0, 0.40188D0, 0.37974D0,
57889 & 0.36342D0, 0.31717D0, 0.27704D0, 0.25615D0, 0.24242D0,
57890 & 0.23256D0, 0.20428D0, 0.17865D0, 0.16439D0, 0.15446D0,
57891 & 0.14683D0, 0.13543D0, 0.12334D0, 0.10944D0, 0.09929D0,
57892 & 0.08411D0, 0.07232D0, 0.06240D0, 0.05181D0, 0.04280D0,
57893 & 0.03507D0, 0.02851D0, 0.02298D0, 0.01835D0, 0.01437D0,
57894 & 0.01128D0, 0.00872D0, 0.00670D0, 0.00509D0, 0.00378D0,
57895 & 0.00278D0, 0.00204D0, 0.00149D0, 0.00099D0, 0.00072D0,
57896 & 0.00050D0, 0.00032D0, 0.00023D0, 0.00009D0, 0.00003D0,
57897 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57898 DATA (FMRS(2,6,I, 5),I=1,49)/
57899 & 0.63213D0, 0.55147D0, 0.48109D0, 0.44417D0, 0.41970D0,
57900 & 0.40166D0, 0.35046D0, 0.30587D0, 0.28254D0, 0.26712D0,
57901 & 0.25592D0, 0.22358D0, 0.19384D0, 0.17718D0, 0.16554D0,
57902 & 0.15661D0, 0.14330D0, 0.12931D0, 0.11348D0, 0.10220D0,
57903 & 0.08579D0, 0.07344D0, 0.06325D0, 0.05250D0, 0.04341D0,
57904 & 0.03561D0, 0.02901D0, 0.02344D0, 0.01875D0, 0.01473D0,
57905 & 0.01158D0, 0.00897D0, 0.00690D0, 0.00525D0, 0.00392D0,
57906 & 0.00287D0, 0.00212D0, 0.00153D0, 0.00104D0, 0.00075D0,
57907 & 0.00052D0, 0.00033D0, 0.00023D0, 0.00009D0, 0.00002D0,
57908 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57909 DATA (FMRS(2,6,I, 6),I=1,49)/
57910 & 0.69484D0, 0.60548D0, 0.52759D0, 0.48675D0, 0.45969D0,
57911 & 0.43974D0, 0.38311D0, 0.33372D0, 0.30779D0, 0.29059D0,
57912 & 0.27800D0, 0.24152D0, 0.20772D0, 0.18874D0, 0.17549D0,
57913 & 0.16535D0, 0.15028D0, 0.13457D0, 0.11704D0, 0.10475D0,
57914 & 0.08728D0, 0.07444D0, 0.06400D0, 0.05308D0, 0.04390D0,
57915 & 0.03605D0, 0.02939D0, 0.02378D0, 0.01903D0, 0.01499D0,
57916 & 0.01179D0, 0.00914D0, 0.00703D0, 0.00535D0, 0.00400D0,
57917 & 0.00293D0, 0.00217D0, 0.00156D0, 0.00107D0, 0.00077D0,
57918 & 0.00053D0, 0.00034D0, 0.00024D0, 0.00009D0, 0.00002D0,
57919 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57920 DATA (FMRS(2,6,I, 7),I=1,49)/
57921 & 0.77164D0, 0.67034D0, 0.58230D0, 0.53624D0, 0.50577D0,
57922 & 0.48332D0, 0.41966D0, 0.36421D0, 0.33508D0, 0.31572D0,
57923 & 0.30145D0, 0.26012D0, 0.22178D0, 0.20031D0, 0.18536D0,
57924 & 0.17396D0, 0.15711D0, 0.13969D0, 0.12049D0, 0.10724D0,
57925 & 0.08874D0, 0.07542D0, 0.06472D0, 0.05362D0, 0.04433D0,
57926 & 0.03642D0, 0.02969D0, 0.02403D0, 0.01923D0, 0.01516D0,
57927 & 0.01193D0, 0.00926D0, 0.00710D0, 0.00541D0, 0.00405D0,
57928 & 0.00297D0, 0.00219D0, 0.00158D0, 0.00108D0, 0.00077D0,
57929 & 0.00052D0, 0.00033D0, 0.00024D0, 0.00008D0, 0.00002D0,
57930 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57931 DATA (FMRS(2,6,I, 8),I=1,49)/
57932 & 0.86838D0, 0.75105D0, 0.64953D0, 0.59658D0, 0.56163D0,
57933 & 0.53592D0, 0.46317D0, 0.39995D0, 0.36678D0, 0.34473D0,
57934 & 0.32838D0, 0.28112D0, 0.23740D0, 0.21303D0, 0.19616D0,
57935 & 0.18334D0, 0.16450D0, 0.14520D0, 0.12419D0, 0.10991D0,
57936 & 0.09031D0, 0.07647D0, 0.06547D0, 0.05416D0, 0.04475D0,
57937 & 0.03674D0, 0.02994D0, 0.02423D0, 0.01939D0, 0.01529D0,
57938 & 0.01202D0, 0.00932D0, 0.00715D0, 0.00545D0, 0.00407D0,
57939 & 0.00298D0, 0.00220D0, 0.00159D0, 0.00108D0, 0.00077D0,
57940 & 0.00052D0, 0.00033D0, 0.00024D0, 0.00008D0, 0.00002D0,
57941 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57942 DATA (FMRS(2,6,I, 9),I=1,49)/
57943 & 0.96608D0, 0.83177D0, 0.71606D0, 0.65593D0, 0.61632D0,
57944 & 0.58722D0, 0.50510D0, 0.43397D0, 0.39671D0, 0.37195D0,
57945 & 0.35355D0, 0.30046D0, 0.25156D0, 0.22448D0, 0.20581D0,
57946 & 0.19169D0, 0.17103D0, 0.15004D0, 0.12743D0, 0.11224D0,
57947 & 0.09169D0, 0.07737D0, 0.06612D0, 0.05461D0, 0.04508D0,
57948 & 0.03697D0, 0.03013D0, 0.02435D0, 0.01949D0, 0.01536D0,
57949 & 0.01207D0, 0.00933D0, 0.00718D0, 0.00545D0, 0.00407D0,
57950 & 0.00298D0, 0.00219D0, 0.00159D0, 0.00106D0, 0.00076D0,
57951 & 0.00052D0, 0.00033D0, 0.00024D0, 0.00009D0, 0.00002D0,
57952 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57953 DATA (FMRS(2,6,I,10),I=1,49)/
57954 & 1.07543D0, 0.92116D0, 0.78892D0, 0.72047D0, 0.67548D0,
57955 & 0.64249D0, 0.54968D0, 0.46963D0, 0.42782D0, 0.40008D0,
57956 & 0.37941D0, 0.32003D0, 0.26568D0, 0.23578D0, 0.21528D0,
57957 & 0.19985D0, 0.17739D0, 0.15473D0, 0.13057D0, 0.11449D0,
57958 & 0.09302D0, 0.07823D0, 0.06672D0, 0.05501D0, 0.04535D0,
57959 & 0.03715D0, 0.03025D0, 0.02442D0, 0.01953D0, 0.01538D0,
57960 & 0.01207D0, 0.00932D0, 0.00717D0, 0.00543D0, 0.00405D0,
57961 & 0.00296D0, 0.00217D0, 0.00158D0, 0.00105D0, 0.00075D0,
57962 & 0.00051D0, 0.00033D0, 0.00023D0, 0.00008D0, 0.00002D0,
57963 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57964 DATA (FMRS(2,6,I,11),I=1,49)/
57965 & 1.17158D0, 0.99923D0, 0.85209D0, 0.77617D0, 0.72639D0,
57966 & 0.68993D0, 0.58762D0, 0.49971D0, 0.45391D0, 0.42357D0,
57967 & 0.40096D0, 0.33616D0, 0.27719D0, 0.24495D0, 0.22293D0,
57968 & 0.20642D0, 0.18248D0, 0.15848D0, 0.13306D0, 0.11628D0,
57969 & 0.09406D0, 0.07891D0, 0.06718D0, 0.05531D0, 0.04555D0,
57970 & 0.03727D0, 0.03032D0, 0.02446D0, 0.01953D0, 0.01537D0,
57971 & 0.01205D0, 0.00930D0, 0.00714D0, 0.00540D0, 0.00402D0,
57972 & 0.00294D0, 0.00214D0, 0.00155D0, 0.00104D0, 0.00074D0,
57973 & 0.00050D0, 0.00032D0, 0.00022D0, 0.00008D0, 0.00002D0,
57974 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57975 DATA (FMRS(2,6,I,12),I=1,49)/
57976 & 1.40820D0, 1.18938D0, 1.00430D0, 0.90953D0, 0.84767D0,
57977 & 0.80252D0, 0.67658D0, 0.56932D0, 0.51382D0, 0.47719D0,
57978 & 0.44989D0, 0.37226D0, 0.30256D0, 0.26497D0, 0.23955D0,
57979 & 0.22062D0, 0.19343D0, 0.16648D0, 0.13836D0, 0.12007D0,
57980 & 0.09626D0, 0.08032D0, 0.06811D0, 0.05588D0, 0.04588D0,
57981 & 0.03745D0, 0.03039D0, 0.02446D0, 0.01948D0, 0.01531D0,
57982 & 0.01197D0, 0.00921D0, 0.00706D0, 0.00532D0, 0.00395D0,
57983 & 0.00288D0, 0.00209D0, 0.00151D0, 0.00101D0, 0.00072D0,
57984 & 0.00049D0, 0.00031D0, 0.00021D0, 0.00008D0, 0.00002D0,
57985 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57986 DATA (FMRS(2,6,I,13),I=1,49)/
57987 & 1.64756D0, 1.37951D0, 1.15467D0, 1.04031D0, 0.96596D0,
57988 & 0.91188D0, 0.76181D0, 0.63505D0, 0.56988D0, 0.52704D0,
57989 & 0.49515D0, 0.40510D0, 0.32525D0, 0.28268D0, 0.25415D0,
57990 & 0.23303D0, 0.20292D0, 0.17336D0, 0.14288D0, 0.12329D0,
57991 & 0.09812D0, 0.08148D0, 0.06886D0, 0.05629D0, 0.04609D0,
57992 & 0.03753D0, 0.03037D0, 0.02438D0, 0.01937D0, 0.01519D0,
57993 & 0.01185D0, 0.00910D0, 0.00695D0, 0.00523D0, 0.00387D0,
57994 & 0.00281D0, 0.00204D0, 0.00147D0, 0.00097D0, 0.00069D0,
57995 & 0.00048D0, 0.00029D0, 0.00020D0, 0.00007D0, 0.00002D0,
57996 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
57997 DATA (FMRS(2,6,I,14),I=1,49)/
57998 & 1.95709D0, 1.62260D0, 1.34467D0, 1.20438D0, 1.11362D0,
57999 & 1.04783D0, 0.86639D0, 0.71460D0, 0.63715D0, 0.58648D0,
58000 & 0.54885D0, 0.44345D0, 0.35130D0, 0.30283D0, 0.27064D0,
58001 & 0.24698D0, 0.21351D0, 0.18099D0, 0.14786D0, 0.12681D0,
58002 & 0.10011D0, 0.08269D0, 0.06959D0, 0.05666D0, 0.04624D0,
58003 & 0.03752D0, 0.03025D0, 0.02422D0, 0.01919D0, 0.01499D0,
58004 & 0.01165D0, 0.00893D0, 0.00678D0, 0.00510D0, 0.00375D0,
58005 & 0.00271D0, 0.00197D0, 0.00141D0, 0.00093D0, 0.00065D0,
58006 & 0.00045D0, 0.00028D0, 0.00019D0, 0.00007D0, 0.00002D0,
58007 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58008 DATA (FMRS(2,6,I,15),I=1,49)/
58009 & 2.33106D0, 1.91266D0, 1.56849D0, 1.39616D0, 1.28524D0,
58010 & 1.20514D0, 0.98569D0, 0.80398D0, 0.71204D0, 0.65222D0,
58011 & 0.60792D0, 0.48491D0, 0.37897D0, 0.32402D0, 0.28785D0,
58012 & 0.26145D0, 0.22441D0, 0.18878D0, 0.15289D0, 0.13035D0,
58013 & 0.10206D0, 0.08383D0, 0.07023D0, 0.05691D0, 0.04625D0,
58014 & 0.03736D0, 0.03004D0, 0.02396D0, 0.01891D0, 0.01473D0,
58015 & 0.01139D0, 0.00872D0, 0.00659D0, 0.00494D0, 0.00362D0,
58016 & 0.00261D0, 0.00189D0, 0.00136D0, 0.00089D0, 0.00062D0,
58017 & 0.00043D0, 0.00026D0, 0.00018D0, 0.00006D0, 0.00002D0,
58018 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58019 DATA (FMRS(2,6,I,16),I=1,49)/
58020 & 2.71585D0, 2.20785D0, 1.79373D0, 1.58787D0, 1.45597D0,
58021 & 1.36104D0, 1.10250D0, 0.89041D0, 0.78391D0, 0.71494D0,
58022 & 0.66403D0, 0.52372D0, 0.40449D0, 0.34337D0, 0.30346D0,
58023 & 0.27452D0, 0.23417D0, 0.19570D0, 0.15732D0, 0.13343D0,
58024 & 0.10373D0, 0.08475D0, 0.07072D0, 0.05705D0, 0.04617D0,
58025 & 0.03716D0, 0.02977D0, 0.02366D0, 0.01861D0, 0.01445D0,
58026 & 0.01114D0, 0.00850D0, 0.00640D0, 0.00478D0, 0.00350D0,
58027 & 0.00251D0, 0.00181D0, 0.00130D0, 0.00086D0, 0.00058D0,
58028 & 0.00040D0, 0.00024D0, 0.00016D0, 0.00006D0, 0.00002D0,
58029 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58030 DATA (FMRS(2,6,I,17),I=1,49)/
58031 & 3.15180D0, 2.53892D0, 2.04375D0, 1.79938D0, 1.64351D0,
58032 & 1.53170D0, 1.22899D0, 0.98294D0, 0.86032D0, 0.78129D0,
58033 & 0.72315D0, 0.56409D0, 0.43066D0, 0.36305D0, 0.31926D0,
58034 & 0.28768D0, 0.24394D0, 0.20257D0, 0.16168D0, 0.13644D0,
58035 & 0.10531D0, 0.08560D0, 0.07112D0, 0.05711D0, 0.04602D0,
58036 & 0.03691D0, 0.02945D0, 0.02332D0, 0.01829D0, 0.01415D0,
58037 & 0.01087D0, 0.00826D0, 0.00621D0, 0.00462D0, 0.00337D0,
58038 & 0.00241D0, 0.00173D0, 0.00124D0, 0.00082D0, 0.00055D0,
58039 & 0.00038D0, 0.00023D0, 0.00015D0, 0.00005D0, 0.00002D0,
58040 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58041 DATA (FMRS(2,6,I,18),I=1,49)/
58042 & 3.55145D0, 2.83962D0, 2.26870D0, 1.98860D0, 1.81061D0,
58043 & 1.68328D0, 1.34021D0, 1.06346D0, 0.92638D0, 0.83839D0,
58044 & 0.77383D0, 0.59827D0, 0.45255D0, 0.37938D0, 0.33229D0,
58045 & 0.29849D0, 0.25191D0, 0.20813D0, 0.16517D0, 0.13882D0,
58046 & 0.10653D0, 0.08622D0, 0.07137D0, 0.05708D0, 0.04584D0,
58047 & 0.03664D0, 0.02914D0, 0.02300D0, 0.01798D0, 0.01388D0,
58048 & 0.01064D0, 0.00807D0, 0.00604D0, 0.00448D0, 0.00326D0,
58049 & 0.00232D0, 0.00166D0, 0.00119D0, 0.00077D0, 0.00053D0,
58050 & 0.00036D0, 0.00022D0, 0.00015D0, 0.00005D0, 0.00001D0,
58051 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58052 DATA (FMRS(2,6,I,19),I=1,49)/
58053 & 4.08243D0, 3.23554D0, 2.56218D0, 2.23414D0, 2.02661D0,
58054 & 1.87862D0, 1.48217D0, 1.16519D0, 1.00935D0, 0.90979D0,
58055 & 0.83697D0, 0.64037D0, 0.47917D0, 0.39910D0, 0.34794D0,
58056 & 0.31141D0, 0.26137D0, 0.21468D0, 0.16924D0, 0.14156D0,
58057 & 0.10788D0, 0.08686D0, 0.07159D0, 0.05697D0, 0.04554D0,
58058 & 0.03624D0, 0.02871D0, 0.02258D0, 0.01759D0, 0.01353D0,
58059 & 0.01034D0, 0.00780D0, 0.00582D0, 0.00431D0, 0.00313D0,
58060 & 0.00222D0, 0.00159D0, 0.00113D0, 0.00073D0, 0.00050D0,
58061 & 0.00034D0, 0.00021D0, 0.00014D0, 0.00005D0, 0.00001D0,
58062 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58063 DATA (FMRS(2,6,I,20),I=1,49)/
58064 & 4.59984D0, 3.61795D0, 2.84314D0, 2.46798D0, 2.23154D0,
58065 & 2.06341D0, 1.61522D0, 1.25965D0, 1.08594D0, 0.97542D0,
58066 & 0.89482D0, 0.67853D0, 0.50302D0, 0.41664D0, 0.36179D0,
58067 & 0.32280D0, 0.26966D0, 0.22039D0, 0.17274D0, 0.14391D0,
58068 & 0.10901D0, 0.08736D0, 0.07173D0, 0.05682D0, 0.04524D0,
58069 & 0.03586D0, 0.02831D0, 0.02220D0, 0.01723D0, 0.01322D0,
58070 & 0.01007D0, 0.00756D0, 0.00563D0, 0.00415D0, 0.00301D0,
58071 & 0.00213D0, 0.00152D0, 0.00108D0, 0.00071D0, 0.00046D0,
58072 & 0.00032D0, 0.00019D0, 0.00013D0, 0.00004D0, 0.00001D0,
58073 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58074 DATA (FMRS(2,6,I,21),I=1,49)/
58075 & 5.10866D0, 3.99099D0, 3.11497D0, 2.69310D0, 2.42814D0,
58076 & 2.24021D0, 1.74141D0, 1.34843D0, 1.15753D0, 1.03651D0,
58077 & 0.94850D0, 0.71355D0, 0.52465D0, 0.43244D0, 0.37419D0,
58078 & 0.33296D0, 0.27700D0, 0.22539D0, 0.17578D0, 0.14590D0,
58079 & 0.10992D0, 0.08772D0, 0.07175D0, 0.05660D0, 0.04490D0,
58080 & 0.03547D0, 0.02791D0, 0.02182D0, 0.01688D0, 0.01291D0,
58081 & 0.00980D0, 0.00735D0, 0.00546D0, 0.00401D0, 0.00289D0,
58082 & 0.00204D0, 0.00145D0, 0.00103D0, 0.00067D0, 0.00045D0,
58083 & 0.00030D0, 0.00018D0, 0.00012D0, 0.00004D0, 0.00001D0,
58084 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58085 DATA (FMRS(2,6,I,22),I=1,49)/
58086 & 5.81063D0, 4.50144D0, 3.48388D0, 2.99716D0, 2.69275D0,
58087 & 2.47752D0, 1.90937D0, 1.46556D0, 1.25149D0, 1.11639D0,
58088 & 1.01845D0, 0.75875D0, 0.55228D0, 0.45248D0, 0.38985D0,
58089 & 0.34573D0, 0.28616D0, 0.23159D0, 0.17950D0, 0.14831D0,
58090 & 0.11099D0, 0.08809D0, 0.07172D0, 0.05628D0, 0.04443D0,
58091 & 0.03495D0, 0.02738D0, 0.02132D0, 0.01642D0, 0.01252D0,
58092 & 0.00947D0, 0.00708D0, 0.00524D0, 0.00384D0, 0.00275D0,
58093 & 0.00194D0, 0.00137D0, 0.00097D0, 0.00062D0, 0.00042D0,
58094 & 0.00028D0, 0.00017D0, 0.00011D0, 0.00004D0, 0.00001D0,
58095 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58096 DATA (FMRS(2,6,I,23),I=1,49)/
58097 & 6.53035D0, 5.02028D0, 3.85558D0, 3.30194D0, 2.95702D0,
58098 & 2.71384D0, 2.07512D0, 1.58008D0, 1.34283D0, 1.19373D0,
58099 & 1.08596D0, 0.80189D0, 0.57834D0, 0.47125D0, 0.40444D0,
58100 & 0.35757D0, 0.29461D0, 0.23726D0, 0.18285D0, 0.15046D0,
58101 & 0.11188D0, 0.08836D0, 0.07162D0, 0.05593D0, 0.04396D0,
58102 & 0.03443D0, 0.02686D0, 0.02084D0, 0.01599D0, 0.01216D0,
58103 & 0.00917D0, 0.00683D0, 0.00504D0, 0.00368D0, 0.00262D0,
58104 & 0.00186D0, 0.00129D0, 0.00092D0, 0.00058D0, 0.00038D0,
58105 & 0.00026D0, 0.00015D0, 0.00010D0, 0.00004D0, 0.00001D0,
58106 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58107 DATA (FMRS(2,6,I,24),I=1,49)/
58108 & 7.24769D0, 5.53321D0, 4.22004D0, 3.59932D0, 3.21397D0,
58109 & 2.94299D0, 2.23445D0, 1.68918D0, 1.42937D0, 1.26671D0,
58110 & 1.14944D0, 0.84202D0, 0.60229D0, 0.48837D0, 0.41766D0,
58111 & 0.36826D0, 0.30216D0, 0.24227D0, 0.18575D0, 0.15227D0,
58112 & 0.11258D0, 0.08849D0, 0.07143D0, 0.05553D0, 0.04345D0,
58113 & 0.03390D0, 0.02636D0, 0.02037D0, 0.01559D0, 0.01181D0,
58114 & 0.00887D0, 0.00659D0, 0.00484D0, 0.00353D0, 0.00252D0,
58115 & 0.00176D0, 0.00124D0, 0.00088D0, 0.00055D0, 0.00037D0,
58116 & 0.00025D0, 0.00014D0, 0.00009D0, 0.00003D0, 0.00001D0,
58117 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58118 DATA (FMRS(2,6,I,25),I=1,49)/
58119 & 8.02203D0, 6.08288D0, 4.60775D0, 3.91431D0, 3.48531D0,
58120 & 3.18439D0, 2.40103D0, 1.80237D0, 1.51875D0, 1.34182D0,
58121 & 1.21461D0, 0.88286D0, 0.62643D0, 0.50552D0, 0.43085D0,
58122 & 0.37888D0, 0.30963D0, 0.24719D0, 0.18858D0, 0.15401D0,
58123 & 0.11322D0, 0.08857D0, 0.07120D0, 0.05510D0, 0.04294D0,
58124 & 0.03336D0, 0.02585D0, 0.01990D0, 0.01519D0, 0.01146D0,
58125 & 0.00858D0, 0.00636D0, 0.00466D0, 0.00338D0, 0.00242D0,
58126 & 0.00168D0, 0.00119D0, 0.00083D0, 0.00052D0, 0.00035D0,
58127 & 0.00023D0, 0.00013D0, 0.00009D0, 0.00003D0, 0.00001D0,
58128 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58129 DATA (FMRS(2,6,I,26),I=1,49)/
58130 & 8.82307D0, 6.64735D0, 5.00295D0, 4.23399D0, 3.75981D0,
58131 & 3.42801D0, 2.56785D0, 1.91480D0, 1.60708D0, 1.41578D0,
58132 & 1.27859D0, 0.92256D0, 0.64966D0, 0.52190D0, 0.44338D0,
58133 & 0.38892D0, 0.31662D0, 0.25175D0, 0.19114D0, 0.15555D0,
58134 & 0.11371D0, 0.08855D0, 0.07090D0, 0.05462D0, 0.04239D0,
58135 & 0.03281D0, 0.02532D0, 0.01944D0, 0.01478D0, 0.01112D0,
58136 & 0.00830D0, 0.00614D0, 0.00448D0, 0.00324D0, 0.00231D0,
58137 & 0.00160D0, 0.00113D0, 0.00079D0, 0.00049D0, 0.00033D0,
58138 & 0.00022D0, 0.00013D0, 0.00008D0, 0.00003D0, 0.00001D0,
58139 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58140 DATA (FMRS(2,6,I,27),I=1,49)/
58141 & 9.62987D0, 7.21210D0, 5.39571D0, 4.55043D0, 4.03076D0,
58142 & 3.66794D0, 2.73100D0, 2.02398D0, 1.69250D0, 1.48708D0,
58143 & 1.34010D0, 0.96040D0, 0.67159D0, 0.53727D0, 0.45509D0,
58144 & 0.39827D0, 0.32310D0, 0.25593D0, 0.19347D0, 0.15692D0,
58145 & 0.11411D0, 0.08848D0, 0.07058D0, 0.05414D0, 0.04185D0,
58146 & 0.03228D0, 0.02482D0, 0.01900D0, 0.01440D0, 0.01080D0,
58147 & 0.00804D0, 0.00593D0, 0.00431D0, 0.00312D0, 0.00222D0,
58148 & 0.00152D0, 0.00108D0, 0.00075D0, 0.00046D0, 0.00031D0,
58149 & 0.00020D0, 0.00012D0, 0.00008D0, 0.00003D0, 0.00001D0,
58150 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58151 DATA (FMRS(2,6,I,28),I=1,49)/
58152 & 10.42894D0, 7.76794D0, 5.77982D0, 4.85875D0, 4.29406D0,
58153 & 3.90061D0, 2.88817D0, 2.12844D0, 1.77387D0, 1.55479D0,
58154 & 1.39837D0, 0.99596D0, 0.69200D0, 0.55150D0, 0.46587D0,
58155 & 0.40684D0, 0.32899D0, 0.25970D0, 0.19552D0, 0.15809D0,
58156 & 0.11441D0, 0.08837D0, 0.07023D0, 0.05366D0, 0.04133D0,
58157 & 0.03176D0, 0.02435D0, 0.01859D0, 0.01405D0, 0.01051D0,
58158 & 0.00780D0, 0.00573D0, 0.00416D0, 0.00301D0, 0.00213D0,
58159 & 0.00146D0, 0.00103D0, 0.00071D0, 0.00045D0, 0.00029D0,
58160 & 0.00020D0, 0.00011D0, 0.00008D0, 0.00003D0, 0.00001D0,
58161 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58162 DATA (FMRS(2,6,I,29),I=1,49)/
58163 & 11.27410D0, 8.35239D0, 6.18132D0, 5.17989D0, 4.56762D0,
58164 & 4.14187D0, 3.05014D0, 2.23540D0, 1.85687D0, 1.62366D0,
58165 & 1.45750D0, 1.03178D0, 0.71238D0, 0.56563D0, 0.47653D0,
58166 & 0.41529D0, 0.33476D0, 0.26336D0, 0.19748D0, 0.15919D0,
58167 & 0.11465D0, 0.08820D0, 0.06985D0, 0.05316D0, 0.04080D0,
58168 & 0.03125D0, 0.02388D0, 0.01817D0, 0.01370D0, 0.01022D0,
58169 & 0.00757D0, 0.00554D0, 0.00401D0, 0.00290D0, 0.00205D0,
58170 & 0.00140D0, 0.00098D0, 0.00068D0, 0.00043D0, 0.00028D0,
58171 & 0.00019D0, 0.00011D0, 0.00007D0, 0.00002D0, 0.00001D0,
58172 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58173 DATA (FMRS(2,6,I,30),I=1,49)/
58174 & 12.14199D0, 8.94909D0, 6.58882D0, 5.50470D0, 4.84361D0,
58175 & 4.38480D0, 3.21222D0, 2.34175D0, 1.93908D0, 1.69167D0,
58176 & 1.51576D0, 1.06678D0, 0.73213D0, 0.57923D0, 0.48674D0,
58177 & 0.42334D0, 0.34023D0, 0.26678D0, 0.19927D0, 0.16016D0,
58178 & 0.11481D0, 0.08798D0, 0.06944D0, 0.05264D0, 0.04025D0,
58179 & 0.03073D0, 0.02343D0, 0.01777D0, 0.01335D0, 0.00994D0,
58180 & 0.00734D0, 0.00536D0, 0.00388D0, 0.00278D0, 0.00196D0,
58181 & 0.00135D0, 0.00094D0, 0.00065D0, 0.00041D0, 0.00027D0,
58182 & 0.00017D0, 0.00010D0, 0.00007D0, 0.00002D0, 0.00001D0,
58183 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58184 DATA (FMRS(2,6,I,31),I=1,49)/
58185 & 13.00875D0, 9.54182D0, 6.99142D0, 5.82458D0, 5.11479D0,
58186 & 4.62308D0, 3.37031D0, 2.44489D0, 2.01852D0, 1.75723D0,
58187 & 1.57179D0, 1.10022D0, 0.75086D0, 0.59207D0, 0.49634D0,
58188 & 0.43089D0, 0.34532D0, 0.26994D0, 0.20090D0, 0.16103D0,
58189 & 0.11492D0, 0.08774D0, 0.06903D0, 0.05213D0, 0.03973D0,
58190 & 0.03024D0, 0.02300D0, 0.01739D0, 0.01303D0, 0.00968D0,
58191 & 0.00712D0, 0.00520D0, 0.00375D0, 0.00268D0, 0.00188D0,
58192 & 0.00130D0, 0.00090D0, 0.00063D0, 0.00039D0, 0.00025D0,
58193 & 0.00016D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00001D0,
58194 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58195 DATA (FMRS(2,6,I,32),I=1,49)/
58196 & 13.85388D0, 10.11672D0, 7.37984D0, 6.13221D0, 5.37500D0,
58197 & 4.85130D0, 3.52087D0, 2.54252D0, 2.09344D0, 1.81889D0,
58198 & 1.62437D0, 1.13136D0, 0.76814D0, 0.60383D0, 0.50509D0,
58199 & 0.43774D0, 0.34990D0, 0.27275D0, 0.20231D0, 0.16173D0,
58200 & 0.11495D0, 0.08745D0, 0.06859D0, 0.05162D0, 0.03921D0,
58201 & 0.02977D0, 0.02256D0, 0.01702D0, 0.01273D0, 0.00943D0,
58202 & 0.00693D0, 0.00505D0, 0.00364D0, 0.00260D0, 0.00181D0,
58203 & 0.00125D0, 0.00086D0, 0.00060D0, 0.00037D0, 0.00024D0,
58204 & 0.00016D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00001D0,
58205 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58206 DATA (FMRS(2,6,I,33),I=1,49)/
58207 & 14.75398D0, 10.72621D0, 7.78974D0, 6.45599D0, 5.64833D0,
58208 & 5.09068D0, 3.67806D0, 2.64398D0, 2.17108D0, 1.88265D0,
58209 & 1.67867D0, 1.16335D0, 0.78579D0, 0.61581D0, 0.51399D0,
58210 & 0.44470D0, 0.35453D0, 0.27558D0, 0.20373D0, 0.16245D0,
58211 & 0.11497D0, 0.08717D0, 0.06816D0, 0.05112D0, 0.03871D0,
58212 & 0.02930D0, 0.02213D0, 0.01666D0, 0.01243D0, 0.00919D0,
58213 & 0.00674D0, 0.00490D0, 0.00353D0, 0.00251D0, 0.00175D0,
58214 & 0.00120D0, 0.00083D0, 0.00058D0, 0.00036D0, 0.00023D0,
58215 & 0.00015D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00001D0,
58216 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58217 DATA (FMRS(2,6,I,34),I=1,49)/
58218 & 15.65461D0, 11.33290D0, 8.19558D0, 6.77553D0, 5.91747D0,
58219 & 5.32596D0, 3.83165D0, 2.74249D0, 2.24617D0, 1.94414D0,
58220 & 1.73088D0, 1.19385D0, 0.80244D0, 0.62703D0, 0.52226D0,
58221 & 0.45111D0, 0.35875D0, 0.27811D0, 0.20493D0, 0.16299D0,
58222 & 0.11490D0, 0.08681D0, 0.06768D0, 0.05059D0, 0.03819D0,
58223 & 0.02883D0, 0.02172D0, 0.01631D0, 0.01213D0, 0.00895D0,
58224 & 0.00656D0, 0.00475D0, 0.00341D0, 0.00243D0, 0.00169D0,
58225 & 0.00116D0, 0.00080D0, 0.00055D0, 0.00034D0, 0.00022D0,
58226 & 0.00015D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00000D0,
58227 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58228 DATA (FMRS(2,6,I,35),I=1,49)/
58229 & 16.55734D0, 11.93842D0, 8.59892D0, 7.09231D0, 6.18381D0,
58230 & 5.55847D0, 3.98278D0, 2.83900D0, 2.31954D0, 2.00411D0,
58231 & 1.78173D0, 1.22341D0, 0.81850D0, 0.63782D0, 0.53020D0,
58232 & 0.45726D0, 0.36278D0, 0.28052D0, 0.20606D0, 0.16351D0,
58233 & 0.11482D0, 0.08647D0, 0.06722D0, 0.05009D0, 0.03770D0,
58234 & 0.02838D0, 0.02133D0, 0.01598D0, 0.01187D0, 0.00873D0,
58235 & 0.00639D0, 0.00462D0, 0.00330D0, 0.00235D0, 0.00163D0,
58236 & 0.00111D0, 0.00077D0, 0.00053D0, 0.00033D0, 0.00021D0,
58237 & 0.00014D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00000D0,
58238 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58239 DATA (FMRS(2,6,I,36),I=1,49)/
58240 & 17.43806D0, 12.52661D0, 8.98898D0, 7.39784D0, 6.44021D0,
58241 & 5.78196D0, 4.12737D0, 2.93087D0, 2.38917D0, 2.06088D0,
58242 & 1.82979D0, 1.25117D0, 0.83346D0, 0.64781D0, 0.53752D0,
58243 & 0.46291D0, 0.36645D0, 0.28268D0, 0.20706D0, 0.16393D0,
58244 & 0.11470D0, 0.08612D0, 0.06676D0, 0.04960D0, 0.03723D0,
58245 & 0.02796D0, 0.02096D0, 0.01566D0, 0.01161D0, 0.00852D0,
58246 & 0.00623D0, 0.00449D0, 0.00321D0, 0.00227D0, 0.00158D0,
58247 & 0.00107D0, 0.00074D0, 0.00051D0, 0.00031D0, 0.00020D0,
58248 & 0.00013D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00000D0,
58249 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58250 DATA (FMRS(2,6,I,37),I=1,49)/
58251 & 18.35067D0, 13.13351D0, 9.38971D0, 7.71095D0, 6.70247D0,
58252 & 6.01024D0, 4.27436D0, 3.02381D0, 2.45940D0, 2.11802D0,
58253 & 1.87806D0, 1.27887D0, 0.84828D0, 0.65765D0, 0.54469D0,
58254 & 0.46841D0, 0.37001D0, 0.28475D0, 0.20797D0, 0.16429D0,
58255 & 0.11453D0, 0.08573D0, 0.06628D0, 0.04909D0, 0.03675D0,
58256 & 0.02752D0, 0.02059D0, 0.01535D0, 0.01135D0, 0.00831D0,
58257 & 0.00606D0, 0.00437D0, 0.00311D0, 0.00220D0, 0.00153D0,
58258 & 0.00103D0, 0.00072D0, 0.00049D0, 0.00030D0, 0.00019D0,
58259 & 0.00013D0, 0.00007D0, 0.00005D0, 0.00001D0, 0.00000D0,
58260 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58261 DATA (FMRS(2,6,I,38),I=1,49)/
58262 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58263 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58264 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58265 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58266 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58267 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58268 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58269 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58270 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58271 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58272 DATA (FMRS(2,7,I, 1),I=1,49)/
58273 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58274 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58275 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58276 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58277 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58278 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58279 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58280 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58281 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58282 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58283 DATA (FMRS(2,7,I, 2),I=1,49)/
58284 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58285 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58286 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58287 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58288 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58289 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58290 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58291 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58292 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58293 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58294 DATA (FMRS(2,7,I, 3),I=1,49)/
58295 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58296 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58297 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58298 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58299 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58300 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58301 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58302 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58303 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58304 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58305 DATA (FMRS(2,7,I, 4),I=1,49)/
58306 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58307 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58308 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58309 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58310 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58311 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58312 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58313 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58314 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58315 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58316 DATA (FMRS(2,7,I, 5),I=1,49)/
58317 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58318 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58319 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58320 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58321 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58322 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58323 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58324 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58325 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58326 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58327 DATA (FMRS(2,7,I, 6),I=1,49)/
58328 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58329 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58330 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58331 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58332 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58333 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58334 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58335 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58336 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58337 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58338 DATA (FMRS(2,7,I, 7),I=1,49)/
58339 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58340 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58341 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58342 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58343 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58344 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58345 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58346 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58347 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58348 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58349 DATA (FMRS(2,7,I, 8),I=1,49)/
58350 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58351 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58352 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58353 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58354 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58355 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58356 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58357 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58358 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58359 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58360 DATA (FMRS(2,7,I, 9),I=1,49)/
58361 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58362 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58363 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58364 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58365 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58366 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58367 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58368 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58369 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58370 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58371 DATA (FMRS(2,7,I,10),I=1,49)/
58372 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58373 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58374 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58375 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58376 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58377 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58378 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58379 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58380 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58381 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58382 DATA (FMRS(2,7,I,11),I=1,49)/
58383 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58384 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58385 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58386 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58387 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58388 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58389 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58390 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58391 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58392 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58393 DATA (FMRS(2,7,I,12),I=1,49)/
58394 & 0.00041D0, 0.00036D0, 0.00032D0, 0.00030D0, 0.00028D0,
58395 & 0.00027D0, 0.00023D0, 0.00021D0, 0.00019D0, 0.00018D0,
58396 & 0.00017D0, 0.00014D0, 0.00012D0, 0.00011D0, 0.00010D0,
58397 & 0.00009D0, 0.00008D0, 0.00007D0, 0.00006D0, 0.00005D0,
58398 & 0.00004D0, 0.00004D0, 0.00003D0, 0.00003D0, 0.00003D0,
58399 & 0.00003D0, 0.00002D0, 0.00002D0, 0.00002D0, 0.00002D0,
58400 & 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0, 0.00001D0,
58401 & 0.00001D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
58402 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58403 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58404 DATA (FMRS(2,7,I,13),I=1,49)/
58405 & 0.21131D0, 0.16558D0, 0.12967D0, 0.11232D0, 0.10141D0,
58406 & 0.09365D0, 0.07296D0, 0.05647D0, 0.04835D0, 0.04314D0,
58407 & 0.03929D0, 0.02893D0, 0.02049D0, 0.01636D0, 0.01376D0,
58408 & 0.01193D0, 0.00947D0, 0.00725D0, 0.00522D0, 0.00409D0,
58409 & 0.00289D0, 0.00226D0, 0.00187D0, 0.00153D0, 0.00127D0,
58410 & 0.00106D0, 0.00087D0, 0.00071D0, 0.00058D0, 0.00046D0,
58411 & 0.00037D0, 0.00028D0, 0.00022D0, 0.00016D0, 0.00012D0,
58412 & 0.00009D0, 0.00007D0, 0.00005D0, 0.00003D0, 0.00002D0,
58413 & 0.00001D0, 0.00001D0, 0.00000D0, 0.00000D0, 0.00000D0,
58414 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58415 DATA (FMRS(2,7,I,14),I=1,49)/
58416 & 0.61374D0, 0.47881D0, 0.37330D0, 0.32254D0, 0.29066D0,
58417 & 0.26804D0, 0.20788D0, 0.16016D0, 0.13675D0, 0.12177D0,
58418 & 0.11072D0, 0.08109D0, 0.05711D0, 0.04545D0, 0.03813D0,
58419 & 0.03299D0, 0.02611D0, 0.01996D0, 0.01434D0, 0.01121D0,
58420 & 0.00789D0, 0.00617D0, 0.00509D0, 0.00414D0, 0.00341D0,
58421 & 0.00282D0, 0.00231D0, 0.00188D0, 0.00151D0, 0.00120D0,
58422 & 0.00094D0, 0.00073D0, 0.00056D0, 0.00042D0, 0.00031D0,
58423 & 0.00023D0, 0.00016D0, 0.00012D0, 0.00008D0, 0.00005D0,
58424 & 0.00003D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58425 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58426 DATA (FMRS(2,7,I,15),I=1,49)/
58427 & 0.99259D0, 0.76862D0, 0.59480D0, 0.51168D0, 0.45967D0,
58428 & 0.42287D0, 0.32549D0, 0.24886D0, 0.21152D0, 0.18775D0,
58429 & 0.17025D0, 0.12366D0, 0.08636D0, 0.06840D0, 0.05719D0,
58430 & 0.04937D0, 0.03895D0, 0.02967D0, 0.02125D0, 0.01657D0,
58431 & 0.01162D0, 0.00903D0, 0.00740D0, 0.00597D0, 0.00488D0,
58432 & 0.00399D0, 0.00325D0, 0.00263D0, 0.00210D0, 0.00166D0,
58433 & 0.00130D0, 0.00100D0, 0.00076D0, 0.00057D0, 0.00042D0,
58434 & 0.00031D0, 0.00022D0, 0.00015D0, 0.00011D0, 0.00007D0,
58435 & 0.00004D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58436 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58437 DATA (FMRS(2,7,I,16),I=1,49)/
58438 & 1.40334D0, 1.07950D0, 0.82983D0, 0.71109D0, 0.63704D0,
58439 & 0.58478D0, 0.44710D0, 0.33953D0, 0.28741D0, 0.25436D0,
58440 & 0.23011D0, 0.16589D0, 0.11498D0, 0.09067D0, 0.07559D0,
58441 & 0.06510D0, 0.05120D0, 0.03889D0, 0.02777D0, 0.02161D0,
58442 & 0.01509D0, 0.01166D0, 0.00950D0, 0.00760D0, 0.00617D0,
58443 & 0.00501D0, 0.00405D0, 0.00325D0, 0.00258D0, 0.00203D0,
58444 & 0.00158D0, 0.00121D0, 0.00091D0, 0.00068D0, 0.00050D0,
58445 & 0.00037D0, 0.00026D0, 0.00018D0, 0.00012D0, 0.00008D0,
58446 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58447 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58448 DATA (FMRS(2,7,I,17),I=1,49)/
58449 & 1.88020D0, 1.43681D0, 1.09723D0, 0.93659D0, 0.83676D0,
58450 & 0.76647D0, 0.58212D0, 0.43908D0, 0.37019D0, 0.32667D0,
58451 & 0.29484D0, 0.21099D0, 0.14515D0, 0.11396D0, 0.09473D0,
58452 & 0.08141D0, 0.06382D0, 0.04833D0, 0.03440D0, 0.02672D0,
58453 & 0.01856D0, 0.01428D0, 0.01156D0, 0.00918D0, 0.00739D0,
58454 & 0.00596D0, 0.00478D0, 0.00381D0, 0.00301D0, 0.00236D0,
58455 & 0.00181D0, 0.00138D0, 0.00104D0, 0.00077D0, 0.00057D0,
58456 & 0.00041D0, 0.00030D0, 0.00020D0, 0.00014D0, 0.00009D0,
58457 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58458 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58459 DATA (FMRS(2,7,I,18),I=1,49)/
58460 & 2.30534D0, 1.75221D0, 1.33088D0, 1.13244D0, 1.00946D0,
58461 & 0.92305D0, 0.69723D0, 0.52301D0, 0.43952D0, 0.38693D0,
58462 & 0.34856D0, 0.24795D0, 0.16954D0, 0.13265D0, 0.11000D0,
58463 & 0.09436D0, 0.07379D0, 0.05574D0, 0.03958D0, 0.03067D0,
58464 & 0.02123D0, 0.01626D0, 0.01309D0, 0.01033D0, 0.00826D0,
58465 & 0.00663D0, 0.00529D0, 0.00419D0, 0.00329D0, 0.00257D0,
58466 & 0.00197D0, 0.00150D0, 0.00112D0, 0.00083D0, 0.00061D0,
58467 & 0.00044D0, 0.00032D0, 0.00022D0, 0.00015D0, 0.00009D0,
58468 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58469 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58470 DATA (FMRS(2,7,I,19),I=1,49)/
58471 & 2.86856D0, 2.16633D0, 1.63487D0, 1.38587D0, 1.23207D0,
58472 & 1.12426D0, 0.84372D0, 0.62876D0, 0.52633D0, 0.46206D0,
58473 & 0.41530D0, 0.29334D0, 0.19914D0, 0.15517D0, 0.12832D0,
58474 & 0.10984D0, 0.08563D0, 0.06450D0, 0.04565D0, 0.03529D0,
58475 & 0.02431D0, 0.01851D0, 0.01482D0, 0.01161D0, 0.00922D0,
58476 & 0.00734D0, 0.00582D0, 0.00458D0, 0.00358D0, 0.00278D0,
58477 & 0.00212D0, 0.00160D0, 0.00119D0, 0.00088D0, 0.00064D0,
58478 & 0.00047D0, 0.00033D0, 0.00023D0, 0.00015D0, 0.00009D0,
58479 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58480 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58481 DATA (FMRS(2,7,I,20),I=1,49)/
58482 & 3.42748D0, 2.57399D0, 1.93167D0, 1.63211D0, 1.44759D0,
58483 & 1.31854D0, 0.98395D0, 0.72909D0, 0.60825D0, 0.53267D0,
58484 & 0.47783D0, 0.33544D0, 0.22632D0, 0.17572D0, 0.14495D0,
58485 & 0.12384D0, 0.09630D0, 0.07234D0, 0.05105D0, 0.03938D0,
58486 & 0.02701D0, 0.02047D0, 0.01631D0, 0.01268D0, 0.01001D0,
58487 & 0.00793D0, 0.00625D0, 0.00489D0, 0.00380D0, 0.00294D0,
58488 & 0.00223D0, 0.00168D0, 0.00125D0, 0.00091D0, 0.00066D0,
58489 & 0.00048D0, 0.00035D0, 0.00024D0, 0.00016D0, 0.00009D0,
58490 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58491 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58492 DATA (FMRS(2,7,I,21),I=1,49)/
58493 & 3.95907D0, 2.95830D0, 2.20894D0, 1.86088D0, 1.64705D0,
58494 & 1.49778D0, 1.11204D0, 0.81980D0, 0.68185D0, 0.59583D0,
58495 & 0.53354D0, 0.37251D0, 0.24993D0, 0.19343D0, 0.15921D0,
58496 & 0.13581D0, 0.10535D0, 0.07895D0, 0.05557D0, 0.04278D0,
58497 & 0.02922D0, 0.02205D0, 0.01748D0, 0.01352D0, 0.01061D0,
58498 & 0.00835D0, 0.00655D0, 0.00511D0, 0.00395D0, 0.00304D0,
58499 & 0.00230D0, 0.00172D0, 0.00128D0, 0.00093D0, 0.00067D0,
58500 & 0.00049D0, 0.00035D0, 0.00024D0, 0.00016D0, 0.00009D0,
58501 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58502 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58503 DATA (FMRS(2,7,I,22),I=1,49)/
58504 & 4.70301D0, 3.49223D0, 2.59131D0, 2.17500D0, 1.92006D0,
58505 & 1.74251D0, 1.28559D0, 0.94171D0, 0.78029D0, 0.68000D0,
58506 & 0.60759D0, 0.42132D0, 0.28074D0, 0.21641D0, 0.17764D0,
58507 & 0.15121D0, 0.11695D0, 0.08738D0, 0.06130D0, 0.04706D0,
58508 & 0.03198D0, 0.02400D0, 0.01891D0, 0.01452D0, 0.01131D0,
58509 & 0.00885D0, 0.00690D0, 0.00535D0, 0.00412D0, 0.00314D0,
58510 & 0.00237D0, 0.00177D0, 0.00130D0, 0.00095D0, 0.00068D0,
58511 & 0.00049D0, 0.00036D0, 0.00024D0, 0.00016D0, 0.00009D0,
58512 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58513 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58514 DATA (FMRS(2,7,I,23),I=1,49)/
58515 & 5.46775D0, 4.03669D0, 2.97803D0, 2.49113D0, 2.19384D0,
58516 & 1.98726D0, 1.45764D0, 1.06148D0, 0.87647D0, 0.76190D0,
58517 & 0.67941D0, 0.46817D0, 0.30998D0, 0.23809D0, 0.19493D0,
58518 & 0.16562D0, 0.12774D0, 0.09517D0, 0.06655D0, 0.05097D0,
58519 & 0.03446D0, 0.02573D0, 0.02017D0, 0.01538D0, 0.01190D0,
58520 & 0.00925D0, 0.00718D0, 0.00553D0, 0.00424D0, 0.00322D0,
58521 & 0.00242D0, 0.00179D0, 0.00132D0, 0.00095D0, 0.00069D0,
58522 & 0.00049D0, 0.00036D0, 0.00024D0, 0.00016D0, 0.00009D0,
58523 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58524 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58525 DATA (FMRS(2,7,I,24),I=1,49)/
58526 & 6.21519D0, 4.56429D0, 3.34948D0, 2.79317D0, 2.45443D0,
58527 & 2.21950D0, 1.61934D0, 1.17290D0, 0.96539D0, 0.83728D0,
58528 & 0.74526D0, 0.51062D0, 0.33614D0, 0.25732D0, 0.21020D0,
58529 & 0.17828D0, 0.13715D0, 0.10192D0, 0.07106D0, 0.05428D0,
58530 & 0.03653D0, 0.02714D0, 0.02117D0, 0.01604D0, 0.01234D0,
58531 & 0.00954D0, 0.00736D0, 0.00565D0, 0.00431D0, 0.00326D0,
58532 & 0.00243D0, 0.00180D0, 0.00132D0, 0.00095D0, 0.00068D0,
58533 & 0.00049D0, 0.00035D0, 0.00024D0, 0.00016D0, 0.00009D0,
58534 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58535 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58536 DATA (FMRS(2,7,I,25),I=1,49)/
58537 & 7.03262D0, 5.13776D0, 3.75072D0, 3.11823D0, 2.73413D0,
58538 & 2.46827D0, 1.79141D0, 1.29068D0, 1.05901D0, 0.91641D0,
58539 & 0.81423D0, 0.55475D0, 0.36312D0, 0.27706D0, 0.22581D0,
58540 & 0.19119D0, 0.14672D0, 0.10875D0, 0.07559D0, 0.05760D0,
58541 & 0.03859D0, 0.02852D0, 0.02214D0, 0.01668D0, 0.01276D0,
58542 & 0.00981D0, 0.00753D0, 0.00575D0, 0.00436D0, 0.00329D0,
58543 & 0.00245D0, 0.00180D0, 0.00132D0, 0.00095D0, 0.00068D0,
58544 & 0.00048D0, 0.00035D0, 0.00024D0, 0.00016D0, 0.00009D0,
58545 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58546 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58547 DATA (FMRS(2,7,I,26),I=1,49)/
58548 & 7.86804D0, 5.71947D0, 4.15459D0, 3.44391D0, 3.01342D0,
58549 & 2.71602D0, 1.96133D0, 1.40596D0, 1.15014D0, 0.99314D0,
58550 & 0.88088D0, 0.59694D0, 0.38863D0, 0.29560D0, 0.24039D0,
58551 & 0.20320D0, 0.15555D0, 0.11500D0, 0.07970D0, 0.06059D0,
58552 & 0.04040D0, 0.02973D0, 0.02296D0, 0.01720D0, 0.01308D0,
58553 & 0.01001D0, 0.00765D0, 0.00581D0, 0.00439D0, 0.00330D0,
58554 & 0.00245D0, 0.00180D0, 0.00131D0, 0.00094D0, 0.00067D0,
58555 & 0.00048D0, 0.00034D0, 0.00024D0, 0.00016D0, 0.00009D0,
58556 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58557 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58558 DATA (FMRS(2,7,I,27),I=1,49)/
58559 & 8.71308D0, 6.30440D0, 4.55822D0, 3.76823D0, 3.29083D0,
58560 & 2.96160D0, 2.12868D0, 1.51874D0, 1.23894D0, 1.06767D0,
58561 & 0.94548D0, 0.63752D0, 0.41296D0, 0.31319D0, 0.25418D0,
58562 & 0.21452D0, 0.16385D0, 0.12085D0, 0.08351D0, 0.06334D0,
58563 & 0.04205D0, 0.03081D0, 0.02369D0, 0.01765D0, 0.01336D0,
58564 & 0.01017D0, 0.00773D0, 0.00586D0, 0.00441D0, 0.00330D0,
58565 & 0.00244D0, 0.00178D0, 0.00129D0, 0.00092D0, 0.00066D0,
58566 & 0.00047D0, 0.00034D0, 0.00024D0, 0.00016D0, 0.00009D0,
58567 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58568 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58569 DATA (FMRS(2,7,I,28),I=1,49)/
58570 & 9.54571D0, 6.87720D0, 4.95101D0, 4.08263D0, 3.55902D0,
58571 & 3.19851D0, 2.28903D0, 1.62602D0, 1.32303D0, 1.13803D0,
58572 & 1.00630D0, 0.67540D0, 0.43546D0, 0.32936D0, 0.26680D0,
58573 & 0.22485D0, 0.17138D0, 0.12612D0, 0.08693D0, 0.06579D0,
58574 & 0.04350D0, 0.03173D0, 0.02430D0, 0.01801D0, 0.01357D0,
58575 & 0.01029D0, 0.00779D0, 0.00587D0, 0.00441D0, 0.00329D0,
58576 & 0.00242D0, 0.00177D0, 0.00128D0, 0.00091D0, 0.00065D0,
58577 & 0.00046D0, 0.00033D0, 0.00024D0, 0.00016D0, 0.00009D0,
58578 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58579 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58580 DATA (FMRS(2,7,I,29),I=1,49)/
58581 & 10.42768D0, 7.48069D0, 5.36257D0, 4.41099D0, 3.83846D0,
58582 & 3.44489D0, 2.45481D0, 1.73627D0, 1.40913D0, 1.20986D0,
58583 & 1.06825D0, 0.71372D0, 0.45804D0, 0.34552D0, 0.27937D0,
58584 & 0.23511D0, 0.17881D0, 0.13130D0, 0.09026D0, 0.06816D0,
58585 & 0.04488D0, 0.03260D0, 0.02487D0, 0.01834D0, 0.01375D0,
58586 & 0.01038D0, 0.00783D0, 0.00588D0, 0.00440D0, 0.00327D0,
58587 & 0.00240D0, 0.00175D0, 0.00126D0, 0.00090D0, 0.00063D0,
58588 & 0.00045D0, 0.00033D0, 0.00024D0, 0.00016D0, 0.00009D0,
58589 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58590 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58591 DATA (FMRS(2,7,I,30),I=1,49)/
58592 & 11.32906D0, 8.09395D0, 5.77834D0, 4.74153D0, 4.11903D0,
58593 & 3.69178D0, 2.61985D0, 1.84528D0, 1.49390D0, 1.28038D0,
58594 & 1.12893D0, 0.75094D0, 0.47979D0, 0.36099D0, 0.29135D0,
58595 & 0.24485D0, 0.18584D0, 0.13617D0, 0.09335D0, 0.07035D0,
58596 & 0.04613D0, 0.03338D0, 0.02536D0, 0.01861D0, 0.01389D0,
58597 & 0.01045D0, 0.00785D0, 0.00587D0, 0.00438D0, 0.00324D0,
58598 & 0.00237D0, 0.00172D0, 0.00124D0, 0.00088D0, 0.00062D0,
58599 & 0.00044D0, 0.00032D0, 0.00024D0, 0.00016D0, 0.00009D0,
58600 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58601 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58602 DATA (FMRS(2,7,I,31),I=1,49)/
58603 & 12.23197D0, 8.70533D0, 6.19083D0, 5.06852D0, 4.39601D0,
58604 & 3.93512D0, 2.78170D0, 1.95161D0, 1.57633D0, 1.34878D0,
58605 & 1.18767D0, 0.78675D0, 0.50057D0, 0.37571D0, 0.30272D0,
58606 & 0.25408D0, 0.19247D0, 0.14074D0, 0.09625D0, 0.07237D0,
58607 & 0.04728D0, 0.03408D0, 0.02579D0, 0.01885D0, 0.01401D0,
58608 & 0.01049D0, 0.00785D0, 0.00586D0, 0.00435D0, 0.00321D0,
58609 & 0.00235D0, 0.00170D0, 0.00122D0, 0.00086D0, 0.00061D0,
58610 & 0.00043D0, 0.00031D0, 0.00023D0, 0.00016D0, 0.00009D0,
58611 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58612 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58613 DATA (FMRS(2,7,I,32),I=1,49)/
58614 & 13.10605D0, 9.29397D0, 6.58574D0, 5.38050D0, 4.65963D0,
58615 & 4.16627D0, 2.93446D0, 2.05131D0, 1.65329D0, 1.41245D0,
58616 & 1.24220D0, 0.81972D0, 0.51953D0, 0.38906D0, 0.31298D0,
58617 & 0.26237D0, 0.19840D0, 0.14478D0, 0.09878D0, 0.07413D0,
58618 & 0.04825D0, 0.03465D0, 0.02614D0, 0.01902D0, 0.01408D0,
58619 & 0.01051D0, 0.00784D0, 0.00583D0, 0.00432D0, 0.00318D0,
58620 & 0.00232D0, 0.00167D0, 0.00120D0, 0.00085D0, 0.00060D0,
58621 & 0.00042D0, 0.00031D0, 0.00023D0, 0.00016D0, 0.00009D0,
58622 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58623 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58624 DATA (FMRS(2,7,I,33),I=1,49)/
58625 & 14.04396D0, 9.92333D0, 7.00645D0, 5.71217D0, 4.93947D0,
58626 & 4.41134D0, 3.09586D0, 2.15625D0, 1.73413D0, 1.47923D0,
58627 & 1.29933D0, 0.85413D0, 0.53923D0, 0.40291D0, 0.32360D0,
58628 & 0.27095D0, 0.20451D0, 0.14895D0, 0.10139D0, 0.07594D0,
58629 & 0.04925D0, 0.03524D0, 0.02649D0, 0.01920D0, 0.01416D0,
58630 & 0.01053D0, 0.00783D0, 0.00580D0, 0.00428D0, 0.00315D0,
58631 & 0.00229D0, 0.00165D0, 0.00118D0, 0.00083D0, 0.00058D0,
58632 & 0.00041D0, 0.00030D0, 0.00022D0, 0.00016D0, 0.00009D0,
58633 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58634 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58635 DATA (FMRS(2,7,I,34),I=1,49)/
58636 & 14.97171D0, 10.54223D0, 7.41762D0, 6.03510D0, 5.21118D0,
58637 & 4.64879D0, 3.25111D0, 2.25643D0, 1.81093D0, 1.54244D0,
58638 & 1.35325D0, 0.88628D0, 0.55744D0, 0.41560D0, 0.33329D0,
58639 & 0.27873D0, 0.21001D0, 0.15267D0, 0.10367D0, 0.07749D0,
58640 & 0.05007D0, 0.03571D0, 0.02675D0, 0.01931D0, 0.01419D0,
58641 & 0.01051D0, 0.00779D0, 0.00576D0, 0.00424D0, 0.00311D0,
58642 & 0.00225D0, 0.00162D0, 0.00115D0, 0.00081D0, 0.00057D0,
58643 & 0.00041D0, 0.00030D0, 0.00022D0, 0.00016D0, 0.00009D0,
58644 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58645 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58646 DATA (FMRS(2,7,I,35),I=1,49)/
58647 & 15.90678D0, 11.16388D0, 7.82922D0, 6.35772D0, 5.48225D0,
58648 & 4.88541D0, 3.40531D0, 2.35558D0, 1.88678D0, 1.60477D0,
58649 & 1.40636D0, 0.91783D0, 0.57524D0, 0.42799D0, 0.34272D0,
58650 & 0.28629D0, 0.21535D0, 0.15626D0, 0.10587D0, 0.07899D0,
58651 & 0.05087D0, 0.03616D0, 0.02700D0, 0.01941D0, 0.01421D0,
58652 & 0.01050D0, 0.00776D0, 0.00572D0, 0.00420D0, 0.00307D0,
58653 & 0.00222D0, 0.00159D0, 0.00113D0, 0.00080D0, 0.00056D0,
58654 & 0.00040D0, 0.00029D0, 0.00022D0, 0.00016D0, 0.00009D0,
58655 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58656 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58657 DATA (FMRS(2,7,I,36),I=1,49)/
58658 & 16.81722D0, 11.76659D0, 8.22652D0, 6.66831D0, 5.74271D0,
58659 & 5.11243D0, 3.55252D0, 2.44976D0, 1.95860D0, 1.66366D0,
58660 & 1.45643D0, 0.94739D0, 0.59179D0, 0.43945D0, 0.35142D0,
58661 & 0.29325D0, 0.22023D0, 0.15953D0, 0.10786D0, 0.08033D0,
58662 & 0.05156D0, 0.03654D0, 0.02720D0, 0.01949D0, 0.01422D0,
58663 & 0.01047D0, 0.00772D0, 0.00567D0, 0.00416D0, 0.00303D0,
58664 & 0.00219D0, 0.00157D0, 0.00111D0, 0.00078D0, 0.00055D0,
58665 & 0.00039D0, 0.00029D0, 0.00022D0, 0.00016D0, 0.00009D0,
58666 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58667 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58668 DATA (FMRS(2,7,I,37),I=1,49)/
58669 & 17.75747D0, 12.38637D0, 8.63327D0, 6.98544D0, 6.00814D0,
58670 & 5.34342D0, 3.70158D0, 2.54461D0, 2.03070D0, 1.72263D0,
58671 & 1.50647D0, 0.97674D0, 0.60811D0, 0.45069D0, 0.35992D0,
58672 & 0.30003D0, 0.22496D0, 0.16268D0, 0.10975D0, 0.08160D0,
58673 & 0.05220D0, 0.03687D0, 0.02737D0, 0.01954D0, 0.01421D0,
58674 & 0.01044D0, 0.00767D0, 0.00562D0, 0.00411D0, 0.00299D0,
58675 & 0.00215D0, 0.00154D0, 0.00109D0, 0.00077D0, 0.00053D0,
58676 & 0.00038D0, 0.00028D0, 0.00021D0, 0.00016D0, 0.00009D0,
58677 & 0.00005D0, 0.00002D0, 0.00000D0, 0.00000D0, 0.00000D0,
58678 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58679 DATA (FMRS(2,7,I,38),I=1,49)/
58680 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58681 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58682 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58683 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58684 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58685 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58686 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58687 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58688 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
58689 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58690 DATA (FMRS(2,8,I, 1),I=1,49)/
58691 & 0.98494D0, 0.83942D0, 0.71517D0, 0.65113D0, 0.60921D0,
58692 & 0.57857D0, 0.49313D0, 0.42114D0, 0.38478D0, 0.36147D0,
58693 & 0.34532D0, 0.30109D0, 0.26601D0, 0.24883D0, 0.23797D0,
58694 & 0.23013D0, 0.21908D0, 0.20797D0, 0.19531D0, 0.18554D0,
58695 & 0.16898D0, 0.15367D0, 0.13862D0, 0.11992D0, 0.10161D0,
58696 & 0.08421D0, 0.06813D0, 0.05380D0, 0.04148D0, 0.03102D0,
58697 & 0.02276D0, 0.01618D0, 0.01125D0, 0.00763D0, 0.00500D0,
58698 & 0.00317D0, 0.00203D0, 0.00121D0, 0.00069D0, 0.00043D0,
58699 & 0.00027D0, 0.00012D0, 0.00011D0, 0.00003D0, 0.00000D0,
58700 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58701 DATA (FMRS(2,8,I, 2),I=1,49)/
58702 & 0.98889D0, 0.84649D0, 0.72438D0, 0.66122D0, 0.61978D0,
58703 & 0.58944D0, 0.50458D0, 0.43271D0, 0.39626D0, 0.37282D0,
58704 & 0.35655D0, 0.31168D0, 0.27538D0, 0.25719D0, 0.24547D0,
58705 & 0.23690D0, 0.22464D0, 0.21217D0, 0.19794D0, 0.18712D0,
58706 & 0.16930D0, 0.15330D0, 0.13787D0, 0.11894D0, 0.10059D0,
58707 & 0.08325D0, 0.06732D0, 0.05317D0, 0.04104D0, 0.03076D0,
58708 & 0.02264D0, 0.01619D0, 0.01134D0, 0.00776D0, 0.00516D0,
58709 & 0.00334D0, 0.00218D0, 0.00135D0, 0.00080D0, 0.00052D0,
58710 & 0.00034D0, 0.00018D0, 0.00014D0, 0.00004D0, 0.00001D0,
58711 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58712 DATA (FMRS(2,8,I, 3),I=1,49)/
58713 & 1.01222D0, 0.87111D0, 0.74946D0, 0.68626D0, 0.64467D0,
58714 & 0.61416D0, 0.52846D0, 0.45538D0, 0.41806D0, 0.39393D0,
58715 & 0.37708D0, 0.33010D0, 0.29099D0, 0.27082D0, 0.25752D0,
58716 & 0.24766D0, 0.23338D0, 0.21871D0, 0.20204D0, 0.18963D0,
58717 & 0.16990D0, 0.15288D0, 0.13686D0, 0.11759D0, 0.09914D0,
58718 & 0.08186D0, 0.06611D0, 0.05221D0, 0.04030D0, 0.03030D0,
58719 & 0.02237D0, 0.01612D0, 0.01138D0, 0.00788D0, 0.00532D0,
58720 & 0.00353D0, 0.00233D0, 0.00151D0, 0.00092D0, 0.00061D0,
58721 & 0.00042D0, 0.00024D0, 0.00016D0, 0.00005D0, 0.00002D0,
58722 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58723 DATA (FMRS(2,8,I, 4),I=1,49)/
58724 & 1.04476D0, 0.90153D0, 0.77771D0, 0.71324D0, 0.67074D0,
58725 & 0.63953D0, 0.55166D0, 0.47640D0, 0.43777D0, 0.41269D0,
58726 & 0.39507D0, 0.34558D0, 0.30362D0, 0.28161D0, 0.26695D0,
58727 & 0.25601D0, 0.24007D0, 0.22367D0, 0.20514D0, 0.19155D0,
58728 & 0.17043D0, 0.15264D0, 0.13620D0, 0.11664D0, 0.09810D0,
58729 & 0.08084D0, 0.06518D0, 0.05144D0, 0.03971D0, 0.02989D0,
58730 & 0.02211D0, 0.01600D0, 0.01135D0, 0.00790D0, 0.00539D0,
58731 & 0.00362D0, 0.00238D0, 0.00157D0, 0.00098D0, 0.00066D0,
58732 & 0.00045D0, 0.00026D0, 0.00018D0, 0.00006D0, 0.00003D0,
58733 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58734 DATA (FMRS(2,8,I, 5),I=1,49)/
58735 & 1.10026D0, 0.95040D0, 0.82069D0, 0.75308D0, 0.70848D0,
58736 & 0.67571D0, 0.58330D0, 0.50390D0, 0.46299D0, 0.43632D0,
58737 & 0.41743D0, 0.36409D0, 0.31818D0, 0.29384D0, 0.27750D0,
58738 & 0.26527D0, 0.24742D0, 0.22908D0, 0.20853D0, 0.19368D0,
58739 & 0.17108D0, 0.15248D0, 0.13556D0, 0.11567D0, 0.09702D0,
58740 & 0.07977D0, 0.06421D0, 0.05061D0, 0.03905D0, 0.02941D0,
58741 & 0.02179D0, 0.01578D0, 0.01121D0, 0.00787D0, 0.00539D0,
58742 & 0.00363D0, 0.00243D0, 0.00163D0, 0.00101D0, 0.00068D0,
58743 & 0.00046D0, 0.00028D0, 0.00020D0, 0.00007D0, 0.00002D0,
58744 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58745 DATA (FMRS(2,8,I, 6),I=1,49)/
58746 & 1.15923D0, 1.00143D0, 0.86481D0, 0.79358D0, 0.74658D0,
58747 & 0.71202D0, 0.61454D0, 0.53061D0, 0.48723D0, 0.45888D0,
58748 & 0.43867D0, 0.38135D0, 0.33152D0, 0.30491D0, 0.28699D0,
58749 & 0.27355D0, 0.25394D0, 0.23384D0, 0.21150D0, 0.19554D0,
58750 & 0.17166D0, 0.15236D0, 0.13502D0, 0.11484D0, 0.09608D0,
58751 & 0.07883D0, 0.06335D0, 0.04988D0, 0.03847D0, 0.02897D0,
58752 & 0.02148D0, 0.01557D0, 0.01108D0, 0.00781D0, 0.00536D0,
58753 & 0.00363D0, 0.00245D0, 0.00167D0, 0.00103D0, 0.00070D0,
58754 & 0.00046D0, 0.00029D0, 0.00021D0, 0.00007D0, 0.00002D0,
58755 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58756 DATA (FMRS(2,8,I, 7),I=1,49)/
58757 & 1.23248D0, 1.06345D0, 0.91726D0, 0.84109D0, 0.79085D0,
58758 & 0.75393D0, 0.64976D0, 0.56002D0, 0.51357D0, 0.48314D0,
58759 & 0.46132D0, 0.39931D0, 0.34507D0, 0.31602D0, 0.29642D0,
58760 & 0.28173D0, 0.26034D0, 0.23848D0, 0.21438D0, 0.19736D0,
58761 & 0.17224D0, 0.15227D0, 0.13452D0, 0.11404D0, 0.09516D0,
58762 & 0.07789D0, 0.06251D0, 0.04914D0, 0.03786D0, 0.02851D0,
58763 & 0.02113D0, 0.01532D0, 0.01096D0, 0.00772D0, 0.00530D0,
58764 & 0.00360D0, 0.00243D0, 0.00166D0, 0.00104D0, 0.00071D0,
58765 & 0.00048D0, 0.00030D0, 0.00020D0, 0.00008D0, 0.00002D0,
58766 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58767 DATA (FMRS(2,8,I, 8),I=1,49)/
58768 & 1.32548D0, 1.14118D0, 0.98212D0, 0.89937D0, 0.84484D0,
58769 & 0.80478D0, 0.69187D0, 0.59465D0, 0.54428D0, 0.51124D0,
58770 & 0.48741D0, 0.41964D0, 0.36014D0, 0.32825D0, 0.30675D0,
58771 & 0.29065D0, 0.26725D0, 0.24348D0, 0.21747D0, 0.19931D0,
58772 & 0.17288D0, 0.15217D0, 0.13398D0, 0.11319D0, 0.09418D0,
58773 & 0.07689D0, 0.06158D0, 0.04833D0, 0.03719D0, 0.02798D0,
58774 & 0.02073D0, 0.01504D0, 0.01077D0, 0.00760D0, 0.00523D0,
58775 & 0.00355D0, 0.00240D0, 0.00165D0, 0.00105D0, 0.00070D0,
58776 & 0.00048D0, 0.00029D0, 0.00020D0, 0.00007D0, 0.00002D0,
58777 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58778 DATA (FMRS(2,8,I, 9),I=1,49)/
58779 & 1.41996D0, 1.21934D0, 1.04662D0, 0.95694D0, 0.89790D0,
58780 & 0.85457D0, 0.73259D0, 0.62769D0, 0.57336D0, 0.53768D0,
58781 & 0.51185D0, 0.43840D0, 0.37384D0, 0.33927D0, 0.31599D0,
58782 & 0.29859D0, 0.27338D0, 0.24788D0, 0.22018D0, 0.20102D0,
58783 & 0.17344D0, 0.15210D0, 0.13351D0, 0.11246D0, 0.09333D0,
58784 & 0.07602D0, 0.06075D0, 0.04762D0, 0.03659D0, 0.02749D0,
58785 & 0.02036D0, 0.01479D0, 0.01057D0, 0.00748D0, 0.00516D0,
58786 & 0.00349D0, 0.00238D0, 0.00163D0, 0.00104D0, 0.00069D0,
58787 & 0.00047D0, 0.00028D0, 0.00019D0, 0.00006D0, 0.00002D0,
58788 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58789 DATA (FMRS(2,8,I,10),I=1,49)/
58790 & 1.52623D0, 1.30628D0, 1.11753D0, 1.01977D0, 0.95552D0,
58791 & 0.90841D0, 0.77603D0, 0.66243D0, 0.60365D0, 0.56506D0,
58792 & 0.53703D0, 0.45743D0, 0.38751D0, 0.35017D0, 0.32507D0,
58793 & 0.30636D0, 0.27933D0, 0.25214D0, 0.22280D0, 0.20266D0,
58794 & 0.17397D0, 0.15202D0, 0.13306D0, 0.11174D0, 0.09248D0,
58795 & 0.07516D0, 0.05994D0, 0.04691D0, 0.03600D0, 0.02702D0,
58796 & 0.02000D0, 0.01454D0, 0.01039D0, 0.00736D0, 0.00507D0,
58797 & 0.00344D0, 0.00235D0, 0.00162D0, 0.00103D0, 0.00069D0,
58798 & 0.00047D0, 0.00027D0, 0.00019D0, 0.00006D0, 0.00002D0,
58799 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58800 DATA (FMRS(2,8,I,11),I=1,49)/
58801 & 1.61996D0, 1.38242D0, 1.17917D0, 1.07414D0, 1.00521D0,
58802 & 0.95472D0, 0.81307D0, 0.69180D0, 0.62911D0, 0.58797D0,
58803 & 0.55803D0, 0.47313D0, 0.39867D0, 0.35901D0, 0.33241D0,
58804 & 0.31262D0, 0.28411D0, 0.25553D0, 0.22487D0, 0.20396D0,
58805 & 0.17439D0, 0.15196D0, 0.13270D0, 0.11116D0, 0.09180D0,
58806 & 0.07446D0, 0.05929D0, 0.04635D0, 0.03552D0, 0.02665D0,
58807 & 0.01972D0, 0.01433D0, 0.01024D0, 0.00726D0, 0.00500D0,
58808 & 0.00340D0, 0.00233D0, 0.00161D0, 0.00102D0, 0.00069D0,
58809 & 0.00047D0, 0.00027D0, 0.00019D0, 0.00006D0, 0.00002D0,
58810 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58811 DATA (FMRS(2,8,I,12),I=1,49)/
58812 & 1.85147D0, 1.56851D0, 1.32816D0, 1.20469D0, 1.12394D0,
58813 & 1.06494D0, 0.90014D0, 0.75989D0, 0.68768D0, 0.64036D0,
58814 & 0.60582D0, 0.50832D0, 0.42330D0, 0.37835D0, 0.34837D0,
58815 & 0.32616D0, 0.29437D0, 0.26278D0, 0.22928D0, 0.20671D0,
58816 & 0.17525D0, 0.15178D0, 0.13188D0, 0.10989D0, 0.09032D0,
58817 & 0.07294D0, 0.05789D0, 0.04511D0, 0.03448D0, 0.02582D0,
58818 & 0.01907D0, 0.01385D0, 0.00987D0, 0.00700D0, 0.00482D0,
58819 & 0.00328D0, 0.00224D0, 0.00154D0, 0.00100D0, 0.00066D0,
58820 & 0.00045D0, 0.00027D0, 0.00019D0, 0.00006D0, 0.00002D0,
58821 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58822 DATA (FMRS(2,8,I,13),I=1,49)/
58823 & 2.08649D0, 1.75519D0, 1.47580D0, 1.33308D0, 1.24007D0,
58824 & 1.17230D0, 0.98378D0, 0.82434D0, 0.74261D0, 0.68917D0,
58825 & 0.65012D0, 0.54038D0, 0.44535D0, 0.39548D0, 0.36240D0,
58826 & 0.33801D0, 0.30327D0, 0.26901D0, 0.23303D0, 0.20903D0,
58827 & 0.17595D0, 0.15158D0, 0.13113D0, 0.10875D0, 0.08901D0,
58828 & 0.07161D0, 0.05666D0, 0.04403D0, 0.03356D0, 0.02508D0,
58829 & 0.01848D0, 0.01341D0, 0.00954D0, 0.00676D0, 0.00467D0,
58830 & 0.00317D0, 0.00216D0, 0.00148D0, 0.00096D0, 0.00064D0,
58831 & 0.00043D0, 0.00027D0, 0.00018D0, 0.00006D0, 0.00002D0,
58832 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58833 DATA (FMRS(2,8,I,14),I=1,49)/
58834 & 2.39126D0, 1.99450D0, 1.66281D0, 1.49454D0, 1.38536D0,
58835 & 1.30604D0, 1.08660D0, 0.90248D0, 0.80863D0, 0.74747D0,
58836 & 0.70276D0, 0.57787D0, 0.47070D0, 0.41497D0, 0.37825D0,
58837 & 0.35132D0, 0.31319D0, 0.27591D0, 0.23714D0, 0.21153D0,
58838 & 0.17666D0, 0.15129D0, 0.13023D0, 0.10742D0, 0.08751D0,
58839 & 0.07010D0, 0.05525D0, 0.04280D0, 0.03250D0, 0.02426D0,
58840 & 0.01784D0, 0.01291D0, 0.00918D0, 0.00650D0, 0.00451D0,
58841 & 0.00308D0, 0.00210D0, 0.00146D0, 0.00091D0, 0.00061D0,
58842 & 0.00040D0, 0.00024D0, 0.00017D0, 0.00007D0, 0.00002D0,
58843 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58844 DATA (FMRS(2,8,I,15),I=1,49)/
58845 & 2.76033D0, 2.28068D0, 1.88356D0, 1.68366D0, 1.55456D0,
58846 & 1.46111D0, 1.20412D0, 0.99043D0, 0.88227D0, 0.81205D0,
58847 & 0.76076D0, 0.61847D0, 0.49766D0, 0.43549D0, 0.39480D0,
58848 & 0.36513D0, 0.32340D0, 0.28293D0, 0.24126D0, 0.21400D0,
58849 & 0.17728D0, 0.15089D0, 0.12922D0, 0.10598D0, 0.08590D0,
58850 & 0.06852D0, 0.05375D0, 0.04146D0, 0.03141D0, 0.02338D0,
58851 & 0.01716D0, 0.01238D0, 0.00882D0, 0.00618D0, 0.00431D0,
58852 & 0.00292D0, 0.00200D0, 0.00136D0, 0.00088D0, 0.00058D0,
58853 & 0.00038D0, 0.00023D0, 0.00015D0, 0.00006D0, 0.00002D0,
58854 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58855 DATA (FMRS(2,8,I,16),I=1,49)/
58856 & 3.14075D0, 2.57242D0, 2.10607D0, 1.87299D0, 1.72314D0,
58857 & 1.61501D0, 1.31935D0, 1.07560D0, 0.95301D0, 0.87374D0,
58858 & 0.81592D0, 0.65651D0, 0.52253D0, 0.45423D0, 0.40982D0,
58859 & 0.37760D0, 0.33254D0, 0.28915D0, 0.24485D0, 0.21612D0,
58860 & 0.17773D0, 0.15044D0, 0.12821D0, 0.10460D0, 0.08439D0,
58861 & 0.06702D0, 0.05238D0, 0.04027D0, 0.03041D0, 0.02258D0,
58862 & 0.01653D0, 0.01190D0, 0.00847D0, 0.00593D0, 0.00412D0,
58863 & 0.00279D0, 0.00191D0, 0.00129D0, 0.00084D0, 0.00056D0,
58864 & 0.00036D0, 0.00023D0, 0.00014D0, 0.00006D0, 0.00002D0,
58865 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58866 DATA (FMRS(2,8,I,17),I=1,49)/
58867 & 3.57238D0, 2.90007D0, 2.35339D0, 2.08215D0, 1.90855D0,
58868 & 1.78371D0, 1.44428D0, 1.16687D0, 1.02831D0, 0.93907D0,
58869 & 0.87409D0, 0.69611D0, 0.54805D0, 0.47331D0, 0.42502D0,
58870 & 0.39015D0, 0.34166D0, 0.29530D0, 0.24836D0, 0.21814D0,
58871 & 0.17810D0, 0.14991D0, 0.12715D0, 0.10317D0, 0.08284D0,
58872 & 0.06549D0, 0.05101D0, 0.03909D0, 0.02941D0, 0.02178D0,
58873 & 0.01590D0, 0.01142D0, 0.00811D0, 0.00570D0, 0.00393D0,
58874 & 0.00267D0, 0.00181D0, 0.00123D0, 0.00079D0, 0.00053D0,
58875 & 0.00034D0, 0.00022D0, 0.00013D0, 0.00006D0, 0.00001D0,
58876 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58877 DATA (FMRS(2,8,I,18),I=1,49)/
58878 & 3.96850D0, 3.19797D0, 2.57613D0, 2.26945D0, 2.07391D0,
58879 & 1.93368D0, 1.55423D0, 1.24636D0, 1.09346D0, 0.99533D0,
58880 & 0.92399D0, 0.72966D0, 0.56941D0, 0.48914D0, 0.43755D0,
58881 & 0.40046D0, 0.34910D0, 0.30027D0, 0.25115D0, 0.21971D0,
58882 & 0.17833D0, 0.14941D0, 0.12622D0, 0.10197D0, 0.08154D0,
58883 & 0.06423D0, 0.04986D0, 0.03809D0, 0.02858D0, 0.02112D0,
58884 & 0.01538D0, 0.01101D0, 0.00783D0, 0.00549D0, 0.00377D0,
58885 & 0.00256D0, 0.00173D0, 0.00118D0, 0.00076D0, 0.00050D0,
58886 & 0.00033D0, 0.00020D0, 0.00012D0, 0.00005D0, 0.00002D0,
58887 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58888 DATA (FMRS(2,8,I,19),I=1,49)/
58889 & 4.49525D0, 3.59055D0, 2.86699D0, 2.51271D0, 2.28784D0,
58890 & 2.12710D0, 1.69466D0, 1.34689D0, 1.17536D0, 1.06574D0,
58891 & 0.98622D0, 0.77102D0, 0.59540D0, 0.50826D0, 0.45260D0,
58892 & 0.41278D0, 0.35791D0, 0.30610D0, 0.25436D0, 0.22147D0,
58893 & 0.17849D0, 0.14870D0, 0.12502D0, 0.10045D0, 0.07994D0,
58894 & 0.06271D0, 0.04847D0, 0.03689D0, 0.02761D0, 0.02033D0,
58895 & 0.01477D0, 0.01056D0, 0.00749D0, 0.00523D0, 0.00359D0,
58896 & 0.00243D0, 0.00165D0, 0.00112D0, 0.00070D0, 0.00047D0,
58897 & 0.00031D0, 0.00018D0, 0.00012D0, 0.00004D0, 0.00002D0,
58898 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58899 DATA (FMRS(2,8,I,20),I=1,49)/
58900 & 5.00899D0, 3.97007D0, 3.14567D0, 2.74457D0, 2.49097D0,
58901 & 2.31023D0, 1.82640D0, 1.44029D0, 1.25101D0, 1.13051D0,
58902 & 1.04327D0, 0.80852D0, 0.61869D0, 0.52527D0, 0.46592D0,
58903 & 0.42363D0, 0.36563D0, 0.31116D0, 0.25711D0, 0.22294D0,
58904 & 0.17857D0, 0.14803D0, 0.12392D0, 0.09909D0, 0.07852D0,
58905 & 0.06137D0, 0.04727D0, 0.03584D0, 0.02676D0, 0.01965D0,
58906 & 0.01424D0, 0.01018D0, 0.00720D0, 0.00501D0, 0.00343D0,
58907 & 0.00232D0, 0.00157D0, 0.00107D0, 0.00066D0, 0.00045D0,
58908 & 0.00029D0, 0.00018D0, 0.00012D0, 0.00004D0, 0.00001D0,
58909 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58910 DATA (FMRS(2,8,I,21),I=1,49)/
58911 & 5.51448D0, 4.34048D0, 3.41543D0, 2.96790D0, 2.68596D0,
58912 & 2.48552D0, 1.95141D0, 1.52811D0, 1.32176D0, 1.19083D0,
58913 & 1.09623D0, 0.84295D0, 0.63982D0, 0.54059D0, 0.47785D0,
58914 & 0.43329D0, 0.37244D0, 0.31558D0, 0.25945D0, 0.22413D0,
58915 & 0.17852D0, 0.14733D0, 0.12285D0, 0.09781D0, 0.07721D0,
58916 & 0.06012D0, 0.04616D0, 0.03490D0, 0.02597D0, 0.01904D0,
58917 & 0.01376D0, 0.00981D0, 0.00692D0, 0.00481D0, 0.00330D0,
58918 & 0.00222D0, 0.00150D0, 0.00102D0, 0.00064D0, 0.00042D0,
58919 & 0.00028D0, 0.00017D0, 0.00011D0, 0.00004D0, 0.00001D0,
58920 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58921 DATA (FMRS(2,8,I,22),I=1,49)/
58922 & 6.21231D0, 4.84766D0, 3.78177D0, 3.26973D0, 2.94855D0,
58923 & 2.72097D0, 2.11789D0, 1.64406D0, 1.41467D0, 1.26974D0,
58924 & 1.16528D0, 0.88741D0, 0.66681D0, 0.56001D0, 0.49289D0,
58925 & 0.44543D0, 0.38094D0, 0.32104D0, 0.26228D0, 0.22553D0,
58926 & 0.17838D0, 0.14638D0, 0.12146D0, 0.09617D0, 0.07554D0,
58927 & 0.05855D0, 0.04477D0, 0.03372D0, 0.02502D0, 0.01828D0,
58928 & 0.01316D0, 0.00936D0, 0.00658D0, 0.00457D0, 0.00313D0,
58929 & 0.00210D0, 0.00142D0, 0.00097D0, 0.00060D0, 0.00039D0,
58930 & 0.00026D0, 0.00016D0, 0.00010D0, 0.00004D0, 0.00001D0,
58931 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58932 DATA (FMRS(2,8,I,23),I=1,49)/
58933 & 6.92819D0, 5.36347D0, 4.15110D0, 3.57245D0, 3.21096D0,
58934 & 2.95557D0, 2.28227D0, 1.75749D0, 1.50504D0, 1.34618D0,
58935 & 1.23195D0, 0.92986D0, 0.69228D0, 0.57821D0, 0.50690D0,
58936 & 0.45669D0, 0.38876D0, 0.32601D0, 0.26481D0, 0.22674D0,
58937 & 0.17816D0, 0.14541D0, 0.12011D0, 0.09461D0, 0.07396D0,
58938 & 0.05707D0, 0.04348D0, 0.03263D0, 0.02417D0, 0.01758D0,
58939 & 0.01264D0, 0.00894D0, 0.00628D0, 0.00436D0, 0.00298D0,
58940 & 0.00199D0, 0.00135D0, 0.00091D0, 0.00057D0, 0.00037D0,
58941 & 0.00024D0, 0.00015D0, 0.00010D0, 0.00004D0, 0.00001D0,
58942 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58943 DATA (FMRS(2,8,I,24),I=1,49)/
58944 & 7.64199D0, 5.87362D0, 4.51337D0, 3.86793D0, 3.46620D0,
58945 & 3.18314D0, 2.44035D0, 1.86558D0, 1.59069D0, 1.41834D0,
58946 & 1.29468D0, 0.96937D0, 0.71569D0, 0.59480D0, 0.51959D0,
58947 & 0.46683D0, 0.39572D0, 0.33035D0, 0.26693D0, 0.22767D0,
58948 & 0.17780D0, 0.14441D0, 0.11876D0, 0.09309D0, 0.07246D0,
58949 & 0.05571D0, 0.04226D0, 0.03164D0, 0.02333D0, 0.01693D0,
58950 & 0.01213D0, 0.00857D0, 0.00600D0, 0.00415D0, 0.00282D0,
58951 & 0.00189D0, 0.00128D0, 0.00086D0, 0.00054D0, 0.00035D0,
58952 & 0.00022D0, 0.00014D0, 0.00009D0, 0.00003D0, 0.00001D0,
58953 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58954 DATA (FMRS(2,8,I,25),I=1,49)/
58955 & 8.41285D0, 6.42055D0, 4.89893D0, 4.18106D0, 3.73585D0,
58956 & 3.42298D0, 2.60571D0, 1.97779D0, 1.67919D0, 1.49264D0,
58957 & 1.35909D0, 1.00958D0, 0.73928D0, 0.61142D0, 0.53225D0,
58958 & 0.47690D0, 0.40260D0, 0.33461D0, 0.26898D0, 0.22853D0,
58959 & 0.17741D0, 0.14339D0, 0.11741D0, 0.09159D0, 0.07099D0,
58960 & 0.05437D0, 0.04108D0, 0.03067D0, 0.02252D0, 0.01631D0,
58961 & 0.01165D0, 0.00822D0, 0.00574D0, 0.00396D0, 0.00268D0,
58962 & 0.00180D0, 0.00120D0, 0.00081D0, 0.00050D0, 0.00033D0,
58963 & 0.00021D0, 0.00013D0, 0.00008D0, 0.00003D0, 0.00001D0,
58964 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58965 DATA (FMRS(2,8,I,26),I=1,49)/
58966 & 9.21054D0, 6.98238D0, 5.29207D0, 4.49895D0, 4.00873D0,
58967 & 3.66510D0, 2.77134D0, 2.08927D0, 1.76669D0, 1.56583D0,
58968 & 1.42235D0, 1.04868D0, 0.76198D0, 0.62728D0, 0.54426D0,
58969 & 0.48640D0, 0.40901D0, 0.33853D0, 0.27078D0, 0.22922D0,
58970 & 0.17691D0, 0.14232D0, 0.11604D0, 0.09010D0, 0.06954D0,
58971 & 0.05305D0, 0.03996D0, 0.02972D0, 0.02176D0, 0.01572D0,
58972 & 0.01122D0, 0.00790D0, 0.00548D0, 0.00378D0, 0.00255D0,
58973 & 0.00171D0, 0.00115D0, 0.00078D0, 0.00048D0, 0.00031D0,
58974 & 0.00020D0, 0.00012D0, 0.00008D0, 0.00002D0, 0.00001D0,
58975 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58976 DATA (FMRS(2,8,I,27),I=1,49)/
58977 & 10.01421D0, 7.54466D0, 5.68289D0, 4.81371D0, 4.27818D0,
58978 & 3.90363D0, 2.93340D0, 2.19757D0, 1.85131D0, 1.63639D0,
58979 & 1.48318D0, 1.08596D0, 0.78341D0, 0.64217D0, 0.55547D0,
58980 & 0.49525D0, 0.41494D0, 0.34210D0, 0.27239D0, 0.22977D0,
58981 & 0.17638D0, 0.14126D0, 0.11473D0, 0.08869D0, 0.06818D0,
58982 & 0.05182D0, 0.03892D0, 0.02884D0, 0.02107D0, 0.01518D0,
58983 & 0.01082D0, 0.00760D0, 0.00526D0, 0.00363D0, 0.00244D0,
58984 & 0.00163D0, 0.00110D0, 0.00075D0, 0.00046D0, 0.00030D0,
58985 & 0.00019D0, 0.00012D0, 0.00007D0, 0.00002D0, 0.00001D0,
58986 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58987 DATA (FMRS(2,8,I,28),I=1,49)/
58988 & 10.81038D0, 8.09822D0, 6.06522D0, 5.12048D0, 4.54007D0,
58989 & 4.13500D0, 3.08954D0, 2.30121D0, 1.93196D0, 1.70343D0,
58990 & 1.54082D0, 1.12100D0, 0.80336D0, 0.65594D0, 0.56579D0,
58991 & 0.50334D0, 0.42032D0, 0.34528D0, 0.27377D0, 0.23019D0,
58992 & 0.17582D0, 0.14022D0, 0.11347D0, 0.08735D0, 0.06690D0,
58993 & 0.05067D0, 0.03795D0, 0.02804D0, 0.02043D0, 0.01468D0,
58994 & 0.01043D0, 0.00733D0, 0.00506D0, 0.00348D0, 0.00235D0,
58995 & 0.00155D0, 0.00105D0, 0.00071D0, 0.00043D0, 0.00029D0,
58996 & 0.00018D0, 0.00011D0, 0.00007D0, 0.00002D0, 0.00001D0,
58997 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
58998 DATA (FMRS(2,8,I,29),I=1,49)/
58999 & 11.65265D0, 8.68040D0, 6.46494D0, 5.44008D0, 4.81224D0,
59000 & 4.37498D0, 3.25050D0, 2.40736D0, 2.01424D0, 1.77163D0,
59001 & 1.59933D0, 1.15629D0, 0.82328D0, 0.66961D0, 0.57598D0,
59002 & 0.51130D0, 0.42557D0, 0.34836D0, 0.27505D0, 0.23054D0,
59003 & 0.17519D0, 0.13914D0, 0.11219D0, 0.08600D0, 0.06563D0,
59004 & 0.04954D0, 0.03699D0, 0.02726D0, 0.01981D0, 0.01419D0,
59005 & 0.01006D0, 0.00705D0, 0.00487D0, 0.00334D0, 0.00225D0,
59006 & 0.00148D0, 0.00100D0, 0.00068D0, 0.00041D0, 0.00027D0,
59007 & 0.00017D0, 0.00010D0, 0.00006D0, 0.00002D0, 0.00001D0,
59008 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
59009 DATA (FMRS(2,8,I,30),I=1,49)/
59010 & 12.51775D0, 9.27489D0, 6.87071D0, 5.76340D0, 5.08688D0,
59011 & 4.61667D0, 3.41161D0, 2.51293D0, 2.09575D0, 1.83900D0,
59012 & 1.65698D0, 1.19078D0, 0.84258D0, 0.68277D0, 0.58574D0,
59013 & 0.51889D0, 0.43052D0, 0.35121D0, 0.27618D0, 0.23078D0,
59014 & 0.17451D0, 0.13804D0, 0.11091D0, 0.08467D0, 0.06438D0,
59015 & 0.04844D0, 0.03605D0, 0.02651D0, 0.01920D0, 0.01373D0,
59016 & 0.00970D0, 0.00677D0, 0.00468D0, 0.00321D0, 0.00215D0,
59017 & 0.00142D0, 0.00096D0, 0.00064D0, 0.00040D0, 0.00026D0,
59018 & 0.00017D0, 0.00010D0, 0.00006D0, 0.00002D0, 0.00001D0,
59019 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
59020 DATA (FMRS(2,8,I,31),I=1,49)/
59021 & 13.38188D0, 9.86555D0, 7.27170D0, 6.08188D0, 5.35680D0,
59022 & 4.85378D0, 3.56878D0, 2.61532D0, 2.17453D0, 1.90394D0,
59023 & 1.71244D0, 1.22374D0, 0.86087D0, 0.69518D0, 0.59491D0,
59024 & 0.52599D0, 0.43513D0, 0.35383D0, 0.27719D0, 0.23095D0,
59025 & 0.17383D0, 0.13697D0, 0.10968D0, 0.08342D0, 0.06322D0,
59026 & 0.04742D0, 0.03518D0, 0.02580D0, 0.01865D0, 0.01331D0,
59027 & 0.00937D0, 0.00652D0, 0.00451D0, 0.00308D0, 0.00206D0,
59028 & 0.00136D0, 0.00092D0, 0.00061D0, 0.00038D0, 0.00024D0,
59029 & 0.00016D0, 0.00010D0, 0.00006D0, 0.00002D0, 0.00001D0,
59030 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
59031 DATA (FMRS(2,8,I,32),I=1,49)/
59032 & 14.22455D0, 10.43853D0, 7.65861D0, 6.38821D0, 5.61583D0,
59033 & 5.08091D0, 3.71848D0, 2.71227D0, 2.24884D0, 1.96503D0,
59034 & 1.76449D0, 1.25443D0, 0.87775D0, 0.70654D0, 0.60325D0,
59035 & 0.53242D0, 0.43925D0, 0.35613D0, 0.27800D0, 0.23100D0,
59036 & 0.17312D0, 0.13592D0, 0.10849D0, 0.08223D0, 0.06212D0,
59037 & 0.04645D0, 0.03438D0, 0.02514D0, 0.01814D0, 0.01292D0,
59038 & 0.00909D0, 0.00631D0, 0.00435D0, 0.00297D0, 0.00198D0,
59039 & 0.00130D0, 0.00088D0, 0.00059D0, 0.00036D0, 0.00023D0,
59040 & 0.00015D0, 0.00009D0, 0.00006D0, 0.00002D0, 0.00000D0,
59041 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
59042 DATA (FMRS(2,8,I,33),I=1,49)/
59043 & 15.12220D0, 11.04609D0, 8.06700D0, 6.71068D0, 5.88799D0,
59044 & 5.31921D0, 3.87481D0, 2.81304D0, 2.32586D0, 2.02823D0,
59045 & 1.81825D0, 1.28597D0, 0.89499D0, 0.71812D0, 0.61173D0,
59046 & 0.53894D0, 0.44342D0, 0.35844D0, 0.27882D0, 0.23104D0,
59047 & 0.17241D0, 0.13488D0, 0.10730D0, 0.08105D0, 0.06103D0,
59048 & 0.04549D0, 0.03359D0, 0.02450D0, 0.01765D0, 0.01253D0,
59049 & 0.00880D0, 0.00610D0, 0.00420D0, 0.00286D0, 0.00191D0,
59050 & 0.00125D0, 0.00083D0, 0.00057D0, 0.00034D0, 0.00022D0,
59051 & 0.00014D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00000D0,
59052 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
59053 DATA (FMRS(2,8,I,34),I=1,49)/
59054 & 16.02044D0, 11.65091D0, 8.47137D0, 7.02895D0, 6.15599D0,
59055 & 5.55343D0, 4.02757D0, 2.91088D0, 2.40036D0, 2.08916D0,
59056 & 1.86995D0, 1.31603D0, 0.91125D0, 0.72894D0, 0.61960D0,
59057 & 0.54494D0, 0.44718D0, 0.36046D0, 0.27943D0, 0.23094D0,
59058 & 0.17160D0, 0.13377D0, 0.10610D0, 0.07985D0, 0.05994D0,
59059 & 0.04455D0, 0.03282D0, 0.02388D0, 0.01715D0, 0.01216D0,
59060 & 0.00853D0, 0.00590D0, 0.00405D0, 0.00275D0, 0.00184D0,
59061 & 0.00120D0, 0.00080D0, 0.00054D0, 0.00033D0, 0.00021D0,
59062 & 0.00013D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00000D0,
59063 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
59064 DATA (FMRS(2,8,I,35),I=1,49)/
59065 & 16.92092D0, 12.25466D0, 8.87333D0, 7.34454D0, 6.42124D0,
59066 & 5.78493D0, 4.17791D0, 3.00675D0, 2.47316D0, 2.14860D0,
59067 & 1.92031D0, 1.34518D0, 0.92693D0, 0.73935D0, 0.62715D0,
59068 & 0.55068D0, 0.45078D0, 0.36238D0, 0.28002D0, 0.23083D0,
59069 & 0.17082D0, 0.13273D0, 0.10496D0, 0.07873D0, 0.05891D0,
59070 & 0.04367D0, 0.03209D0, 0.02331D0, 0.01669D0, 0.01182D0,
59071 & 0.00827D0, 0.00571D0, 0.00391D0, 0.00265D0, 0.00178D0,
59072 & 0.00117D0, 0.00077D0, 0.00052D0, 0.00031D0, 0.00020D0,
59073 & 0.00012D0, 0.00008D0, 0.00005D0, 0.00002D0, 0.00000D0,
59074 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
59075 DATA (FMRS(2,8,I,36),I=1,49)/
59076 & 17.79951D0, 12.84117D0, 9.26208D0, 7.64895D0, 6.67663D0,
59077 & 6.00749D0, 4.32176D0, 3.09803D0, 2.54226D0, 2.20489D0,
59078 & 1.96790D0, 1.37254D0, 0.94153D0, 0.74899D0, 0.63410D0,
59079 & 0.55594D0, 0.45404D0, 0.36409D0, 0.28048D0, 0.23067D0,
59080 & 0.17006D0, 0.13172D0, 0.10387D0, 0.07767D0, 0.05796D0,
59081 & 0.04286D0, 0.03142D0, 0.02277D0, 0.01627D0, 0.01150D0,
59082 & 0.00803D0, 0.00554D0, 0.00379D0, 0.00256D0, 0.00172D0,
59083 & 0.00113D0, 0.00074D0, 0.00050D0, 0.00030D0, 0.00019D0,
59084 & 0.00012D0, 0.00007D0, 0.00005D0, 0.00002D0, 0.00000D0,
59085 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
59086 DATA (FMRS(2,8,I,37),I=1,49)/
59087 & 18.71000D0, 13.44641D0, 9.66151D0, 7.96092D0, 6.93787D0,
59088 & 6.23483D0, 4.46802D0, 3.19039D0, 2.61196D0, 2.26153D0,
59089 & 2.01571D0, 1.39986D0, 0.95599D0, 0.75847D0, 0.64090D0,
59090 & 0.56106D0, 0.45717D0, 0.36568D0, 0.28085D0, 0.23044D0,
59091 & 0.16924D0, 0.13067D0, 0.10276D0, 0.07660D0, 0.05700D0,
59092 & 0.04204D0, 0.03075D0, 0.02224D0, 0.01586D0, 0.01118D0,
59093 & 0.00780D0, 0.00537D0, 0.00367D0, 0.00247D0, 0.00167D0,
59094 & 0.00108D0, 0.00071D0, 0.00047D0, 0.00029D0, 0.00018D0,
59095 & 0.00011D0, 0.00006D0, 0.00004D0, 0.00002D0, 0.00000D0,
59096 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
59097 DATA (FMRS(2,8,I,38),I=1,49)/
59098 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
59099 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
59100 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
59101 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
59102 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
59103 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
59104 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
59105 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
59106 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0,
59107 & 0.00000D0, 0.00000D0, 0.00000D0, 0.00000D0/
59108 END
59109CDECK ID>, HWUDKL.
59110*CMZ :- -27/07/99 13.33.03 by Mike Seymour
59111*-- Author : Ian Knowles
59112C-----------------------------------------------------------------------
59113 SUBROUTINE HWUDKL(ID,PMOM,DISP)
59114C-----------------------------------------------------------------------
59115C Given a real or virtual particle, flavour ID and 4-momentum PMOM,
59116C returns DISP its distance travelled in mm.
59117C
59118C Modified 16/01/01 by BRW to force particle on mass shell if
59119C p^2-m^2 < 10^-10 GeV^2 (rounding errors)
59120C-----------------------------------------------------------------------
c63d70bc 59121 INCLUDE 'herwig65.inc'
65767955 59122 DOUBLE PRECISION HWRGEN,PMOM(4),DISP(4),PMOM2,SCALE,OFFSH
59123 INTEGER ID
59124 EXTERNAL HWRGEN
59125 PMOM2=(PMOM(4)+PMOM(3))*(PMOM(4)-PMOM(3))-PMOM(1)**2-PMOM(2)**2
59126 OFFSH=PMOM2-RMASS(ID)**2
59127 IF (OFFSH.LT.1D-10) OFFSH=ZERO
59128 SCALE=-GEV2MM*LOG(HWRGEN(0))/SQRT(OFFSH**2+(PMOM2/DKLTM(ID))**2)
59129 IF (ID.GT.197.AND.ID.LT.203) SCALE=SCALE*EXAG
59130 CALL HWVSCA(4,SCALE,PMOM,DISP)
59131 END
59132C-----------------------------------------------------------------------
59133CDECK ID>, HWUDKS.
59134*CMZ :- -27/07/99 13.33.03 by Mike Seymour
59135*-- Author : Ian Knowles
59136C-----------------------------------------------------------------------
59137 SUBROUTINE HWUDKS
59138C-----------------------------------------------------------------------
59139C Sets up internal pointers based on the decay table in HWUDAT or as
59140C supplied via HWIODK. Computes CoM momenta of two-body decay modes.
59141C Particles with long lifetimes or no allowed decay (excepting light
59142C b hadrons when CLEO/EURODEC decays requested) are set stable, else
59143C calculate DKLTM(I) = mass/width ( = mass * lifetime/hbar).
59144C Gives warnings if: a particle has no decay modes or antiparticle's
59145C modes are not the charge conjugates of the particles.
59146C (N.B. CP violation permits this).
59147C-----------------------------------------------------------------------
c63d70bc 59148 INCLUDE 'herwig65.inc'
65767955 59149 DOUBLE PRECISION HWUPCM,HWUAEM,HWUALF,BRSUM,EPS,SCALE,
59150 & BRTMP(NMXDKS),FN,X,W,Q,FAC
59151 INTEGER HWUANT,I,IDKY,LAST,LTMP(NMXMOD),J,L,K,M,N,INDX(NMXMOD),
59152 & IRES,IAPDG,IPART,LR,LP,KPRDLR
59153 LOGICAL BPDK,TOPDKS,MATCH(5),PMATCH(NMXMOD),IFGO
59154 CHARACTER*7 CVETO(2)
59155 CHARACTER*8 CDUM
59156 EXTERNAL HWUPCM,HWUAEM,HWUALF,HWUANT
59157 PARAMETER(EPS=1.E-6)
59158 FN(X,Q,W)=X**4/(((X*X-Q*Q)**2+W*W*(X*X+Q*Q)-2.*W**4)
59159 & *SQRT(X**4+Q**4+W**4-2.*(X*X*Q*Q+X*X*W*W+Q*Q*W*W)))
59160 WRITE(6,10)
59161 10 FORMAT(/10X,'Checking consistency of decay tables'/)
59162 DKPSET=.TRUE.
59163C First zero arrays
59164 DO 20 I=1,NMXRES
59165 LSTRT(I)=0
59166 20 NMODES(I)=0
59167 DO 30 I=1,NMXDKS
59168 NPRODS(I)=0
59169 LNEXT(I)=0
59170 30 CMMOM(I)=0
59171 BPDK=BDECAY.NE.'HERW'
59172 DO 180 I=1,NDKYS
59173C Search for next decaying particle type
59174 IDKY=IDK(I)
59175C Skip if particle is not recognised or already dealt with
59176 IF (IDKY.EQ.0.OR.IDKY.EQ.20) THEN
59177 WRITE(6,40) I
59178 40 FORMAT(1X,'Line ',I4,': decaying particle not recognised')
59179 GOTO 180
59180 ENDIF
59181 IF (NMODES(IDKY).GT.0) GOTO 180
59182C Check and include first decay mode, storing a copy
59183 CALL HWDCHK(IDKY,I,IFGO)
59184 IF(IFGO) GOTO 180
59185 LSTRT(IDKY)=I
59186 NMODES(IDKY)=1
59187 BRSUM=BRFRAC(I)
59188 LTMP(1)=I
59189 BRTMP(1)=-BRFRAC(I)
59190 LAST=I
59191C Sets CMMOM(IDKY) = CoM momentum for first 2-body decay mode I (else 0)
59192 IF (NPRODS(I).EQ.2) CMMOM(I)=
59193 & HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,I)),RMASS(IDKPRD(2,I)))
59194C Include any other decay modes of IDKY
59195 DO 120 J=I+1,NDKYS
59196 IF (IDK(J).EQ.IDKY) THEN
59197C First see if it is a copy of the same decay channel
59198 IF ((IDKPRD(2,J).GE.1.AND.IDKPRD(2,J).LE.13).OR.
59199 & (IDKPRD(3,J).GE.1.AND.IDKPRD(3,J).LE.13)) THEN
59200C Partonic respect order
59201 L=LSTRT(IDKY)
59202 DO 50 K=1,NMODES(IDKY)
59203 IF (IDKPRD(1,L).EQ.IDKPRD(1,J).AND.
59204 & IDKPRD(2,L).EQ.IDKPRD(2,J).AND.
59205 & IDKPRD(3,L).EQ.IDKPRD(3,J).AND.
59206 & IDKPRD(4,L).EQ.IDKPRD(4,J).AND.
59207 & IDKPRD(5,L).EQ.IDKPRD(5,J)) GOTO 100
59208 50 L=LNEXT(L)
59209 ELSE
59210C Allow for different order in matching
59211 L=LSTRT(IDKY)
59212 DO 90 K=1,NMODES(IDKY)
59213 DO 60 M=1,5
59214 60 MATCH(M)=.FALSE.
59215 DO 80 M=1,5
59216 DO 70 N=1,5
59217 IF (.NOT.MATCH(N).AND.IDKPRD(N,L).EQ.IDKPRD(M,J)) THEN
59218 MATCH(N)=.TRUE.
59219 GOTO 80
59220 ENDIF
59221 70 CONTINUE
59222 80 CONTINUE
59223 IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
59224 & MATCH(4).AND.MATCH(5)) GOTO 100
59225 90 L=LNEXT(L)
59226 ENDIF
59227 CALL HWDCHK(IDKY,J,IFGO)
59228 IF(IFGO) GOTO 120
59229 NMODES(IDKY)=NMODES(IDKY)+1
59230 IF (NMODES(IDKY).GT.NMXMOD) THEN
59231 CALL HWWARN('HWUDKS',100)
59232 GOTO 999
59233 ENDIF
59234 LNEXT(LAST)=J
59235 BRSUM=BRSUM+BRFRAC(J)
59236 LTMP(NMODES(IDKY))=J
59237 BRTMP(NMODES(IDKY))=-BRFRAC(J)
59238 LAST=J
59239C Sets CMMOM(IDKY) = CoM momentum for next 2-body decay mode J (else 0)
59240 IF (NPRODS(J).EQ.2) CMMOM(J)=
59241 & HWUPCM(RMASS(IDKY),RMASS(IDKPRD(1,J)),RMASS(IDKPRD(2,J)))
59242 ENDIF
59243 GOTO 120
59244 100 WRITE(6,110) L,J,BRFRAC(J),NME(J)
59245 BRSUM=BRSUM-BRFRAC(L)+BRFRAC(J)
59246 BRFRAC(L)=BRFRAC(J)
59247 BRTMP(L)=-BRFRAC(L)
59248 NME(L)=NME(J)
59249 110 FORMAT(1X,'Line ',I4,' is the same as line ',I4/
59250 & 1X,'Take BR ',F5.3,' and ME code ',I3,' from second entry')
59251 120 CONTINUE
59252C Set sum of branching ratios to 1. if necessary
59253 IF (ABS(BRSUM-1.).GT.EPS) THEN
59254 WRITE(6,130) RNAME(IDKY),BRSUM
59255 130 FORMAT(1X,A8,': BR sum =',F8.5)
59256 IF (ABS(BRSUM).LT.EPS) THEN
59257 WRITE(6,140)
59258 140 FORMAT(1X,'Setting particle stable'/)
59259 NMODES(IDKY)=0
59260 ELSE
59261 WRITE(6,150)
59262 150 FORMAT(1X,'Rescaling to 1'/)
59263 SCALE=1./BRSUM
59264 K=LSTRT(IDKY)
59265 DO 160 J=1,NMODES(IDKY)
59266 BRFRAC(K)=SCALE*BRFRAC(K)
59267 160 K=LNEXT(K)
59268 ENDIF
59269 ENDIF
59270C Sort branching ratios into descending order and rearrange pointers
59271 CALL HWUSOR(BRTMP,NMODES(IDKY),INDX,2)
59272 LSTRT(IDKY)=LTMP(INDX(1))
59273 LNEXT(LTMP(INDX(1)))=LTMP(INDX(1))
59274 DO 170 J=2,NMODES(IDKY)
59275 IF (ABS(BRFRAC(LTMP(INDX(J)))).LT.EPS) THEN
59276 NMODES(IDKY)=J-1
59277 GOTO 175
59278 ENDIF
59279 170 LNEXT(LTMP(INDX(J-1)))=LTMP(INDX(J))
59280 175 LNEXT(LTMP(INDX(NMODES(IDKY))))=LTMP(INDX(NMODES(IDKY)))
59281 180 CONTINUE
59282C If not a short lived particle with a decay mode then set stable
59283 DO 190 I=1,NRES
59284 IF (.NOT.RSTAB(I).AND.RLTIM(I).LT.PLTCUT.AND.
59285 & (NMODES(I).GT.0.OR.
59286 & (BPDK.AND.((I.GE.221.AND.I.LE.231).OR.
59287 & (I.GE.245.AND.I.LE.254))))) THEN
59288 DKLTM(I)=RLTIM(I)*RMASS(I)/HBAR
59289 ELSE
59290 RSTAB(I)=.TRUE.
59291 ENDIF
59292 190 CONTINUE
59293C Set up DKLTM for light quarks
59294 DO 200 I=1,5
59295 DKLTM(I)=RMASS(I)**2/VMIN2
59296 200 DKLTM(I+6)=DKLTM(I)
59297C gluon
59298 DKLTM(13)=RMASS(13)**2/VMIN2
59299C and diquarks
59300 DO 210 I=109,114
59301 DKLTM(I)=RMASS(I)**2/VMIN2
59302 210 DKLTM(I+6)=DKLTM(I)
59303C Set up DKLTM for weak bosons
59304 DKLTM(198)=RMASS(198)/GAMW
59305 DKLTM(199)=DKLTM(198)
59306 DKLTM(200)=RMASS(200)/GAMZ
59307 DKLTM(201)=RMASS(201)/GAMH
59308 DKLTM(202)=RMASS(202)/GAMZP
59309C Set up DKTRM for massive quarks (plus check m_Q > M_W + m_q)
59310 FAC=SWEIN*(FOUR*RMASS(198))**2/HWUAEM(RMASS(198)**2)
59311 IF (.NOT.SUSYIN) THEN
59312 IF (RMASS(6).GT.RMASS(5)+RMASS(198)) THEN
59313 DKLTM(6)=FAC*FN(RMASS(6 ),RMASS(5 ),RMASS(198))
59314 & /(1-HWUALF(1,RMASS(6))*2*(2*PIFAC**2/3-5/2)/(3*PIFAC))
59315 DKLTM(12)=DKLTM(6)
59316 ELSE
59317 WRITE(6,220) RNAME(6),RNAME(5),RNAME(198)
59318 ENDIF
59319 ENDIF
59320 IF (RMASS(209).GT.RMASS(4)+RMASS(198)) THEN
59321 DKLTM(209)=FAC*FN(RMASS(209),RMASS(4 ),RMASS(198))
59322 DKLTM(215)=DKLTM(209)
59323 ELSE
59324 WRITE(6,220) RNAME(209),RNAME(4),RNAME(198)
59325 ENDIF
59326 IF (RMASS(210).GT.RMASS(209)+RMASS(198)) THEN
59327 DKLTM(210)=FAC*FN(RMASS(210),RMASS(209),RMASS(198))
59328 DKLTM(216)=DKLTM(210)
59329 ELSE
59330 WRITE(6,220) RNAME(210),RNAME(209),RNAME(198)
59331 ENDIF
59332 IF (RMASS(211).GT.RMASS(6)+RMASS(198)) THEN
59333 DKLTM(211)=FAC*FN(RMASS(211),RMASS(6 ),RMASS(198))
59334 DKLTM(217)=DKLTM(211)
59335 ELSE
59336 WRITE(6,220) RNAME(211),RNAME(6),RNAME(198)
59337 ENDIF
59338 IF (RMASS(212).GT.RMASS(211)+RMASS(198)) THEN
59339 DKLTM(212)=FAC*FN(RMASS(212),RMASS(211),RMASS(198))
59340 DKLTM(218)=DKLTM(212)
59341 ELSE
59342 WRITE(6,220) RNAME(212),RNAME(211),RNAME(198)
59343 ENDIF
59344 220 FORMAT(1X,'W not real in the decay: ',A8,' --> ',A8,' + ',A8)
59345C Now carry out diagnostic checks on decay table
59346 CALL HWDTOP(TOPDKS)
59347 DO 310 IRES=1,NRES
59348 IAPDG=ABS(IDPDG(IRES))
59349C Do not check (di-)quarks, gauge bosons, higgses or special particles
59350 IF ((IAPDG.GE.1.AND.IAPDG.LE.9).OR.
59351 & (MOD(IAPDG/10,10).EQ.0.AND.MOD(IAPDG/1000,10).NE.0).OR.
59352 & (IAPDG.GE.21.AND.IAPDG.LE.26).OR.
59353 & IAPDG.EQ.32.OR.
59354 & (IAPDG.GE.35.AND.IAPDG.LE.37).OR.
59355 & IAPDG.EQ.91.OR.
59356 & IAPDG.EQ.98.OR.IAPDG.EQ.99) THEN
59357 GOTO 310
59358C Ignore top hadrons if top decays
59359 ELSEIF(TOPDKS.AND.((IRES.GE.232.AND.IRES.LE.244).OR.
59360 & (IRES.GE.255.AND.IRES.LE.264))) THEN
59361 GOTO 310
59362C Ignore particles not produced in cluster or particle decays
59363 ELSEIF(VTOCDK(IRES).AND.VTORDK(IRES)) THEN
59364 GOTO 310
59365C Ignore B's if EURO or CLEO decay package used
59366 ELSEIF(((IRES.GE.221.AND.IRES.LE.223).OR.
59367 & (IRES.GE.245.AND.IRES.LE.247)).AND.BDECAY.NE.'HERW') THEN
59368 WRITE(6,320) BDECAY,RNAME(IRES)
59369C Check decay modes exist for massive, short lived particles
59370 ELSEIF (NMODES(IRES).EQ.0.AND.RMASS(IRES).NE.ZERO.AND.
59371 & RLTIM(IRES).LT.PLTCUT) THEN
59372 IF (VTOCDK(IRES)) THEN
59373 CVETO(1)='VETOED '
59374 ELSE
59375 CVETO(1)='ALLOWED'
59376 ENDIF
59377 IF (VTORDK(IRES)) THEN
59378 CVETO(2)='VETOED '
59379 ELSE
59380 CVETO(2)='ALLOWED'
59381 ENDIF
59382 WRITE(6,330) RNAME(IRES),CVETO(1),CVETO(2)
59383C ignore particles with no modes if massless or long lived
59384 ELSEIF (NMODES(IRES).EQ.0.AND.
59385 & (RMASS(IRES).EQ.ZERO.OR.RLTIM(IRES).GT.PLTCUT)) THEN
59386 GOTO 310
59387 ELSEIF (IDPDG(IRES).LT.0) THEN
59388C Antiparticle: check decays are charge conjugates of particle decays
59389 CALL HWUIDT(1,-IDPDG(IRES),IPART,CDUM)
59390 IF (NMODES(IPART).EQ.0) THEN
59391C Nothing to compare to
59392 WRITE(6,340) RNAME(IPART),RNAME(IRES)
59393 ELSE
59394C First initialize particle matching array
59395 DO 230 I=1,NMODES(IPART)
59396 230 PMATCH(I)=.FALSE.
59397C Loop through antiparticle decay modes
59398 LR=LSTRT(IRES)
59399 DO 290 I=1,NMODES(IRES)
59400C Search for conjugate mode allowing for different particle order
59401 LP=LSTRT(IPART)
59402 DO 270 J=1,NMODES(IPART)
59403 IF (PMATCH(J)) GOTO 270
59404 DO 240 K=1,5
59405 240 MATCH(K)=.FALSE.
59406 DO 260 K=1,5
59407 KPRDLR=HWUANT(IDKPRD(K,LR))
59408 DO 250 L=1,5
59409 IF (.NOT.MATCH(L).AND.KPRDLR.EQ.IDKPRD(L,LP) ) THEN
59410 MATCH(L)=.TRUE.
59411 GOTO 260
59412 ENDIF
59413 250 CONTINUE
59414 260 CONTINUE
59415 IF (MATCH(1).AND.MATCH(2).AND.MATCH(3).AND.
59416 & MATCH(4).AND.MATCH(5)) GOTO 280
59417 270 LP=LNEXT(LP)
59418C No match found
59419 WRITE(6,350) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5)
59420 GOTO 290
59421C Match found, check branching ratios and matrix element codes
59422 280 PMATCH(J)=.TRUE.
59423 IF (BRFRAC(LR).NE.BRFRAC(LP))
59424 & WRITE(6,360) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5),
59425 & BRFRAC(LR),BRFRAC(LP)
59426 IF (NME(LR).NE.NME(LP))
59427 & WRITE(6,370) LR,RNAME(IRES),(RNAME(IDKPRD(J,LR)),J=1,5),
59428 & NME(LR),NME(LP)
59429 290 LR=LNEXT(LR)
59430C Check for unmatched modes of particle conjugate to antiparticle
59431 LP=LSTRT(IPART)
59432 DO 300 I=1,NMODES(IPART)
59433 IF (.NOT.PMATCH(I))
59434 & WRITE(6,350) LP,RNAME(IPART),(RNAME(IDKPRD(J,LP)),J=1,5)
59435 300 LP=LNEXT(LP)
59436 ENDIF
59437 ENDIF
59438 310 CONTINUE
59439 320 FORMAT(1X,A8,' decay package to be used for particle ',A8)
59440 330 FORMAT(1X,'No decay modes available for particle ',A8/
59441 & 1X,'Production in cluster decays ',A7,' and particle decays ',A7)
59442 340 FORMAT(1X,A8,' has no modes conjugate to those of ',A8)
59443 350 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
59444 & 1X,'A charge conjugate decay mode does not exist')
59445 360 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
59446 & 1X,'BR ',F5.3,' unequal to that of conjugate mode ',F5.3)
59447 370 FORMAT(1X,'Line, ',I4,' decay: ',A8,' --> ',4(A8,1X),A8/
59448 & 1X,'ME code ',I3,' unequal to that of conjugate mode ',I3)
59449 999 RETURN
59450 END
59451CDECK ID>, HWUDPR.
59452*CMZ :- -27/07/99 13.33.03 by Mike Seymour
59453*-- Author : Ian Knowles, Bryan Webber & Kosuke Odagiri
59454C-----------------------------------------------------------------------
59455 SUBROUTINE HWUDPR
59456C-----------------------------------------------------------------------
59457C Prints out particle properies/decay tables in a number of formats:
59458C If (PRNDEF) ASCII to stout
59459C If (PRNTEX) LaTeX to the file HW_decays.tex
59460C Paper size and offsets as set in HWUEPR
59461C Uses the package longtable.sty
59462C Designed to be printed as landscape
59463C If (PRNWEB) HTML to the file HW_decays/index.html
59464C /PART0000001.html etc.
59465C-----------------------------------------------------------------------
c63d70bc 59466 INCLUDE 'herwig65.inc'
65767955 59467 INTEGER MMWIDE,MMLONG,MMHOFF,MMVOFF,IUNITT,IUNTW1,IUNTW2,I,NM,J,K,
59468 & L,M
59469 CHARACTER*1 Z
59470 CHARACTER*2 ZZ,ACHRG
59471 CHARACTER*3 ASPIN(0:10)
59472 CHARACTER*6 BGCOLS(5),TBCOLS(3)
59473 CHARACTER*7 HWUNST,TMPNME
59474 CHARACTER*17 FNAMEP
59475 CHARACTER*33 FNAMEW
59476 COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
59477 EXTERNAL HWUNST
59478 SAVE BGCOLS,TBCOLS,ASPIN
59479 DATA BGCOLS/'ffffff','0000aa','aa0000','00aa00','aa00ff'/
59480 DATA TBCOLS/'ccccff','9966ff','ffff00'/
59481 DATA ASPIN/' 0 ','1/2',' 1 ','3/2',' 2 ','5/2',' 3 ','7/2',
59482 & ' 4 ','9/2',' 5 '/
59483C
59484 Z=CHAR(92)
59485 ZZ=Z//Z
59486C
59487 IUNITT=50
59488 IUNTW1=51
59489 IUNTW2=52
59490C Open and write out file header information for index file
59491 IF (PRNDEF) THEN
59492 IF (NPRFMT.LE.1) THEN
59493 WRITE (6,10) NRES
59494 ELSE
59495 WRITE (6,20) NRES
59496 END IF
59497 END IF
59498 IF (PRNTEX) THEN
59499 OPEN(IUNITT,STATUS='UNKNOWN',FILE='HW_decays.tex')
59500 IF (NPRFMT.LE.1) THEN
59501 WRITE(IUNITT,30) Z,Z,Z,MMWIDE,Z,MMLONG,Z,MMHOFF,Z,MMVOFF,
59502 & Z,Z,Z,Z,Z,ZZ,Z,Z,Z,Z,Z,Z,NRES,ZZ,Z,Z,ZZ,Z,Z
59503 ELSE
59504 WRITE(IUNITT,40) Z,Z,Z,MMLONG,Z,MMWIDE,Z,MMHOFF,Z,MMVOFF,
59505 & Z,Z,Z,Z,Z,Z,ZZ,Z,Z,Z,Z,Z,Z,NRES,ZZ,Z,Z,Z,ZZ,Z,Z
59506 END IF
59507 ENDIF
59508 IF (PRNWEB) THEN
59509 OPEN(IUNTW1,STATUS='UNKNOWN',FILE='HW_decays/index.html')
59510 WRITE(IUNTW1,50) BGCOLS,TBCOLS,NRES,((TBCOLS(I),I=2,3),J=1,7)
59511 ENDIF
59512 10 FORMAT(1H1//15X,'TABLE OF PROPERTIES OF',I4,' PARTICLES USED'/)
59513 20 FORMAT(1H1//30X,'TABLE OF PROPERTIES OF',I4,' PARTICLES USED'//
59514 & 5X,'Name IDPDG Mass Chg Spn Lifetime Modes ',
59515 & ' Branching fractions ME codes and decay products')
59516 30 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
59517 & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
59518 & A1,'hoffset ',I4,'mm ',A1,'voffset ',I4,'mm'/
59519 & A1,'pagestyle{empty}'/A1,'begin{document}'/
59520 & A1,'begin{center}'/A1,'begin{longtable}{|r|c|r|r|r|r|r|r|}'/
59521 & A1,'hline'/'Id HW & Name & Id PDG & Mass & Charge & Spin ',
59522 & '& Lifetime & Modes ',A2/A1,'hline'/
59523 & A1,'endhead'/A1,'hline'/A1,'endfoot'/A1,'hline'/
59524 & A1,'multicolumn{8}{|c|}{HERWIG 6.5: Table of properties',
59525 & ' of the ',I3,' particles used} ',A2/A1,'hline',A1,'hline'/
59526 & 'Id HW & Name & Id PDG & Mass & Charge & Spin & ',
59527 & 'Lifetime & Modes ',A2/A1,'hline'/A1,'endfirsthead')
59528 40 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
59529 & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
59530 & A1,'hoffset ',I4,'mm ',A1,'voffset ',I4,'mm'/
59531 & A1,'pagestyle{empty}'/A1,'begin{document}'/A1,'begin{center}'/
59532 & A1,'begin{longtable}{|r|c|r|r|r|r|r|r|c|r|ccccc|}'/
59533 & A1,'hline'/'Id HW & Name & Id PDG & Mass & Charge & Spin ',
59534 & '& Lifetime & Modes & B.R. & M.E. & ' /
59535 & A1,'multicolumn{5}{|c|}{Decay Products} ',A2/A1,'hline'/
59536 & A1,'endhead'/A1,'hline'/A1,'endfoot'/A1,'hline'/
59537 & A1,'multicolumn{15}{|c|}{HERWIG 6.5: Table of properties',
59538 & ' of the ',I3,' particles used} ',A2/A1,'hline',A1,'hline'/
59539 & 'Id HW & Name & Id PDG & Mass & Charge & Spin & ',
59540 & 'Lifetime & Modes & B.R. & M.E. & '/
59541 & A1,'multicolumn{5}{|c|}{Decay Products} ',A2/A1,'hline'/
59542 & A1,'endfirsthead')
59543 50 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
59544 & '<TITLE>HERWIG 6.5 Particle Properties</TITLE>'/'</HEAD>'/
59545 & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
59546 & ' ALINK=#',A6,' VLINK=#',A6,'>'/'<CENTER>'/
59547 & '<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>',
59548 & '<TR>'/'<TH COLSPAN=8 BGCOLOR=#',A6,' ALIGN="CENTER">',
59549 & '<A HREF=="http://hepwww.rl.ac.uk/theory/seymour/herwig/">',
59550 & 'HERWIG 6.5:</A><FONT COLOR=#',A6,'> Table of properties of',
59551 & ' the ',I3,' particles used</FONT></TH>'/'<TR>'/'<TH></TH>'/
59552 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Name</FONT></TH>'/
59553 & '<TH BGCOLOR=#',A6,' ALIGN="CENTER"><FONT COLOR=#',A6,'>',
59554 & 'Id PDG</FONT></TH>'/
59555 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Mass</FONT></TH>'/
59556 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Charge</FONT></TH>'/
59557 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Spin</FONT></TH>'/
59558 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Lifetime</FONT></TH>'/
59559 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Modes</FONT></TH>'/
59560 & '</TR>')
59561C Loop through resonances
59562 DO 260 I=1,NRES
59563C Skip particles that can't be produced or blank lines
59564 IF ((VTOCDK(I).AND.VTORDK(I)).OR.
59565 & (RNAME(I).EQ.' ')) GOTO 260
59566C Open and write out header information for particle file
59567 IF (PRNWEB) THEN
59568 TMPNME = HWUNST(I)
59569 WRITE(FNAMEP,'(A5,A7,A5)') 'PART_',TMPNME,'.html'
59570 WRITE(FNAMEW,'(A,A17)') 'HW_decays/',FNAMEP
59571 OPEN(IUNTW2,STATUS='UNKNOWN',FILE=FNAMEW)
59572 WRITE(IUNTW2,60) RNAME(I),BGCOLS
59573 WRITE(IUNTW2,70) TBCOLS,((TBCOLS(L),L=2,3),M=1,6)
59574 ENDIF
59575 60 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
59576 & '<TITLE>HERWIG 6.5: ',A8,' properties</TITLE>'/'</HEAD>'/
59577 & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
59578 & ' ALINK=#',A6,' VLINK=#',A6,'>'/'<CENTER>')
59579 70 FORMAT('<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/
59580 & '<TR>'/'<TH></TH>'/
59581 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Name</FONT></TH>'/
59582 & '<TH BGCOLOR=#',A6,' ALIGN="CENTER"><FONT COLOR=#',A6,
59583 & '>Id PDG</FONT></TH>'/
59584 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Mass</FONT></TH>'/
59585 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Charge</FONT></TH>'/
59586 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Spin</FONT></TH>'/
59587 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Lifetime</FONT></TH>'/
59588 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Modes</FONT></TH>'/
59589 & '</TR>')
59590C Trick to output charge in fractions for di/s - quarks
59591 IF ((I.GE. 1.AND.I.LE. 12).OR.(I.GE.109.AND.I.LE.120).OR.
59592 & (I.GE.209.AND.I.LE.218).OR.(I.GE.401.AND.I.LE.424)) THEN
59593 ACHRG='/3'
59594 ELSE
59595 ACHRG=' '
59596 ENDIF
59597C Write out special particles with no decay modes
59598 IF (NMODES(I).EQ.0) THEN
59599 IF (PRNDEF) THEN
59600 IF (NPRFMT.LE.1) THEN
59601 WRITE(6,80) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
59602 & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
59603 ELSE
59604 WRITE(6,90) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
59605 & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
59606 ENDIF
59607 ENDIF
59608C Add particle to LaTeX file
59609 IF (PRNTEX) THEN
59610 IF (NPRFMT.LE.1) THEN
59611 WRITE(IUNITT,100) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
59612 & ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0,ZZ
59613 ELSE
59614 WRITE(IUNITT,110) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
59615 & ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0,Z,ZZ
59616 ENDIF
59617 ENDIF
59618 IF (PRNWEB) THEN
59619C Add properties to Web index
59620 WRITE(IUNTW1,120) TBCOLS(2),TBCOLS(3),I,FNAMEP,TXNAME(2,I),
59621 & IDPDG(I),RMASS(I),ICHRG(I),ACHRG,
59622 & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
59623C Add properties to Web particle file
59624 WRITE(IUNTW2,130) TBCOLS(2),TBCOLS(3),I,TXNAME(2,I),
59625 & IDPDG(I),RMASS(I),ICHRG(I),ACHRG,
59626 & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),0
59627 ENDIF
59628 80 FORMAT(/1X,I3,1X,A8,' IDPDG=',I8,', M=',F8.3,', Q=',I2,', J=',
59629 & A3,', T=',1P,E9.3,',',I3,' Modes')
59630 90 FORMAT(/1X,I3,1X,A8,1X,I8,1X,F8.3,1X,I2,1X,A3,1X,1P,E9.3,1X,I3)
59631 100 FORMAT(A1,'hline',I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,
59632 & A2,'$ & ',A3,' & $',1P,E9.3,'$ & ',I3,' ',A2)
59633 110 FORMAT(A1,'cline{1-8}'/
59634 & I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',A3,
59635 & ' & $',1P,E9.3,'$ & ',I3,' & ',A1,'multicolumn{7}{|c|}{} ',A2)
59636 120 FORMAT('<TR>'/
59637 & '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',I3,
59638 & '</FONT></TD>'/
59639 & '<TD ALIGN="CENTER"><A HREF="',A17,'">',A37,'</A></TD>'/
59640 & '<TD ALIGN="RIGHT">',I8,'</TD>'/
59641 & '<TD ALIGN="RIGHT">',F8.3,'</TD>'/
59642 & '<TD ALIGN="RIGHT">',I2,A2,'</TD>'/
59643 & '<TD ALIGN="RIGHT">',A3,'</TD>'/
59644 & '<TD ALIGN="RIGHT">',1P,E9.3,'</TD>'/
59645 & '<TD ALIGN="RIGHT">',I3,'</TD>'/'</TR>')
59646 130 FORMAT('<TR>'/
59647 & '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',I3,
59648 & '</FONT></TD>'/
59649 & '<TD ALIGN="CENTER">',A37,'</TD>'/
59650 & '<TD ALIGN="RIGHT">',I8,'</TD>'/
59651 & '<TD ALIGN="RIGHT">',F8.3,'</TD>'/
59652 & '<TD ALIGN="RIGHT">',I2,A2,'</TD>'/
59653 & '<TD ALIGN="RIGHT">',A3,'</TD>'/
59654 & '<TD ALIGN="RIGHT">',1P,E9.3,'</TD>'/
59655 & '<TD ALIGN="RIGHT">',I3,'</TD>'/'</TR>'/'</TABLE>'/'<P>')
59656 ELSE
59657C Particle with decay modes
59658 IF (RSTAB(I)) THEN
59659 NM=0
59660 ELSEIF (VTOCDK(I)) THEN
59661 NM=-NMODES(I)
59662 ELSE
59663 NM=NMODES(I)
59664 ENDIF
59665 K=LSTRT(I)
59666C Write out properties and first decay mode
59667 IF (PRNDEF) THEN
59668 IF (NPRFMT.LE.1) THEN
59669 WRITE(6, 80) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
59670 & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM
59671 WRITE(6,140) (RNAME(IDKPRD(L,K)),L=1,5),BRFRAC(K),NME(K)
59672 ELSE
59673 WRITE(6,150) I,RNAME(I),IDPDG(I),RMASS(I),ICHRG(I),
59674 & ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,BRFRAC(K),NME(K),
59675 & (RNAME(IDKPRD(L,K)),L=1,5)
59676 ENDIF
59677 ENDIF
59678 IF (PRNTEX) THEN
59679 IF (NPRFMT.LE.1) THEN
59680 WRITE(IUNITT,160) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
59681 & ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,ZZ,Z
59682 WRITE(IUNITT,170) Z,Z,(TXNAME(1,IDKPRD(L,K)),L=1,5),Z,
59683 & BRFRAC(K),Z,NME(K),ZZ
59684 ELSE
59685 WRITE(IUNITT,180) Z,I,TXNAME(1,I),IDPDG(I),RMASS(I),
59686 & ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM,
59687 & BRFRAC(K),NME(K),(TXNAME(1,IDKPRD(L,K)),L=1,5),ZZ,Z
59688 ENDIF
59689 END IF
59690 IF (PRNWEB) THEN
59691C Add properties to index
59692 WRITE(IUNTW1,120) TBCOLS(2),TBCOLS(3),I,FNAMEP,TXNAME(2,I),
59693 & IDPDG(I),RMASS(I),ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),
59694 & RLTIM(I),NM
59695C Add properties to Web particle file
59696 WRITE(IUNTW2,130) TBCOLS(2),TBCOLS(3),I,TXNAME(2,I),IDPDG(I),
59697 & RMASS(I),ICHRG(I),ACHRG,ASPIN(INT(TWO*RSPIN(I))),RLTIM(I),NM
59698 WRITE(IUNTW2,190) TBCOLS,TXNAME(2,I),
59699 & ((TBCOLS(L),L=2,3),M=1,3)
59700 WRITE(IUNTW2,200) TBCOLS(2),TBCOLS(3),1,BRFRAC(K),NME(K),
59701 & (TXNAME(2,IDKPRD(L,K)),L=1,5)
59702 ENDIF
59703 140 FORMAT(5X,'BR[ -->',5(1X,A8),']=',F5.3,', ME code',I5)
59704 150 FORMAT(/1X,I3,1X,A8,1X,I8,1X,F8.3,1X,I2,1X,A3,1X,1P,E9.3,1X,I3,
59705 & 2X,F5.3,1X,I3,5(1X,A8))
59706 160 FORMAT(A1,'hline',
59707 & I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',
59708 & A3,' & $',1P,E9.3,'$ & ',I3,' ',A2/A1,'cline{2-8}')
59709 170 FORMAT(' & & ',A1,'multicolumn{2}{l}{$',A1,'longrightarrow$'/
59710 & 5(A37,' '),'}'/' & ',A1,'multicolumn{2}{l}{BR = ',F5.3,'} & ',
59711 & A1,'multicolumn{2}{l|}{ME code = ',I3,'} ',A2)
59712 180 FORMAT(A1,'hline'/
59713 & I4,' & ',A37,' & $',I8,'$ & ',F8.3,' & $',I2,A2,'$ & ',
59714 & A3,' & $',1P,E9.3,'$ & ',I3,' & ',F5.3,' & ',I3,
59715 & 5(' & ',A37), ' ',A2/A1,'cline{2-8}')
59716 190 FORMAT('<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/'<TR>'/
59717 & '<TH COLSPAN=8 BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',A37,
59718 & ' Decay Modes</FONT></TH>'/'</TR>'/'<TR>'/'<TH></TH>',
59719 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>B.R.</FONT></TH>'/
59720 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>M.E.</FONT></TH>'/
59721 & '<TH BGCOLOR=#',A6,' ALIGN="CENTER" COLSPAN=5>',
59722 & '<FONT COLOR=#',A6,'>Decay products</FONT></TH>'/'</TR>')
59723 200 FORMAT('<TR>'/
59724 & '<TD ALIGN="RIGHT" BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>',
59725 & I3,'</FONT></TD>'/
59726 & '<TD ALIGN="RIGHT">',F5.3,'</TD>'/
59727 & '<TD ALIGN="RIGHT">',I3,'</TD>'/
59728 & 5('<TD ALIGN="CENTER">',A37,'</TD>'/),'</TR>')
59729C Write out additional decay modes
59730 IF (NMODES(I).GE.2) THEN
59731 DO 210 J=2,NMODES(I)
59732 K=LNEXT(K)
59733 IF (PRNDEF) THEN
59734 IF (NPRFMT.LE.1) THEN
59735 WRITE(6,140) (RNAME(IDKPRD(L,K)),L=1,5),BRFRAC(K),NME(K)
59736 ELSE
59737 WRITE(6,220) BRFRAC(K),NME(K),(RNAME(IDKPRD(L,K)),L=1,5)
59738 END IF
59739 END IF
59740 IF (PRNTEX) THEN
59741 IF (NPRFMT.LE.1) THEN
59742 WRITE(IUNITT,170) Z,Z,(TXNAME(1,IDKPRD(L,K)),L=1,5),Z,
59743 & BRFRAC(K),Z,NME(K),ZZ
59744 ELSE
59745 WRITE(IUNITT,230) Z,BRFRAC(K),NME(K),
59746 & (TXNAME(1,IDKPRD(L,K)),L=1,5),ZZ
59747 ENDIF
59748 ENDIF
59749 IF (PRNWEB) WRITE(IUNTW2,200) TBCOLS(2),TBCOLS(3),J,
59750 & BRFRAC(K),NME(K),(TXNAME(2,IDKPRD(L,K)),L=1,5)
59751 210 CONTINUE
59752 IF (PRNTEX.AND.NPRFMT.EQ.2.AND.NMODES(I+1).EQ.0)
59753 & WRITE(IUNITT,240) Z
59754 220 FORMAT(54X,F5.3,1X,I3,5(1X,A8))
59755 230 FORMAT(' & ',A1,'multicolumn{7}{|c|}{} & ',F5.3,' & ',I3,
59756 & 5(' & ',A37),' ',A2)
59757 240 FORMAT(A1,'hline')
59758 ENDIF
59759 ENDIF
59760C Close Web particle file
59761 IF (PRNWEB) THEN
59762 WRITE(IUNTW2,250)
59763 CLOSE(IUNTW2)
59764 ENDIF
59765 250 FORMAT('</TABLE>'/'</CENTER>'/'<P>'/
59766 & 'Main particle <A HREF="index.html">index</A>'/
59767 & '</BODY>'/'</HTML>')
59768 260 CONTINUE
59769C Close the LaTeX file
59770 IF (PRNTEX) THEN
59771 WRITE(IUNITT,270) Z,Z,Z
59772 CLOSE(IUNITT)
59773 ENDIF
59774C Close the index file
59775 IF (PRNWEB) THEN
59776 WRITE(IUNTW1,280)
59777 CLOSE(IUNTW1)
59778 ENDIF
59779 270 FORMAT(A1,'end{longtable}'/A1,'end{center}'/A1,'end{document}')
59780 280 FORMAT('</TABLE>'/'</CENTER>'/'</BODY>'/'</HTML>')
59781 END
59782CDECK ID>, HWUECM.
59783*CMZ :- -29/01/93 11.11.55 by Bryan Webber
59784*-- Author : Giovanni Abbiendi & Luca Stanco
59785C---------------------------------------------------------------------
59786 FUNCTION HWUECM (S,M1QUAD,M2QUAD)
59787C-----------------------------------------------------------------------
59788C C.M. ENERGY OF A PARTICLE IN 1-->2 BRANCH, MAY BE SPACELIKE
59789C---------------------------------------------------------------------
59790 IMPLICIT NONE
59791 DOUBLE PRECISION HWUECM,S,M1QUAD,M2QUAD
59792 HWUECM = (S+M1QUAD-M2QUAD)/(2.D0*SQRT(S))
59793 END
59794CDECK ID>, HWUEDT.
59795*CMZ :- -09/12/91 12.07.08 by Mike Seymour
59796*-- Author : Mike Seymour
59797C-----------------------------------------------------------------------
59798 SUBROUTINE HWUEDT(N,IEDT)
59799C-----------------------------------------------------------------------
59800C EDIT THE EVENT RECORD
59801C IF N>0 DELETE THE N ENTRIES IN IEDT FROM EVENT RECORD
59802C IF N<0 INSERT LINES AFTER THE -N ENTRIES IN IEDT
59803C-----------------------------------------------------------------------
c63d70bc 59804 INCLUDE 'herwig65.inc'
65767955 59805 INTEGER N,IEDT(*),IMAP(0:NMXHEP),IHEP,I,J,I1,I2
59806 COMMON /HWUMAP/IMAP
59807C---MOVE ENTRIES AND CALCULATE MAPPING OF POINTERS
59808 IF (N.EQ.0) THEN
59809 RETURN
59810 ELSEIF (N.GT.0) THEN
59811 I=1
59812 I1=1
59813 I2=NHEP
59814 ELSE
59815 I=NHEP-N
59816 I1=NHEP
59817 I2=1
59818 ENDIF
59819 DO 110 IHEP=I1,I2,SIGN(1,I2-I1)
59820 IMAP(IHEP)=I
59821 DO 100 J=1,ABS(N)
59822 IF (IHEP.EQ.IEDT(J)) THEN
59823 IF (N.GT.0) IMAP(IHEP)=0
59824 I=I-1
59825 IF (N.LT.0) IMAP(IHEP)=I
59826 ENDIF
59827 100 CONTINUE
59828 IF (IMAP(IHEP).EQ.I .AND. IHEP.NE.I) THEN
59829 ISTHEP(I)=ISTHEP(IHEP)
59830 IDHW(I)=IDHW(IHEP)
59831 IDHEP(I)=IDHEP(IHEP)
59832 JMOHEP(1,I)=JMOHEP(1,IHEP)
59833 JMOHEP(2,I)=JMOHEP(2,IHEP)
59834 JDAHEP(1,I)=JDAHEP(1,IHEP)
59835 JDAHEP(2,I)=JDAHEP(2,IHEP)
59836 CALL HWVEQU(5,PHEP(1,IHEP),PHEP(1,I))
59837 CALL HWVEQU(4,VHEP(1,IHEP),VHEP(1,I))
59838 ISTHEP(IHEP)=0
59839 IDHW(IHEP)=20
59840 IDHEP(IHEP)=0
59841 JMOHEP(1,IHEP)=0
59842 JMOHEP(2,IHEP)=0
59843 JDAHEP(1,IHEP)=0
59844 JDAHEP(2,IHEP)=0
59845 CALL HWVZRO(5,PHEP(1,IHEP))
59846 CALL HWVZRO(4,VHEP(1,IHEP))
59847 ENDIF
59848 I=I+SIGN(1,N)
59849 110 CONTINUE
59850 NHEP=NHEP-N
59851C---RELABEL POINTERS, SETTING ANY WHICH WERE TO DELETED ENTRIES TO ZERO
59852 IMAP(0)=0
59853 DO 200 IHEP=1,NHEP
59854 JMOHEP(1,IHEP)=IMAP(JMOHEP(1,IHEP))
59855 JMOHEP(2,IHEP)=IMAP(JMOHEP(2,IHEP))
59856 JDAHEP(1,IHEP)=IMAP(JDAHEP(1,IHEP))
59857 JDAHEP(2,IHEP)=IMAP(JDAHEP(2,IHEP))
59858 200 CONTINUE
59859 END
59860CDECK ID>, HWUEEC.
59861*CMZ :- -26/04/91 14.22.30 by Federico Carminati
59862*-- Author : Bryan Webber and Ian Knowles
59863C-----------------------------------------------------------------------
59864 SUBROUTINE HWUEEC(IL)
59865C-----------------------------------------------------------------------
59866C Loads cross-section coefficients, for kinematically open channels,
59867C in llbar-->qqbar; lepton label IL=1-6: e,nu_e,mu,nu_mu,tau,nu_tau.
59868C-----------------------------------------------------------------------
c63d70bc 59869 INCLUDE 'herwig65.inc'
65767955 59870 DOUBLE PRECISION Q2
59871 INTEGER IL,JL,IQ
59872 Q2=EMSCA**2
59873 JL=IL+10
59874 MAXFL=0
59875 TQWT=0.
59876 DO 10 IQ=1,NFLAV
59877 IF (EMSCA.GT.2.*RMASS(IQ)) THEN
59878 MAXFL=MAXFL+1
59879 MAPQ(MAXFL)=IQ
59880 CALL HWUCFF(JL,IQ,Q2,CLQ(1,MAXFL))
59881 TQWT=TQWT+CLQ(1,MAXFL)
59882 ENDIF
59883 10 CONTINUE
59884 IF (MAXFL.EQ.0) CALL HWWARN('HWUEEC',100)
59885 END
59886CDECK ID>, HWUEMV.
59887*CMZ :- -30/06/94 19.31.08 by Mike Seymour
59888*-- Author : Mike Seymour
59889C-----------------------------------------------------------------------
59890 SUBROUTINE HWUEMV(N,IFROM,ITO)
59891C-----------------------------------------------------------------------
59892C MOVE A BLOCK OF ENTRIES IN THE EVENT RECORD
59893C N ENTRIES IN HEPEVT STARTING AT IFROM ARE MOVED TO AFTER ITO
59894C-----------------------------------------------------------------------
c63d70bc 59895 INCLUDE 'herwig65.inc'
65767955 59896 INTEGER N,IFROM,ITO,IMAP(0:NMXHEP),LFROM,LTO,I,IEDT(NMXHEP),IHEP,
59897 $ JHEP,KHEP
59898 COMMON /HWUMAP/IMAP
59899 LFROM=IFROM
59900 LTO=ITO
59901 DO 100 I=1,N
59902 100 IEDT(I)=LTO
59903 CALL HWUEDT(-N,IEDT)
59904 DO 300 I=1,N
59905 IHEP=LTO+I
59906 JHEP=IMAP(LFROM+I-1)
59907 ISTHEP(IHEP)=ISTHEP(JHEP)
59908 IDHW(IHEP)=IDHW(JHEP)
59909 IDHEP(IHEP)=IDHEP(JHEP)
59910 JMOHEP(1,IHEP)=JMOHEP(1,JHEP)
59911 JMOHEP(2,IHEP)=JMOHEP(2,JHEP)
59912 JDAHEP(1,IHEP)=JDAHEP(1,JHEP)
59913 JDAHEP(2,IHEP)=JDAHEP(2,JHEP)
59914 CALL HWVEQU(5,PHEP(1,JHEP),PHEP(1,IHEP))
59915 CALL HWVEQU(4,VHEP(1,JHEP),VHEP(1,IHEP))
59916 DO 200 KHEP=1,NHEP
59917 IF (JMOHEP(1,KHEP).EQ.JHEP) JMOHEP(1,KHEP)=IHEP
59918 IF (JMOHEP(2,KHEP).EQ.JHEP) JMOHEP(2,KHEP)=IHEP
59919 IF (JDAHEP(1,KHEP).EQ.JHEP) JDAHEP(1,KHEP)=IHEP
59920 IF (JDAHEP(2,KHEP).EQ.JHEP) JDAHEP(2,KHEP)=IHEP
59921 200 CONTINUE
59922 IEDT(I)=JHEP
59923 300 CONTINUE
59924 CALL HWUEDT(N,IEDT)
59925 END
59926CDECK ID>, HWUEPR.
59927*CMZ :- -27/07/99 13.33.03 by Mike Seymour
59928*-- Author : Ian Knowles, Bryan Webber & Kosuke Odagiri
59929C-----------------------------------------------------------------------
59930 SUBROUTINE HWUEPR
59931C-----------------------------------------------------------------------
59932C Prints out event data in a number of possible formats:
59933C If (PRNDEF) ASCII to stout
59934C If (PRNTEX) LaTeX to the file HWEV_*******.tex
59935C Please check paper size and offsets given in mm
59936C Uses the package longtable.sty
59937C If (PRVTX>OR.NPRFMT.EQ.2) designed to be printed
59938C as landscape
59939C If (PRNWEB) HTML to the file HWEV_*******.html
59940C Call HWUDPR to create particle property files in
59941C the subdirectory HW_decays/
59942C ******* gives the event number 0000001 etc.
59943C-----------------------------------------------------------------------
c63d70bc 59944 INCLUDE 'herwig65.inc'
65767955 59945 INTEGER MMWIDE,MMLONG,MMHOFF,MMVOFF,I,IST,IS,ID,MS,J,K,IUNITW,
59946 & IUNITT
59947 CHARACTER*1 Z
59948 CHARACTER*2 ZZ
59949 CHARACTER*6 BGCOLS(5),TBCOLS(3),THEAD(17,3)
59950 CHARACTER*7 HWUNST,TMPNME
59951 CHARACTER*16 FNAMET
59952 CHARACTER*17 FNAMEW
59953 CHARACTER*27 FNAMEP
59954 CHARACTER*28 TITLE(11),SECTXT
59955 LOGICAL FIRST(11),NEWSEC
59956 COMMON/PAPER/MMWIDE,MMLONG,MMHOFF,MMVOFF
59957 EXTERNAL HWUNST
59958C
59959 SAVE BGCOLS,TBCOLS,THEAD,TITLE
59960 DATA BGCOLS/'ffffff','0000aa','aa0000','00aa00','aa00ff'/
59961 DATA TBCOLS/'ccccff','9966ff','ffff00'/
59962 DATA THEAD/ 17*'9966ff',17*'ffff00',
59963 & 'IHEP ',' ID ',' IDPDG',' IST ',' MO1 ',' MO2 ',
59964 & ' DA1 ',' DA2 ',' P-X ',' P-Y ',' P-Z ','ENERGY',
59965 & ' MASS ',' V-X ',' V-Y ',' V-Z ',' V-C*T'/
59966 DATA TITLE/' ---INITIAL STATE--- ',
59967 & ' ---HARD SUBPROCESS--- ',
59968 & ' ---PARTON SHOWERS--- ',
59969 & ' ---GLUON SPLITTING--- ',
59970 & ' ---CLUSTER FORMATION--- ',
59971 & ' ---CLUSTER DECAYS--- ',
59972 & ' ---STRONG HADRON DECAYS--- ',
59973 & ' ---HEAVY PARTICLE DECAYS---',
59974 & ' ---H/W/Z BOSON DECAYS--- ',
59975 & ' ---SOFT UNDERLYING EVENT---',
59976 & ' ---MULTIPLE SCATTERING--- '/
59977 Z=CHAR(92)
59978 ZZ=Z//Z
59979C
59980 IUNITT=50
59981 IUNITW=51
59982C Write out any required file header information
59983 TMPNME=HWUNST(NEVHEP)
59984 IF (PRNTEX) THEN
59985 WRITE(FNAMET,'(A5,A7,A4)') 'HWEV_',TMPNME,'.tex'
59986 OPEN(IUNITT,STATUS='UNKNOWN',FILE=FNAMET)
59987 IF (PRVTX.OR.NPRFMT.EQ.2) THEN
59988 WRITE(IUNITT,10) Z,Z,Z,MMLONG,Z,MMWIDE,Z,MMVOFF,Z,MMHOFF,Z,Z,Z
59989 ELSE
59990 WRITE(IUNITT,10) Z,Z,Z,MMWIDE,Z,MMLONG,Z,MMHOFF,Z,MMVOFF,Z,Z,Z
59991 ENDIF
59992 ENDIF
59993 IF (PRNWEB) THEN
59994 WRITE(FNAMEW,'(A5,A7,A5)') 'HWEV_',TMPNME,'.html'
59995 OPEN(IUNITW,STATUS='UNKNOWN',FILE=FNAMEW)
59996 WRITE(IUNITW,20) BGCOLS
59997 ENDIF
59998 10 FORMAT(A1,'documentclass{article}'/A1,'usepackage{longtable}'/
59999 & A1,'textwidth ',I4,'mm ',A1,'textheight ',I4,'mm'/
60000 & A1,'hoffset ',I4,'mm ',A1,'voffset ',I4,'mm'/
60001 & A1,'pagestyle{empty}'/A1,'begin{document}'/A1,'begin{center}')
60002 20 FORMAT('<!-- No Less productions -->'/'<HTML>'/'<HEAD>'/
60003 & '<TITLE>HERWIG Event Record</TITLE>'/'</HEAD>'/
60004 & '<BODY BGCOLOR=#',A6,' TEXT=#',A6,' LINK=#',A6,
60005 & ' ALINK=#',A6,' VLINK=#',A6,'>')
60006C Write out event header details and set up tables
60007 IF (PRNDEF) THEN
60008 WRITE(6,30) NEVHEP,PBEAM1,PART1,PBEAM2,PART2,
60009 & IPROC,NRN,ISTAT,IERROR,EVWGT
60010 ENDIF
60011 IF (PRNTEX) THEN
60012 WRITE(IUNITT,40) Z,Z,Z,ISTAT,ZZ,Z,
60013 & IPROC,PBEAM1,PBEAM2,NRN(1),
60014 & IERROR,ZZ,Z,Z,NEVHEP,TXNAME(1,IDHW(1)),TXNAME(1,IDHW(2)),
60015 & NRN(2),EVWGT,ZZ,Z,Z,Z
60016 IF (PRVTX) THEN
60017 WRITE(IUNITT,50) Z,Z,Z,Z,Z
60018 ELSE
60019 WRITE(IUNITT,60) Z,Z,Z,Z,Z
60020 ENDIF
60021 ENDIF
60022 IF (PRNWEB) THEN
60023 WRITE(IUNITW,70) TBCOLS(1),TBCOLS(2),(TBCOLS(2),TBCOLS(3),
60024 & I=1,4),ISTAT,TBCOLS(2),TBCOLS(3),
60025 & IPROC,PBEAM1,PBEAM2,NRN(1),
60026 & TBCOLS(2),TBCOLS(3),IERROR
60027 WRITE(IUNITW,71) TBCOLS(2),TBCOLS(3),NEVHEP,TXNAME(2,IDHW(1)),
60028 & TXNAME(2,IDHW(2)),NRN(2),TBCOLS(2),TBCOLS(3),EVWGT,TBCOLS(1)
60029 ENDIF
60030 30 FORMAT(///1X,'EVENT ',I7,':',F8.2,' GEV/C ',A8,' ON ',F8.2,
60031 & ' GEV/C ',A8,' PROCESS:',I6/1X,'SEEDS: ',I11,' & ',I11,
60032 & ' STATUS: ',I4,' ERROR:',I4,' WEIGHT: ',1P,E11.4/)
60033 40 FORMAT(A1,'begin{tabular}{|l|r|c|c|r|l|c|}'/A1,'hline'/
60034 & A1,'multicolumn{2}{|c|}{HERWIG 6.5} & Beam 1: & Beam 2: & ',
60035 & 'Seeds: & Status: & ',I4, ' ',A2/A1,'hline'/'Process: & ',I6,
60036 & ' & ',F8.2,'~GeV/c & ',F8.2,'~GeV/c',' & ',I11,' & Error: & ',
60037 & I4,' ',A2/A1,'cline{1-2} ',A1,'cline{6-7}'/'Event: & ',I7,' & ',
60038 & A37,' & ',A37,' & ',I11,' & Weight: & ',1P,E11.4,' ',A2/A1,
60039 & 'hline'/A1,'end{tabular}'/A1,'vskip 5mm')
60040 50 FORMAT(A1,'begin{longtable}{|r|c|r|r|r|r|r|r|r|r|r|r|r|r|r|r|r|}'/
60041 & A1,'hline'/A1,'endhead'/A1,'hline'/A1,'endfoot')
60042 60 FORMAT(A1,'begin{longtable}{|r|c|r|r|r|r|r|r|r|r|r|r|r|}'/
60043 & A1,'hline'/A1,'endhead'/A1,'hline'/A1,'endfoot')
60044 70 FORMAT(/'<CENTER>'/'<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>'/
60045 & '<TR>'/'<TH BGCOLOR=#',A6,' COLSPAN=2>',
60046 & '<A HREF="http://hepwww.rl.ac.uk/theory/seymour/herwig/">',
60047 & 'HERWIG 6.5</A></TH>'/
60048 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Beam 1:</FONT></TH>'/
60049 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Beam 2:</FONT></TH>'/
60050 & '<TH BGCOLOR=#',A6,'><FONT COLOR=#',A6,'>Seeds:</FONT></TH>'/
60051 & '<TH BGCOLOR=#',A6,' ALIGN="LEFTT"><FONT COLOR=#',A6,
60052 & '>Status:</FONT></TH>'/'<TD ALIGN="RIGHT">',I4,'</TD>'/'</TR>'/
60053 & '<TR>'/
60054 & '<TH BGCOLOR=#',A6,' ALIGN="LEFTT"><FONT COLOR=#',A6,
60055 & '>Process:</Th>'/'<TD>',I6,'</TD>'/
60056 & '<TD>',F8.2,' GeV/c</TD>'/'<TD>',F8.2,' GeV/c</TD>'/
60057 & '<TD ALIGN="RIGHT">',I11,'</TD>'/
60058 & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
60059 & '>Error:</FONT></TH>'/'<TD ALIGN="RIGHT">',I4,'</TD>'/'</TR>')
60060 71 FORMAT('<TR>'/
60061 & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
60062 & '>Event:</Th>'/'<TD ALIGN="RIGHT">',I7,'</TD>'/
60063 & '<TD ALIGN="CENTER">',A37,'</TD>'/
60064 & '<TD ALIGN="CENTER">',A37,'</TD>'/
60065 & '<TD ALIGN="RIGHT">',I11,'</TD>'/
60066 & '<TH BGCOLOR=#',A6,' ALIGN="LEFT"><FONT COLOR=#',A6,
60067 & '>Weight:</FONT></TH>'/'<TD>',1P,E11.4,'</TD>'/'</TR>'/
60068 & '</TABLE>'//'<P>'/
60069 & '<TABLE ALIGN="CENTER" BGCOLOR=#',A6,'>')
60070C Initialize control flags
60071 DO 80 I=1,11
60072 80 FIRST(I)=.TRUE.
60073C Loop through event record
60074 DO 410 I=1,NHEP
60075 NEWSEC=.FALSE.
60076C First find start of new sections
60077 IST=ISTHEP(I)
60078 IS=IST/10
60079 ID=IDHW(I)
60080 IF (IST.EQ.101) THEN
60081 NEWSEC=.TRUE.
60082 SECTXT=TITLE(1)
60083 ELSEIF (FIRST(2).AND.IS.EQ.12) THEN
60084 NEWSEC=.TRUE.
60085 SECTXT=TITLE(2)
60086 FIRST(2)=.FALSE.
60087 ELSEIF (FIRST(3).AND.IS.EQ.14) THEN
60088 NEWSEC=.TRUE.
60089 SECTXT=TITLE(3)
60090 FIRST(3)=.FALSE.
60091 FIRST(8)=.TRUE.
60092 FIRST(9)=.TRUE.
60093 FIRST(11)=.TRUE.
60094 ELSEIF (FIRST(4).AND.IST.GE.158.AND.IST.NE.160
60095 & .AND.IST.LE.162) THEN
60096 NEWSEC=.TRUE.
60097 SECTXT=TITLE(4)
60098 FIRST(4)=.FALSE.
60099 ELSEIF (FIRST(5).AND.(IS.EQ.16.OR.IS.EQ.18)
60100 & .AND.IST.GT.162) THEN
60101 NEWSEC=.TRUE.
60102 SECTXT=TITLE(5)
60103 FIRST(5)=.FALSE.
60104 ELSEIF (IS.EQ.19.OR.IST.EQ.1.OR.IST.EQ.200) THEN
60105 MS=ISTHEP(JMOHEP(1,I))/10
60106 IF (MS.EQ.15.OR.MS.EQ.16.OR.MS.EQ.18) THEN
60107 IF (FIRST(6)) THEN
60108 NEWSEC=.TRUE.
60109 SECTXT=TITLE(6)
60110 FIRST(6)=.FALSE.
60111 ENDIF
60112 ELSEIF (FIRST(7).AND.(.NOT.FIRST(6))) THEN
60113 NEWSEC=.TRUE.
60114 SECTXT=TITLE(7)
60115 FIRST(7)=.FALSE.
60116 ENDIF
60117 ELSEIF (FIRST(8).AND.(IST.EQ.125.OR.IST.EQ.155.OR.
60118 & (IST.EQ.123.AND.ISTHEP(JMOHEP(1,I)).EQ.199))) THEN
60119 NEWSEC=.TRUE.
60120 SECTXT=TITLE(8)
60121 FIRST(3)=.TRUE.
60122 FIRST(4)=.TRUE.
60123 FIRST(5)=.TRUE.
60124 FIRST(6)=.TRUE.
60125 FIRST(7)=.TRUE.
60126 FIRST(8)=.FALSE.
60127 ELSEIF (FIRST(9).AND.(IST.EQ.123.OR.IST.EQ.124)) THEN
60128 MS=ABS(IDHEP(JMOHEP(1,I)))
60129 IF (MS.EQ.23.OR.MS.EQ.24.OR.MS.EQ.25) THEN
60130 NEWSEC=.TRUE.
60131 SECTXT=TITLE(9)
60132 FIRST(3)=.TRUE.
60133 FIRST(4)=.TRUE.
60134 FIRST(5)=.TRUE.
60135 FIRST(6)=.TRUE.
60136 FIRST(7)=.TRUE.
60137 FIRST(8)=.TRUE.
60138 FIRST(9)=.FALSE.
60139 ENDIF
60140 ELSEIF (IST.EQ.170) THEN
60141 NEWSEC=.TRUE.
60142 SECTXT=TITLE(10)
60143 FIRST(6)=.FALSE.
60144 FIRST(7)=.FALSE.
60145 FIRST(8)=.FALSE.
60146 ELSEIF (FIRST(11).AND.(ID.EQ.71.OR.ID.EQ.72)) THEN
60147 NEWSEC=.TRUE.
60148 SECTXT=TITLE(11)
60149 FIRST(3)=.TRUE.
60150 FIRST(11)=.FALSE.
60151 ENDIF
60152C Print out section heading
60153 IF (NEWSEC) THEN
60154 IF (PRVTX) THEN
60155 IF (PRNDEF) THEN
60156 IF (NPRFMT.EQ.1) THEN
60157 WRITE(6, 90) SECTXT,(THEAD(J,3),J=1,17)
60158 ELSE
60159 WRITE(6,100) SECTXT,(THEAD(J,3),J=1,17)
60160 ENDIF
60161 ENDIF
60162 IF (PRNTEX) WRITE(IUNITT,110) Z,Z,SECTXT,ZZ,Z,
60163 & (Z,THEAD(J,3),J=1,17),ZZ,Z
60164 IF (PRNWEB) WRITE(IUNITW,120) TBCOLS(2),TBCOLS(3),
60165 & SECTXT,((THEAD(K,J),J=1,3),K=1,17)
60166 90 FORMAT(/46X,A28//1X,A4,2X,A6,3X,A6,5A4,3(2X,A6),A6,3X,A5,
60167 & 4(4X,A6))
60168 100 FORMAT(/58X,A28//1X,A4,2X,A6,3X,A6,5A4,3(6X,A6),5X,A6,8X,A5,
60169 & 4X,A6,2(5X,A6),6X,A6)
60170 110 FORMAT(A1,'hline'/A1,'multicolumn{17}{|c|}{',A28,'} ',A2/A1,
60171 & 'hline'/16(A1,'multicolumn{1}{|c|}{',A6,'} & '),
60172 & A1,'multicolumn{1}{|c|}{',A6,'} ',A2/A1,'hline')
60173 120 FORMAT('<TR><TH COLSPAN=17 BGCOLOR=#',A6,'>',
60174 & '<FONT COLOR=#',A6,'>',A28,'</FONT></TH></TR>'/
60175 & '<TR>',17(/,1X,'<TH BGCOLOR=#',A6,'>
60176 & <FONT COLOR=',A6,'>',A6,'</FONT></TH>'),'</TR>')
60177 ELSE
60178 IF (PRNDEF) THEN
60179 IF (NPRFMT.EQ.1) THEN
60180 WRITE(6,130) SECTXT,(THEAD(J,3),J=1,13)
60181 ELSE
60182 WRITE(6,140) SECTXT,(THEAD(J,3),J=1,13)
60183 ENDIF
60184 END IF
60185 IF (PRNTEX) WRITE(IUNITT,150) Z,Z,SECTXT,ZZ,Z,
60186 & (Z,THEAD(J,3),J=1,13),ZZ,Z
60187 IF (PRNWEB) WRITE(IUNITW,160) TBCOLS(2),TBCOLS(3),
60188 & SECTXT,((THEAD(K,J),J=1,3),K=1,13)
60189 130 FORMAT(/26X,A28//1X,A4,2X,A6,3X,A6,5A4,3(2X,A6),A6,3X,A5)
60190 140 FORMAT(/36X,A28//1X,A4,2X,A6,3X,A6,5A4,3(6X,A6),5X,A6,8X,A5)
60191 150 FORMAT(A1,'hline'/A1,'multicolumn{13}{|c|}{',A28,'} ',A2/A1,
60192 & 'hline'/12(A1,'multicolumn{1}{|c|}{',A6,'} & '),
60193 & A1,'multicolumn{1}{|c|}{',A6,'} ',A2/A1,'hline')
60194 160 FORMAT('<TR><TH COLSPAN=13 BGCOLOR=#',A6,'>',
60195 & '<FONT COLOR=#',A6,'>',A28,'</FONT></TH></TR>'/
60196 & '<TR>',13(/'<TH BGCOLOR=#',A6,'>',
60197 & '<FONT COLOR=#',A6,'>',A6,'</FONT></TH>'),'</TR>')
60198 ENDIF
60199 ENDIF
60200C Now print out the data line
60201 IF (PRVTX) THEN
60202C Include vertex information
60203 IF (PRNDEF) THEN
60204 IF (PRNDEC) THEN
60205 IF (NPRFMT.EQ.1) THEN
60206 WRITE(6,190) I,RNAME(IDHW(I)),IDHEP(I),IST,
60207 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60208 & (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
60209 ELSE
60210 WRITE(6,200) I,RNAME(IDHW(I)),IDHEP(I),IST,
60211 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60212 & (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
60213 ENDIF
60214 ELSE
60215 IF (NPRFMT.EQ.1) THEN
60216 WRITE(6,210) I,RNAME(IDHW(I)),IDHEP(I),IST,
60217 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60218 & (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
60219 ELSE
60220 WRITE(6,220) I,RNAME(IDHW(I)),IDHEP(I),IST,
60221 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60222 & (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
60223 ENDIF
60224 ENDIF
60225 ENDIF
60226 IF (PRNTEX) WRITE(IUNITT,230) I,TXNAME(1,IDHW(I)),IDHEP(I),
60227 & IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60228 & (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4),ZZ
60229 IF (PRNWEB) THEN
60230 WRITE(IUNITW,240) TBCOLS(2),TBCOLS(3),I,I
60231 IF (IDHEP(I).EQ.0.OR.IDHEP(I).EQ.91) THEN
60232 WRITE(IUNITW,250) TXNAME(2,IDHW(I)),IDHEP(I),IST
60233 ELSE
60234 TMPNME=HWUNST(IDHW(I))
60235 WRITE(FNAMEP,'(A15,A7,A5)')
60236 & 'HW_decays/PART_',TMPNME,'.html'
60237 WRITE(IUNITW,260) FNAMEP,TXNAME(2,IDHW(I)),IDHEP(I),IST
60238 ENDIF
60239 DO 170 J=1,2
60240 IF (JMOHEP(J,I).NE.0) THEN
60241 WRITE(IUNITW,270) JMOHEP(J,I),JMOHEP(J,I)
60242 ELSE
60243 WRITE(IUNITW,280) JMOHEP(J,I)
60244 ENDIF
60245 170 CONTINUE
60246 DO 180 J=1,2
60247 IF (JDAHEP(J,I).NE.0) THEN
60248 WRITE(IUNITW,270) JDAHEP(J,I),JDAHEP(J,I)
60249 ELSE
60250 WRITE(IUNITW,280) JDAHEP(J,I)
60251 ENDIF
60252 180 CONTINUE
60253 IF (NPRFMT.EQ.1) THEN
60254 WRITE(IUNITW,290) (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
60255 ELSE
60256 WRITE(IUNITW,300) (PHEP(J,I),J=1,5),(VHEP(J,I),J=1,4)
60257 ENDIF
60258 ENDIF
60259 190 FORMAT(1X,I4,1X,A8,I8,5I4, 2F8.2,2F7.1,F8.2,1P,4E10.3)
60260 200 FORMAT(1X,I4,1X,A8,I8,5I4, 5F12.5,1P,4E11.4)
60261 210 FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,2F8.2,2F7.1,F8.2,1P,4E10.3)
60262 220 FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,5F12.5,1P,4E11.4)
60263 230 FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
60264 & 5(' & $',F8.2,'$'),4(' & $',1P,E11.3,'$'),' ',A2)
60265 240 FORMAT('<TR>'/'<TD BGCOLOR=#',A6,' ALIGN="RIGHT">',
60266 & '<FONT COLOR=#',A6,'><A NAME="',I4,'">',I4,'</A></FONT></TD>'/)
60267 250 FORMAT('<TD ALIGN="CENTER">',A37,'</TD>'/'<TD ALIGN="RIGHT">',
60268 & I8,'</TD>'/'<TD ALIGN="RIGHT">',I4,'</TD>')
60269 260 FORMAT('<TD ALIGN="CENTER"><A HREF="',A27,'">',A37,'</A></TD>'/
60270 & '<TD ALIGN="RIGHT">',I8,'</TD>'/
60271 & '<TD ALIGN="RIGHT">',I4,'</TD>')
60272 270 FORMAT(/'<TD ALIGN="RIGHT"><A HREF="#',I4,'">',I4,'</A></TD>')
60273 280 FORMAT(/'<TD ALIGN="RIGHT">',I4,'</TD>')
60274 290 FORMAT(5(/'<TD ALIGN="RIGHT">',F8.2,'</TD>'),1P,
60275 & 4(/'<TD ALIGN="RIGHT">',E10.3,'</TD>')/'</TR>')
60276 300 FORMAT(5(/'<TD ALIGN="RIGHT">',F12.5,'</TD>'),1P,
60277 & 4(/'<TD ALIGN="RIGHT">',E11.4,'</TD>')/'</TR>')
60278 ELSE
60279C Do not include vertex information
60280 IF (PRNDEF) THEN
60281 IF (PRNDEC) THEN
60282 IF (NPRFMT.EQ.1) THEN
60283 WRITE(6,330) I,RNAME(IDHW(I)),IDHEP(I),IST,
60284 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60285 & (PHEP(J,I),J=1,5)
60286 ELSE
60287 WRITE(6,340) I,RNAME(IDHW(I)),IDHEP(I),IST,
60288 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60289 & (PHEP(J,I),J=1,5)
60290 ENDIF
60291 ELSE
60292 IF (NPRFMT.EQ.1) THEN
60293 WRITE(6,350) I,RNAME(IDHW(I)),IDHEP(I),IST,
60294 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60295 & (PHEP(J,I),J=1,5)
60296 ELSE
60297 WRITE(6,360) I,RNAME(IDHW(I)),IDHEP(I),IST,
60298 & JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60299 & (PHEP(J,I),J=1,5)
60300 ENDIF
60301 ENDIF
60302 ENDIF
60303 IF (PRNTEX) THEN
60304 IF (NPRFMT.EQ.1) THEN
60305 WRITE(IUNITT,370) I,TXNAME(1,IDHW(I)),IDHEP(I),
60306 & IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60307 & (PHEP(J,I),J=1,5),ZZ
60308 ELSE
60309 WRITE(IUNITT,380) I,TXNAME(1,IDHW(I)),IDHEP(I),
60310 & IST,JMOHEP(1,I),JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),
60311 & (PHEP(J,I),J=1,5),ZZ
60312 ENDIF
60313 ENDIF
60314 IF (PRNWEB) THEN
60315 WRITE(IUNITW,240) TBCOLS(2),TBCOLS(3),I,I
60316 IF (IDHEP(I).EQ.0.OR.IDHEP(I).EQ.91) THEN
60317 WRITE(IUNITW,250) TXNAME(2,IDHW(I)),IDHEP(I),IST
60318 ELSE
60319 TMPNME = HWUNST(IDHW(I))
60320 WRITE(FNAMEP,'(A15,A7,A5)')
60321 & 'HW_decays/PART_',TMPNME,'.html'
60322 WRITE(IUNITW,260) FNAMEP,TXNAME(2,IDHW(I)),IDHEP(I),IST
60323 ENDIF
60324 DO 310 J=1,2
60325 IF (JMOHEP(J,I).NE.0) THEN
60326 WRITE(IUNITW,270) JMOHEP(J,I),JMOHEP(J,I)
60327 ELSE
60328 WRITE(IUNITW,280) JMOHEP(J,I)
60329 ENDIF
60330 310 CONTINUE
60331 DO 320 J=1,2
60332 IF (JDAHEP(J,I).NE.0) THEN
60333 WRITE(IUNITW,270) JDAHEP(J,I),JDAHEP(J,I)
60334 ELSE
60335 WRITE(IUNITW,280) JDAHEP(J,I)
60336 ENDIF
60337 320 CONTINUE
60338 IF (NPRFMT.EQ.1) THEN
60339 WRITE(IUNITW,390) (PHEP(J,I),J=1,5)
60340 ELSE
60341 WRITE(IUNITW,400) (PHEP(J,I),J=1,5)
60342 ENDIF
60343 ENDIF
60344 330 FORMAT(1X,I4,1X,A8,I8,5I4 ,2F8.2,2F7.1,F8.2)
60345 340 FORMAT(1X,I4,1X,A8,I8,5I4 ,5F12.5)
60346 350 FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,2F8.2,2F7.1,F8.2)
60347 360 FORMAT(1X,Z4,1X,A8,I8,I4,4Z4,5F12.5)
60348 370 FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
60349 & 5(' & $',F8.2,'$'),' ',A2)
60350 380 FORMAT(I4,' & ',A37,' & $',I8,'$',5(' & ',I4),
60351 & 5(' & $',F12.5,'$'),' ',A2)
60352 390 FORMAT(5(/'<TD ALIGN="RIGHT">',F8.2,'</TD>')/'</TR>')
60353 400 FORMAT(5(/'<TD ALIGN="RIGHT">',F12.5,'</TD>')/'</TR>')
60354 ENDIF
60355 410 CONTINUE
60356C Close the files
60357 IF (PRNTEX) THEN
60358 WRITE(IUNITT,420) Z,Z,Z
60359 420 FORMAT(A1,'end{longtable}'/A1,'end{center}'/A1,'end{document}')
60360 CLOSE(IUNITT)
60361 ENDIF
60362 IF (PRNWEB) THEN
60363 WRITE(IUNITW,430)
60364 430 FORMAT('</TABLE>'/'</CENTER>'/'</BODY>'/'</HTML>')
60365 CLOSE(IUNITW)
60366 ENDIF
60367 END
60368CDECK ID>, HWUGUP.
60369*CMZ :- -13/02/02 07.20.46 by Peter Richardson
60370*-- Author : Peter Richardson
60371C-----------------------------------------------------------------------
60372 SUBROUTINE HWUGUP
60373C-----------------------------------------------------------------------
60374C Subroutine to handle termination of HERWIG if reaches end of event
60375C file
60376C-----------------------------------------------------------------------
c63d70bc 60377 INCLUDE 'herwig65.inc'
65767955 60378C--reset the number of events to the correct value
60379 NEVHEP = NEVHEP-1
60380C--output information on the events
60381 CALL HWEFIN
60382 STOP
60383 END
60384CDECK ID>, HWUFNE.
60385*CMZ :- -16/10/93 12.42.15 by Mike Seymour
60386*-- Author : Mike Seymour
60387C-----------------------------------------------------------------------
60388 SUBROUTINE HWUFNE
60389C-----------------------------------------------------------------------
60390C FINALISES THE EVENT BY UNDOING THE LORENTZ BOOST IF THERE WAS ONE,
60391C CHECKING FOR ERRORS, AND PRINTING
60392C-----------------------------------------------------------------------
c63d70bc 60393 INCLUDE 'herwig65.inc'
65767955 60394 INTEGER IHEP
60395 LOGICAL CALLED
60396 COMMON/HWDBUG/CALLED
60397 CALLED=.TRUE.
60398C---UNBOOST EVENT RECORD IF NECESSARY
60399 CALL HWUBST(0)
60400C---CHECK FOR NEGATIVE ENERGY PARTICLES (REMNANT BUG?)
60401 DO IHEP=1,NHEP
60402 IF (ISTHEP(IHEP).EQ.1.AND.PHEP(4,IHEP).LT.ZERO) THEN
60403 CALL HWWARN('HWUFNE',100)
60404 GOTO 99
60405 ENDIF
60406 ENDDO
60407 99 CONTINUE
60408C---CHANGE LIGHTEST SUSY HIGGS CODE TO THE PDG VALUE
60409 DO IHEP=1,NHEP
60410 IF (IDHEP(IHEP).EQ.26) IDHEP(IHEP)=25
60411 ENDDO
60412C---CHECK FOR FATAL ERROR
60413 IF (IERROR.NE.0) THEN
60414 IF (IERROR.GT.0) THEN
60415 NUMER=NUMER+1
60416 ELSE
60417 NUMERU=NUMERU+1
60418 ENDIF
60419 IF (NUMER.GT.MAXER) CALL HWWARN('HWUFNE',300)
60420 NEVHEP=NEVHEP-1
60421 IF (NEGWTS.AND.EVWGT.LT.ZERO) NNEGEV=NNEGEV-1
60422C---PRINT FIRST MAXPR EVENTS
60423 ELSEIF (NEVHEP.LE.MAXPR) THEN
60424 CALL HWUEPR
60425 END IF
60426 END
60427CDECK ID>, HWUGAU.
60428*CMZ :- -26/04/91 11.11.56 by Bryan Webber
60429*-- Author : Adapted by Bryan Webber
60430C-----------------------------------------------------------------------
60431 FUNCTION HWUGAU(F,A,B,EPS)
60432C-----------------------------------------------------------------------
60433C ADAPTIVE GAUSSIAN INTEGRATION OF FUNCTION F
60434C IN INTERVAL (A,B) WITH PRECISION EPS
60435C (MODIFIED CERN LIBRARY ROUTINE GAUSS)
60436C-----------------------------------------------------------------------
60437 IMPLICIT NONE
60438 DOUBLE PRECISION HWUGAU,F,A,B,EPS,CONST,AA,BB,C1,C2,S8,U,S16,
60439 & W(12),X(12),ZERO
60440 INTEGER I
60441 EXTERNAL F
60442 PARAMETER (ZERO=0.0D0)
60443 SAVE W,X
60444 DATA W/.1012285363D0,.2223810345D0,.3137066459D0,
60445 & .3626837834D0,.0271524594D0,.0622535239D0,
60446 & .0951585117D0,.1246289713D0,.1495959888D0,
60447 & .1691565194D0,.1826034150D0,.1894506105D0/
60448 DATA X/.9602898565D0,.7966664774D0,.5255324099D0,
60449 & .1834346425D0,.9894009350D0,.9445750231D0,
60450 & .8656312024D0,.7554044084D0,.6178762444D0,
60451 & .4580167777D0,.2816035508D0,.0950125098D0/
60452 HWUGAU=0.
60453 IF (A.EQ.B) RETURN
60454 CONST=.005/ABS(B-A)
60455 BB=A
60456 1 AA=BB
60457 BB=B
60458 2 C1=0.5*(BB+AA)
60459 C2=0.5*(BB-AA)
60460 S8=0.
60461 DO 3 I=1,4
60462 U=C2*X(I)
60463 S8=S8+W(I)*(F(C1+U)+F(C1-U))
60464 3 CONTINUE
60465 S8=C2*S8
60466 S16=0.
60467 DO 4 I=5,12
60468 U=C2*X(I)
60469 S16=S16+W(I)*(F(C1+U)+F(C1-U))
60470 4 CONTINUE
60471 S16=C2*S16
60472 IF (ABS(S16-S8).LE.EPS*(1.+ABS(S16))) GOTO 5
60473 BB=C1
60474 IF (CONST*ABS(C2).NE.ZERO) GOTO 2
60475C---TOO HIGH ACCURACY REQUESTED
60476 CALL HWWARN('HWUGAU',500)
60477 5 HWUGAU=HWUGAU+S16
60478 IF (BB.NE.B) GOTO 1
60479 END
60480CDECK ID>, HWUIDT.
60481*CMZ :- -26/04/91 10.18.58 by Bryan Webber
60482*-- Author : Bryan Webber
60483C-----------------------------------------------------------------------
60484 SUBROUTINE HWUIDT(IOPT,IPDG,IWIG,NWIG)
60485C-----------------------------------------------------------------------
60486C TRANSLATES PARTICLE IDENTIFIERS:
60487C IPDG = PARTICLE DATA GROUP CODE
60488C IWIG = HERWIG IDENTITY CODE
60489C NWIG = HERWIG CHARACTER*8 NAME
60490C
60491C IOPT= 1 GIVEN IPDG, RETURNS IWIG AND NWIG
60492C IOPT= 2 GIVEN IWIG, RETURNS IPDG AND NWIG
60493C IOPT= 3 GIVEN NWIG, RETURNS IPDG AND IWIG
60494C-----------------------------------------------------------------------
c63d70bc 60495 INCLUDE 'herwig65.inc'
65767955 60496 INTEGER IOPT,IPDG,IWIG,I
60497 CHARACTER*8 NWIG
60498 IF (IOPT.EQ.1) THEN
60499 DO 10 I=0,NRES
60500 IF (IDPDG(I).EQ.IPDG) THEN
60501 IWIG=I
60502 NWIG=RNAME(I)
60503 RETURN
60504 ENDIF
60505 10 CONTINUE
60506 WRITE(6,20) IPDG
60507 20 FORMAT(1X,'Particle not recognised, PDG code: ',I8)
60508 IWIG=20
60509 NWIG=RNAME(20)
60510 CALL HWWARN('HWUIDT',101)
60511 GOTO 999
60512 ELSEIF (IOPT.EQ.2) THEN
60513 IF (IWIG.LT.0.OR.IWIG.GT.NRES) THEN
60514 WRITE(6,30) IWIG
60515 30 FORMAT(1X,'Particle not recognised, HERWIG code: ',I3)
60516 IPDG=0
60517 NWIG=RNAME(20)
60518 CALL HWWARN('HWUIDT',102)
60519 GOTO 999
60520 ELSE
60521 IPDG=IDPDG(IWIG)
60522 NWIG=RNAME(IWIG)
60523 RETURN
60524 ENDIF
60525 ELSEIF (IOPT.EQ.3) THEN
60526 DO 40 I=0,NRES
60527 IF (RNAME(I).EQ.NWIG) THEN
60528 IWIG=I
60529 IPDG=IDPDG(I)
60530 RETURN
60531 ENDIF
60532 40 CONTINUE
60533 WRITE(6,50) NWIG
60534 50 FORMAT(1X,'Particle not recognised, HERWIG name: ',A8)
60535 IWIG=20
60536 IPDG=0
60537 CALL HWWARN('HWUIDT',103)
60538 GOTO 999
60539 ELSE
60540 CALL HWWARN('HWUIDT',404)
60541 ENDIF
60542 999 RETURN
60543 END
60544CDECK ID>, HWUINC.
60545*CMZ :- -12/10/01 09.56.07 by Peter Richardson
60546*-- Author : Bryan Webber
60547C-----------------------------------------------------------------------
60548 SUBROUTINE HWUINC
60549C-----------------------------------------------------------------------
60550C COMPUTES CONSTANTS AND LOOKUP TABLES
60551C---BRW change 27/8/04: include Frixione's fix to reduce PDFSET calls
60552C-----------------------------------------------------------------------
c63d70bc 60553 INCLUDE 'herwig65.inc'
65767955 60554 DOUBLE PRECISION HWBVMC,HWUALF,HWUPCM,XMIN,XMAX,XPOW,QR,DQKWT,
60555 & UQKWT,SQKWT,DIQWT,QMAX,PMAX,PTLIM,ETLIM,PGS,PTELM,X,QSCA,UPV,DNV,
60556 & USEA,DSEA,STR,CHM,BTM,TOP,GLU,VAL(20),CLMXPW,RCLPOW,TEST,RPM(2)
60557 INTEGER ISTOP,I,J,IQK,IDB,IDT,ISET,IOP1,IOP2,IP2,ID,IH,IV
60558 INTEGER LPROC,KPROC
60559 INTEGER IS,IP(3),IQ
60560 COMMON/SQSQH/JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
60561 INTEGER JHIGGS,ILBL,JH,IF1MIN,IF1MAX,IF2MIN,IF2MAX
60562 INTEGER ISQ1,ISQ2
60563 INTEGER IHLP,JHLP,KHLP,ISIGN,ITMP(8)
60564 LOGICAL FIRST,FSTPDF
60565 CHARACTER*20 PARM(20)
60566 EXTERNAL HWBVMC,HWUALF,HWUPCM
60567 COMMON/HWRPIN/XMIN,XMAX,XPOW,FIRST
60568 COMMON/W50516/FSTPDF
60569 CHARACTER*20 PARMSAVE
60570 DOUBLE PRECISION VALSAVE
60571 COMMON/HWSFSA/PARMSAVE
60572 COMMON/HWSFSB/VALSAVE
60573 SAVE ITMP
60574 DATA ITMP/0,12,-12,0,0,12,-12,0/
60575C--read in the information frmo the Les Houches common block if needed
60576 IF(IPROC.LE.0) CALL HWIGUP
60577C---MSSM Higgs processes: additional IDs to distinguish from SM-like ones.
60578 IMSSM=0
60579 IHIGGS=0
60580C---Sets even parity of Higgs bosons (in the coupling to fermions) as default.
60581 PARITY=1
60582C...define parity of Neutral MSSM Higgses.
60583 IP(1)=+1
60584 IP(2)=+1
60585 IP(3)=-1
60586C---IPRO=9,11 (lepton-lepton); 31...38 (hadron-hadron) MSSM Higgs production.
60587 LPROC=MOD(IPROC,10000)
60588 IF((LPROC.LT.3100).OR.(LPROC.GE.3900))THEN
60589C...add here MSSM Higgs processes in lepton-lepton collisions.
60590 IF((LPROC/100.NE.9).AND.(LPROC/100.NE.11))GOTO 666
60591 END IF
60592C-----------------------------------------------------------------------
60593C HARD 2 LEPTON/PARTON -> HIGGS + X PROCESSES IN MSSM
60594C IH = 1 MSSM h^0 IV = 0 SM W+/- IQ = 1,3,5 d,s,b-quark
60595C = 2 MSSM H^0 = 1 SM Z 2,4,6 u,c,t-quark
60596C = 3 MSSM A^0 ID = IQ, IL
60597C = 4/5 MSSM H^+/- IL = 1,2,3 e,mu,tau-lepton
60598C-----------------------------------------------------------------------
60599C...leptonic processes.
60600 IF(LPROC/100.EQ.9)THEN
60601 IF(LPROC.EQ.955)THEN
60602 IMSSM=-1
60603 IHIGGS=206-201
60604 ELSE IF(LPROC.EQ.965)THEN
60605 IHIGGS=203-201
60606 IMSSM=-1
60607 ELSE IF(LPROC.EQ.975)THEN
60608 IHIGGS=204-201
60609 IMSSM=-1
60610 ELSE IF((LPROC.EQ.910).OR.(LPROC.EQ.920).OR.
60611 & (LPROC.EQ.960).OR.(LPROC.EQ.970))THEN
60612 KPROC=MIN(951,LPROC)
60613 IV=MAX(KPROC-950,0)
60614 IF((IV.LT.0).OR.(IV.GT.1)) CALL HWWARN('HWUINC',627)
60615 IH=LPROC/10-90-5*IV
60616 IF((IH.LE.0).OR.(IH.GT.2)) CALL HWWARN('HWUINC',626)
60617 IF(LPROC.LE.920)IMSSM=LPROC-400
60618 IF(LPROC.GE.960)IMSSM=LPROC-300
60619C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
60620 DO 545 I=10,10
60621 ENHANC(I )=GHWWSS(IH)
60622 ENHANC(I+1)=GHZZSS(IH)
60623 545 CONTINUE
60624 IF(IH.EQ.1)IHIGGS=203-201
60625 IF(IH.EQ.2)IHIGGS=204-201
60626 IF(IH.EQ.3)IHIGGS=205-201
60627 ELSE
60628 CALL HWWARN('HWUINC',625)
60629 END IF
60630 ELSE IF(LPROC/100.EQ.11)THEN
60631 IMSSM=-1
60632 IF(LPROC.GE.1140)THEN
60633 IHIGGS=207-201
60634 PARITY=1
60635 GOTO 548
60636 END IF
60637 IF(LPROC.LT.1140)IH=3
60638 IF(LPROC.LT.1130)IH=2
60639 IF(LPROC.LT.1120)IH=1
60640 IF((IH.LE.0).OR.(IH.GT.3)) CALL HWWARN('HWUINC',624)
60641 IQ=LPROC-1100-10*IH
60642 IF((IQ.LE.0).OR.(IQ.GT.9)) CALL HWWARN('HWUINC',623)
60643C...assign Neutral MSSM Higgs parity.
60644 PARITY=IP(IH)
60645C...assign enhancement for MSSM Higgs-QQ couplings, Q->U,D-type quarks.
60646 DO 546 I=1,5,2
60647 ENHANC(I )=GHDDSS(IH)
60648 ENHANC(I+1)=GHUUSS(IH)
60649 546 CONTINUE
60650C...assign enhancement for MSSM Higgs-LL couplings, L->D-type leptons.
60651 ENHANC(7)=GHDDSS(IH)
60652 ENHANC(8)=GHDDSS(IH)
60653 ENHANC(9)=GHDDSS(IH)
60654C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
60655 DO 547 I=10,10
60656 ENHANC(I )=GHWWSS(IH)
60657 ENHANC(I+1)=GHZZSS(IH)
60658 547 CONTINUE
60659 IF(IH.EQ.1)IHIGGS=203-201
60660 IF(IH.EQ.2)IHIGGS=204-201
60661 IF(IH.EQ.3)IHIGGS=205-201
60662 548 CONTINUE
60663C...hadronic processes.
60664 ELSE IF((LPROC/100.EQ.31).OR.(LPROC/100.EQ.32))THEN
60665 IF(LPROC/100.EQ.31)THEN
60666 IF((LPROC.LE.3109).OR.
60667 & ((LPROC.GE.3119).AND.(LPROC.LE.3139)).OR.
60668 & ((LPROC.GE.3149).AND.(LPROC.LE.3169)).OR.
60669 & (LPROC.GE.3179)) CALL HWWARN('HWUINC',622)
60670 IMSSM=-1
60671 IF(LPROC/100-LPROC/10*10.LE.4)IHIGGS=5
60672 IF(LPROC/100-LPROC/10*10.GE.5)IHIGGS=6
60673 ELSE IF(LPROC/100.EQ.32)THEN
60674 IF(LPROC.LE.3209) CALL HWWARN('HWUINC',621)
60675 IF(LPROC.EQ.3219) CALL HWWARN('HWUINC',620)
60676 IF(LPROC.EQ.3229) CALL HWWARN('HWUINC',619)
60677 IF(LPROC.EQ.3239) CALL HWWARN('HWUINC',618)
60678 IF(LPROC.EQ.3249) CALL HWWARN('HWUINC',617)
60679 IF(LPROC.EQ.3259) CALL HWWARN('HWUINC',616)
60680 IF(LPROC.EQ.3269) CALL HWWARN('HWUINC',615)
60681 IF(LPROC.EQ.3279) CALL HWWARN('HWUINC',614)
60682 IF(LPROC.EQ.3289) CALL HWWARN('HWUINC',613)
60683 IF(LPROC.GE.3299) CALL HWWARN('HWUINC',612)
60684 IMSSM=-1
60685 IF(LPROC.LT.3300)IHIGGS=4
60686 IF(LPROC.LT.3290)IHIGGS=3
60687 IF(LPROC.LT.3280)IHIGGS=2
60688 IF(LPROC.LT.3270)IHIGGS=4
60689 IF(LPROC.LT.3260)IHIGGS=3
60690 IF(LPROC.LT.3250)IHIGGS=2
60691 IF(LPROC.LT.3240)IHIGGS=4
60692 IF(LPROC.LT.3230)IHIGGS=3
60693 IF(LPROC.LT.3220)IHIGGS=2
60694 END IF
60695C...assign squarks/Higgs-flavours.
60696 IF(LPROC/100.EQ.31)JHIGGS=1
60697 IF(LPROC/100.EQ.32)JHIGGS=IHIGGS-1
60698 IF(LPROC/100.EQ.31)ILBL=3100
60699 IF(LPROC/100.EQ.32)ILBL=3200
60700 IHLP=LPROC-ILBL-60-JHIGGS*10
60701 IF(LPROC.LT.ILBL+70)IHLP=LPROC-ILBL-30-JHIGGS*10
60702 IF(LPROC.LT.ILBL+40)IHLP=LPROC-ILBL -JHIGGS*10
60703 IF(IHLP.LE.8)ISIGN=-1
60704 IF(IHLP.LE.4)ISIGN=+1
60705 JHLP=IHLP/5
60706 KHLP=IHLP/(3+4*JHLP)
60707 ISQ1=405+JHLP+12*KHLP
60708 IF(ILBL.EQ.3100)THEN
60709 ISQ2=ISQ1+ITMP(IHLP)+6+ISIGN
60710 IF(ISIGN.EQ.+1)JH=206
60711 IF(ISIGN.EQ.-1)JH=207
60712 IF(ISIGN.EQ.+1)JHIGGS=4
60713 IF(ISIGN.EQ.-1)JHIGGS=5
60714 ELSE IF(ILBL.EQ.3200)THEN
60715 ISQ2=ISQ1+ITMP(IHLP)+6
60716 IF(JHIGGS.EQ.1)JH=203
60717 IF(JHIGGS.EQ.2)JH=204
60718 IF(JHIGGS.EQ.3)JH=205
60719 END IF
60720 IF1MIN=ISQ1
60721 IF1MAX=ISQ1
60722 IF2MIN=ISQ2
60723 IF2MAX=ISQ2
60724 IF((LPROC.EQ.3110).OR.(LPROC.EQ.3210).OR.
60725 & (LPROC.EQ.3220).OR.(LPROC.EQ.3230).OR.
60726 & (LPROC.EQ.3140).OR.(LPROC.EQ.3240).OR.
60727 & (LPROC.EQ.3250).OR.(LPROC.EQ.3260).OR.
60728 & (LPROC.EQ.3170).OR.(LPROC.EQ.3270).OR.
60729 & (LPROC.EQ.3280).OR.(LPROC.EQ.3290))THEN
60730 IF1MIN=405
60731 IF1MAX=418
60732 IF2MIN=411
60733 IF2MAX=424
60734 END IF
60735 ELSE IF(LPROC/100.EQ.33)THEN
60736 IF((LPROC.EQ.3350).OR.(LPROC.EQ.3355))THEN
60737 IMSSM=-1
60738 IHIGGS=206-201
60739 ELSE IF((LPROC.EQ.3310).OR.(LPROC.EQ.3320).OR.
60740 & (LPROC.EQ.3360).OR.(LPROC.EQ.3370))THEN
60741 KPROC=MIN(3351,LPROC)
60742 IV=MAX(KPROC-3350,0)
60743 IF((IV.LT.0).OR.(IV.GT.1)) CALL HWWARN('HWUINC',611)
60744 IH=LPROC/10-330-5*IV
60745 IF((IH.LE.0).OR.(IH.GT.2)) CALL HWWARN('HWUINC',610)
60746 IF(LPROC.LE.3320)IMSSM=LPROC-2600
60747 IF(LPROC.GE.3360)IMSSM=LPROC-2700
60748C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
60749 DO 555 I=10,10
60750 ENHANC(I )=GHWWSS(IH)
60751 ENHANC(I+1)=GHZZSS(IH)
60752 555 CONTINUE
60753 IF(IH.EQ.1)IHIGGS=203-201
60754 IF(IH.EQ.2)IHIGGS=204-201
60755 IF(IH.EQ.3)IHIGGS=205-201
60756 ELSE IF((LPROC.EQ.3315).OR.(LPROC.EQ.3365))THEN
60757 IHIGGS=203-201
60758 IMSSM=-1
60759 ELSE IF((LPROC.EQ.3325).OR.(LPROC.EQ.3375))THEN
60760 IHIGGS=204-201
60761 IMSSM=-1
60762 ELSE IF(LPROC.EQ.3335)THEN
60763 IHIGGS=205-201
60764 IMSSM=-1
60765 ELSE
60766 CALL HWWARN('HWUINC',609)
60767 END IF
60768 ELSE IF(LPROC/100.EQ.34)THEN
60769 IMSSM=-1
60770 IF(LPROC.EQ.3410)IHIGGS=203-201
60771 IF(LPROC.EQ.3420)IHIGGS=204-201
60772 IF(LPROC.EQ.3430)IHIGGS=205-201
60773 IF(LPROC.EQ.3450)IHIGGS=206-201
60774 IF(IHIGGS.EQ.0) CALL HWWARN('HWUINC',608)
60775 ELSE IF(LPROC/100.EQ.35)THEN
60776 IMSSM=-1
60777 IHIGGS=206-201
60778 ELSE IF(LPROC/100.EQ.36)THEN
60779 IF((LPROC.NE.3610).AND.(LPROC.NE.3620).AND.
60780 & (LPROC.NE.3630)) CALL HWWARN('HWUINC',607)
60781 IH=LPROC/10-360
60782 IF((IH.LE.0).OR.(IH.GT.3)) CALL HWWARN('HWUINC',606)
60783 ID=LPROC-3600-10*IH
60784 IF((ID.LT.0).OR.(ID.GT.9)) CALL HWWARN('HWUINC',605)
60785 IMSSM=LPROC-(1600+ID)
60786C...assign Neutral MSSM Higgs parity.
60787 IF(IH.EQ.3)PARITY=-1
60788 DO 222 I=1,5,2
60789C...assign enhancement for Neutral MSSM Higgs-QQ couplings, Q->U,D-type quarks.
60790 ENHANC(I)=GHDDSS(IH)
60791 ENHANC(I+1)=GHUUSS(IH)
60792 222 CONTINUE
60793C...assign enhancement for Neutral MSSM Higgs-Q~Q~ couplings,
60794C Q~->U,D-type squarks.
60795 DO 223 I=1,6
60796 SENHNC(I )=RMASS(198)*GHSQSS(IH,I,1,1)/RMASS(400+I)**2
60797 SENHNC(I+12)=RMASS(198)*GHSQSS(IH,I,2,2)/RMASS(412+I)**2
60798 223 CONTINUE
60799 IF(IH.EQ.1)IHIGGS=203-201
60800 IF(IH.EQ.2)IHIGGS=204-201
60801 IF(IH.EQ.3)IHIGGS=205-201
60802 ELSE IF(LPROC/100.EQ.37)THEN
60803 IH=LPROC/10-370
60804 IF((IH.LE.0).OR.(IH.GT.2)) CALL HWWARN('HWUINC',604)
60805 IMSSM=LPROC-1900
60806C...assign enhancement for MSSM Higgs-VV couplings, V->W,Z-gauge bosons.
60807 DO 333 I=10,10
60808 ENHANC(I )=GHWWSS(IH)
60809 ENHANC(I+1)=GHZZSS(IH)
60810 333 CONTINUE
60811 IF(IH.EQ.1)IHIGGS=203-201
60812 IF(IH.EQ.2)IHIGGS=204-201
60813 IF(IH.EQ.3)IHIGGS=205-201
60814 ELSE IF(LPROC/100.EQ.38)THEN
60815 IMSSM=-1
60816 IF((LPROC.EQ.3839).OR.(LPROC.EQ.3869).OR.(LPROC.EQ.3899))THEN
60817 IHIGGS=207-201
60818 PARITY=1
60819 GOTO 445
60820 END IF
60821 IF(LPROC.LT.4000)IS=6
60822 IF(LPROC.LT.3870)IS=3
60823 IF(LPROC.LT.3840)IS=0
60824 IH=LPROC/10-380-IS
60825 IF((IH.LE.0).OR.(IH.GT.3)) CALL HWWARN('HWUINC',603)
60826 IQ=LPROC-3800-10*(IH+IS)
60827 IF((IQ.LE.0).OR.(IQ.GT.6)) CALL HWWARN('HWUINC',602)
60828C...assign Neutral MSSM Higgs parity.
60829 PARITY=IP(IH)
60830C...assign enhancement for MSSM Higgs-QQ couplings, Q->U,D-type quarks.
60831 DO 444 I=1,5,2
60832 ENHANC(I )=GHDDSS(IH)
60833 ENHANC(I+1)=GHUUSS(IH)
60834 444 CONTINUE
60835 IF(IH.EQ.1)IHIGGS=203-201
60836 IF(IH.EQ.2)IHIGGS=204-201
60837 IF(IH.EQ.3)IHIGGS=205-201
60838 445 CONTINUE
60839 END IF
60840 IF((IMSSM.NE.-1).AND.(IPROC.GE.10000))IMSSM=IMSSM+10000
60841 666 CONTINUE
60842 IPRO=MOD(IPROC/100,100)
60843 IQK=MOD(IPROC,100)
60844C---SET UP BEAMS
60845 CALL HWUIDT(3,IDB,IPART1,PART1)
60846 CALL HWUIDT(3,IDT,IPART2,PART2)
60847 EBEAM1=SQRT(PBEAM1**2+RMASS(IPART1)**2)
60848 EBEAM2=SQRT(PBEAM2**2+RMASS(IPART2)**2)
60849C---PHOTON CUTOFF DEFAULTS TO ROOT S
60850 PTLIM=SQRT(HALF*(EBEAM1*EBEAM2+PBEAM1*PBEAM2))
60851 ETLIM=TWO*PTLIM
60852 IF (VPCUT.GT.ETLIM) VPCUT=ETLIM
60853 IF (Q2MAX.GT.ETLIM**2) Q2MAX=ETLIM**2
60854C---PRINT OUT MOST IMPORTANT INPUT PARAMETERS
60855 IF (IPRINT.EQ.0) GOTO 50
60856 WRITE (6,10) PART1,PBEAM1,PART2,PBEAM2,IPROC,
60857 & NFLAV,NSTRU,AZSPIN,AZSOFT,QCDLAM,(RMASS(I),I=1,6),RMASS(13)
60858 IF (ISPAC.LE.1) THEN
60859 WRITE (6,20) VQCUT,VGCUT,VPCUT,CLMAX,QSPAC,PTRMS
60860 ELSE
60861 WRITE (6,30) VQCUT,VGCUT,VPCUT,CLMAX,QSPAC,PTRMS
60862 ENDIF
60863C--switch on three body matrix elements if doing spin correlations
60864 IF(SYSPIN) THREEB=.TRUE.
60865C--output spin correlation options
60866 WRITE(6,35) SYSPIN,THREEB,FOURB
60867 IF (NOSPAC) WRITE (6,40)
60868 10 FORMAT(/10X,'INPUT CONDITIONS FOR THIS RUN'//
60869 & 10X,'BEAM 1 (',A8,') MOM. =',F10.2/
60870 & 10X,'BEAM 2 (',A8,') MOM. =',F10.2/
60871 & 10X,'PROCESS CODE (IPROC) =',I8/
60872 & 10X,'NUMBER OF FLAVOURS =',I5/
60873 & 10X,'STRUCTURE FUNCTION SET =',I5/
60874 & 10X,'AZIM SPIN CORRELATIONS =',L5/
60875 & 10X,'AZIM SOFT CORRELATIONS =',L5/
60876 & 10X,'QCD LAMBDA (GEV) =',F10.4/
60877 & 10X,'DOWN QUARK MASS =',F10.4/
60878 & 10X,'UP QUARK MASS =',F10.4/
60879 & 10X,'STRANGE QUARK MASS =',F10.4/
60880 & 10X,'CHARMED QUARK MASS =',F10.4/
60881 & 10X,'BOTTOM QUARK MASS =',F10.4/
60882 & 10X,'TOP QUARK MASS =',F10.4/
60883 & 10X,'GLUON EFFECTIVE MASS =',F10.4)
60884 20 FORMAT(10X,'EXTRA SHOWER CUTOFF (Q)=',F10.4/
60885 & 10X,'EXTRA SHOWER CUTOFF (G)=',F10.4/
60886 & 10X,'PHOTON SHOWER CUTOFF =',F10.4/
60887 & 10X,'CLUSTER MASS PARAMETER =',F10.4/
60888 & 10X,'SPACELIKE EVOLN CUTOFF =',F10.4/
60889 & 10X,'INTRINSIC P-TRAN (RMS) =',F10.4)
60890 30 FORMAT(10X,'EXTRA SHOWER CUTOFF (Q)=',F10.4/
60891 & 10X,'EXTRA SHOWER CUTOFF (G)=',F10.4/
60892 & 10X,'PHOTON SHOWER CUTOFF =',F10.4/
60893 & 10X,'CLUSTER MASS PARAMETER =',F10.4/
60894 & 10X,'PDF FREEZING CUTOFF =',F10.4/
60895 & 10X,'INTRINSIC P-TRAN (RMS) =',F10.4)
60896 35 FORMAT(10X,'DECAY SPIN CORRELATIONS=',L5/
60897 & 10X,'SUSY THREE BODY ME =',L5/
60898 & 10X,'SUSY FOUR BODY ME =',L5)
60899 40 FORMAT(10X,'NO SPACE-LIKE SHOWERS')
60900 50 ISTOP=0
60901C---INITIALIZE ALPHA-STRONG
60902 IF (QLIM.GT.ETLIM) QLIM=ETLIM
60903 QR=HWUALF(0,QLIM)
60904C---DO SOME SAFETY CHECKS ON INPUT PARAMETERS
60905C Check beam order for point-like photon/QCD processes
60906 IF (IPRO.GE.50.AND.IPRO.LE.59.AND.
60907 & IDB.NE.22.AND.ABS(IDB).NE.11.AND.ABS(IDB).NE.13) THEN
60908 WRITE(6,60)
60909 60 FORMAT(1X,'WARNING: require FIRST beam to be a photon/lepton')
60910 ISTOP=ISTOP+1
60911 ENDIF
60912 QG=HWBVMC(13)
60913 QR=QG/QCDL3
60914 IF (QR.GE.2.01) GOTO 80
60915 WRITE (6,70) QG,QCDLAM,QCDL3
60916 70 FORMAT(//10X,'SHOWER GLUON VIRTUAL MASS CUTOFF =',F8.5/
60917 & 10X,'TOO SMALL RELATIVE TO QCD LAMBDA =',F8.5/
60918 & 10X,'CORRESPONDS TO 3-FLAV MC LAMBDA =',F8.5)
60919 ISTOP=ISTOP+1
60920 80 QV=MIN(HWBVMC(1),HWBVMC(2))
60921 IF (QV.GE.QG/(QR-1.)) GOTO 100
60922 ISTOP=ISTOP+1
60923 WRITE (6,90) QV,QCDLAM,QCDL3
60924 90 FORMAT(//10X,'SHOWER QUARK VIRTUAL MASS CUTOFF =',F8.5/
60925 & 10X,'TOO SMALL RELATIVE TO QCD LAMBDA =',F8.5/
60926 & 10X,'CORRESPONDS TO 3-FLAV MC LAMBDA =',F8.5)
60927 100 IF (ISTOP.NE.0) THEN
60928 WRITE (6,110) ISTOP
60929 110 FORMAT(//10X,'EXECUTION PREVENTED BY',I2,
60930 & ' ERRORS IN INPUT PARAMETERS.')
60931 STOP
60932 ENDIF
60933 DO 120 I=1,6
60934 120 RMASS(I+6)=RMASS(I)
60935 RMASS(199)=RMASS(198)
60936C---A PRIORI WEIGHTS FOR QUARK AND DIQUARKS
60937 DQKWT=PWT(1)
60938 UQKWT=PWT(2)
60939 SQKWT=PWT(3)
60940 DIQWT=PWT(7)
60941 PWT(10)=PWT(4)
60942 PWT(11)=PWT(5)
60943 PWT(12)=PWT(6)
60944C
60945 PWT(4)=UQKWT*UQKWT*DIQWT
60946 PWT(5)=UQKWT*DQKWT*DIQWT*HALF
60947 PWT(6)=DQKWT*DQKWT*DIQWT
60948 PWT(7)=UQKWT*SQKWT*DIQWT*HALF
60949 PWT(8)=DQKWT*SQKWT*DIQWT*HALF
60950 PWT(9)=SQKWT*SQKWT*DIQWT
60951 QMAX=MAX(PWT(1),PWT(2),PWT(3))
60952 PMAX=MAX(PWT(4),PWT(5),PWT(6),PWT(7),PWT(8),PWT(9),
60953 & PWT(10),PWT(11),PWT(12),QMAX)
60954 PMAX=1./PMAX
60955 QMAX=1./QMAX
60956 DO 130 I=1,3
60957 130 QWT(I)=PWT(I)*QMAX
60958 DO 140 I=1,12
60959 140 PWT(I)=PWT(I)*PMAX
60960C MASSES OF DIQUARKS (ASSUME BINDING NEGLIGIBLE)
60961 RMASS(109)=RMASS(2)+RMASS(2)
60962 RMASS(110)=RMASS(1)+RMASS(2)
60963 RMASS(111)=RMASS(1)+RMASS(1)
60964 RMASS(112)=RMASS(2)+RMASS(3)
60965 RMASS(113)=RMASS(1)+RMASS(3)
60966 RMASS(114)=RMASS(3)+RMASS(3)
60967 DO 150 I=109,114
60968 150 RMASS(I+6)=RMASS(I)
60969C MASSES OF TOP HADRONS (ASSUME BINDING NEGLIGIBLE)
60970 RMASS(232)=RMASS(6)+RMASS(5)
60971 RMASS(233)=RMASS(6)+RMASS(1)
60972 RMASS(234)=RMASS(6)+RMASS(2)
60973 RMASS(235)=RMASS(6)+RMASS(3)
60974 RMASS(236)=RMASS(6)+RMASS(2)+RMASS(2)
60975 RMASS(237)=RMASS(6)+RMASS(1)+RMASS(2)
60976 RMASS(238)=RMASS(6)+RMASS(1)+RMASS(1)
60977 RMASS(239)=RMASS(6)+RMASS(2)+RMASS(3)
60978 RMASS(240)=RMASS(6)+RMASS(1)+RMASS(3)
60979 RMASS(241)=RMASS(6)+RMASS(3)+RMASS(3)
60980 RMASS(242)=RMASS(6)+RMASS(4)
60981 RMASS(243)=RMASS(6)+RMASS(5)
60982 RMASS(244)=RMASS(6)+RMASS(6)
60983 RMASS(232)=RMASS(243)
60984 DO 160 I=233,242
60985 160 RMASS(I+22)=RMASS(I)
60986C Set up an array of cluster mass threholds
60987 CLMXPW=CLMAX**CLPOW
60988 RCLPOW=ONE/CLPOW
60989 CALL HWVZRO(144,CTHRPW(1,1))
60990 DO 170 I=1,6
60991 DO 170 J=1,6
60992 CTHRPW(I ,J )=(CLMXPW+(RMASS(I )+RMASS(J+6 ))**CLPOW)**RCLPOW
60993 CTHRPW(I ,J+6)=(CLMXPW+(RMASS(I )+RMASS(J+108))**CLPOW)**RCLPOW
60994 170 CTHRPW(I+6,J )=(CLMXPW+(RMASS(I+114)+RMASS(J+6 ))**CLPOW)**RCLPOW
60995C Decay length conversion factor GEV2MM hbar.c/e
60996 GEV2MM=1.D-15*SQRT(GEV2NB/10.)
60997C Plank's constant/2pi (GeV.s)
60998 HBAR=GEV2MM/CSPEED
60999C Check the SUSY DATA has been read in (if needed)
61000 IF((IPRO.EQ.7.OR.IPRO.EQ.8.OR.IPRO.EQ.9.OR.IPRO.EQ.11.OR.
61001 & (IPRO.GE.30.AND.IPRO.LE.41)).AND..NOT.SUSYIN)
61002 & CALL HWWARN('HWUINC',601)
61003C---IMPORTANCE SAMPLING
61004 FIRST=.TRUE.
61005 XMIN=0
61006 XMAX=0
61007 XPOW=-1
61008 IF (IPRO.EQ.5) THEN
61009 IF (EMMAX.GT.ETLIM) EMMAX=ETLIM
61010 IF (PTMAX.GT.PTLIM) PTMAX=PTLIM
61011 ELSEIF (IPRO.EQ.13) THEN
61012 IF (EMMIN.EQ.ZERO) EMMIN=10
61013 IF (EMMAX.GT.ETLIM) EMMAX=ETLIM
61014 IF (IQK.GT.0.AND.IQK.LE.6) EMMIN=MAX(EMMIN,2*RMASS(IQK))
61015 XMIN=EMMIN
61016 XMAX=EMMAX
61017 XPOW=-EMPOW
61018 ELSEIF (IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.18.OR.IPRO.EQ.21
61019 & .OR.IPRO.EQ.22.OR.IPRO.EQ.23.OR.IPRO.EQ.24.OR.IPRO.EQ.50
61020 & .OR.IPRO.EQ.51.OR.IPRO.EQ.53.OR.IPRO.EQ.55.OR.IPRO.EQ.60) THEN
61021 IF (PTMAX.GT.PTLIM) PTMAX=PTLIM
61022 IF (IQK.NE.0.AND.IQK.LT.7.AND.IPRO.NE.23) THEN
61023 XMIN=2.*SQRT(PTMIN**2+RMASS(IQK)**2)
61024 XMAX=2.*SQRT(PTMAX**2+RMASS(IQK)**2)
61025 IF (XMAX.GT.ETLIM) XMAX=ETLIM
61026 ELSE
61027 XMIN=2.*PTMIN
61028 XMAX=2.*PTMAX
61029 ENDIF
61030 XPOW=-PTPOW
61031C--Gauge Boson pairs in hadron-hadron
61032 ELSEIF(IPRO.EQ.28) THEN
61033 IF(EMMIN.EQ.ZERO) EMMIN=20.0D0
61034C--Drell-Yan + 2 jets processes
61035 ELSEIF(IPRO.EQ.29) THEN
61036 IF(EMMIN.EQ.ZERO) EMMIN=20.0D0
61037 IF(PTMAX.GT.ETLIM) PTMAX = ETLIM
61038C--Cuts on the graviton to avoid unitarity violations
61039C--If the width exceeds 0.1 times the mass this should be reset
61040 ELSEIF(IPRO.EQ.42) THEN
61041 EMMIN = 0.9D0*EMGRV
61042 EMMAX = 1.1D0*EMGRV
61043 ELSEIF (IPRO.EQ.52) THEN
61044 PTELM=PTLIM-RMASS(IQK)**2/(4.*PTLIM)
61045 IF (PTMAX.GT.PTELM) PTMAX=PTELM
61046 XMIN=PTMIN
61047 XMAX=PTMAX
61048 XPOW=-PTPOW
61049 ELSEIF (IPRO.EQ.30) THEN
61050 IF (PTMAX.GT.PTLIM) PTMAX=PTLIM
61051 XMIN=2.*SQRT(PTMIN**2+RMMNSS**2)
61052 XMAX=2.*SQRT(PTMAX**2+RMMNSS**2)
61053 IF (XMAX.GT.ETLIM) XMAX=ETLIM
61054 XPOW=-PTPOW
61055C--PR MOD 7/7/99
61056 ELSEIF(IPRO.EQ.40.OR.IPRO.EQ.41) THEN
61057 IF (PTMAX.GT.PTLIM) PTMAX=PTLIM
61058 ID = MOD(IPROC,100)
61059 RPM(1) = RMMNSS
61060 RPM(2) = ZERO
61061 IF(ID.GE.10.AND.ID.LT.20) THEN
61062 RPM(1) = ABS(RMASS(450))
61063 IF(ID.GT.10) RPM(1) = ABS(RMASS(449+MOD(ID,10)))
61064 ELSEIF(ID.GE.20.AND.ID.LT.30) THEN
61065 RPM(1) = ABS(RMASS(454))
61066 IF(ID.GT.20) RPM(1) = ABS(RMASS(453+MOD(ID,20)))
61067 ELSEIF(ID.EQ.30) THEN
61068 RPM(1) = RMASS(449)
61069 ELSEIF(ID.EQ.40) THEN
61070 IF(IPRO.EQ.40) THEN
61071 RPM(1) = RMASS(425)
61072 DO I=1,5
61073 RPM(1) = MIN(RPM(1),RMASS(425+I))
61074 ENDDO
61075 ELSE
61076 RPM(1) = MIN(RMASS(405),RMASS(406))
61077 ENDIF
61078 RPM(2) = RMASS(198)
61079 ELSEIF(ID.EQ.50) THEN
61080 IF(IPRO.EQ.40) THEN
61081 RPM(1) = RMASS(425)
61082 DO I=1,5
61083 RPM(1) = MIN(RPM(1),RMASS(425+I))
61084 ENDDO
61085 DO I=1,3
61086 RPM(2) = MIN(RPM(1),RMASS(433+2*I))
61087 ENDDO
61088 RPM(1) = MIN(RPM(1),RPM(2))
61089 RPM(2) = RMASS(203)
61090 DO I=1,2
61091 RPM(2) = MIN(RPM(2),RMASS(204+I))
61092 ENDDO
61093 ELSE
61094 RPM(1) = RMASS(401)
61095 RPM(2) = RMASS(413)
61096 DO I=1,5
61097 RPM(1) = MIN(RPM(1),RMASS(401+I))
61098 RPM(2) = MIN(RPM(2),RMASS(413+I))
61099 ENDDO
61100 RPM(1) = MIN(RPM(1),RPM(2))
61101 RPM(2) = RMASS(203)
61102 DO I=1,2
61103 RPM(2) = MIN(RPM(2),RMASS(204+I))
61104 ENDDO
61105 ENDIF
61106 RPM(2) = RMASS(203)
61107 DO I=1,2
61108 RPM(2) = MIN(RPM(2),RMASS(204+I))
61109 ENDDO
61110 ELSEIF(ID.GE.60) THEN
61111 RPM(1) = ZERO
61112 ENDIF
61113 RPM(1) = RPM(1)**2
61114 RPM(2) = RPM(2)**2
61115 XMIN = SQRT(RPM(1)+RPM(2)+TWO*(PTMIN**2+
61116 & SQRT(RPM(1)*RPM(2)+PTMIN**2*(RPM(1)+RPM(2)+PTMIN**2))))
61117 XMAX = SQRT(RPM(1)+RPM(2)+TWO*(PTMAX**2+
61118 & SQRT(RPM(1)*RPM(2)+PTMAX**2*(RPM(1)+RPM(2)+PTMAX**2))))
61119 IF (XMAX.GT.ETLIM) XMAX=ETLIM
61120C--end of mod
61121 ELSEIF (IPRO.EQ.90) THEN
61122 XMIN=SQRT(Q2MIN)
61123 XMAX=SQRT(Q2MAX)
61124 XPOW=1.-2.*Q2POW
61125 ELSEIF (IPRO.EQ.91) THEN
61126 IF (EMMAX.GT.ETLIM) EMMAX=ETLIM
61127 ENDIF
61128C---CALCULATE HIGGS WIDTH
61129 IF (IPRO.EQ. 3.OR.IPRO.EQ. 4.OR.IPRO.EQ.10.OR.IPRO.EQ.16
61130 &.OR.IPRO.EQ.19.OR.IPRO.EQ.23.OR.IPRO.EQ.25.OR.IPRO.EQ.26
61131 &.OR.IPRO.EQ.27.OR.IPRO.EQ.95) THEN
61132 GAMH=RMASS(201)
61133 CALL HWDHIG(GAMH)
61134 ENDIF
61135C---IF Q**2 CAN BE TOO SMALL, BREIT FRAME MAKES NO SENSE
61136 IF ((IPRO/10.EQ.9.AND.Q2MIN.LE.1.D-2).OR.
61137 & (IPRO.EQ.91.AND.IQK.EQ.7)) BREIT=.FALSE.
61138 IF (IPRINT.NE.0) THEN
61139 IF (PBEAM1.NE.PBEAM2) WRITE (6,180) USECMF
61140 IF (IPRO.EQ.91.OR.IPRO.EQ.92)
61141 & WRITE (6,190) PTMIN
61142 IF (IPRO.EQ.90.OR.(IPRO.EQ.91.AND.IQK.NE.7).OR.IPRO.EQ.92)
61143 & WRITE (6,200) Q2MIN,Q2MAX,BREIT
61144 IF (IPRO.EQ.90.OR.(IPRO.EQ.91.AND.IQK.NE.7).OR.IPRO.EQ.92)
61145 & WRITE (6,210) YBMIN,YBMAX
61146 IF (IPRO.EQ.91.AND.IQK.EQ.7)
61147 & WRITE (6,220) Q2WWMN,Q2WWMX,BREIT,ZJMAX
61148 IF (IPROC/10.EQ.11) WRITE (6,230) THMAX
61149 IF (IPRO.EQ.13) WRITE (6,240) EMMIN,EMMAX
61150 IF (IPRO.EQ.15.OR.IPRO.EQ.17.OR.IPRO.EQ.18.OR.IPRO.EQ.21
61151 & .OR.IPRO.EQ.22.OR.IPRO.EQ.23.OR.IPRO.EQ.24.OR.IPRO.EQ.50
61152 & .OR.IPRO.EQ.51.OR.IPRO.EQ.52.OR.IPRO.EQ.53.OR.IPRO.EQ.55
61153 & .OR.IPRO.EQ.60)
61154 & WRITE (6,250) PTMIN,PTMAX
61155 IF (IPRO.EQ. 3.OR.IPRO.EQ. 4.OR.IPRO.EQ.10.OR.IPRO.EQ.16
61156 & .OR.IPRO.EQ.19.OR.IPRO.EQ.23.OR.IPRO.EQ.25.OR.IPRO.EQ.26
61157 & .OR.IPRO.EQ.27.OR.IPRO.EQ.95)
61158 & WRITE (6,260) RMASS(201),GAMH,
61159 & GAMMAX,RMASS(201)+GAMMAX*GAMH,(BRHIG(I)*100,I=1,12)
61160 IF (IPRO.EQ.91) WRITE (6,270) BGSHAT,EMMIN,EMMAX
61161 IF (IPRO.EQ.5.AND.IQK.LT.50)
61162 & WRITE (6,280) EMMIN,EMMAX,PTMIN,PTMAX,CTMAX
61163 IF (IPRO.EQ.5.AND.IQK.GE.50)
61164 & WRITE (6,290) EMMIN,EMMAX,Q2MIN,Q2MAX,PTMIN
61165 IF (IPRO.GT.12.AND.
61166 & (IPRO.LT.90.AND.(ABS(IDB).EQ.11.OR.ABS(IDB).EQ.13).OR.
61167 & (ABS(IDT).EQ.11.OR.ABS(IDT).EQ.13))) THEN
61168 WRITE (6,300) Q2WWMN,Q2WWMX,YWWMIN,YWWMAX
61169 IF (PHOMAS.GT.ZERO) WRITE (6,310) PHOMAS
61170 ENDIF
61171 IF (IPROC/10.EQ.10.OR.IPRO.EQ.90)
61172 & WRITE (6,320) HARDME,SOFTME
61173C Check minimum mass threshold if ISR switched on
61174 IF ((IPRO.LE.3.OR.IPRO.EQ.6).AND.ZMXISR.GT.ZERO) THEN
61175 TEST=TWO*RMASS(IPART1)**2+ETLIM**2
61176 TEST=FOUR*RMASS(2)**2/TEST
61177 IF (TMNISR.LT.TEST) THEN
61178 WRITE(6,175) TMNISR,TEST
61179 175 FORMAT(10X,'Minimum invariant mass',F10.6,' too low'/
61180 & 10X,'increasing to TMNISR=',F10.6)
61181 TMNISR=TEST
61182 ENDIF
61183 WRITE (6,330) TMNISR,ONE-ZMXISR
61184 ENDIF
61185 IF (WHMIN.GT.ZERO .AND. IPRO.GT.12.AND.(IPRO.EQ.90.OR.
61186 & (ABS(IDB).EQ.11.OR.ABS(IDB).EQ.13).OR.
61187 & (ABS(IDT).EQ.11.OR.ABS(IDT).EQ.13))) WRITE (6,340) WHMIN
61188 180 FORMAT(10X,'USE BEAM-TARGET C.M.F. =',L5)
61189 190 FORMAT(10X,'MIN P-T FOR O(AS) DILS =',F10.4)
61190 200 FORMAT(10X,'MIN ABS(Q**2) FOR DILS =',E10.4/
61191 & 10X,'MAX ABS(Q**2) FOR DILS =',E10.4/
61192 & 10X,'BREIT FRAME SHOWERING =',L5)
61193 210 FORMAT(10X,'MIN BJORKEN Y FOR DILS =',F10.4/
61194 & 10X,'MAX BJORKEN Y FOR DILS =',F10.4)
61195 220 FORMAT(10X,'MIN ABS(Q**2) FOR J/PSI=',E10.4/
61196 & 10X,'MAX ABS(Q**2) FOR J/PSI=',E10.4/
61197 & 10X,'BREIT FRAME SHOWERING =',L5/
61198 & 10X,'MAX Z FOR J/PSI =',F10.4)
61199 230 FORMAT(10X,'MAX THRUST FOR 2->3 =',F10.4)
61200 240 FORMAT(10X,'MIN MASS FOR DRELL-YAN =',F10.4/
61201 & 10X,'MAX MASS FOR DRELL-YAN =',F10.4)
61202 250 FORMAT(10X,'MIN P-TRAN FOR 2->2 =',F10.4/
61203 & 10X,'MAX P-TRAN FOR 2->2 =',F10.4)
61204 260 FORMAT(10X,'HIGGS BOSON MASS =',F10.4/
61205 & 10X,'HIGGS BOSON WIDTH =',F10.4/
61206 & 10X,'CUTOFF = EMH +',F4.1,'*GAMH=',F10.4/
61207 & 10X,'HIGGS D DBAR =',F10.4/
61208 & 10X,'BRANCHING U UBAR =',F10.4/
61209 & 10X,'FRACTIONS S SBAR =',F10.4/
61210 & 10X,'(PER CENT) C CBAR =',F10.4/
61211 & 10X,' B BBAR =',F10.4/
61212 & 10X,' T TBAR =',F10.4/
61213 & 10X,' E+ E- =',F10.4/
61214 & 10X,' MU+ MU- =',F10.4/
61215 & 10X,' TAU+ TAU- =',F10.4/
61216 & 10X,' W W =',F10.4/
61217 & 10X,' Z Z =',F10.4/
61218 & 10X,' GAMMA GAMMA =',F10.4)
61219 270 FORMAT(10X,'SCALE FOR BGF IS S-HAT =',L5/
61220 & 10X,'MIN MASS FOR BGF =',F10.4/
61221 & 10X,'MAX MASS FOR BGF =',F10.4)
61222 280 FORMAT(10X,'MIN MASS FOR 2 PHOTONS =',F10.4/
61223 & 10X,'MAX MASS FOR 2 PHOTONS =',F10.4/
61224 & 10X,'MIN PT OF 2 PHOTON CMF =',F10.4/
61225 & 10X,'MAX PT OF 2 PHOTON CMF =',F10.4/
61226 & 10X,'MAX COS THETA IN CMF =',F10.4)
61227 290 FORMAT(10X,'MIN MASS FOR GAMMA + W =',F10.4/
61228 & 10X,'MAX MASS FOR GAMMA + W =',F10.4/
61229 & 10X,'MIN ABS(Q**2) =',E10.4/
61230 & 10X,'MAX ABS(Q**2) =',E10.4/
61231 & 10X,'MIN PT =',F10.4)
61232 300 FORMAT(10X,'MIN Q**2 FOR WW PHOTON =',F10.4/
61233 & 10X,'MAX Q**2 FOR WW PHOTON =',F10.4/
61234 & 10X,'MIN MOMENTUM FRACTION =',F10.4/
61235 & 10X,'MAX MOMENTUM FRACTION =',F10.4)
61236 310 FORMAT(10X,'GAMMA* S.F. MASS PARAM =',F10.4)
61237 320 FORMAT(10X,'HARD M.E. MATCHING =',L5/
61238 & 10X,'SOFT M.E. MATCHING =',L5)
61239 330 FORMAT(10X,'MIN MTM FRAC FOR ISR =',1PE10.4/
61240 & 10X,'1-MAX MTM FRAC FOR ISR =',1PE10.4)
61241 340 FORMAT(10X,'MINIMUM HADRONIC MASS =',F10.4)
61242 IF (LWEVT.LE.0) THEN
61243 WRITE (6,350)
61244 ELSE
61245 WRITE (6,360) LWEVT
61246 ENDIF
61247 350 FORMAT(/10X,'NO EVENTS WILL BE WRITTEN TO DISK')
61248 360 FORMAT(/10X,'EVENTS WILL BE OUTPUT ON UNIT',I4)
61249 ENDIF
61250C Verify and print beam polarisations
61251 IF((IPRO.EQ.1.OR.IPRO.EQ.3).OR.
61252 & ((IPRO.EQ.9).AND.(MOD(IPROC,10000).EQ.960)).OR.
61253 & ((IPRO.EQ.9).AND.(MOD(IPROC,10000).EQ.970)))THEN
61254C Set up transverse polarisation parameters for e+e-
61255 IF ((EPOLN(1)**2+EPOLN(2)**2)
61256 & *(PPOLN(1)**2+PPOLN(2)**2).GT.ZERO) THEN
61257 TPOL=.TRUE.
61258 COSS=EPOLN(1)*PPOLN(1)-EPOLN(2)*PPOLN(2)
61259 SINS=EPOLN(2)*PPOLN(1)+EPOLN(1)*PPOLN(2)
61260 ELSE
61261 TPOL=.FALSE.
61262 ENDIF
61263C print out lepton beam polarisation(s)
61264 IF (IPRINT.NE.0) THEN
61265 IF (IPART1.EQ.121) THEN
61266 WRITE (6,370) PART1,EPOLN,PART2,PPOLN
61267 ELSE
61268 WRITE (6,370) PART1,PPOLN,PART2,EPOLN
61269 ENDIF
61270 370 FORMAT(/10X,A8,'Beam polarisation=',3F10.4/
61271 & 10X,A8,'Beam polarisation=',3F10.4)
61272 ENDIF
61273 ELSEIF (IPRO.GE.90.AND.IPRO.LE.99) THEN
61274 IF (IDB.GE.11.AND.IDB.LE.16) THEN
61275 CALL HWVZRO(3,PPOLN)
61276C Check neutrino polarisations for DIS
61277 IF (IDB.EQ. 12.OR.IDB.EQ. 14.OR.IDB.EQ. 16.AND.
61278 & EPOLN(3).NE.-ONE) EPOLN(3)=-ONE
61279 IF (IPRINT.NE.0) WRITE(6,380) PART1,EPOLN(3)
61280 ELSE
61281 CALL HWVZRO(3,EPOLN)
61282C Check anti-neutrino polarisations for DIS
61283 IF (IDB.EQ.-12.OR.IDB.EQ.-14.OR.IDB.EQ.-16.AND.
61284 & PPOLN(3).NE.ONE) PPOLN(3)=ONE
61285 IF (IPRINT.NE.0) WRITE(6,380) PART1,PPOLN(3)
61286 ENDIF
61287 380 FORMAT(/10X,A8,1X,'Longitudinal beam polarisation=',F10.4/)
61288 ENDIF
61289 IF (IPRINT.NE.0) THEN
61290 IF (ZPRIME) THEN
61291 WRITE(6,390) RMASS(200),RMASS(202),GAMZ,GAMZP
61292 WRITE(6,400) (RNAME(I),VFCH(I,1),AFCH(I,1),VFCH(I,2),
61293 & AFCH(I,2),I=1,6)
61294 WRITE(6,400) (RNAME(110+I),VFCH(I,1),AFCH(I,1),
61295 & VFCH(I,2),AFCH(I,2),I=11,16)
61296 390 FORMAT(/10X,'MASSIVE NEUTRAL VECTOR BOSON PARAMS'/
61297 & 10X,'Z MASS=',F10.4,7X,'Z-PRIME MASS=',F10.4/
61298 & 10X,' WIDTH=',F10.4,7X,' WIDTH=',F10.4/
61299 & 10X,'FERMION COUPLINGS: e.(V.1+A.G_5)G_mu'/
61300 & 10X,'FERMION: VECTOR AXIAL',6X,
61301 & 'VECTOR AXIAL'/)
61302 400 FORMAT(10X,A8,2X,F10.4,1X,F10.4,1X,F10.4,1X,F10.4)
61303 ENDIF
61304 IF (MIXING) THEN
61305 WRITE(6,410) XMIX(2),YMIX(2),XMIX(1),YMIX(1)
61306 410 FORMAT(/10X,'B_d: Delt-M/Gam =',F6.4,
61307 & ' Delt-Gam/2*Gam =',F6.4,/
61308 & 10X,'B_s: Delt-M/Gam =',F6.2,
61309 & ' Delt-Gam/2*Gam =',F6.4)
61310 ENDIF
61311 IF (CLRECO) WRITE(6,420) PRECO,EXAG
61312 420 FORMAT(/10X,'Colour rearrangement ALLOWED, probability =',F6.4,/
61313 & 10x,'Weak boson life-time exaggeration factor =',F10.6)
61314C---PDF STRUCTURE FUNCTIONS
61315 WRITE (6,'(1X)')
61316 DO 450 I=1,2
61317 IF (MODPDF(I).GE.0) THEN
61318 WRITE (6,430) I,MODPDF(I),AUTPDF(I)
61319 ELSE
61320 WRITE (6,440) I
61321 ENDIF
61322 430 FORMAT(10X,'PDFLIB USED FOR BEAM',I2,': SET',I3,' OF ',A20)
61323 440 FORMAT(10X,'PDFLIB NOT USED FOR BEAM',I2)
61324 450 CONTINUE
61325C---GET THE UGLY INITIALISATION MESSAGES OVER AND DONE WITH NOW TOO
61326 DO 460 I=1,2
61327 IF (MODPDF(I).GE.0) THEN
61328 PARM(1)=AUTPDF(I)
61329 VAL(1)=FLOAT(MODPDF(I))
61330 PARMSAVE=PARM(1)
61331 VALSAVE=VAL(1)
61332 FSTPDF=.TRUE.
61333 X=0.5
61334 QSCA=10
61335C---FIX TO CALL SCHULER-SJOSTRAND CODE
61336 IF (AUTPDF(I).EQ.'SaSph') THEN
61337 ISET=MOD(MODPDF(I),10)
61338 IOP1=MOD(MODPDF(I)/10,2)
61339 IOP2=MOD(MODPDF(I)/20,2)
61340 IP2=MODPDF(I)/100
61341 IF (ISET.EQ.1) THEN
61342 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 1D'
61343 ELSEIF (ISET.EQ.2) THEN
61344 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 1M'
61345 ELSEIF (ISET.EQ.3) THEN
61346 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 2D'
61347 ELSEIF (ISET.EQ.4) THEN
61348 WRITE (6,'(10X,A)')'SCHULER-SJOSTRAND PHOTON PDF SET 2M'
61349 ELSE
61350 WRITE (6,'(10X,A)')'UNKNOWN SCHULER-SJOSTRAND PDF SET'
61351 CALL HWWARN('HWUINC',500)
61352 ENDIF
61353 IF (IOP1.EQ.1) THEN
61354 WRITE (6,'(10X,A)') 'WITH DIRECT COMPONENT IN DIS'
61355 IF (IPRO.NE.90) WRITE (6,'(10X,A)')
61356 $ 'NOT RECOMMENDED FOR NON-DIS PROCESSES'
61357 ENDIF
61358 IF (IOP2.EQ.1) THEN
61359 WRITE (6,'(10X,A)') 'WITH P**2 DEPENDENCE INCLUDED'
61360 IF (PHOMAS.GT.ZERO)
61361 $ WRITE (6,'(10X,A)') 'NOT RECOMMENDED WITH PHOMAS.GT.0'
61362 IF (IP2.GT.0)
61363 $ WRITE (6,'(10X,A,I2)') 'WITH IP2 OPTION EQUAL TO',IP2
61364 ENDIF
61365 ELSEIF (AUTPDF(I).EQ.'SSph') THEN
61366 WRITE (6,'(10X,A)') 'THE ACRONYM FOR SCHULER-SJOSTRAND'
61367 WRITE (6,'(10X,A)') 'HAS CHANGED TO SaSph ACCORDING TO'
61368 WRITE (6,'(10X,A)') 'THEIR WISHES. SSph NO LONGER WORKS'
61369 STOP
61370 ELSE
d08a7832 61371 CALL PDFSET_HERWIG(PARM,VAL)
65767955 61372 CALL STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BTM,TOP,GLU)
61373 ENDIF
61374 ENDIF
61375 460 CONTINUE
61376 WRITE (6,'(1X)')
61377 ENDIF
61378C Set up neutral B meson mixing parameters
61379 IF (MIXING.AND..NOT.(RSTAB(223).AND.RSTAB(247))) THEN
61380 XMRCT(1)=XMIX(1)*RMASS(223)/(CSPEED*RLTIM(223))
61381 YMRCT(1)=YMIX(1)*RMASS(223)/(CSPEED*RLTIM(223))
61382 ENDIF
61383 IF (MIXING.AND..NOT.(RSTAB(221).AND.RSTAB(245))) THEN
61384 XMRCT(2)=XMIX(2)*RMASS(221)/(CSPEED*RLTIM(221))
61385 YMRCT(2)=YMIX(2)*RMASS(221)/(CSPEED*RLTIM(221))
61386 ENDIF
61387C---B DECAY PACKAGE
61388 IF (BDECAY.EQ.'EURO') THEN
61389 IF (IPRINT.NE.0) WRITE (6,470) 'EURODEC'
61390 ELSEIF (BDECAY.EQ.'CLEO') THEN
61391 IF (IPRINT.NE.0) WRITE (6,470) 'CLEO'
61392 ELSE
61393 BDECAY='HERW'
61394 ENDIF
61395 470 FORMAT (10X,A,' B DECAY PACKAGE WILL BE USED')
61396C---TAU DECAY PACKAGE
61397 IF(TAUDEC.EQ.'TAUOLA') THEN
61398 IF(IPRINT.NE.0) WRITE(6,475) 'TAUOLA'
61399 CALL HWDTAU(-1,0,0.0D0)
61400 ENDIF
61401 475 FORMAT(10X,A,' TAU DECAY PACKAGE WILL BE USED'/)
61402C---COMPUTE PARTICLE PROPERTIES FOR HADRONIZATION
61403 CALL HWURES
61404C Prepare internal decay tables and do diagnostic checks
61405 CALL HWUDKS
61406C Convert ampersands to backslahes in particle LaTeX names
61407 CALL HWUATS
61408C---MISCELLANEOUS DERIVED QUANTITIES
61409 TMTOP=2.*LOG(RMASS(6)/30.)
61410 PXRMS=PTRMS/SQRT(2.)
61411 ZBINM=0.25/ZBINM
61412 PSPLT(1)=1./PSPLT(1)
61413 PSPLT(2)=1./PSPLT(2)
61414 NDTRY=2*NCTRY
61415 NGSPL=0
61416 PGSMX=0.
61417 DO 480 I=1,4
61418 PGS=HWUPCM(RMASS(13),RMASS(I),RMASS(I))
61419 IF (PGS.GE.ZERO) NGSPL=I
61420 IF (PGS.GE.PGSMX) PGSMX=PGS
61421 480 PGSPL(I)=PGS
61422 CALL HWVZRO(6,PTINT)
61423 IF (IPRO.NE.80) THEN
61424C---SET UP TABLES OF SUDAKOV FORM FACTORS, GIVING
61425C PROBABILITY DISTRIBUTION IN VARIABLE Q = E*SQRT(XI)
61426 NSUD=NFLAV
61427 CALL HWBSUD
61428C---SET PARAMETERS FOR SPACELIKE BRANCHING
61429 DO 500 I=1,NSUD
61430 DO 490 J=2,NQEV
61431 IF (QEV(J,I).GT.QSPAC) GOTO 500
61432 490 CONTINUE
61433 500 NSPAC(I)=J-1
61434 ENDIF
61435 EVWGT=AVWGT
61436 ISTAT=1
61437C--optimize the weights for the channels if needed
61438 CALL HWIPHS(2)
61439C--perform the initialisation of the SUSY ME's
61440 IF(SYSPIN.OR.THREEB.OR.FOURB) THEN
61441 CALL HWISPN
61442 IF (IPRINT.NE.0) WRITE (6,510)
61443 510 FORMAT(/10X,'CHECKING SUSY DECAY MATRIX ELEMENTS')
61444 ENDIF
61445C Print particle decay tables here
61446 IF (IPRINT.GE.2) CALL HWUDPR
61447C-- initialise photos if needed
61448 IF ((TAUDEC.EQ.'TAUOLA'.AND.IFPHOT.EQ.1).OR.ITOPRD.EQ.1)
61449 & CALL PHOINI
61450 END
61451CDECK ID>, HWUINE.
61452*CMZ :- -16/10/93 12.42.15 by Mike Seymour
61453*-- Author : Bryan Webber
61454C-----------------------------------------------------------------------
61455 SUBROUTINE HWUINE
61456C-----------------------------------------------------------------------
61457C INITIALISES AN EVENT
61458C-----------------------------------------------------------------------
c63d70bc 61459 INCLUDE 'herwig65.inc'
65767955 61460 DOUBLE PRECISION HWRGEN,HWRGET,DUMMY
61461 REAL TL
61462 LOGICAL CALLED,HWRLOG
61463 EXTERNAL HWRGEN,HWRGET,HWRLOG
61464 COMMON/HWDBUG/CALLED
61465C---CHECK THAT MAIN PROGRAM HAS BEEN MODIFIED CORRECTLY
61466 IF (NEVHEP.GT.0.AND..NOT.CALLED) THEN
61467 WRITE (6,10)
61468 10 FORMAT (1X,'A call to the subroutine HWUFNE should be added to',
61469 & /,' the main program, immediately after the call to HWMEVT')
61470 CALL HWWARN('HWUINE',500)
61471 ENDIF
61472 CALLED=.FALSE.
61473C---CHECK TIME LEFT
61474 CALL HWUTIM(TL)
61475 IF (TL.LT.TLOUT) CALL HWWARN('HWUINE',200)
61476C---UPDATE RANDOM NUMBER SEED
61477 DUMMY = HWRGET(NRN)
61478 NEVHEP=NEVHEP+1
61479 IF (NEGWTS.AND.EVWGT.LT.ZERO) NNEGEV=NNEGEV+1
61480 NHEP=0
61481 ISTAT=6
61482 IERROR=0
61483 EVWGT=AVWGT
61484 HVFCEN=.FALSE.
61485 ISLENT=1
61486 NQDK=0
61487C---DECIDE WHETHER TO GENERATE SOFT UNDERLYING EVENT
61488 GENSOF=IPROC.GE.1300.AND.IPROC.LT.10000.AND.
61489 & (IPROC.EQ.8000.OR.HWRLOG(PRSOF))
61490C Zero arrays
61491 CALL HWVZRI(2*NMXHEP,JMOHEP)
61492 CALL HWVZRI(2*NMXHEP,JDAHEP)
61493 CALL HWVZRO(4*NMXHEP,VHEP)
61494 CALL HWVZRO(3*NMXHEP,RHOHEP)
61495 EMSCA=ZERO
61496 IF(SYSPIN) THEN
61497 NSPN = 0
61498 CALL HWVZRI( NMXHEP,ISNHEP)
61499 CALL HWVZRI( NMXSPN,JMOSPN)
61500 CALL HWVZRI(2*NMXSPN,JDASPN)
61501 CALL HWVZRI( NMXSPN, IDSPN)
61502 ENDIF
61503 END
61504CDECK ID>, HWULB4.
61505*CMZ :- -05/11/95 19.33.42 by Mike Seymour
61506*-- Author : Adapted by Bryan Webber
61507C-----------------------------------------------------------------------
61508 SUBROUTINE HWULB4(PS,PI,PF)
61509C-----------------------------------------------------------------------
61510C TRANSFORMS PI (GIVEN IN REST FRAME OF PS) INTO PF (IN LAB)
61511C N.B. P(1,2,3,4) = (PX,PY,PZ,E); PS(5)=M
61512C-----------------------------------------------------------------------
61513 IMPLICIT NONE
61514 DOUBLE PRECISION PF4,FN,PS(5),PI(4),PF(4)
61515 IF (PS(4).EQ.PS(5)) THEN
61516 PF(1)= PI(1)
61517 PF(2)= PI(2)
61518 PF(3)= PI(3)
61519 PF(4)= PI(4)
61520 ELSE
61521 PF4 = (PI(1)*PS(1)+PI(2)*PS(2)
61522 & +PI(3)*PS(3)+PI(4)*PS(4))/PS(5)
61523 FN = (PF4+PI(4)) / (PS(4)+PS(5))
61524 PF(1)= PI(1) + FN*PS(1)
61525 PF(2)= PI(2) + FN*PS(2)
61526 PF(3)= PI(3) + FN*PS(3)
61527 PF(4)= PF4
61528 END IF
61529 END
61530CDECK ID>, HWULDO.
61531*CMZ :- -26/04/91 11.11.56 by Bryan Webber
61532*-- Author : Bryan Webber
61533C----------------------------------------------------------------------
61534 FUNCTION HWULDO(P,Q)
61535C----------------------------------------------------------------------
61536C LORENTZ 4-VECTOR DOT PRODUCT
61537C----------------------------------------------------------------------
61538 IMPLICIT NONE
61539 DOUBLE PRECISION HWULDO,P(4),Q(4)
61540 HWULDO=P(4)*Q(4)-(P(1)*Q(1)+P(2)*Q(2)+P(3)*Q(3))
61541 END
61542CDECK ID>, HWULF4.
61543*CMZ :- -05/11/95 19.33.42 by Mike Seymour
61544*-- Author : Adapted by Bryan Webber
61545C-----------------------------------------------------------------------
61546 SUBROUTINE HWULF4(PS,PI,PF)
61547C-----------------------------------------------------------------------
61548C TRANSFORMS PI (GIVEN IN LAB) INTO PF (IN REST FRAME OF PS)
61549C N.B. P(1,2,3,4) = (PX,PY,PZ,E); PS(5)=M
61550C-----------------------------------------------------------------------
61551 IMPLICIT NONE
61552 DOUBLE PRECISION PF4,FN,PS(5),PI(4),PF(4)
61553 IF (PS(4).EQ.PS(5)) THEN
61554 PF(1)= PI(1)
61555 PF(2)= PI(2)
61556 PF(3)= PI(3)
61557 PF(4)= PI(4)
61558 ELSE
61559 PF4 = (PI(4)*PS(4)-PI(3)*PS(3)
61560 & -PI(2)*PS(2)-PI(1)*PS(1))/PS(5)
61561 FN = (PF4+PI(4)) / (PS(4)+PS(5))
61562 PF(1)= PI(1) - FN*PS(1)
61563 PF(2)= PI(2) - FN*PS(2)
61564 PF(3)= PI(3) - FN*PS(3)
61565 PF(4)= PF4
61566 END IF
61567 END
61568CDECK ID>, HWULI2.
61569*CMZ :- -23/08/94 13.22.29 by Mike Seymour
61570*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
61571C-----------------------------------------------------------------------
61572 FUNCTION HWULI2(X)
61573C-----------------------------------------------------------------------
61574C Complex dilogarithm function, Li_2 (Spence function)
61575C-----------------------------------------------------------------------
61576 IMPLICIT NONE
61577 DOUBLE COMPLEX HWULI2,PROD,Y,Y2,X,Z
61578 DOUBLE PRECISION XR,XI,R2,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,ZETA2,
61579 & ZERO,ONE,HALF
61580 PARAMETER (ZERO=0.0D0, ONE=1.0D0, HALF=0.5D0)
61581 SAVE A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,ZETA2
61582 DATA A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,ZETA2/ -0.250000000000000D0,
61583 & -0.111111111111111D0,-0.010000000000000D0,-0.017006802721088D0,
61584 & -0.019444444444444D0,-0.020661157024793D0,-0.021417300648069D0,
61585 & -0.021948866377231D0,-0.022349233811171D0,-0.022663689135191D0,
61586 & 1.644934066848226D0/
61587 PROD(Y,Y2)=Y*(ONE+A1*Y*(ONE+A2*Y*(ONE+A3*Y2*(ONE+A4*Y2*(ONE+A5*Y2*
61588 & (ONE+A6*Y2*(ONE+A7*Y2*(ONE+A8*Y2*(ONE+A9*Y2*(ONE+A10*Y2))))))))))
61589 XR=DREAL(X)
61590 XI=DIMAG(X)
61591 R2=XR*XR+XI*XI
61592 IF (R2.GT.ONE.AND.(XR/R2).GT.HALF) THEN
61593 Z=-LOG(ONE/X)
61594 HWULI2=PROD(Z,Z*Z)+ZETA2-LOG(X)*LOG(ONE-X)+HALF*LOG(X)**2
61595 ELSEIF (R2.GT.ONE.AND.(XR/R2).LE.HALF) THEN
61596 Z=-LOG(ONE-ONE/X)
61597 HWULI2=-PROD(Z,Z*Z)-ZETA2-HALF*LOG(-X)**2
61598 ELSEIF (R2.EQ.ONE.AND.XI.EQ.ZERO) THEN
61599 HWULI2=ZETA2
61600 ELSEIF (R2.LE.ONE.AND.XR.GT.HALF) THEN
61601 Z=-LOG(X)
61602 HWULI2=-PROD(Z,Z*Z)+ZETA2-LOG(X)*LOG(ONE-X)
61603 ELSE
61604 Z=-LOG(ONE-X)
61605 HWULI2=PROD(Z,Z*Z)
61606 ENDIF
61607 END
61608CDECK ID>, HWULOB.
61609*CMZ :- -05/11/95 19.33.42 by Mike Seymour
61610*-- Author : Adapted by Bryan Webber
61611C-----------------------------------------------------------------------
61612 SUBROUTINE HWULOB(PS,PI,PF)
61613C-----------------------------------------------------------------------
61614C TRANSFORMS PI (GIVEN IN REST FRAME OF PS) INTO PF (IN LAB)
61615C N.B. P(1,2,3,4,5) = (PX,PY,PZ,E,M)
61616C-----------------------------------------------------------------------
61617 IMPLICIT NONE
61618 DOUBLE PRECISION PS(5),PI(5),PF(5)
61619 CALL HWULB4(PS,PI,PF)
61620 PF(5)= PI(5)
61621 END
61622CDECK ID>, HWULOF.
61623*CMZ :- -05/11/95 19.33.42 by Mike Seymour
61624*-- Author : Adapted by Bryan Webber
61625C-----------------------------------------------------------------------
61626 SUBROUTINE HWULOF(PS,PI,PF)
61627C-----------------------------------------------------------------------
61628C TRANSFORMS PI (GIVEN IN LAB) INTO PF (IN REST FRAME OF PS)
61629C N.B. P(1,2,3,4,5) = (PX,PY,PZ,E,M)
61630C-----------------------------------------------------------------------
61631 IMPLICIT NONE
61632 DOUBLE PRECISION PS(5),PI(5),PF(5)
61633 CALL HWULF4(PS,PI,PF)
61634 PF(5)= PI(5)
61635 END
61636CDECK ID>, HWULOR.
61637*CMZ :- -26/04/91 11.11.56 by Bryan Webber
61638*-- Author : Giovanni Abbiendi & Luca Stanco
61639C-----------------------------------------------------------------------
61640 SUBROUTINE HWULOR (TRANSF,PI,PF)
61641C-----------------------------------------------------------------------
61642C Makes the HWULOR transformation specified by TRANSF on the
61643C quadrivector PI(5), giving PF(5).
61644C-----------------------------------------------------------------------
61645 IMPLICIT NONE
61646 DOUBLE PRECISION TRANSF(4,4),PI(5),PF(5)
61647 INTEGER I,J
61648 DO 1 I=1,5
61649 PF(I)=0.D0
61650 1 CONTINUE
61651 DO 3 I=1,4
61652 DO 2 J=1,4
61653 PF(I) = PF(I) + TRANSF(I,J) * PI(J)
61654 2 CONTINUE
61655 3 CONTINUE
61656 PF(5) = PI(5)
61657 END
61658CDECK ID>, HWUMAS.
61659*CMZ :- -26/04/91 11.11.56 by Bryan Webber
61660*-- Author : Bryan Webber
61661C-----------------------------------------------------------------------
61662 SUBROUTINE HWUMAS(P)
61663C-----------------------------------------------------------------------
61664C PUTS INVARIANT MASS IN 5TH COMPONENT OF VECTOR
61665C (NEGATIVE SIGN IF SPACELIKE)
61666C-----------------------------------------------------------------------
61667 IMPLICIT NONE
61668 DOUBLE PRECISION HWUSQR,P(5)
61669 EXTERNAL HWUSQR
61670 P(5)=HWUSQR((P(4)+P(3))*(P(4)-P(3))-P(1)**2-P(2)**2)
61671 END
61672CDECK ID>, HWUMBW.
61673*CMZ :- -21/02/98 11.11.56 by Bryan Webber
61674*-- Author : Bryan Webber
61675C-----------------------------------------------------------------------
61676 FUNCTION HWUMBW(ID)
61677C-----------------------------------------------------------------------
61678C CHOOSES MASS ACCORDING TO BREIT-WIGNER DISTRIBUTION
61679C--BRW fix 27/8/04: changed from mass to mass-squared BW formula
61680C-----------------------------------------------------------------------
c63d70bc 61681 INCLUDE 'herwig65.inc'
65767955 61682 DOUBLE PRECISION HWUMBW,HWRGEN,WMX,TAU,GAM,T,TM
61683 INTEGER ID
61684C--WMX IS MAX NUMBER OF WIDTHS FROM NOMINAL MASS
61685 WMX=GAMMAX
61686 HWUMBW=RMASS(ID)
61687 IF(ID.EQ.198.OR.ID.EQ.199) THEN
61688 TAU = HBAR/GAMW
61689 ELSEIF(ID.EQ.200) THEN
61690 TAU = HBAR/GAMZ
61691 ELSEIF(ID.EQ.201) THEN
61692 TAU = HBAR/GAMH
61693 ELSE
61694 TAU=RLTIM(ID)
61695 ENDIF
61696 IF (TAU.EQ.ZERO.OR.TAU.GT.1D-18) RETURN
61697 GAM=HBAR/TAU
61698 1 T=TAN(PIFAC*(HWRGEN(0)-HALF))
61699 TM=RMASS(ID)*(RMASS(ID)+GAM*T)
61700 IF(TM.LT.ZERO) GOTO 1
61701 TM=SQRT(TM)
61702 IF (ABS(TM-RMASS(ID)).GT.WMX*GAM) GOTO 1
61703 HWUMBW=TM
61704 END
61705CDECK ID>, HWUNST.
61706*CMZ :- -27/07/99 13.33.03 by Mike Seymour
61707*-- Author : Ian Knowles
61708C-----------------------------------------------------------------------
61709 FUNCTION HWUNST(N)
61710C-----------------------------------------------------------------------
61711C Creates a character string of length 7 equivalent to integer N
61712C-----------------------------------------------------------------------
61713 IMPLICIT NONE
61714 INTEGER N,I,M,NN(7)
61715 CHARACTER*1 NCHAR(0:9)
61716 CHARACTER*7 HWUNST
61717 SAVE NCHAR
61718 DATA NCHAR/'0','1','2','3','4','5','6','7','8','9'/
61719 M=1
61720 DO 10 I=7,1,-1
61721 NN(I)=MOD(N/M,10)
61722 10 M=M*10
61723 WRITE(HWUNST,'(7A1)') (NCHAR(NN(I)),I=1,7)
61724 END
61725CDECK ID>, HWUPCM.
61726*CMZ :- -26/04/91 11.11.56 by Bryan Webber
61727*-- Author : Bryan Webber
61728C-----------------------------------------------------------------------
61729 FUNCTION HWUPCM(EM0,EM1,EM2)
61730C-----------------------------------------------------------------------
61731C C.M. MOMENTUM FOR DECAY MASSES EM0 -> EM1 + EM2
61732C SET TO -1 BELOW THRESHOLD
61733C-----------------------------------------------------------------------
61734 IMPLICIT NONE
61735 DOUBLE PRECISION HWUPCM,EM0,EM1,EM2,EMS,EMD
61736 EMS=ABS(EM1+EM2)
61737 EMD=ABS(EM1-EM2)
61738 IF (EM0.LT.EMS.OR.EM0.LT.EMD) THEN
61739 HWUPCM=-1.
61740 ELSEIF (EM0.EQ.EMS.OR.EM0.EQ.EMD) THEN
61741 HWUPCM=0.
61742 ELSE
61743 HWUPCM=SQRT((EM0+EMD)*(EM0-EMD)*
61744 & (EM0+EMS)*(EM0-EMS))*.5/EM0
61745 ENDIF
61746 END
61747CDECK ID>, HWURAP.
61748*CMZ :- -26/04/91 11.11.56 by Bryan Webber
61749*-- Author : Bryan Webber
61750C-----------------------------------------------------------------------
61751 FUNCTION HWURAP(P)
61752C-----------------------------------------------------------------------
61753C LONGITUDINAL RAPIDITY (SET TO +/-1000 IF TOO LARGE)
61754C-----------------------------------------------------------------------
61755 IMPLICIT NONE
61756 DOUBLE PRECISION HWURAP,EMT2,P(5),ZERO
61757 PARAMETER (ZERO=0.D0)
61758 EMT2=P(1)**2+P(2)**2+P(5)**2
61759 IF (P(3).GT.ZERO) THEN
61760 IF (EMT2.EQ.ZERO) THEN
61761 HWURAP=1000.
61762 ELSE
61763 HWURAP= 0.5*LOG((P(3)+P(4))**2/EMT2)
61764 ENDIF
61765 ELSEIF (P(3).LT.ZERO) THEN
61766 IF (EMT2.EQ.ZERO) THEN
61767 HWURAP=-1000.
61768 ELSE
61769 HWURAP=-0.5*LOG((P(3)-P(4))**2/EMT2)
61770 ENDIF
61771 ELSE
61772 HWURAP=0.
61773 ENDIF
61774 END
61775CDECK ID>, HWUMPO.
61776*CMZ :- -26/11/00 17.21.55 by Bryan Webber
61777*-- Author : Kosuke Odagiri
61778C-----------------------------------------------------------------------
61779 SUBROUTINE HWUMPO(P,M,PMM,MGAM,PPROJ,FPROP)
61780C-----------------------------------------------------------------------
61781C RETURNS PROJECTION OPERATOR 1/(P-SLASH - M + I*MGAM) IN WEYL-BASIS
61782C USED IN SUBROUTINE HWH2QH
61783C-----------------------------------------------------------------------
61784 IMPLICIT NONE
61785 DOUBLE PRECISION P(0:3),M,PMM,MGAM,ZERO,ONE
61786 DOUBLE COMPLEX PROP, PPROJ(4,4), CZERO
61787 LOGICAL FPROP
61788 PARAMETER (ZERO=0.D0,CZERO=(0.D0,0.D0),ONE=1.D0)
61789 IF (FPROP) THEN
61790 PROP=ONE/DCMPLX(PMM,MGAM)
61791 ELSE
61792 PROP=DCMPLX(ONE/PMM, ZERO)
61793 END IF
61794 PPROJ(1,1) = M*PROP
61795 PPROJ(1,2) = CZERO
61796 PPROJ(2,1) = CZERO
61797 PPROJ(2,2) = PPROJ(1,1)
61798 PPROJ(1,3) = (P(0)-P(3))*PROP
61799 PPROJ(1,4) = DCMPLX(-P(1),P(2))*PROP
61800 PPROJ(2,3) = DCMPLX(-P(1),-P(2))*PROP
61801 PPROJ(2,4) = (P(0)+P(3))*PROP
61802 PPROJ(3,1) = PPROJ(2,4)
61803 PPROJ(3,2) = -PPROJ(1,4)
61804 PPROJ(4,1) = -PPROJ(2,3)
61805 PPROJ(4,2) = PPROJ(1,3)
61806 PPROJ(3,3) = PPROJ(1,1)
61807 PPROJ(3,4) = CZERO
61808 PPROJ(4,3) = CZERO
61809 PPROJ(4,4) = PPROJ(1,1)
61810 END
61811CDECK ID>, HWUMPP.
61812*CMZ :- -26/11/00 17.21.55 by Bryan Webber
61813*-- Author : Kosuke Odagiri
61814C-----------------------------------------------------------------------
61815 SUBROUTINE HWUMPP(M,GPM,PERM,U,UU,LR)
61816C-----------------------------------------------------------------------
61817C APPLIES OPERATOR FROM HWUMPO ON SPINORS.
61818C SPINOR COMPONENTS CAN BE PERMUTATED (PERM) AND TRANSVERSED (LR)
61819C-----------------------------------------------------------------------
61820 IMPLICIT NONE
61821 DOUBLE COMPLEX U(4), TEMP, A(4,4), M(16), UU(4), CZERO
61822 DOUBLE PRECISION GPM(2), FAC, ZERO, ONE, MONE
61823 INTEGER LR,TV(4,4,2),I,J, PERM(4), IZERO, GTOF(4)
61824 PARAMETER (ZERO=0.D0,CZERO=(0.D0,0.D0),IZERO=0)
61825 PARAMETER (ONE =1.D0,MONE = -1.D0)
61826 SAVE GTOF,TV
61827 DATA GTOF/1,1,2,2/
61828 DATA TV/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,
61829 & 1,5,9,13,2,6,10,14,3,7,11,15,4,8,12,16/
61830 DO I=1,4
61831 FAC = GPM(GTOF(I))
61832 IF ((PERM(I).EQ.IZERO).OR.(FAC.EQ.ZERO)) THEN
61833 DO J=1,4
61834 A(I,J)=CZERO
61835 END DO
61836 ELSE
61837 IF(FAC.EQ.ONE) THEN
61838 TEMP = U(PERM(I))
61839 ELSEIF(FAC.EQ.MONE) THEN
61840 TEMP = -U(PERM(I))
61841 ELSE
61842 TEMP = FAC*U(PERM(I))
61843 ENDIF
61844 IF(TEMP.NE.ZERO) THEN
61845 DO J=1,4
61846 IF(M(TV(I,J,LR)).NE.ZERO) THEN
61847 A(I,J)=TEMP*M(TV(I,J,LR))
61848 ELSE
61849 A(I,J)=ZERO
61850 ENDIF
61851 END DO
61852 ELSE
61853 DO J=1,4
61854 A(I,J)=ZERO
61855 END DO
61856 END IF
61857 END IF
61858 END DO
61859 DO J=1,4
61860 UU(J)=A(1,J)+A(2,J)+A(3,J)+A(4,J)
61861 END DO
61862 END
61863CDECK ID>, HWUPUP.
61864*CMZ :- -13/02/02 16.42.23 by Peter Richardson
61865*-- Author : Bryan Webber
61866C----------------------------------------------------------------------
61867 SUBROUTINE HWUPUP
61868C----------------------------------------------------------------------
61869C Prints contents of the GUPI (Generic User Process Interface)
61870C common block HEPEUP
61871C----------------------------------------------------------------------
c63d70bc 61872 INCLUDE 'herwig65.inc'
65767955 61873 INTEGER MAXNUP
61874 PARAMETER (MAXNUP=500)
61875 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
61876 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
61877 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
61878 & IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
61879 & ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
61880 & SPINUP(MAXNUP)
61881 INTEGER IUP,IWIG,I
61882 CHARACTER*8 NAME
61883 PRINT *
61884 PRINT *, ' I ISTUP IDUP NAME MOTHUP ICOLUP PUP'
61885 DO IUP=1,NUP
61886 CALL HWUIDT(1,IDUP(IUP),IWIG,NAME)
61887 PRINT 11,IUP,ISTUP(IUP),IDUP(IUP),NAME,MOTHUP(1,IUP),
61888 & MOTHUP(2,IUP),ICOLUP(1,IUP),ICOLUP(2,IUP),(PUP(I,IUP),I=1,5)
61889 Enddo
61890 11 Format(2I3,I4,2X,A8,2I3,2I4,5F8.1)
61891 End
61892CDECK ID>, HWURES.
61893*CMZ :- -26/04/91 11.11.56 by Bryan Webber
61894*-- Author : Ian Knowles & Bryan Webber
61895C-----------------------------------------------------------------------
61896 SUBROUTINE HWURES
61897C-----------------------------------------------------------------------
61898C Using properties of particle I supplied in HWUDAT checks particles
61899C and antiparticles have compatible properties and sets SWTEF(I) =
61900C ( rep. enhancement factor)^2 - used in cluster decays
61901C Finds iso-flavour hadrons and creates pointers for cluster decays.
61902C Sets CLDKWT(K) =(2J+1) spin weight normalizing largest value to 1.
61903C-----------------------------------------------------------------------
c63d70bc 61904 INCLUDE 'herwig65.inc'
65767955 61905 INTEGER NMXTMP
61906 PARAMETER (NMXTMP=20)
61907 DOUBLE PRECISION EPS,WTMX,REMMN,RWTMX,WTMP,RESTMP(91),WTMX2,
61908 & REMMN2,WT,CDWTMP(NMXTMP)
61909 INTEGER HWUANT,MAPF(89),MAPC(12,12),I,IANT,IABPDG,J,L,N,K,LTMP,
61910 & NCDKS,IMN,ITMP,LOCTMP(91),NTMP,NCDTMP(NMXTMP),IMN2
61911 EXTERNAL HWUANT
61912 PARAMETER (EPS=1.D-6)
61913 SAVE MAPF,MAPC
61914 DATA MAPF/21,31,41,51,61,12,32,42,52,62,13,23,43,53,63,14,24,34,
61915 & 44,54,64,15,25,35,45,55,65,16,26,36,46,56,66,111,112,113,122,123,
61916 & 133,222,223,233,333,-111,-112,-113,-122,-123,-133,-222,-223,-233,
61917 & -333,114,124,134,224,234,334,-114,-124,-134,-224,-234,-334,115,
61918 & 125,135,225,235,335,-115,-125,-135,-225,-235,-335,116,126,136,
61919 & 226,236,336,-116,-126,-136,-226,-236,-336/
61920 DATA MAPC/90,1,2,47,45,44,48,46,49,3,4,5,6,90,7,50,47,45,51,48,52,
61921 & 8,9,10,11,12,91,51,48,46,52,49,53,13,14,15,37,40,41,6*0,57,69,81,
61922 & 35,37,38,6*0,55,67,79,34,35,36,6*0,54,66,78,38,41,42,6*0,58,70,
61923 & 82,36,38,39,6*0,56,68,80,39,42,43,6*0,59,71,83,16,17,18,63,61,60,
61924 & 64,62,65,19,20,21,22,23,24,75,73,72,76,74,77,25,26,27,28,29,30,
61925 & 87,85,84,88,86,89,31,32,33/
61926C Check particle/anti-particle properties are compatible
61927 WRITE(6,10)
61928 10 FORMAT(/10X,'Checking consistency of particle properties'/)
61929 DO 20 I=10,NRES
61930 IF (IDPDG(I).GT.0) THEN
61931 IANT=HWUANT(I)
61932 IF (IANT.EQ.20) GOTO 20
61933 IF (MOD(IDPDG(I)/1000,10).EQ.0.AND.
61934 & MOD(IDPDG(I)/100 ,10).NE.0) THEN
61935 IF (MOD(IFLAV(I)/10-IFLAV(IANT),10).NE.0.OR.
61936 & MOD(IFLAV(I)-IFLAV(IANT)/10,10).NE.0)
61937 & WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)
61938 ELSE
61939 IF (IFLAV(I)+IFLAV(IANT).NE.0)
61940 & WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)
61941 ENDIF
61942 IF (ICHRG(I)+ICHRG(IANT).NE.0)
61943 & WRITE(6,40) RNAME(I),RNAME(IANT),ICHRG(I),ICHRG(IANT)
61944 IF (ABS(RMASS(I)-RMASS(IANT)).GT.EPS)
61945 & WRITE(6,50) RNAME(I),RMASS(I),RMASS(IANT)
61946 IF (ABS(RLTIM(I)-RLTIM(IANT)).GT.EPS)
61947 & WRITE(6,60) RNAME(I),RLTIM(I),RLTIM(IANT)
61948 IF (ABS(RSPIN(I)-RSPIN(IANT)).GT.EPS)
61949 & WRITE(6,70) RNAME(I),RSPIN(I),RSPIN(IANT)
61950 ENDIF
61951 20 CONTINUE
61952 30 FORMAT(10X,A8,' flavour code=',I4,5X,' antiparticle=',I4)
61953 40 FORMAT(10X,2A8,' charge =',I2,7X,' antiparticle=',I2)
61954 50 FORMAT(10X,A8,' mass =',F7.3,2X,' antiparticle=',F7.3)
61955 60 FORMAT(10X,A8,' life time =',E9.3,' antiparticle=',E9.3)
61956 70 FORMAT(10X,A8,' spin =',F3.1,6X,' antiparticle=',F3.1)
61957C Compute resonance properties
61958 DO 80 I=21,NRES
61959C Compute representation weights for hadrons, used in cluster decays
61960 IABPDG=ABS(IDPDG(I))
61961 J=MOD(IABPDG,10)
61962 IF (J.EQ.2.AND.MOD(IABPDG/100,10).LT.MOD(IABPDG/10,10)) THEN
61963C Singlet (Lambda-like) baryon
61964 SWTEF(I)=SNGWT**2
61965 ELSEIF (J.EQ.4) THEN
61966C Decuplet baryon
61967 SWTEF(I)=DECWT**2
61968 ELSEIF(2*(J/2).NE.J) THEN
61969C Mesons: identify by spin, angular momentum & radial excitation
61970 J=(J-1)/2
61971 L= MOD(IABPDG/10000 ,10)
61972 N= MOD(IABPDG/100000,10)
61973 IF (L.EQ.0.AND.J.EQ.0.AND.N.EQ.0.OR.
61974 & L.GT.3.OR. J.GT.4.OR .N.GT.4) THEN
61975 SWTEF(I)=1.
61976 ELSE
61977 SWTEF(I)=REPWT(L,J,N)**2
61978 ENDIF
61979 ELSE
61980C Not recognized
61981 SWTEF(I)=1.
61982 ENDIF
61983 80 CONTINUE
61984C Prepare tables for cluster decays, except flavourless light mesons
61985 LTMP=1
61986 NCDKS=0
61987 DO 120 I=1,89
61988C Store particles, flavour MAPF(I), noting highest spin and lowest mass
61989 WTMX=0.
61990 REMMN=1000.
61991 DO 90 J=21,NRES
61992 IF (VTOCDK(J).OR.IFLAV(J).NE.MAPF(I)) GOTO 90
61993 NCDKS=NCDKS+1
61994 IF (NCDKS.GT.NMXCDK) THEN
61995 CALL HWWARN('HWURES',101)
61996 GOTO 999
61997 ENDIF
61998 NCLDK(NCDKS)=J
61999 CLDKWT(NCDKS)=TWO*RSPIN(J)+ONE
62000 IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)
62001 IF (RMASS(J).LT.REMMN) THEN
62002 REMMN=RMASS(J)
62003 IMN=NCDKS
62004 ENDIF
62005 90 CONTINUE
62006 IF (NCDKS+1-LTMP.EQ.0) THEN
62007 WRITE(6,100) MAPF(I)
62008 100 FORMAT(1X,'No particles exist for a cluster with flavour, ',I4,
62009 & ' to decay into')
62010 CALL HWWARN('HWURES',51)
62011 GOTO 120
62012 ENDIF
62013C Set scaled spin weights
62014 RWTMX=1./WTMX
62015 DO 110 J=LTMP,NCDKS
62016 110 CLDKWT(J)=CLDKWT(J)*RWTMX
62017C Swap order if lightest hadron of given flavour not first
62018 IF (IMN.NE.LTMP) THEN
62019 ITMP=NCLDK(LTMP)
62020 WTMP=CLDKWT(LTMP)
62021 NCLDK(LTMP)=NCLDK(IMN)
62022 CLDKWT(LTMP)=CLDKWT(IMN)
62023 NCLDK(IMN)=ITMP
62024 CLDKWT(IMN)=WTMP
62025 ENDIF
62026C Set pointers etc
62027 LOCTMP(I)=LTMP
62028 RESTMP(I)=FLOAT(NCDKS+1-LTMP)
62029 LTMP=NCDKS+1
62030 120 CONTINUE
62031C Now do flavourless light mesons, allowing for mixing in weights
62032 WTMX=0.
62033 REMMN=1000.
62034 WTMX2=0.
62035 REMMN2=1000.
62036 NTMP=0
62037 DO 140 J=21,NRES
62038 IF (VTOCDK(J)) THEN
62039 GOTO 140
62040C Calculate mixing weight for (|uubar>+|ddbar>)/sqrt(2) component
62041 ELSEIF (IFLAV(J).EQ.11) THEN
62042 WT=1.
62043 ELSEIF (IFLAV(J).EQ.33) THEN
62044C eta - eta'
62045 IF (J.EQ.22 ) THEN
62046 WT=COS(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62047 ELSEIF (J.EQ.25 ) THEN
62048 WT=SIN(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62049C phi - omega
62050 ELSEIF (J.EQ.56 ) THEN
62051 WT=COS(PHIMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62052 ELSEIF (J.EQ.24 ) THEN
62053 WT=SIN(PHIMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62054C f'_2 - f_2
62055 ELSEIF (J.EQ.58 ) THEN
62056 WT=COS(F2MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
62057 ELSEIF (J.EQ.26 ) THEN
62058 WT=SIN(F2MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
62059C f_1(1420) - f_1(1285)
62060 ELSEIF (J.EQ.57 ) THEN
62061 WT=COS(F1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
62062 ELSEIF (J.EQ.28 ) THEN
62063 WT=SIN(F1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
62064C h_1(1380) - h_1(1170)
62065 ELSEIF (J.EQ.289) THEN
62066 WT=COS(H1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
62067 ELSEIF (J.EQ.288) THEN
62068 WT=SIN(H1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
62069C MISSING - f_0(1370)
62070 ELSEIF (J.EQ.294) THEN
62071 WT=SIN(F0MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2
62072C phi_3 - omega_3
62073 ELSEIF (J.EQ.396) THEN
62074 WT=COS(PH3MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62075 ELSEIF (J.EQ.395) THEN
62076 WT=SIN(PH3MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62077C eta_2(1645) - eta_2(1870)
62078 ELSEIF (J.EQ.397) THEN
62079 WT=COS(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62080 ELSEIF (J.EQ.398) THEN
62081 WT=SIN(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62082C MISSING - omega(1600)
62083 ELSEIF (J.EQ.399) THEN
62084 WT=SIN(OMHMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
62085 ELSE
62086 WT=1./3.
62087 WRITE(6,130) J
62088 130 FORMAT(1X,'Isoscalar particle ',I3,' not recognised,',
62089 & ' no I=0 mixing assumed')
62090 ENDIF
62091 ELSE
62092 GOTO 140
62093 ENDIF
62094 IF (WT.GT.EPS) THEN
62095 NCDKS=NCDKS+1
62096 IF (NCDKS.GT.NMXCDK) THEN
62097 CALL HWWARN('HWURES',102)
62098 GOTO 999
62099 ENDIF
62100 NCLDK(NCDKS)=J
62101 CLDKWT(NCDKS)=WT*(TWO*RSPIN(J)+ONE)
62102 IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)
62103 IF (RMASS(J).LT.REMMN) THEN
62104 REMMN=RMASS(J)
62105 IMN=NCDKS
62106 ENDIF
62107 ENDIF
62108 IF (ONE-WT.GT.EPS) THEN
62109 NTMP=NTMP+1
62110 IF (NTMP.GT.NMXTMP) THEN
62111 CALL HWWARN('HWURES',103)
62112 GOTO 999
62113 ENDIF
62114 NCDTMP(NTMP)=J
62115 CDWTMP(NTMP)=(ONE-WT)*(TWO*RSPIN(J)+ONE)
62116 IF (CDWTMP(NTMP).GT.WTMX2) WTMX2=CDWTMP(NTMP)
62117 IF (RMASS(J).LT.REMMN2) THEN
62118 REMMN2=RMASS(J)
62119 IMN2=NTMP
62120 ENDIF
62121 ENDIF
62122 140 CONTINUE
62123 IF (NCDKS+1-LTMP.EQ.0) THEN
62124 WRITE(6,100) 11
62125 CALL HWWARN('HWURES',52)
62126 GOTO 160
62127 ENDIF
62128C Normalize scaled spin weights
62129 RWTMX=1./WTMX
62130 DO 150 I=LTMP,NCDKS
62131 150 CLDKWT(I)=CLDKWT(I)*RWTMX
62132C Swap order if lightest hadron of flavour 11 not first
62133 IF (IMN.NE.LTMP) THEN
62134 ITMP=NCLDK(LTMP)
62135 WTMP=CLDKWT(LTMP)
62136 NCLDK(LTMP)=NCLDK(IMN)
62137 CLDKWT(LTMP)=CLDKWT(IMN)
62138 NCLDK(IMN)=ITMP
62139 CLDKWT(IMN)=WTMP
62140 ENDIF
62141 160 IF (NTMP.EQ.0) THEN
62142 WRITE(6,100) 33
62143 CALL HWWARN('HWURES',53)
62144 GOTO 180
62145 ENDIF
62146 IF (NCDKS+NTMP.GT.NMXCDK) THEN
62147 CALL HWWARN('HWURES',104)
62148 GOTO 999
62149 ENDIF
62150C Store hadrons for |ssbar> channel and normalize their weights
62151 RWTMX=1./WTMX2
62152 DO 170 I=1,NTMP
62153 J=NCDKS+I
62154 NCLDK(J)=NCDTMP(I)
62155 170 CLDKWT(J)=CDWTMP(I)*RWTMX
62156C Swap order if lightest hadron of flavour 33 not first
62157 IF (IMN2.NE.1) THEN
62158 ITMP=NCLDK(NCDKS+1)
62159 WTMP=CLDKWT(NCDKS+1)
62160 NCLDK(NCDKS+1)=NCLDK(NCDKS+IMN2)
62161 CLDKWT(NCDKS+1)=CLDKWT(NCDKS+IMN2)
62162 NCLDK(NCDKS+IMN2)=ITMP
62163 CLDKWT(NCDKS+IMN2)=WTMP
62164 ENDIF
62165C Set pointers etc
62166 180 LOCTMP(90)=LTMP
62167 RESTMP(90)=FLOAT(NCDKS+1-LTMP)
62168 LOCTMP(91)=NCDKS+1
62169 RESTMP(91)=FLOAT(NTMP)
62170C Set pointers to hadrons of given flavours for cluster decays
62171 DO 190 I=1,12
62172 DO 190 J=1,12
62173 K=MAPC(I,J)
62174 IF (K.EQ.0) THEN
62175 LOCN(I,J)=0
62176 RESN(I,J)=0
62177 RMIN(I,J)=MIN(RMASS(NCLDK(LOCN(I,1)))+RMASS(NCLDK(LOCN(1,J))),
62178 $ RMASS(NCLDK(LOCN(I,2)))+RMASS(NCLDK(LOCN(2,J))))+1.D-2
62179 ELSE
62180 LOCN(I,J)=LOCTMP(K)
62181 RESN(I,J)=RESTMP(K)
62182 RMIN(I,J)=RMASS(NCLDK(LOCN(I,J)))
62183 ENDIF
62184 190 CONTINUE
62185 999 RETURN
62186 END
62187CDECK ID>, HWUROB.
62188*CMZ :- -26/04/91 11.11.56 by Bryan Webber
62189*-- Author : Bryan Webber
62190C-----------------------------------------------------------------------
62191 SUBROUTINE HWUROB(R,P,Q)
62192C-----------------------------------------------------------------------
62193C ROTATES VECTORS BY INVERSE OF ROTATION MATRIX R
62194C-----------------------------------------------------------------------
62195 IMPLICIT NONE
62196 DOUBLE PRECISION S1,S2,S3,R(3,3),P(3),Q(3)
62197 S1=P(1)*R(1,1)+P(2)*R(2,1)+P(3)*R(3,1)
62198 S2=P(1)*R(1,2)+P(2)*R(2,2)+P(3)*R(3,2)
62199 S3=P(1)*R(1,3)+P(2)*R(2,3)+P(3)*R(3,3)
62200 Q(1)=S1
62201 Q(2)=S2
62202 Q(3)=S3
62203 END
62204CDECK ID>, HWUROF.
62205*CMZ :- -26/04/91 11.11.56 by Bryan Webber
62206*-- Author : Bryan Webber
62207C-----------------------------------------------------------------------
62208 SUBROUTINE HWUROF(R,P,Q)
62209C-----------------------------------------------------------------------
62210C ROTATES VECTORS BY ROTATION MATRIX R
62211C-----------------------------------------------------------------------
62212 IMPLICIT NONE
62213 DOUBLE PRECISION S1,S2,S3,R(3,3),P(3),Q(3)
62214 S1=R(1,1)*P(1)+R(1,2)*P(2)+R(1,3)*P(3)
62215 S2=R(2,1)*P(1)+R(2,2)*P(2)+R(2,3)*P(3)
62216 S3=R(3,1)*P(1)+R(3,2)*P(2)+R(3,3)*P(3)
62217 Q(1)=S1
62218 Q(2)=S2
62219 Q(3)=S3
62220 END
62221CDECK ID>, HWUROT.
62222*CMZ :- -26/04/91 11.11.56 by Bryan Webber
62223*-- Author : Bryan Webber
62224C-----------------------------------------------------------------------
62225 SUBROUTINE HWUROT(P,CP,SP,R)
62226C-----------------------------------------------------------------------
62227C R IS ROTATION MATRIX TO GET FROM VECTOR P TO Z AXIS, FOLLOWED BY
62228C A ROTATION BY PSI ABOUT Z AXIS, WHERE CP = COS-PSI, SP = SIN-PSI
62229C-----------------------------------------------------------------------
62230 IMPLICIT NONE
62231 DOUBLE PRECISION WN,CP,SP,PTCUT,PP,PT,CT,ST,CF,SF,P(3),R(3,3)
62232 SAVE WN,PTCUT
62233 DATA WN,PTCUT/1.D0,1.D-20/
62234 PT=P(1)**2+P(2)**2
62235 PP=P(3)**2+PT
62236 IF (PT.LE.PP*PTCUT) THEN
62237 CT=SIGN(WN,P(3))
62238 ST=0.
62239 CF=1.
62240 SF=0.
62241 ELSE
62242 PP=SQRT(PP)
62243 PT=SQRT(PT)
62244 CT=P(3)/PP
62245 ST=PT/PP
62246 CF=P(1)/PT
62247 SF=P(2)/PT
62248 END IF
62249 R(1,1)= CP*CF*CT+SP*SF
62250 R(1,2)= CP*SF*CT-SP*CF
62251 R(1,3)=-CP*ST
62252 R(2,1)=-CP*SF+SP*CF*CT
62253 R(2,2)= CP*CF+SP*SF*CT
62254 R(2,3)=-SP*ST
62255 R(3,1)= CF*ST
62256 R(3,2)= SF*ST
62257 R(3,3)= CT
62258 END
62259CDECK ID>, HWURQM.
62260*CMZ :- -17/07/03 11.11.56 by Bryan Webber
62261*-- Author : Bryan Webber
62262C----------------------------------------------------------------------
62263 SUBROUTINE HWURQM(SCALE,RQM)
62264C-----------------------------------------------------------------------
62265C RUNNING QUARK MASSES (MSBAR, 2-LOOP, 5 FLAVOUR, NO THRESHOLDS)
62266C ASSUMING RMASS(IQ) IS POLE MASS
62267C-----------------------------------------------------------------------
c63d70bc 62268 INCLUDE 'herwig65.inc'
65767955 62269 DOUBLE PRECISION HWUALF,SCALE,ALFAS,P0,C1,CC,MHAT(6),RQM(6)
62270 INTEGER IQ
62271 LOGICAL FIRST
62272 SAVE P0,C1,MHAT,FIRST
62273 DATA FIRST/.TRUE./
62274 IF (FIRST) THEN
62275C---INITIALIZE CONSTANTS
62276 P0=12./23.
62277 C1=3731./(3174.*PIFAC)
62278 CC=C1+4./(3.*PIFAC)
62279 DO IQ=1,6
62280 ALFAS=HWUALF(1,RMASS(IQ))
62281 IF (ALFAS.GT.ZERO) THEN
62282 MHAT(IQ)=RMASS(IQ)/(1.+CC*ALFAS)/ALFAS**P0
62283 ELSE
62284 CALL HWWARN('HWURQM',IQ)
62285 MHAT(IQ)=ZERO
62286 ENDIF
62287 ENDDO
62288 FIRST=.FALSE.
62289 ENDIF
62290 ALFAS=HWUALF(1,SCALE)
62291 CC=(1.+C1*ALFAS)*ALFAS**P0
62292 DO IQ=1,6
62293 RQM(IQ)=MHAT(IQ)*CC
62294 ENDDO
62295 END
62296CDECK ID>, HWUSOR.
62297*CMZ :- -26/04/91 11.11.56 by Bryan Webber
62298*-- Author : Adapted by Bryan Webber
62299C-----------------------------------------------------------------------
62300 SUBROUTINE HWUSOR(A,N,K,IOPT)
62301C-----------------------------------------------------------------------
62302C Sort A(N) into ascending order
62303C IOPT = 1 : return sorted A and index array K
62304C IOPT = 2 : return index array K only
62305C-----------------------------------------------------------------------
62306 IMPLICIT NONE
62307 INTEGER N,I,J,IOPT,K(N),IL(500),IR(500)
62308 DOUBLE PRECISION A(N),B(500)
62309 IF (N.GT.500) THEN
62310 CALL HWWARN('HWUSOR',100)
62311 GOTO 999
62312 ENDIF
62313 IL(1)=0
62314 IR(1)=0
62315 DO 10 I=2,N
62316 IL(I)=0
62317 IR(I)=0
62318 J=1
62319 2 IF(A(I).GT.A(J)) GOTO 5
62320 IF(IL(J).EQ.0) GOTO 4
62321 J=IL(J)
62322 GOTO 2
62323 4 IR(I)=-J
62324 IL(J)=I
62325 GOTO 10
62326 5 IF(IR(J).LE.0) GOTO 6
62327 J=IR(J)
62328 GOTO 2
62329 6 IR(I)=IR(J)
62330 IR(J)=I
62331 10 CONTINUE
62332 I=1
62333 J=1
62334 GOTO 8
62335 20 J=IL(J)
62336 8 IF(IL(J).GT.0) GOTO 20
62337 9 K(I)=J
62338 B(I)=A(J)
62339 I=I+1
62340C---REMOVED OBSOLESCENT ARITHMETIC IF STATEMENT
62341C$$$ IF(IR(J)) 12,30,13
62342 IF (IR(J).LT.0) THEN
62343 GOTO 12
62344 ELSEIF (IR(J).EQ.0) THEN
62345 GOTO 30
62346 ELSE
62347 GOTO 13
62348 ENDIF
62349C---END OF REPLACEMENT ARITHMETIC IF STATEMENT
62350 13 J=IR(J)
62351 GOTO 8
62352 12 J=-IR(J)
62353 GOTO 9
62354 30 IF(IOPT.EQ.2) RETURN
62355 DO 31 I=1,N
62356 31 A(I)=B(I)
62357 999 RETURN
62358 END
62359CDECK ID>, HWUSPR.
62360*CMZ :- -17/10/01 13:59:28 by Peter Richardson
62361*-- Author : Peter Richardson
62362C-----------------------------------------------------------------------
62363 SUBROUTINE HWUSPR
62364C-----------------------------------------------------------------------
62365C Subroutine to output the contents of the spin common block
62366C-----------------------------------------------------------------------
c63d70bc 62367 INCLUDE 'herwig65.inc'
65767955 62368 INTEGER I
62369C--write out the header
62370 WRITE(6,1000)
62371 DO I=1,NSPN
62372 WRITE(6,1010) I,IDSPN(I),DECSPN(I),JMOSPN(I),JDASPN(1,I),
62373 & JDASPN(2,I)
62374 ENDDO
62375 1000 FORMAT(/1X,'ISPN',1X,'IDSPN',1X,'DECS',1X,'JMOSPN',1X,' JDASPN '/)
62376 1010 FORMAT( 1X, I4 ,1X, I5 ,1X, L4 ,1X, I6 ,1X, I3,2X,I3)
62377 END
62378CDECK ID>, HWUSQR.
62379*CMZ :- -26/04/91 11.11.56 by Bryan Webber
62380*-- Author : Bryan Webber
62381C-----------------------------------------------------------------------
62382 FUNCTION HWUSQR(X)
62383C-----------------------------------------------------------------------
62384C SQUARE ROOT WITH SIGN RETENTION
62385C-----------------------------------------------------------------------
62386 IMPLICIT NONE
62387 DOUBLE PRECISION HWUSQR,X
62388 HWUSQR=SIGN(SQRT(ABS(X)),X)
62389 END
62390CDECK ID>, HWUSTA.
62391*CMZ :- -26/04/91 10.18.58 by Bryan Webber
62392*-- Author : Bryan Webber
62393C-----------------------------------------------------------------------
62394 SUBROUTINE HWUSTA(NAME)
62395C-----------------------------------------------------------------------
62396C MAKES PARTICLE TYPE 'NAME' STABLE
62397C-----------------------------------------------------------------------
c63d70bc 62398 INCLUDE 'herwig65.inc'
65767955 62399 INTEGER IPDG,IWIG
62400 CHARACTER*8 NAME
62401 CALL HWUIDT(3,IPDG,IWIG,NAME)
62402 IF (IWIG.EQ.20) CALL HWWARN('HWUSTA',500)
62403 RSTAB(IWIG)=.TRUE.
62404 WRITE (6,10) IWIG,NAME
62405 10 FORMAT(/10X,'PARTICLE TYPE',I4,'=',A8,' SET STABLE')
62406 END
62407CDECK ID>, HWUTAB.
62408*CMZ :- -26/04/91 11.11.56 by Bryan Webber
62409*-- Author : Adapted by Bryan Webber
62410C-----------------------------------------------------------------------
62411 FUNCTION HWUTAB(F,A,NN,X,MM)
62412C-----------------------------------------------------------------------
62413C MODIFIED CERN INTERPOLATION ROUTINE DIVDIF
62414C-----------------------------------------------------------------------
62415 IMPLICIT NONE
62416 INTEGER NN,MM,MMAX,N,M,MPLUS,IX,IY,MID,NPTS,IP,I,J,L,ISUB
62417 DOUBLE PRECISION HWUTAB,SUM,X,F(NN),A(NN),T(20),D(20)
62418 LOGICAL EXTRA
62419 SAVE MMAX
62420 DATA MMAX/10/
62421 N=NN
62422 M=MIN(MM,MMAX,N-1)
62423 MPLUS=M+1
62424 IX=0
62425 IY=N+1
62426 IF (A(1).GT.A(N)) GOTO 4
62427 1 MID=(IX+IY)/2
62428 IF (X.GE.A(MID)) GOTO 2
62429 IY=MID
62430 GOTO 3
62431 2 IX=MID
62432 3 IF (IY-IX.GT.1) GOTO 1
62433 GOTO 7
62434 4 MID=(IX+IY)/2
62435 IF (X.LE.A(MID)) GOTO 5
62436 IY=MID
62437 GOTO 6
62438 5 IX=MID
62439 6 IF (IY-IX.GT.1) GOTO 4
62440 7 NPTS=M+2-MOD(M,2)
62441 IP=0
62442 L=0
62443 GOTO 9
62444 8 L=-L
62445 IF (L.GE.0) L=L+1
62446 9 ISUB=IX+L
62447 IF ((1.LE.ISUB).AND.(ISUB.LE.N)) GOTO 10
62448 NPTS=MPLUS
62449 GOTO 11
62450 10 IP=IP+1
62451 T(IP)=A(ISUB)
62452 D(IP)=F(ISUB)
62453 11 IF (IP.LT.NPTS) GOTO 8
62454 EXTRA=NPTS.NE.MPLUS
62455 DO 14 L=1,M
62456 IF (.NOT.EXTRA) GOTO 12
62457 ISUB=MPLUS-L
62458 D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB))
62459 12 I=MPLUS
62460 DO 13 J=L,M
62461 ISUB=I-L
62462 D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB))
62463 I=I-1
62464 13 CONTINUE
62465 14 CONTINUE
62466 SUM=D(MPLUS)
62467 IF (EXTRA) SUM=0.5*(SUM+D(M+2))
62468 J=M
62469 DO 15 L=1,M
62470 SUM=D(J)+(X-T(J))*SUM
62471 J=J-1
62472 15 CONTINUE
62473 HWUTAB=SUM
62474 END
62475CDECK ID>, HWUTIM.
62476*CMZ :- -26/04/91 11.38.43 by Federico Carminati
62477*-- Author : Federico Carminati
62478C-----------------------------------------------------------------------
62479 SUBROUTINE HWUTIM(TRES)
62480C-----------------------------------------------------------------------
62481 IMPLICIT NONE
62482 REAL TRES
62483 CALL TIMEL(TRES)
62484 END
62485CDECK ID>, HWVDIF.
62486*CMZ :- -26/04/91 11.11.56 by Bryan Webber
62487*-- Author : Bryan Webber
62488C-----------------------------------------------------------------------
62489 SUBROUTINE HWVDIF(N,P,Q,R)
62490C-----------------------------------------------------------------------
62491C VECTOR DIFFERENCE
62492C-----------------------------------------------------------------------
62493 IMPLICIT NONE
62494 INTEGER N,I
62495 DOUBLE PRECISION P(N),Q(N),R(N)
62496 DO 10 I=1,N
62497 10 R(I)=P(I)-Q(I)
62498 END
62499CDECK ID>, HWVDOT.
62500*CMZ :- -26/04/91 11.11.56 by Bryan Webber
62501*-- Author : Bryan Webber
62502C-----------------------------------------------------------------------
62503 FUNCTION HWVDOT(N,P,Q)
62504C-----------------------------------------------------------------------
62505C VECTOR DOT PRODUCT
62506C-----------------------------------------------------------------------
62507 IMPLICIT NONE
62508 INTEGER N,I
62509 DOUBLE PRECISION HWVDOT,PQ,P(N),Q(N)
62510 PQ=0.
62511 DO 10 I=1,N
62512 10 PQ=PQ+P(I)*Q(I)
62513 HWVDOT=PQ
62514 END
62515CDECK ID>, HWVEQU.
62516*CMZ :- -26/04/91 11.11.56 by Bryan Webber
62517*-- Author : Bryan Webber
62518C-----------------------------------------------------------------------
62519 SUBROUTINE HWVEQU(N,P,Q)
62520C-----------------------------------------------------------------------
62521C VECTOR EQUALITY
62522C-----------------------------------------------------------------------
62523 IMPLICIT NONE
62524 INTEGER N,I
62525 DOUBLE PRECISION P(N),Q(N)
62526 DO 10 I=1,N
62527 10 Q(I)=P(I)
62528 END
62529CDECK ID>, HWVSCA.
62530*CMZ :- -26/04/91 11.11.56 by Bryan Webber
62531*-- Author : Bryan Webber
62532C-----------------------------------------------------------------------
62533 SUBROUTINE HWVSCA(N,C,P,Q)
62534C-----------------------------------------------------------------------
62535C VECTOR TIMES SCALAR
62536C-----------------------------------------------------------------------
62537 IMPLICIT NONE
62538 INTEGER N,I
62539 DOUBLE PRECISION C,P(N),Q(N)
62540 DO 10 I=1,N
62541 10 Q(I)=C*P(I)
62542 END
62543CDECK ID>, HWVSUM.
62544*CMZ :- -26/04/91 11.11.56 by Bryan Webber
62545*-- Author : Bryan Webber
62546C-----------------------------------------------------------------------
62547 SUBROUTINE HWVSUM(N,P,Q,R)
62548C-----------------------------------------------------------------------
62549C VECTOR SUM
62550C-----------------------------------------------------------------------
62551 IMPLICIT NONE
62552 INTEGER N,I
62553 DOUBLE PRECISION P(N),Q(N),R(N)
62554 DO 10 I=1,N
62555 10 R(I)=P(I)+Q(I)
62556 END
62557CDECK ID>, HWVZRI.
62558*CMZ :- -05/02/98 11.11.56 by Bryan Webber
62559*-- Author : Bryan Webber
62560C-----------------------------------------------------------------------
62561 SUBROUTINE HWVZRI(N,IP)
62562C-----------------------------------------------------------------------
62563C ZERO INTEGER VECTOR
62564C-----------------------------------------------------------------------
62565 IMPLICIT NONE
62566 INTEGER N,IP(N),I
62567 DO 10 I=1,N
62568 10 IP(I)=0
62569 END
62570CDECK ID>, HWVZRO.
62571*CMZ :- -26/04/91 11.11.56 by Bryan Webber
62572*-- Author : Bryan Webber
62573C-----------------------------------------------------------------------
62574 SUBROUTINE HWVZRO(N,P)
62575C-----------------------------------------------------------------------
62576C ZERO VECTOR
62577C-----------------------------------------------------------------------
62578 IMPLICIT NONE
62579 INTEGER N,I
62580 DOUBLE PRECISION P(N)
62581 DO 10 I=1,N
62582 10 P(I)=0D0
62583 END
62584CDECK ID>, HWWARN.
62585*CMZ :- -26/04/91 10.18.58 by Bryan Webber
62586*-- Author : Bryan Webber
62587C-----------------------------------------------------------------------
62588 SUBROUTINE HWWARN(SUBRTN,ICODE)
62589C-----------------------------------------------------------------------
62590C DEALS WITH ERRORS DURING EXECUTION
62591C SUBRTN = NAME OF CALLING SUBROUTINE
62592C ICODE = ERROR CODE: - -1 NONFATAL, KILL EVENT & PRINT NOTHING
62593C 0- 49 NONFATAL, PRINT WARNING & CONTINUE
62594C 50- 99 NONFATAL, PRINT WARNING & JUMP
62595C 100-199 NONFATAL, DUMP & KILL EVENT
62596C 200-299 FATAL, TERMINATE RUN
62597C 300-399 FATAL, DUMP EVENT & TERMINATE RUN
62598C 400-499 FATAL, DUMP EVENT & STOP DEAD
62599C 500- FATAL, STOP DEAD WITH NO DUMP
62600C-----------------------------------------------------------------------
c63d70bc 62601 INCLUDE 'herwig65.inc'
65767955 62602 INTEGER ICODE
62603 CHARACTER*6 SUBRTN
62604 IF (ICODE.GE.0) WRITE (6,10) SUBRTN,ICODE
62605 10 FORMAT(/' HWWARN CALLED FROM SUBPROGRAM ',A6,': CODE =',I4)
62606 IF (ICODE.LT.0) THEN
62607 IERROR=ICODE
62608 RETURN
62609 ELSEIF (ICODE.LT.100) THEN
62610 WRITE (6,20) NEVHEP,NRN,EVWGT
62611 20 FORMAT(' EVENT',I8,': SEEDS =',I11,' &',I11,
62612 &' WEIGHT =',E11.4/' EVENT SURVIVES. EXECUTION CONTINUES')
62613 IF (ICODE.GT.49) RETURN
62614 ELSEIF (ICODE.LT.200) THEN
62615 WRITE (6,30) NEVHEP,NRN,EVWGT
62616 30 FORMAT(' EVENT',I8,': SEEDS =',I11,' &',I11,
62617 &' WEIGHT =',E11.4/' EVENT KILLED. EXECUTION CONTINUES')
62618 IERROR=ICODE
62619 RETURN
62620 ELSEIF (ICODE.LT.300) THEN
62621 WRITE (6,40)
62622 40 FORMAT(' EVENT SURVIVES. RUN ENDS GRACEFULLY')
62623 CALL HWEFIN
62624 STOP
62625 ELSEIF (ICODE.LT.400) THEN
62626 WRITE (6,50)
62627 50 FORMAT(' EVENT KILLED: DUMP FOLLOWS. RUN ENDS GRACEFULLY')
62628 IERROR=ICODE
62629 CALL HWUEPR
62630 CALL HWUBPR
62631 CALL HWEFIN
62632 STOP
62633 ELSEIF (ICODE.LT.500) THEN
62634 WRITE (6,60)
62635 60 FORMAT(' EVENT KILLED: DUMP FOLLOWS. RUN STOPS DEAD')
62636 IERROR=ICODE
62637 CALL HWUEPR
62638 CALL HWUBPR
62639 STOP
62640 ELSE
62641 WRITE (6,70)
62642 70 FORMAT(' RUN CANNOT CONTINUE')
62643 STOP
62644 ENDIF
62645 END
62646CDECK ID>, IEUPDG.
62647*CMZ :- -28/01/92 12.34.44 by Mike Seymour
62648*-- Author : Luca Stanco
62649C-----------------------------------------------------------------------
62650 FUNCTION IEUPDG(I)
62651C-----------------------------------------------------------------------
62652C DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
62653C IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
62654C-----------------------------------------------------------------------
62655 IMPLICIT NONE
62656 INTEGER IEUPDG,I
62657 WRITE (6,10)
62658 10 FORMAT(/10X,'IEUPDG CALLED BUT NOT LINKED')
62659 IEUPDG=0
62660 STOP
62661 END
62662CDECK ID>, IPDGEU.
62663*CMZ :- -28/01/92 12.34.44 by Mike Seymour
62664*-- Author : Luca Stanco
62665C-----------------------------------------------------------------------
62666 FUNCTION IPDGEU(I)
62667C-----------------------------------------------------------------------
62668C DUMMY SUBROUTINE: DELETE AND SET BDECAY='EURO'
62669C IN MAIN PROGRAM IF YOU USE EURODEC DECAY PACKAGE
62670C-----------------------------------------------------------------------
62671 IMPLICIT NONE
62672 INTEGER IPDGEU,I
62673 WRITE (6,10)
62674 10 FORMAT(/10X,'IPDGEU CALLED BUT NOT LINKED')
62675 IPDGEU=0
62676 STOP
62677 END
62678CDECK ID>, INIETC.
62679*CMZ :- -17/10/01 10.03.37 by Peter Richardson
62680*-- Author : Peter Richardson
62681C-----------------------------------------------------------------------
62682 SUBROUTINE INIETC(JAK1,JAK2,ITDKRC,IFPHOT)
62683C-----------------------------------------------------------------------
62684C DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
62685C IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
62686C-----------------------------------------------------------------------
62687 IMPLICIT NONE
62688 INTEGER JAK1,JAK2,ITDKRC,IFPHOT
62689 WRITE (6,10)
62690 10 FORMAT(/10X,'INIETC CALLED BUT NOT LINKED')
62691 STOP
62692 END
62693CDECK ID>, INIMAS.
62694*CMZ :- -17/10/01 10.03.37 by Peter Richardson
62695*-- Author : Peter Richardson
62696C-----------------------------------------------------------------------
62697 SUBROUTINE INIMAS
62698C-----------------------------------------------------------------------
62699C DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
62700C IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
62701C-----------------------------------------------------------------------
62702 IMPLICIT NONE
62703 WRITE (6,10)
62704 10 FORMAT(/10X,'INIMAS CALLED BUT NOT LINKED')
62705 STOP
62706 END
62707CDECK ID>, INIPHX.
62708*CMZ :- -17/10/01 10.03.37 by Peter Richardson
62709*-- Author : Peter Richardson
62710C-----------------------------------------------------------------------
62711 SUBROUTINE INIPHX(CUT)
62712C-----------------------------------------------------------------------
62713C DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
62714C IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
62715C-----------------------------------------------------------------------
62716 IMPLICIT NONE
62717 DOUBLE PRECISION CUT
62718 WRITE (6,10)
62719 10 FORMAT(/10X,'INIPHX CALLED BUT NOT LINKED')
62720 STOP
62721 END
62722CDECK ID>, INITDK.
62723*CMZ :- -17/10/01 10.03.37 by Peter Richardson
62724*-- Author : Peter Richardson
62725C-----------------------------------------------------------------------
62726 SUBROUTINE INITDK
62727C-----------------------------------------------------------------------
62728C DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
62729C IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
62730C-----------------------------------------------------------------------
62731 IMPLICIT NONE
62732 WRITE (6,10)
62733 10 FORMAT(/10X,'INITDK CALLED BUT NOT LINKED')
62734 STOP
62735 END
62736CDECK ID>, PHOINI.
62737*CMZ :- -17/10/01 10.03.37 by Peter Richardson
62738*-- Author : Peter Richardson
62739C-----------------------------------------------------------------------
62740 SUBROUTINE PHOINI
62741C-----------------------------------------------------------------------
62742C DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
62743C IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
62744C-----------------------------------------------------------------------
62745 IMPLICIT NONE
62746 WRITE (6,10)
62747 10 FORMAT(/10X,'PHOINI CALLED BUT NOT LINKED')
62748 STOP
62749 END
62750CDECK ID>, PHOTOS.
62751*CMZ :- -17/10/01 10.03.37 by Peter Richardson
62752*-- Author : Peter Richardson
62753C-----------------------------------------------------------------------
62754 SUBROUTINE PHOTOS(IHEP)
62755C-----------------------------------------------------------------------
62756C DUMMY SUBROUTINE: DELETE AND SET TAUDEC='TAUOLA'
62757C IN MAIN PROGRAM IF YOU USE TAUOLA DECAY PACKAGE
62758C-----------------------------------------------------------------------
62759 IMPLICIT NONE
62760 INTEGER IHEP
62761 WRITE (6,10)
62762 10 FORMAT(/10X,'PHOTOS CALLED BUT NOT LINKED')
62763 STOP
62764 END
62765CDECK ID>, QQINIT.
62766*CMZ :- -28/01/92 12.34.44 by Mike Seymour
62767*-- Author : Luca Stanco
62768C-----------------------------------------------------------------------
62769 SUBROUTINE QQINIT(QQLERR)
62770C-----------------------------------------------------------------------
62771C DUMMY SUBROUTINE: DELETE AND SET BDECAY='CLEO'
62772C IN MAIN PROGRAM IF YOU USE CLEO DECAY PACKAGE
62773C-----------------------------------------------------------------------
62774 IMPLICIT NONE
62775 LOGICAL QQLERR
62776 WRITE (6,10)
62777 10 FORMAT(/10X,'QQINIT CALLED BUT NOT LINKED')
62778 STOP
62779 END
62780CDECK ID>, QQLMAT.
62781*CMZ :- -28/01/92 12.34.44 by Mike Seymour
62782*-- Author : Luca Stanco
62783C-----------------------------------------------------------------------
62784 INTEGER FUNCTION QQLMAT(IDL,NDIR)
62785C-----------------------------------------------------------------------
62786C. QQLMAT - Given a particle flavor (KF), converts it to QQ particle number
62787C. (KF = IDPDG code)
62788C.
62789C. Inputs : IDL (input particle code)
62790C NDIR = 1 LUND --> QQ
62791C NDIR = 2 QQ --> LUND
62792C
62793C. Outputs : QQLMAT (output particle code)
62794C.
62795C-----------------------------------------------------------------------
62796 IMPLICIT NONE
62797C-- Calling variable
62798 INTEGER IDL,NDIR
62799C-- External declaration
62800C-- Local variables
62801 INTEGER AKF(321),I
62802 SAVE AKF
62803 DATA (AKF(I), I=1,151) /
62804 + 0, 0, 0, 0, 0, 0, 0, 21, -6, -5,
62805 + -4, -3, -1, -2, 6, 5, 4, 3, 1, 2,
62806 + 0,
62807 + 22, 23, 24, -24, 90, 0, 11, -11, 12, -12,
62808 + 13, -13, 14, -14, 15, -15, 16, -16,20313,-20313,
62809 + 211, -211, 321, -321, 311, -311, 421, -421, 411, -411,
62810 + 431, -431, -521, 521, -511, 511, -531, 531, -541, 541,
62811 + 621, -621, 611, -611, 631, -631, 641, -641, 651, -651,
62812 + 111, 221, 331, 441,20551, 661, 310, 130,10313,-10313,
62813 + 213, -213, 323, -323, 313, -313, 423, -423, 413, -413,
62814 + 433, -433, -523, 523, -513, 513, -533, 533, -543, 543,
62815 + 623, -623, 613, -613, 633, -633, 643, -643, 653, -653,
62816 + 113, 223, 333, 443, 553, 136, 20553, 30553, 40553, 551,
62817 + 10553, 555, 10551,70553,10555, 0, 20213, 20113, -20213, 10441,
62818 + 10443, 445, 8*0,
62819 + 3122, -3122, 4122, -4122, 4232, -4232, 4132, -4132, 3212, -3212/
62820 DATA (AKF(I), I=152,321) /
62821 + 4212, -4212, 4322, -4322, 4312, -4312, 2212, -2212, 3222, -3222,
62822 + 4222, -4222, 2112, -2112, 3112, -3112, 4112, -4112, 3322, -3322,
62823 + 3312, -3312, 4332, -4332, 6*0,
62824 + 3214, -3214, 4214, -4214, 4324, -4324, 4314, -4314, 2214, -2214,
62825 + 3224, -3224, 4224, -4224, 2114, -2114, 3114, -3114, 4114, -4114,
62826 + 3324, -3324, 3314, -3314, 4334, -4334, 4*0,
62827 + 0, 0, 2224, -2224, 1114, -1114, 3334, -3334, 0, 0,
62828 + 10323, -10323, 20323, -20323, 6*0,
62829 + 30443, 0, 0, 0, 70443, 50553, 60553, 80553, 20443, 0,
62830 + 10411, 20413, 10413, 415,
62831 + -10411,-20413,-10413,-415,
62832 + 10421, 20423, 10423, 425,
62833 + -10421,-20423,-10423,-425,
62834 + 10431, 20433, 10433, 435,
62835 + -10431,-20433,-10433,-435, 0,0,0,0,0,0,
62836 + 10111, 10211,-10211, 115, 215, -215,10221,10331,20223,20333,
62837 + 225, 335, 10223, 10333, 10113, 10213,-10213, 33*0 /
62838 IF(NDIR.EQ.1) THEN
62839 DO 10 I=1,321
62840 IF (IDL.EQ.AKF(I)) THEN
62841 QQLMAT=I-21
62842 RETURN
62843 ENDIF
62844 10 CONTINUE
62845 QQLMAT=0
62846 WRITE(6,20) IDL
62847 20 FORMAT(1X,'Lund code particle ',I6,' not recognized')
62848 ELSEIF(NDIR.EQ.2) THEN
62849 QQLMAT = AKF(IDL+21)
62850 ELSE
62851 QQLMAT=0
62852 WRITE(6,30)
62853 30 FORMAT(1X,'Unrecognized option in QQLMAT')
62854 ENDIF
62855 END
62856C-----------------------------------------------------------------------
62857C...SaSgam version 2 - parton distributions of the photon
62858C...by Gerhard A. Schuler and Torbjorn Sjostrand
62859C...For further information see Z. Phys. C68 (1995) 607
62860C...and CERN-TH/96-04 and LU TP 96-2.
62861C...Program last changed on 18 January 1996.
62862C
62863C!!!Note that one further call parameter - IP2 - has been added
62864C!!!to the SASGAM argument list compared with version 1.
62865C
62866C...The user should only need to call the SASGAM routine,
62867C...which in turn calls the auxiliary routines SASVMD, SASANO,
62868C...SASBEH and SASDIR. The package is self-contained.
62869C
62870C...One particular aspect of these parametrizations is that F2 for
62871C...the photon is not obtained just as the charge-squared-weighted
62872C...sum of quark distributions, but differ in the treatment of
62873C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
62874C...the kinematics range of heavy-flavour production, but the same
62875C...kinematics is not relevant e.g. for jet production) and, for the
62876C...'MSbar' fits, in the addition of a Cgamma term related to the
62877C...separation of direct processes. Schematically:
62878C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
62879C...F2 = VMD (rho, omega, phi) + anomalous (d, u, s) +
62880C... Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
62881C...The J/psi and Upsilon states have not been included in the VMD sum,
62882C...but low c and b masses in the other components should compensate
62883C...for this in a duality sense.
62884C
62885C...The calling sequence is the following:
62886C CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
62887C...with the following declaration statement:
62888C DIMENSION XPDFGM(-6:6)
62889C...and, optionally, further information in:
62890C COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
62891C &XPDIR(-6:6)
62892C COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
62893C...Input: ISET = 1 : SaS set 1D ('DIS', Q0 = 0.6 GeV)
62894C = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
62895C = 3 : SaS set 2D ('DIS', Q0 = 2 GeV)
62896C = 4 : SaS set 2M ('MSbar', Q0 = 2 GeV)
62897C X : x value.
62898C Q2 : Q2 value.
62899C P2 : P2 value; should be = 0. for an on-shell photon.
62900C IP2 : scheme used to evaluate off-shell anomalous component.
62901C = 0 : recommended default, see = 7.
62902C = 1 : dipole dampening by integration; very time-consuming.
62903C = 2 : P_0^2 = max( Q_0^2, P^2 )
62904C = 3 : P'_0^2 = Q_0^2 + P^2.
62905C = 4 : P_{eff} that preserves momentum sum.
62906C = 5 : P_{int} that preserves momentum and average
62907C evolution range.
62908C = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
62909C = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
62910C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
62911C XPFDGM : x times parton distribution functions of the photon,
62912C with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
62913C 6 = t (always empty!), - for antiquarks (result is same).
62914C...The breakdown by component is stored in the commonblock SASCOM,
62915C with elements as above.
62916C XPVMD : rho, omega, phi VMD part only of output.
62917C XPANL : d, u, s anomalous part only of output.
62918C XPANH : c, b anomalous part only of output.
62919C XPBEH : c, b Bethe-Heitler part only of output.
62920C XPDIR : Cgamma (direct contribution) part only of output.
62921C...The above arrays do not distinguish valence and sea contributions,
62922C...although this information is available internally. The additional
62923C...commonblock SASVAL provides the valence part only of the above
62924C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
62925C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
62926C...and therefore not given doubly. VXPDGM gives the sum of valence
62927C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
62928C...and so on, gives the sea part only.
62929C
62930 SUBROUTINE SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
62931C...Purpose: to construct the F2 and parton distributions of the photon
62932C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
62933C...For F2, c and b are included by the Bethe-Heitler formula;
62934C...in the 'MSbar' scheme additionally a Cgamma term is added.
62935 DIMENSION XPDFGM(-6:6)
62936 COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
62937 &XPDIR(-6:6)
62938 COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
62939 SAVE /SASCOM/,/SASVAL/
62940C
62941C...Temporary array.
62942 DIMENSION XPGA(-6:6), VXPGA(-6:6)
62943 SAVE PMC,PMB,AEM,AEM2PI,ALAM,FRACU,FRHO,FOMEGA,FPHI,PMRHO,PMPHI,
62944 $ NSTEP
62945C...Charm and bottom masses (low to compensate for J/psi etc.).
62946 DATA PMC/1.3/, PMB/4.6/
62947C...alpha_em and alpha_em/(2*pi).
62948 DATA AEM/0.007297/, AEM2PI/0.0011614/
62949C...Lambda value for 4 flavours.
62950 DATA ALAM/0.20/
62951C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
62952 DATA FRACU/0.8/
62953C...VMD couplings f_V**2/(4*pi).
62954 DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
62955C...Masses for rho (=omega) and phi.
62956 DATA PMRHO/0.770/, PMPHI/1.020/
62957C...Number of points in integration for IP2=1.
62958 DATA NSTEP/100/
62959C
62960C...Reset output.
62961 F2GM=0.
62962 DO 100 KFL=-6,6
62963 XPDFGM(KFL)=0.
62964 XPVMD(KFL)=0.
62965 XPANL(KFL)=0.
62966 XPANH(KFL)=0.
62967 XPBEH(KFL)=0.
62968 XPDIR(KFL)=0.
62969 VXPVMD(KFL)=0.
62970 VXPANL(KFL)=0.
62971 VXPANH(KFL)=0.
62972 VXPDGM(KFL)=0.
62973 100 CONTINUE
62974C
62975C...Check that input sensible.
62976 IF(ISET.LE.0.OR.ISET.GE.5) THEN
62977 WRITE(*,*) ' FATAL ERROR: SaSgam called for unknown set'
62978 WRITE(*,*) ' ISET = ',ISET
62979 STOP
62980 ENDIF
62981 IF(X.LE.0..OR.X.GT.1.) THEN
62982 WRITE(*,*) ' FATAL ERROR: SaSgam called for unphysical x'
62983 WRITE(*,*) ' X = ',X
62984 STOP
62985 ENDIF
62986C
62987C...Set Q0 cut-off parameter as function of set used.
62988 IF(ISET.LE.2) THEN
62989 Q0=0.6
62990 ELSE
62991 Q0=2.
62992 ENDIF
62993 Q02=Q0**2
62994C
62995C...Scale choice for off-shell photon; common factors.
62996 Q2A=Q2
62997 FACNOR=1.
62998 IF(IP2.EQ.1) THEN
62999 P2MX=P2+Q02
63000 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
63001 FACNOR=LOG(Q2/Q02)/NSTEP
63002 ELSEIF(IP2.EQ.2) THEN
63003 P2MX=MAX(P2,Q02)
63004 ELSEIF(IP2.EQ.3) THEN
63005 P2MX=P2+Q02
63006 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
63007 ELSEIF(IP2.EQ.4) THEN
63008 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
63009 & ((Q2+P2)*(Q02+P2)))
63010 ELSEIF(IP2.EQ.5) THEN
63011 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
63012 & ((Q2+P2)*(Q02+P2)))
63013 P2MX=Q0*SQRT(P2MXA)
63014 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
63015 ELSEIF(IP2.EQ.6) THEN
63016 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
63017 & ((Q2+P2)*(Q02+P2)))
63018 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
63019 ELSE
63020 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
63021 & ((Q2+P2)*(Q02+P2)))
63022 P2MX=Q0*SQRT(P2MXA)
63023 P2MXB=P2MX
63024 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
63025 P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
63026 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
63027 ENDIF
63028C
63029C...Call VMD parametrization for d quark and use to give rho, omega,
63030C...phi. Note dipole dampening for off-shell photon.
63031 CALL SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
63032 XFVAL=VXPGA(1)
63033 XPGA(1)=XPGA(2)
63034 XPGA(-1)=XPGA(-2)
63035 FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
63036 FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
63037 DO 110 KFL=-5,5
63038 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
63039 110 CONTINUE
63040 XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
63041 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
63042 XPVMD(3)=XPVMD(3)+FACS*XFVAL
63043 XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
63044 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
63045 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
63046 VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
63047 VXPVMD(2)=FRACU*FACUD*XFVAL
63048 VXPVMD(3)=FACS*XFVAL
63049 VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
63050 VXPVMD(-2)=FRACU*FACUD*XFVAL
63051 VXPVMD(-3)=FACS*XFVAL
63052C
63053 IF(IP2.NE.1) THEN
63054C...Anomalous parametrizations for different strategies
63055C...for off-shell photons; except full integration.
63056C
63057C...Call anomalous parametrization for d + u + s.
63058 CALL SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
63059 DO 120 KFL=-5,5
63060 XPANL(KFL)=FACNOR*XPGA(KFL)
63061 VXPANL(KFL)=FACNOR*VXPGA(KFL)
63062 120 CONTINUE
63063C
63064C...Call anomalous parametrization for c and b.
63065 CALL SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
63066 DO 130 KFL=-5,5
63067 XPANH(KFL)=FACNOR*XPGA(KFL)
63068 VXPANH(KFL)=FACNOR*VXPGA(KFL)
63069 130 CONTINUE
63070 CALL SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
63071 DO 140 KFL=-5,5
63072 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
63073 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
63074 140 CONTINUE
63075C
63076 ELSE
63077C...Special option: loop over flavours and integrate over k2.
63078 DO 170 KF=1,5
63079 DO 160 ISTEP=1,NSTEP
63080 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
63081 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
63082 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
63083 CALL SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
63084 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
63085 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
63086 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
63087 DO 150 KFL=-5,5
63088 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
63089 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
63090 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
63091 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
63092 150 CONTINUE
63093 160 CONTINUE
63094 170 CONTINUE
63095 ENDIF
63096C
63097C...Call Bethe-Heitler term expression for charm and bottom.
63098 CALL SASBEH(4,X,Q2,P2,PMC**2,XPBH)
63099 XPBEH(4)=XPBH
63100 XPBEH(-4)=XPBH
63101 CALL SASBEH(5,X,Q2,P2,PMB**2,XPBH)
63102 XPBEH(5)=XPBH
63103 XPBEH(-5)=XPBH
63104C
63105C...For MSbar subtraction call C^gamma term expression for d, u, s.
63106 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
63107 CALL SASDIR(X,Q2,P2,Q02,XPGA)
63108 DO 180 KFL=-5,5
63109 XPDIR(KFL)=XPGA(KFL)
63110 180 CONTINUE
63111 ENDIF
63112C
63113C...Store result in output array.
63114 DO 190 KFL=-5,5
63115 CHSQ=1./9.
63116 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
63117 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
63118 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
63119 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
63120 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
63121 190 CONTINUE
63122C
63123 END
63124C
63125C*********************************************************************
63126C
63127 SUBROUTINE SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
63128C...Purpose: to evaluate the VMD parton distributions of a photon,
63129C...evolved homogeneously from an initial scale P2 to Q2.
63130C...Does not include dipole suppression factor.
63131C...ISET is parton distribution set, see above;
63132C...additionally ISET=0 is used for the evolution of an anomalous photon
63133C...which branched at a scale P2 and then evolved homogeneously to Q2.
63134C...ALAM is the 4-flavour Lambda, which is automatically converted
63135C...to 3- and 5-flavour equivalents as needed.
63136 DIMENSION XPGA(-6:6), VXPGA(-6:6)
63137 SAVE PMC,PMB
63138 DATA PMC/1.3/, PMB/4.6/
63139C
63140C...Reset output.
63141 DO 100 KFL=-6,6
63142 XPGA(KFL)=0.
63143 VXPGA(KFL)=0.
63144 100 CONTINUE
63145 KFA=IABS(KF)
63146C
63147C...Calculate Lambda; protect against unphysical Q2 and P2 input.
63148 ALAM3=ALAM*(PMC/ALAM)**(2./27.)
63149 ALAM5=ALAM*(ALAM/PMB)**(2./23.)
63150 P2EFF=MAX(P2,1.2*ALAM3**2)
63151 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
63152 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
63153 Q2EFF=MAX(Q2,P2EFF)
63154C
63155C...Find number of flavours at lower and upper scale.
63156 NFP=4
63157 IF(P2EFF.LT.PMC**2) NFP=3
63158 IF(P2EFF.GT.PMB**2) NFP=5
63159 NFQ=4
63160 IF(Q2EFF.LT.PMC**2) NFQ=3
63161 IF(Q2EFF.GT.PMB**2) NFQ=5
63162C
63163C...Find s as sum of 3-, 4- and 5-flavour parts.
63164 S=0.
63165 IF(NFP.EQ.3) THEN
63166 Q2DIV=PMC**2
63167 IF(NFQ.EQ.3) Q2DIV=Q2EFF
63168 S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
63169 ENDIF
63170 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
63171 P2DIV=P2EFF
63172 IF(NFP.EQ.3) P2DIV=PMC**2
63173 Q2DIV=Q2EFF
63174 IF(NFQ.EQ.5) Q2DIV=PMB**2
63175 S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
63176 ENDIF
63177 IF(NFQ.EQ.5) THEN
63178 P2DIV=PMB**2
63179 IF(NFP.EQ.5) P2DIV=P2EFF
63180 S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
63181 ENDIF
63182C
63183C...Calculate frequent combinations of x and s.
63184 X1=1.-X
63185 XL=-LOG(X)
63186 S2=S**2
63187 S3=S**3
63188 S4=S**4
63189C
63190C...Evaluate homogeneous anomalous parton distributions below or
63191C...above threshold.
63192 IF(ISET.EQ.0) THEN
63193 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
63194 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
63195 XVAL = X * 1.5 * (X**2+X1**2)
63196 XGLU = 0.
63197 XSEA = 0.
63198 ELSE
63199 XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
63200 & (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
63201 & X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
63202 XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
63203 & X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
63204 & ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
63205 XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
63206 & X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
63207 & ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
63208 & (2.*X-1.)*X*XL**2)
63209 ENDIF
63210C
63211C...Evaluate set 1D parton distributions below or above threshold.
63212 ELSEIF(ISET.EQ.1) THEN
63213 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
63214 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
63215 XVAL = 1.294 * X**0.80 * X1**0.76
63216 XGLU = 1.273 * X**0.40 * X1**1.76
63217 XSEA = 0.100 * X1**3.76
63218 ELSE
63219 XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
63220 & X1**(0.76+0.667*S) * XL**(2.*S)
63221 XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
63222 & X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
63223 & 1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
63224 XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
63225 & X**(-7.32*S2/(1.+10.3*S2)) *
63226 & X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
63227 XSEA0 = 0.100 * X1**3.76
63228 ENDIF
63229C
63230C...Evaluate set 1M parton distributions below or above threshold.
63231 ELSEIF(ISET.EQ.2) THEN
63232 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
63233 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
63234 XVAL = 0.8477 * X**0.51 * X1**1.37
63235 XGLU = 3.42 * X**0.255 * X1**2.37
63236 XSEA = 0.
63237 ELSE
63238 XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
63239 & * X1**1.37 * XL**(2.667*S)
63240 XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
63241 & X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
63242 & XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
63243 & X1**(2.37+3.*S)
63244 XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
63245 & X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
63246 & XL**(2.8*S)
63247 XSEA0 = 0.
63248 ENDIF
63249C
63250C...Evaluate set 2D parton distributions below or above threshold.
63251 ELSEIF(ISET.EQ.3) THEN
63252 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
63253 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
63254 XVAL = X**0.46 * X1**0.64 + 0.76 * X
63255 XGLU = 1.925 * X1**2
63256 XSEA = 0.242 * X1**4
63257 ELSE
63258 XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
63259 & * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
63260 & (0.76+0.4*S) * X * X1**(2.667*S)
63261 XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
63262 & EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
63263 & * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
63264 XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
63265 & X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
63266 XSEA0 = 0.242 * X1**4
63267 ENDIF
63268C
63269C...Evaluate set 2M parton distributions below or above threshold.
63270 ELSEIF(ISET.EQ.4) THEN
63271 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
63272 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
63273 XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
63274 XGLU = 1.808 * X1**2
63275 XSEA = 0.209 * X1**4
63276 ELSE
63277 XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
63278 & X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
63279 & X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
63280 & (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
63281 XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
63282 & X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
63283 & X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
63284 & XL**(10.9*S/(1.+2.5*S))
63285 XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
63286 & X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
63287 & X1**(4.+S) * XL**(0.45*S)
63288 XSEA0 = 0.209 * X1**4
63289 ENDIF
63290 ENDIF
63291C
63292C...Threshold factors for c and b sea.
63293 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
63294 XCHM=0.
63295 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
63296 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
63297 IF(ISET.EQ.0) THEN
63298 XCHM=XSEA*(1.-(SCH/SLL)**2)
63299 ELSE
63300 XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
63301 ENDIF
63302 ENDIF
63303 XBOT=0.
63304 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
63305 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
63306 IF(ISET.EQ.0) THEN
63307 XBOT=XSEA*(1.-(SBT/SLL)**2)
63308 ELSE
63309 XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
63310 ENDIF
63311 ENDIF
63312C
63313C...Fill parton distributions.
63314 XPGA(0)=XGLU
63315 XPGA(1)=XSEA
63316 XPGA(2)=XSEA
63317 XPGA(3)=XSEA
63318 XPGA(4)=XCHM
63319 XPGA(5)=XBOT
63320 XPGA(KFA)=XPGA(KFA)+XVAL
63321 DO 110 KFL=1,5
63322 XPGA(-KFL)=XPGA(KFL)
63323 110 CONTINUE
63324 VXPGA(KFA)=XVAL
63325 VXPGA(-KFA)=XVAL
63326C
63327 END
63328C
63329C*********************************************************************
63330C
63331 SUBROUTINE SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
63332C...Purpose: to evaluate the parton distributions of the anomalous
63333C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
63334C...to Q2.
63335C...KF=0 gives the sum over (up to) 5 flavours,
63336C...KF<0 limits to flavours up to abs(KF),
63337C...KF>0 is for flavour KF only.
63338C...ALAM is the 4-flavour Lambda, which is automatically converted
63339C...to 3- and 5-flavour equivalents as needed.
63340 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
63341 SAVE PMC,PMB,AEM2PI
63342 DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
63343C
63344C...Reset output.
63345 DO 100 KFL=-6,6
63346 XPGA(KFL)=0.
63347 VXPGA(KFL)=0.
63348 100 CONTINUE
63349 IF(Q2.LE.P2) RETURN
63350 KFA=IABS(KF)
63351C
63352C...Calculate Lambda; protect against unphysical Q2 and P2 input.
63353 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
63354 ALAMSQ(4)=ALAM**2
63355 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
63356 P2EFF=MAX(P2,1.2*ALAMSQ(3))
63357 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
63358 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
63359 Q2EFF=MAX(Q2,P2EFF)
63360 XL=-LOG(X)
63361C
63362C...Find number of flavours at lower and upper scale.
63363 NFP=4
63364 IF(P2EFF.LT.PMC**2) NFP=3
63365 IF(P2EFF.GT.PMB**2) NFP=5
63366 NFQ=4
63367 IF(Q2EFF.LT.PMC**2) NFQ=3
63368 IF(Q2EFF.GT.PMB**2) NFQ=5
63369C
63370C...Define range of flavour loop.
63371 IF(KF.EQ.0) THEN
63372 KFLMN=1
63373 KFLMX=5
63374 ELSEIF(KF.LT.0) THEN
63375 KFLMN=1
63376 KFLMX=KFA
63377 ELSE
63378 KFLMN=KFA
63379 KFLMX=KFA
63380 ENDIF
63381C
63382C...Loop over flavours the photon can branch into.
63383 DO 110 KFL=KFLMN,KFLMX
63384C
63385C...Light flavours: calculate t range and (approximate) s range.
63386 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
63387 TDIFF=LOG(Q2EFF/P2EFF)
63388 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
63389 & LOG(P2EFF/ALAMSQ(NFQ)))
63390 IF(NFQ.GT.NFP) THEN
63391 Q2DIV=PMB**2
63392 IF(NFQ.EQ.4) Q2DIV=PMC**2
63393 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
63394 & LOG(P2EFF/ALAMSQ(NFQ)))
63395 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
63396 & LOG(P2EFF/ALAMSQ(NFQ-1)))
63397 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
63398 ENDIF
63399 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
63400 Q2DIV=PMC**2
63401 SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
63402 & LOG(P2EFF/ALAMSQ(4)))
63403 SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
63404 & LOG(P2EFF/ALAMSQ(3)))
63405 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
63406 ENDIF
63407C
63408C...u and s quark do not need a separate treatment when d has been done.
63409 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
63410C
63411C...Charm: as above, but only include range above c threshold.
63412 ELSEIF(KFL.EQ.4) THEN
63413 IF(Q2.LE.PMC**2) GOTO 110
63414 P2EFF=MAX(P2EFF,PMC**2)
63415 Q2EFF=MAX(Q2EFF,P2EFF)
63416 TDIFF=LOG(Q2EFF/P2EFF)
63417 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
63418 & LOG(P2EFF/ALAMSQ(NFQ)))
63419 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
63420 Q2DIV=PMB**2
63421 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
63422 & LOG(P2EFF/ALAMSQ(NFQ)))
63423 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
63424 & LOG(P2EFF/ALAMSQ(NFQ-1)))
63425 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
63426 ENDIF
63427C
63428C...Bottom: as above, but only include range above b threshold.
63429 ELSEIF(KFL.EQ.5) THEN
63430 IF(Q2.LE.PMB**2) GOTO 110
63431 P2EFF=MAX(P2EFF,PMB**2)
63432 Q2EFF=MAX(Q2,P2EFF)
63433 TDIFF=LOG(Q2EFF/P2EFF)
63434 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
63435 & LOG(P2EFF/ALAMSQ(NFQ)))
63436 ENDIF
63437C
63438C...Evaluate flavour-dependent prefactor (charge^2 etc.).
63439 CHSQ=1./9.
63440 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
63441 FAC=AEM2PI*2.*CHSQ*TDIFF
63442C
63443C...Evaluate parton distributions (normalized to unit momentum sum).
63444 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
63445 XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
63446 & (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
63447 & 1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
63448 & X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
63449 XGLU= 2.*S/(1.+4.*S+7.*S**2) *
63450 & X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
63451 & ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
63452 XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
63453 & X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
63454 & ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
63455 & (2.*X-1.)*X*XL**2)
63456C
63457C...Threshold factors for c and b sea.
63458 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
63459 XCHM=0.
63460 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
63461 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
63462 XCHM=XSEA*(1.-(SCH/SLL)**3)
63463 ENDIF
63464 XBOT=0.
63465 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
63466 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
63467 XBOT=XSEA*(1.-(SBT/SLL)**3)
63468 ENDIF
63469 ENDIF
63470C
63471C...Add contribution of each valence flavour.
63472 XPGA(0)=XPGA(0)+FAC*XGLU
63473 XPGA(1)=XPGA(1)+FAC*XSEA
63474 XPGA(2)=XPGA(2)+FAC*XSEA
63475 XPGA(3)=XPGA(3)+FAC*XSEA
63476 XPGA(4)=XPGA(4)+FAC*XCHM
63477 XPGA(5)=XPGA(5)+FAC*XBOT
63478 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
63479 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
63480 110 CONTINUE
63481 DO 120 KFL=1,5
63482 XPGA(-KFL)=XPGA(KFL)
63483 VXPGA(-KFL)=VXPGA(KFL)
63484 120 CONTINUE
63485C
63486 END
63487C
63488C*********************************************************************
63489C
63490 SUBROUTINE SASBEH(KF,X,Q2,P2,PM2,XPBH)
63491C...Purpose: to evaluate the Bethe-Heitler cross section for
63492C...heavy flavour production.
63493 SAVE AEM2PI
63494 DATA AEM2PI/0.0011614/
63495C
63496C...Reset output.
63497 XPBH=0.
63498 SIGBH=0.
63499C
63500C...Check kinematics limits.
63501 IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
63502 W2=Q2*(1.-X)/X-P2
63503 BETA2=1.-4.*PM2/W2
63504 IF(BETA2.LT.1E-10) RETURN
63505 BETA=SQRT(BETA2)
63506 RMQ=4.*PM2/Q2
63507C
63508C...Simple case: P2 = 0.
63509 IF(P2.LT.1E-4) THEN
63510 IF(BETA.LT.0.99) THEN
63511 XBL=LOG((1.+BETA)/(1.-BETA))
63512 ELSE
63513 XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
63514 ENDIF
63515 SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
63516 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
63517C
63518C...Complicated case: P2 > 0, based on approximation of
63519C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
63520 ELSE
63521 RPQ=1.-4.*X**2*P2/Q2
63522 IF(RPQ.GT.1E-10) THEN
63523 RPBE=SQRT(RPQ*BETA2)
63524 IF(RPBE.LT.0.99) THEN
63525 XBL=LOG((1.+RPBE)/(1.-RPBE))
63526 XBI=2.*RPBE/(1.-RPBE**2)
63527 ELSE
63528 RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
63529 XBL=LOG((1.+RPBE)**2/RPBESN)
63530 XBI=2.*RPBE/RPBESN
63531 ENDIF
63532 SIGBH=BETA*(6.*X*(1.-X)-1.)+
63533 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
63534 & XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
63535 ENDIF
63536 ENDIF
63537C
63538C...Multiply by charge-squared etc. to get parton distribution.
63539 CHSQ=1./9.
63540 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
63541 XPBH=3.*CHSQ*AEM2PI*X*SIGBH
63542C
63543 END
63544C
63545C*********************************************************************
63546C
63547 SUBROUTINE SASDIR(X,Q2,P2,Q02,XPGA)
63548C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
63549C...as needed in MSbar parametrizations.
63550 DIMENSION XPGA(-6:6)
63551 SAVE AEM2PI
63552 DATA AEM2PI/0.0011614/
63553C
63554C...Reset output.
63555 DO 100 KFL=-6,6
63556 XPGA(KFL)=0.
63557 100 CONTINUE
63558C
63559C...Evaluate common x-dependent expression.
63560 XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
63561 CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
63562C
63563C...d, u, s part by simple charge factor.
63564 XPGA(1)=(1./9.)*CGAM
63565 XPGA(2)=(4./9.)*CGAM
63566 XPGA(3)=(1./9.)*CGAM
63567C
63568C...Also fill for antiquarks.
63569 DO 110 KF=1,5
63570 XPGA(-KF)=XPGA(KF)
63571 110 CONTINUE
63572C
63573 END
63574C-----------------------------------------------------------------------
63575CDECK ID>, TIMEL.
63576*CMZ :- -28/06/01 16.55.32 by Bryan Webber
63577*-- Author : Bryan Webber
63578C-----------------------------------------------------------------------
63579 SUBROUTINE TIMEL(TRES)
63580C-----------------------------------------------------------------------
63581C DUMMY TIME SUBROUTINE: DELETE AND REPLACE BY SYSTEM
63582C ROUTINE GIVING TRES = CPU TIME REMAINING (SECONDS)
63583C-----------------------------------------------------------------------
63584 IMPLICIT NONE
63585 REAL TRES
63586 LOGICAL FIRST
63587 SAVE FIRST
63588 DATA FIRST/.TRUE./
63589 IF (FIRST) THEN
63590 WRITE (6,10)
63591 10 FORMAT(/10X,'SUBROUTINE TIMEL CALLED BUT NOT LINKED.'/
63592 & 10X,'DUMMY TIMEL WILL BE USED. DELETE DUMMY'/
63593 & 10X,'AND LINK CERNLIB FOR CPU TIME REMAINING.')
63594 FIRST=.FALSE.
63595 ENDIF
63596 TRES=1E10
63597 END