1 C*********************************************************************
2 C*********************************************************************
6 C* The Lund Monte Carlo **
8 C* PYTHIA version 6.2 **
10 C* Torbjorn Sjostrand **
11 C* Department of Theoretical Physics **
13 C* Solvegatan 14A, S-223 62 Lund, Sweden **
14 C* phone +46 - 46 - 222 48 16 **
15 C* E-mail torbjorn@thep.lu.se **
17 C* SUSY and Technicolor parts by **
19 C* Physics Department, UC Davis **
20 C* One Shields Avenue, Davis, CA 95616, USA **
21 C* phone + 1 - 530 - 752 - 2661 **
22 C* E-mail mrenna@physics.ucdavis.edu **
24 C* PYTHIA 7 efforts coordinated by **
26 C* Department of Theoretical Physics **
28 C* Solvegatan 14A, S-223 62 Lund, Sweden **
29 C* phone +46 - 46 - 222 77 80 **
30 C* E-mail leif@thep.lu.se **
32 C* Several parts are written by Hans-Uno Bengtsson **
33 C* PYSHOW is written together with Mats Bengtsson **
34 C* PYMAEL is written by Emanuel Norrbin **
35 C* advanced popcorn baryon production written by Patrik Eden **
36 C* code for virtual photons mainly written by Christer Friberg **
37 C* code for low-mass strings mainly written by Emanuel Norrbin **
38 C* Bose-Einstein code mainly written by Leif Lonnblad **
39 C* Lepton number violation code by Peter Skands **
40 C* CTEQ parton distributions are by the CTEQ collaboration **
41 C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
42 C* SaS photon parton distributions together with Gerhard Schuler **
43 C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
44 C* MSSM Higgs mass calculation code by M. Carena, **
45 C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
46 C* PYGAUS adapted from CERN library (K.S. Kolbig) **
48 C* The latest program version and documentation is found on WWW **
49 C* http://www.thep.lu.se/~torbjorn/Pythia.html **
51 C* Copyright Torbjorn Sjostrand, Lund 2001 **
53 C*********************************************************************
54 C*********************************************************************
56 C List of subprograms in order of appearance, with main purpose *
57 C (S = subroutine, F = function, B = block data) *
59 C B PYDATA to contain all default values *
60 C S PYTEST to test the proper functioning of the package *
61 C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
63 C S PYINIT to administer the initialization procedure *
64 C S PYEVNT to administer the generation of an event *
65 C S PYSTAT to print cross-section and other information *
66 C S PYINRE to initialize treatment of resonances *
67 C S PYINBM to read in beam, target and frame choices *
68 C S PYINKI to initialize kinematics of incoming particles *
69 C S PYINPR to set up the selection of included processes *
70 C S PYXTOT to give total, elastic and diffractive cross-sect. *
71 C S PYMAXI to find differential cross-section maxima *
72 C S PYPILE to select multiplicity of pileup events *
73 C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
74 C S PYGAGA to handle lepton -> lepton + gamma branchings *
75 C S PYRAND to select subprocess and kinematics for event *
76 C S PYSCAT to set up kinematics and colour flow of event *
77 C S PYSSPA to simulate initial state spacelike showers *
78 C S PYMEMX auxiliary to PYSSPA for ME correction maximum *
79 C S PYMEWT auxiliary to PYSSPA for matrix element correction *
80 C S PYADSH to administrate sequential final-state showers *
81 C S PYRESD to perform resonance decays *
82 C S PYMULT to generate multiple interactions *
83 C S PYREMN to add on target remnants *
84 C S PYDIFF to set up kinematics for diffractive events *
85 C S PYDISG to set up kinematics, remnant and showers for DIS *
86 C S PYDOCU to compute cross-sections and handle documentation *
87 C S PYFRAM to perform boosts between different frames *
88 C S PYWIDT to calculate full and partial widths of resonances *
89 C S PYOFSH to calculate partial width into off-shell channels *
90 C S PYRECO to handle colour reconnection in W+W- events *
91 C S PYKLIM to calculate borders of allowed kinematical region *
92 C S PYKMAP to construct value of kinematical variable *
93 C S PYSIGH to calculate differential cross-sections *
94 C S PYPDFU to evaluate parton distributions *
95 C S PYPDFL to evaluate parton distributions at low x and Q^2 *
96 C S PYPDEL to evaluate electron parton distributions *
97 C S PYPDGA to evaluate photon parton distributions (generic) *
98 C S PYGGAM to evaluate photon parton distributions (SaS sets) *
99 C S PYGVMD to evaluate VMD part of photon parton distributions *
100 C S PYGANO to evaluate anomalous part of photon pdf's *
101 C S PYGBEH to evaluate Bethe-Heitler part of photon pdf's *
102 C S PYGDIR to evaluate direct contribution to photon pdf's *
103 C S PYPDPI to evaluate pion parton distributions *
104 C S PYPDPR to evaluate proton parton distributions *
105 C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
106 C S PYGRVL to evaluate the GRV 94L proton parton distributions *
107 C S PYGRVM to evaluate the GRV 94M proton parton distributions *
108 C S PYGRVD to evaluate the GRV 94D proton parton distributions *
109 C F PYGRVV auxiliary to the PYGRV* routines *
110 C F PYGRVW auxiliary to the PYGRV* routines *
111 C F PYGRVS auxiliary to the PYGRV* routines *
112 C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
113 C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
114 C S PYPDPO to evaluate old proton parton distributions *
115 C F PYHFTH to evaluate threshold factor for heavy flavour *
116 C S PYSPLI to find flavours left in hadron when one removed *
117 C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
118 C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
119 C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
120 C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
121 C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
123 C S PYMSIN to initialize the supersymmetry simulation *
124 C S PYAPPS to determine MSSM parameters from SUGRA input *
125 C F PYRNMQ to determine running quark masses *
126 C F PYRNMT to determine running top mass *
127 C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
128 C S PYINOM to calculate neutralino/chargino mass eigenstates *
129 C F PYRNM3 to determine running M3, gluino mass *
130 C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
131 C S PYHGGM to determine Higgs mass spectrum *
132 C S PYSUBH to determine Higgs masses in the MSSM *
133 C S PYPOLE to determine Higgs masses in the MSSM *
134 C S PYRGHM auxiliary to PYPOLE *
135 C S PYGFXX auxiliary to PYRGHM *
136 C F PYFINT auxiliary to PYPOLE *
137 C F PYFISB auxiliary to PYFINT *
138 C S PYSFDC to calculate sfermion decay partial widths *
139 C S PYGLUI to calculate gluino decay partial widths *
140 C S PYTBBN to calculate 3-body decay of gluino to neutralino *
141 C S PYTBBC to calculate 3-body decay of gluino to chargino *
142 C S PYNJDC to calculate neutralino decay partial widths *
143 C S PYCJDC to calculate chargino decay partial widths *
144 C F PYXXZ6 auxiliary for ino 3-body decays *
145 C F PYXXGA auxiliary for ino -> ino + gamma decay *
146 C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
147 C F PYX2XH auxiliary for ino -> ino + Higgs decay *
148 C S PYHEXT to calculate non-SM Higgs decay partial widths *
149 C F PYH2XX auxiliary for H -> ino + ino decay *
150 C F PYGAUS to perform Gaussian integration *
151 C F PYSIMP to perform Simpson integration *
152 C F PYLAMF to evaluate the lambda kinematics function *
153 C S PYTBDY to perform 3-body decay of gauginos *
154 C S PYTECM to calculate techni_rho/omega masses *
155 C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
156 C S PYCMQR auxiliary to PYEICG *
157 C S PYCMQ2 auxiliary to PYEICG *
158 C S PYCDIV auxiliary to PYCMQR *
159 C S PYCSRT auxiliary to PYCMQR *
160 C S PYTHAG auxiliary to PYCMQR *
161 C S PYCBAL auxiliary to PYEICG *
162 C S PYCBA2 auxiliary to PYEICG *
163 C S PYCRTH auxiliary to PYEICG *
164 C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
165 C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
166 C S PYWIDX to calculate decay widths from within PYWIDT *
167 C S PYRVSF to calculate R-violating sfermion decay widths *
168 C S PYRVNE to calculate R-violating neutralino decay widths *
169 C S PYRVCH to calculate R-violating chargino decay widths *
170 C F PYRVSB auxiliary to PYRVSF *
171 C S PYRVGW to calculate R-Violating 3-body widths *
172 C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
173 C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
174 C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
175 C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
176 C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
177 C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
178 C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
179 C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
180 C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
182 C S PY1ENT to fill one entry (= parton or particle) *
183 C S PY2ENT to fill two entries *
184 C S PY3ENT to fill three entries *
185 C S PY4ENT to fill four entries *
186 C S PY2FRM to interface to generic two-fermion generator *
187 C S PY4FRM to interface to generic four-fermion generator *
188 C S PY6FRM to interface to generic six-fermion generator *
189 C S PY4JET to generate a shower from a given 4-parton config *
190 C S PY4JTW to evaluate the weight od a shower history for above *
191 C S PY4JTS to set up the parton configuration for above *
192 C S PYJOIN to connect entries with colour flow information *
193 C S PYGIVE to fill (or query) commonblock variables *
194 C S PYEXEC to administrate fragmentation and decay chain *
195 C S PYPREP to rearrange showered partons along strings *
196 C S PYSTRF to do string fragmentation of jet system *
197 C S PYINDF to do independent fragmentation of one or many jets *
198 C S PYDECY to do the decay of a particle *
199 C S PYDCYK to select parton and hadron flavours in decays *
200 C S PYKFDI to select parton and hadron flavours in fragm *
201 C S PYNMES to select number of popcorn mesons *
202 C S PYKFIN to calculate falvour prod. ratios from input params. *
203 C S PYPTDI to select transverse momenta in fragm *
204 C S PYZDIS to select longitudinal scaling variable in fragm *
205 C S PYSHOW to do timelike parton shower evolution *
206 C F PYMAEL auxiliary to PYSHOW, with gluon emission ME's *
207 C S PYBOEI to include Bose-Einstein effects (crudely) *
208 C S PYBESQ auxiliary to PYBOEI *
209 C F PYMASS to give the mass of a particle or parton *
210 C F PYMRUN to give the running MSbar mass of a quark *
211 C S PYNAME to give the name of a particle or parton *
212 C F PYCHGE to give three times the electric charge *
213 C F PYCOMP to compress standard KF flavour code to internal KC *
214 C S PYERRM to write error messages and abort faulty run *
215 C F PYALEM to give the alpha_electromagnetic value *
216 C F PYALPS to give the alpha_strong value *
217 C F PYANGL to give the angle from known x and y components *
218 C F PYR to provide a random number generator *
219 C S PYRGET to save the state of the random number generator *
220 C S PYRSET to set the state of the random number generator *
221 C S PYROBO to rotate and/or boost an event *
222 C S PYEDIT to remove unwanted entries from record *
223 C S PYLIST to list event record or particle data *
224 C S PYLOGO to write a logo *
225 C S PYUPDA to update particle data *
226 C F PYK to provide integer-valued event information *
227 C F PYP to provide real-valued event information *
228 C S PYSPHE to perform sphericity analysis *
229 C S PYTHRU to perform thrust analysis *
230 C S PYCLUS to perform three-dimensional cluster analysis *
231 C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
232 C S PYJMAS to give high and low jet mass of event *
233 C S PYFOWO to give Fox-Wolfram moments *
234 C S PYTABU to analyze events, with tabular output *
236 C S PYEEVT to administrate the generation of an e+e- event *
237 C S PYXTEE to give the total cross-section at given CM energy *
238 C S PYRADK to generate initial state photon radiation *
239 C S PYXKFL to select flavour of primary qqbar pair *
240 C S PYXJET to select (matrix element) jet multiplicity *
241 C S PYX3JT to select kinematics of three-jet event *
242 C S PYX4JT to select kinematics of four-jet event *
243 C S PYXDIF to select angular orientation of event *
244 C S PYONIA to perform generation of onium decay to gluons *
246 C S PYBOOK to book a histogram *
247 C S PYFILL to fill an entry in a histogram *
248 C S PYFACT to multiply histogram contents by a factor *
249 C S PYOPER to perform operations between histograms *
250 C S PYHIST to print and reset all histograms *
251 C S PYPLOT to print a single histogram *
252 C S PYNULL to reset contents of a single histogram *
253 C S PYDUMP to dump histogram contents onto a file *
255 C S PYKCUT dummy routine for user kinematical cuts *
256 C S PYEVWT dummy routine for weighting events *
257 C S UPINIT dummy routine to initialize user processes *
258 C S UPEVNT dummy routine to generate a user process event *
259 C S PDFSET dummy routine to be removed when using PDFLIB *
260 C S STRUCTM dummy routine to be removed when using PDFLIB *
261 C S STRUCTP dummy routine to be removed when using PDFLIB *
262 C S PYTAUD dummy routine for interface to tau decay libraries *
263 C S PYTIME dummy routine for giving date and time *
265 C*********************************************************************
268 C...Default values for switches and parameters,
269 C...and particle, decay and process data.
273 C...Double precision and integer declarations.
274 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
275 IMPLICIT INTEGER(I-N)
276 C PH INTEGER PYK,PYCHGE,PYCOMP
278 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
279 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
280 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
281 COMMON/PYDAT4/CHAF(500,2)
283 COMMON/PYDATR/MRPY(6),RRPY(100)
284 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
285 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
286 COMMON/PYINT1/MINT(400),VINT(400)
287 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
288 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
289 COMMON/PYINT4/MWID(500),WIDS(500,5)
290 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
291 COMMON/PYINT6/PROC(0:500)
293 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
294 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
295 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
296 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
297 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
298 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
299 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
300 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
301 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYBINS/
303 C...PYDAT1, containing status codes and most parameters.
305 & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
306 1 6, 1, 1, 0, 0, 1, 0, 0, 0, 0,
307 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
308 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
309 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
310 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
311 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
313 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
314 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
316 DATA (PARU(I),I=1,100)/
317 & 3.141592653589793D0, 6.283185307179586D0,
318 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
319 1 0.001D0, 0.09D0, 0.01D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
320 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
321 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
322 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
323 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
324 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
326 DATA (PARU(I),I=101,200)/
327 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
328 & 0D0, 0D0, 0D0, 0D0, 0D0,
329 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
330 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
331 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
332 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
333 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
334 5 1.0D0, 0D0, 0D0, 0D0, 1000D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0,0D0,
335 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
336 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
337 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
338 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
340 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
341 1 4, 2, 0, 1, 0, 2, 2, 0, 0, 0,
342 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
343 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
344 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
345 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
347 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
348 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
351 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
352 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
353 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
354 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
355 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,0D0,
356 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0, 0D0, 0D0,0D0,
357 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
358 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
359 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
360 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
361 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
362 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
363 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
364 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
365 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
366 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
367 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
371 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
372 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
373 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
374 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
377 C...PYDAT2, with particle data and flavour treatment parameters.
378 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
379 &-3,0,-3,6*0,3,9*0,3,2*0,3,4*0,-1,41*0,2,-1,20*0,3*3,7*0,3*3,3*0,
380 &3*3,3*0,3*3,6*0,3*3,3*0,3*3,4*0,-2,-3,2*1,2*0,4,2*3,6,2*-2,2*-3,
381 &0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,3,2*1,2*0,
382 &2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,3,2*-2,
383 &2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,-3,2*0,
384 &2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,3,0,3,
385 &2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,2,-1,
386 &2,-1,2,-3,0,-3,0,-3,2*0,3,3*0,3,8*0,-1,2,-3,6*0,3,2*6,0,3,4*0,3,
388 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
389 &2*0,-1,3*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0,
390 &-1,7*0,2*-1,5*0,2*-1,6*0,2*-1,7*0,2*-1,8*0,-1,56*0,6*1,6*0,2,7*0,
391 &6*1,9*0,2,3*0,2,0,5*2,2*1,156*0/
392 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
393 &2*1,39*0,1,0,2*1,20*0,3*1,4*0,6*1,3*0,9*1,3*0,12*1,4*0,100*1,2*0,
394 &2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,0,4*1,3*0,12*1,3*0,
395 &1,2*0,1,0,12*1,0,1,3*0,1,8*0,4*1,5*0,3*1,0,1,3*0,2*1,139*0/
396 DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
397 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
398 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
399 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
400 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
401 &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
402 &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
403 &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
404 &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
405 &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
406 &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
407 &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
408 &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
409 &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
410 &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
411 &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
412 &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
413 &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
414 &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
415 &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
416 DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
417 &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
418 &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
419 &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
420 &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
421 &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
422 &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
423 &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
424 &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
425 &9902110,9902210,139*0/
426 DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
427 &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
428 &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
429 &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
430 &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
431 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
432 &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
433 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
434 &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
435 &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
436 &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
437 &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
438 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
439 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
440 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
441 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
442 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
443 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
444 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
445 &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
446 DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
447 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
448 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
449 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
450 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
451 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
452 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
453 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
454 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
455 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
456 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
457 &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
458 &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,139*0D0/
459 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
460 &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
461 &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
462 &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
463 &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
464 &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
465 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
466 &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
467 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
468 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
469 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
470 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
471 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
472 &0.02911D0,0.01741D0,0.04536D0,0.09511D0,0.8686D0,0.62395D0,
473 &0.19192D0,123.27638D0,0.02296D0,0.18886D0,23.26819D0,2.86306D0,
474 &0D0,3.45903D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
475 &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
477 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
478 &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
479 &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
480 &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
481 &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
482 &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
483 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
484 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
485 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
486 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
487 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
488 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
489 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
490 &0.29108D0,0.17412D0,0.45362D0,0.95114D0,8.68604D0,6.23946D0,
491 &1.91923D0,450D0,0.22959D0,1.88863D0,232.68185D0,28.63059D0,0D0,
492 &34.59032D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
493 &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
494 &8.80013D0,7*0D0,139*0D0/
495 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
496 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
497 &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
498 &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
499 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
500 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
501 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
502 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,112*0D0,139*0D0/
504 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
505 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
506 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
507 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
508 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
509 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
510 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
511 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
512 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
513 9 0.0099D0, 0.0056D0, 0.199D0, 1.35D0, 4.5D0, 165D0, 4*0D0,
514 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
515 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
516 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
518 4 0.2D0, 0.5D0, 8*0D0,
520 DATA ((VCKM(I,J),J=1,4),I=1,4)/
521 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
522 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
523 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
524 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
526 C...PYDAT3, with particle decay parameters and data.
527 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
528 &4*1,3*0,2*1,40*0,3*1,16*0,3*1,2*0,9*1,0,32*1,2*0,1,3*0,1,2*0,2*1,
529 &2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,2*0,6*1,0,7*1,2*0,5*1,2*0,
530 &6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,1,0,26*1,146*0/
531 DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
532 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
533 &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
534 &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
535 &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
536 &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
537 &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
538 &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
539 &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
540 &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
541 &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
542 &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
543 &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
544 &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
545 &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
546 &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
547 &1631,1652,1691,1712,1751,1775,1806,1832,1864,1890,1922,1948,2009,
548 &2160,2406,2615,2877,3155,0,3388,3431,3456,3499,3524,3567,3592,0,
549 &3628,0,3664,0,3700,3708,3716,3724,3727,3751,3777,3801,3807,3814,
550 &3821,3828,3834,3840,3849,3853,3857,3860,3862,3883,3905,3927,3949/
551 DATA (MDCY(I,2),I= 352, 500)/3964,3976,3983,146*0/
552 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
553 &2*0,9,12,16,20,79,6*0,22,0,23,86,83,27,3*0,9,1,40*0,1,4,9,16*0,2,
554 &5,2*9,2*2,7,8,6,9,2*2,3,10,6,3,11,6,11,6,63,3,8,61,2,8,33,2,4,1,
555 &3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,2*0,1,3*0,3,2*0,3,1,2*0,2,
556 &3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,4*1,4,2*0,1,2,1,2,4,1,
557 &0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,1,9,2*0,8*9,0,9*9,4*1,
558 &5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,9*2,11,14,39,21,39,21,
559 &39,24,31,26,32,26,32,26,61,151,246,209,262,278,233,0,43,25,43,25,
560 &43,25,36,0,36,0,36,0,3*8,3,24,26,24,6,3*7,2*6,9,2*4,3,2,21,3*22,
562 DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
563 &7*1,-1,1,7*-1,8*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,5*1,0,2*-1,6*1,0,
564 &2*-1,3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,
565 &2*-1,3*1,-1,5*1,62*-1,6*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,
566 &3*1,4*-1,6*1,2*-1,3*1,-1,12*1,62*-1,6*1,2*-1,3*1,-1,9*1,62*-1,
567 &3*1,-1,3*1,-1,1,18*-1,4*1,2*-1,2*1,-1,1225*1,2*-1,248*1,2*-1,
568 &1725*1,2*-1,6*1,2*-1,9*1,-1,3*1,-1,3*1,5*-1,3*1,-1,14*1,2*-1,6*1,
569 &2*-1,67*1,2*-1,6*1,2*-1,4*1,-1,107*1,4011*0/
570 DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
571 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
572 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
573 &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
574 &18*53,6*32,4*0,12,2*42,2*11,9*42,0,2,3,15*0,4*42,5*0,3,12*0,2,
575 &3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,3*0,1,11*0,22*42,41*0,
576 &2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,6*0,12,2*0,12,0,12,
577 &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
578 &19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,4*32,2*4,0,32,45*0,
579 &14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,2*42,2*11,0,2*42,
580 &2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,
581 &2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,9*42,0,162*42,50*0,2*12,
582 &17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,5*0,2108*53,4*32,
583 &3*0,6*32,3*0,4*32,3*0,4*32,8*0,8*32,14*0,16*32,12*0,8*32,8*0,
584 &46*32,3*53,12*0,8*32,13*0,66*51,6*32,9*0,9*32,4028*0/
585 DATA (BRAT(I) ,I= 1, 346)/43*0D0,0.00003D0,0.001765D0,
586 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
587 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
588 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
589 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
590 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
591 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
592 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
593 &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
594 &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
595 &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
596 &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
597 &0.108087D0,0D0,0.000001D0,0D0,0.000349D0,0.048707D0,0.768308D0,
598 &4*0D0,0.000227D0,0.064048D0,0D0,0.040621D0,0.002043D0,0.000615D0,
599 &0.006981D0,0.068099D0,62*0D0,0.145835D0,0.113276D0,0.145835D0,
600 &0.113271D0,0.145781D0,0.049002D0,2*0D0,0.032025D0,0.063642D0,
601 &0.032025D0,0.063642D0,0.032022D0,0.063642D0,8*0D0,0.251225D0,
602 &0.0129D0,0.000006D0,0D0,0.0129D0,0.250764D0,0.00038D0,0D0,
603 &0.000008D0,0.000465D0,0.215418D0,5*0D0,2*0.085312D0,0.08531D0,
604 &7*0D0,0.000049D0,0.000774D0,5*0D0,0.000074D0,0D0,0.000417D0/
605 DATA (BRAT(I) ,I= 347, 651)/0.000015D0,0.000061D0,0.30671D0,
606 &0.689011D0,0D0,0.002889D0,69*0D0,0.000001D0,0.000121D0,
607 &0.001924D0,4*0D0,0.000001D0,0.000184D0,0D0,0.003106D0,0.000015D0,
608 &0.000003D0,2*0D0,0.994646D0,66*0D0,0.000021D0,0.090135D0,2*0D0,
609 &0.000013D0,0.003714D0,0D0,0.906117D0,18*0D0,3*0.215119D0,
610 &0.214724D0,2*0D0,0.06996D0,0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,
611 &0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
612 &0.005D0,0.988D0,0.012D0,0.998739D0,0.00079D0,0.00038D0,
613 &0.000046D0,0.000045D0,2*0.34725D0,0.144D0,0.104D0,0.0245D0,
614 &2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0,2*0.1939D0,
615 &2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0,0.000123D0,
616 &0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0,0.049D0,0.0028D0,
617 &0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0,0.0049D0,0.0013D0,
618 &0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0,0.00083D0,
619 &2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0,2*0.0115D0,
620 &0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0,0.333D0,
621 &0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0,0.059D0,
622 &2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0,0.0482D0,
623 &0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0,0.168D0,0.084D0,
624 &0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0,0.437D0,0.208D0/
625 DATA (BRAT(I) ,I= 652, 823)/0.302D0,0.0302D0,0.0212D0,0.0016D0,
626 &0.48947D0,0.34D0,3*0.043D0,0.027D0,0.0126D0,0.0013D0,0.0003D0,
627 &0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,2*0.004D0,0.07D0,
628 &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,0.065D0,2*0.005D0,
629 &2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0,0.041D0,0.045D0,
630 &0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0,0.0006D0,0.0066D0,
631 &0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0,0.005D0,0.012D0,
632 &0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0,0.004D0,0.019D0,
633 &0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0,0.087D0,0.001D0,
634 &0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0,0.011D0,0.3D0,0.15D0,
635 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.034D0,0.027D0,
636 &2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0,2*0.002D0,
637 &2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0,3*0.021D0,
638 &0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0,0.0041D0,
639 &0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0,0.0018D0,
640 &0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0,0.0036D0,
641 &0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0,0.0077D0,
642 &0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0,0.017D0,
643 &0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0,0.08D0,
644 &0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,2*0.005D0/
645 DATA (BRAT(I) ,I= 824, 991)/2*0.02D0,0.03D0,2*0.005D0,0.015D0,
646 &0.037D0,0.028D0,0.079D0,0.095D0,0.052D0,0.0078D0,4*0.001D0,
647 &0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,0.0952D0,
648 &0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,0.8797D0,
649 &0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,
650 &0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
651 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
652 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
653 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
654 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
655 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
656 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
657 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,
658 &0.0008D0,0.0014D0,0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,
659 &0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,
660 &0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,
661 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,
662 &0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,
663 &0.0135D0,0.025D0,2*0.0002D0,0.0007D0,2*0.0004D0,0.0014D0,0.001D0,
664 &0.0009D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0/
665 DATA (BRAT(I) ,I= 992,1183)/1D0,2*0.3D0,2*0.2D0,0.047D0,0.122D0,
666 &0.006D0,0.012D0,0.035D0,0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,
667 &0.037D0,0.008D0,0.002D0,0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,
668 &0.042D0,0.014D0,0.042D0,0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,
669 &0.002D0,0.001D0,0.002D0,0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,
670 &0.0252D0,0.0248D0,0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,
671 &0.7743D0,0.029D0,0.22D0,0.78D0,1D0,0.331D0,0.663D0,0.006D0,
672 &0.663D0,0.331D0,0.006D0,1D0,0.999D0,0.001D0,0.88D0,2*0.06D0,
673 &0.639D0,0.358D0,0.002D0,0.001D0,1D0,0.88D0,2*0.06D0,0.516D0,
674 &0.483D0,0.001D0,0.88D0,2*0.06D0,0.9988D0,0.0001D0,0.0006D0,
675 &0.0004D0,0.0001D0,0.667D0,0.333D0,0.9954D0,0.0011D0,0.0035D0,
676 &0.333D0,0.667D0,0.676D0,0.234D0,0.085D0,0.005D0,2*1D0,0.018D0,
677 &2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.018D0,2*0.005D0,0.003D0,
678 &0.002D0,2*0.006D0,0.0066D0,0.025D0,0.016D0,0.0088D0,2*0.005D0,
679 &0.0058D0,0.005D0,0.0055D0,4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,
680 &0.002D0,2*0.003D0,3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,
681 &2*0.002D0,0.0013D0,0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,
682 &2*0.002D0,2*0.001D0,2*0.002D0,2*0.001D0,0.2432D0,0.057D0,
683 &2*0.035D0,0.15D0,2*0.075D0,0.03D0,2*0.015D0,2*0.08D0,0.76D0,
684 &0.08D0,4*1D0,2*0.08D0,0.76D0,0.08D0,1D0,2*0.5D0,1D0,2*0.5D0/
685 DATA (BRAT(I) ,I=1184,1377)/2*0.08D0,0.76D0,0.08D0,1D0,2*0.08D0,
686 &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,
687 &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,
688 &0.04D0,0.0077D0,0.02D0,0.0235D0,0.0285D0,0.0435D0,0.0011D0,
689 &0.0022D0,0.0044D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
690 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
691 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
692 &4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
693 &0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
694 &0.005D0,4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
695 &0.015D0,0.005D0,1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
696 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
697 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
698 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
699 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
700 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
701 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
702 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
703 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
704 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0/
705 DATA (BRAT(I) ,I=1378,1580)/0.015D0,0.005D0,2*0.105D0,0.04D0,
706 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
707 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
708 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
709 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
710 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
711 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
712 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
713 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,
714 &0.11D0,2*0.055D0,0.333D0,0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,
715 &0.14D0,0.313D0,0.157D0,0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,
716 &0.313D0,0.157D0,0.11D0,0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,
717 &4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,
718 &0.333D0,4*0.5D0,0.007D0,0.993D0,1D0,0.667D0,0.333D0,0.667D0,
719 &0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,
720 &1D0,4*0.5D0,3*0.146D0,3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,
721 &0.667D0,0.333D0,0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,
722 &0.333D0,2*0.5D0,0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,
723 &4*0.5D0,0.35D0,0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,
724 &0.027D0,0.001D0,0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0/
725 DATA (BRAT(I) ,I=1581,3853)/0.008D0,0.024D0,0.008D0,0.024D0,
726 &0.425D0,0.02D0,0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2108*0D0,
727 &0.017431D0,0.054048D0,0.857694D0,2*0D0,0.00025D0,0.070578D0,0D0,
728 &0.022748D0,0.026576D0,0.359486D0,0.561581D0,2*0D0,0.000104D0,
729 &0.029504D0,0.011185D0,0.034681D0,0.550354D0,2*0D0,0.00016D0,
730 &0.045287D0,0.358333D0,0.445781D0,0D0,0.554219D0,0.144051D0,
731 &2*0.351902D0,0D0,0.082107D0,0.029566D0,0.001511D0,0.000726D0,
732 &0.004518D0,0.006522D0,0.004518D0,0.006522D0,0.004513D0,3*0D0,
733 &0.002908D0,0.000973D0,0.002908D0,0.000973D0,0.002908D0,
734 &0.000973D0,2*0D0,0.143982D0,0.489888D0,0.1951D0,0D0,0.114302D0,
735 &0.008426D0,0.014868D0,0.000763D0,2*0D0,0.000763D0,0.01484D0,
736 &0.000003D0,2*0D0,0.000027D0,0.001945D0,5*0D0,3*0.00503D0,0D0,
737 &0.133776D0,0.003284D0,0.37169D0,0.006838D0,2*0.030954D0,
738 &0.00163D0,0D0,0.047224D0,0.073737D0,0.047224D0,0.073732D0,
739 &0.047179D0,3*0D0,0.034761D0,0.009166D0,0.034761D0,0.009166D0,
740 &0.034759D0,0.009166D0,2*0D0,4*0.009069D0,0.510147D0,0.453576D0,
741 &6*0D0,1D0,6*0D0,1D0,4*0.001128D0,0.571047D0,0.382288D0,
742 &0.042153D0,4*0.016597D0,0.93361D0,0D0,4*0.016597D0,0.93361D0,0D0,
743 &4*0.05515D0,0.34469D0,0D0,0.228998D0,0.164208D0,0.041503D0,
744 &0.850973D0,0.005411D0,0.045025D0,0.098591D0,0.849898D0/
745 DATA (BRAT(I) ,I=3854,3984)/0.021617D0,0.030018D0,0.098466D0,
746 &0.294448D0,0.10945D0,0.596102D0,0.389906D0,0.610094D0,3*0.0633D0,
747 &0.063299D0,0.063295D0,0.056281D0,2*0D0,6*0.020495D0,2*0D0,
748 &0.327919D0,0.04099D0,0.045236D0,0.090112D0,0D0,0.19874D0,
749 &0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0,
750 &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,
751 &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0,
752 &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0,
753 &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0,
754 &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,
755 &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0,
756 &0.010236D0,0.198928D0,0.000149D0,0.000006D0,0.000368D0,
757 &0.080733D0,0.199344D0,0.010234D0,0.000003D0,0.010236D0,
758 &0.198928D0,0.000149D0,0.000006D0,0.000368D0,0.080733D0,4*0D0,
759 &0.184738D0,0.104588D0,0.184738D0,0.104587D0,0.184731D0,0.09582D0,
760 &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0,
761 &0.015602D0,0.022902D0,0.008429D0,0.015602D0,0.28959D0,0.01487D0,
762 &0.000008D0,0.01487D0,0.289061D0,0.000492D0,0.000009D0,0.000536D0,
763 &0.27911D0,2*0.037151D0,0.03715D0,0.090266D0,2*0.001805D0,
764 &0.090266D0,0.001805D0,0.812263D0,0.00179D0,0.090428D0,0.001809D0/
765 DATA (BRAT(I) ,I=3985,8000)/0.001808D0,0.090428D0,0.001808D0,
766 &0.81372D0,0D0,4011*0D0/
767 DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
768 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
769 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
770 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
771 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
772 &-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,
773 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
774 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
775 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
776 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
777 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
778 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
779 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
780 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
781 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
782 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
783 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
784 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
785 &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
786 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
787 DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
788 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
789 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
790 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
791 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
792 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
793 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
794 &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
795 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
796 &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
797 &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
798 &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
799 &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
800 &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
801 &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
802 &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
803 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
804 &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
805 &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
806 &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
807 DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
808 &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
809 &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
810 &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
811 &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
812 &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
813 &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
814 &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
815 &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
816 &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
817 &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
818 &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
819 &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
820 &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
821 &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
822 &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
823 &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
824 &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
825 &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
826 &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
827 DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
828 &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
829 &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
830 &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
831 &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
832 &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
833 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
834 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
835 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
836 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
837 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
838 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
839 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
840 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
841 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
842 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
843 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
844 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
845 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
846 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
847 DATA (KFDP(I,1),I=1403,1708)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
848 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
849 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
850 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
851 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
852 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
853 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
854 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
855 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
856 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
857 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
858 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
859 &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
860 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,1000039,1000024,
861 &1000037,1000022,1000023,1000025,1000035,1000001,2000001,1000001,
862 &2000001,1000021,3*-11,3*-13,3*-15,1000039,-1000024,-1000037,
863 &1000022,1000023,1000025,1000035,1000004,2000004,1000004,2000004,
864 &1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,
865 &15,16,15,16,15,1000039,1000024,1000037,1000022,1000023,1000025,
866 &1000035,1000003,2000003,1000003,2000003,1000021,3*-11,3*-13/
867 DATA (KFDP(I,1),I=1709,1966)/3*-15,1000039,-1000024,-1000037,
868 &1000022,1000023,1000025,1000035,1000006,2000006,1000006,2000006,
869 &1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,
870 &15,16,15,16,15,1000039,1000024,1000037,1000022,1000023,1000025,
871 &1000035,1000005,2000005,1000005,2000005,1000021,1000022,1000016,
872 &-1000015,3*-11,3*-13,3*-15,1000039,-1000024,-1000037,1000022,
873 &1000023,1000025,1000035,1000012,2000012,1000012,2*12,2*14,2*16,
874 &3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,1000037,1000022,
875 &1000023,1000025,1000035,1000011,2000011,1000011,2000011,3*-13,
876 &3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,1000022,1000023,
877 &1000025,1000035,1000014,2000014,1000014,2000014,2*12,2*14,2*16,
878 &3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,1000037,1000022,
879 &1000023,1000025,1000035,1000013,2000013,1000013,2000013,3*-11,
880 &3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,1000022,1000023,
881 &1000025,1000035,1000016,2000016,1000016,2000016,2*12,2*14,2*16,
882 &3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,1000037,1000022,
883 &1000023,1000025,1000035,1000015,2000015,1000015,2000015,3*-11,
884 &3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,2000001,-2000001,
885 &1000002,-1000002,2000002,-2000002,1000003,-1000003,2000003,
886 &-2000003,1000004,-1000004,2000004,-2000004,1000005,-1000005/
887 DATA (KFDP(I,1),I=1967,2235)/2000005,-2000005,1000006,-1000006,
888 &2000006,-2000006,6*1000022,6*1000023,6*1000025,6*1000035,1000024,
889 &-1000024,1000024,-1000024,1000024,-1000024,1000037,-1000037,
890 &1000037,-1000037,1000037,-1000037,5*1000039,4,1,-12,12,-12,12,
891 &-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,
892 &-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,
893 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
894 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
895 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
896 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
897 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
898 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,5*1000039,
899 &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
900 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
901 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
902 &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
903 &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
904 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
905 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
906 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011/
907 DATA (KFDP(I,1),I=2236,2523)/-2000011,1000012,-1000012,2000012,
908 &-2000012,1000013,-1000013,2000013,-2000013,1000014,-1000014,
909 &2000014,-2000014,1000015,-1000015,2000015,-2000015,1000016,
910 &-1000016,2000016,-2000016,5*1000021,-12,12,-12,12,-12,12,-12,12,
911 &-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,-16,16,
912 &-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,-11,11,
913 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
914 &-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,-13,13,
915 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
916 &-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,-15,15,
917 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
918 &-15,15,-16,16,-15,15,-16,16,-15,15,2*1000039,6*1000022,6*1000023,
919 &6*1000025,6*1000035,1000022,1000023,1000025,1000035,1000002,
920 &2000002,-1000001,-2000001,1000004,2000004,-1000003,-2000003,
921 &1000006,2000006,-1000005,-2000005,1000012,2000012,-1000011,
922 &-2000011,1000014,2000014,-1000013,-2000013,1000016,2000016,
923 &-1000015,-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,
924 &12,-11,-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,
925 &-14,14,-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
926 &-16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12/
927 DATA (KFDP(I,1),I=2524,2794)/2*-11,12,-12,2*-11,12,-12,2*-11,12,
928 &-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
929 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
930 &-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
931 &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
932 &5*1000039,16*1000022,16*1000023,1000024,-1000024,1000024,
933 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
934 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
935 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
936 &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
937 &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
938 &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
939 &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
940 &1000011,-1000011,2000011,-2000011,1000012,-1000012,2000012,
941 &-2000012,1000013,-1000013,2000013,-2000013,1000014,-1000014,
942 &2000014,-2000014,1000015,-1000015,2000015,-2000015,1000016,
943 &-1000016,2000016,-2000016,5*1000021,-12,12,-12,12,-12,12,-12,12,
944 &-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,-16,16,
945 &-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,-11,11,
946 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12/
947 DATA (KFDP(I,1),I=2795,3070)/-11,11,-12,12,-11,11,-12,12,-11,11,
948 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
949 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
950 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
951 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
952 &5*1000039,16*1000022,16*1000023,16*1000025,1000024,-1000024,
953 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
954 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
955 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
956 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001,
957 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003,
958 &-1000003,2000003,-2000003,1000004,-1000004,2000004,-2000004,
959 &1000005,-1000005,2000005,-2000005,1000006,-1000006,2000006,
960 &-2000006,1000011,-1000011,2000011,-2000011,1000012,-1000012,
961 &2000012,-2000012,1000013,-1000013,2000013,-2000013,1000014,
962 &-1000014,2000014,-2000014,1000015,-1000015,2000015,-2000015,
963 &1000016,-1000016,2000016,-2000016,5*1000021,-12,12,-12,12,-12,12,
964 &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
965 &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
966 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11/
967 DATA (KFDP(I,1),I=3071,3398)/-12,12,-11,11,-12,12,-11,11,-12,12,
968 &-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
969 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
970 &-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
971 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
972 &-15,15,2*1000039,15*1000024,6*1000022,6*1000023,6*1000025,
973 &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
974 &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
975 &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
976 &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
977 &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
978 &-12,12,-11,-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
979 &-13,-14,14,-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,
980 &16,-15,-16,16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,
981 &12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,
982 &12,-12,2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,
983 &14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,
984 &14,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,
985 &16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,1000039,
986 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000001/
987 DATA (KFDP(I,1),I=3399,3676)/1000002,2000002,1000002,2000002,
988 &1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,
989 &15,16,15,16,15,1000039,1000024,1000037,1000022,1000023,1000025,
990 &1000035,4*1000002,1000001,2000001,1000001,2000001,1000021,3*-11,
991 &3*-13,3*-15,1000039,-1000024,-1000037,1000022,1000023,1000025,
992 &1000035,4*1000003,1000004,2000004,1000004,2000004,1000021,3*-12,
993 &3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,
994 &15,1000039,1000024,1000037,1000022,1000023,1000025,1000035,
995 &4*1000004,1000003,2000003,1000003,2000003,1000021,3*-11,3*-13,
996 &3*-15,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
997 &4*1000005,1000006,2000006,1000006,2000006,1000021,3*-12,3*-14,
998 &3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,
999 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,
1000 &4*1000006,1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,
1001 &3*-15,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1002 &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1003 &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1004 &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1005 &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1006 &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016/
1007 DATA (KFDP(I,1),I=3677,8000)/1000016,2000016,2*12,2*14,2*16,
1008 &3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,6,11,13,15,21,2*4,2,4,24,-11,
1009 &-13,-15,3,4,5,6,11,13,15,21,5,6,21,2*24,2*3000211,2*22,2*23,1,2,
1010 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,2*24,3*3000211,24,4*-1,4*-3,
1011 &4*-5,4*-7,-11,-13,-15,-17,22,23,22,23,24,3000211,24,3000211,1,2,
1012 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,1,2,3,4,5,6,1,2,3,4,5,6,21,1,
1013 &2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,
1014 &21,3100111,3200111,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1,2,
1015 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,21,22,23,24,0,9*11,9*-11,
1016 &2*11,2*-11,9*13,9*-13,2*13,2*-13,9*15,9*-15,2*15,2*-15,1,2,3,4,5,
1017 &6,11,12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,
1018 &-13,-15,3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,4011*0/
1019 DATA (KFDP(I,2),I= 1, 339)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
1020 &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,6*1000006,3*7,
1021 &2,4,6,8,7,4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14,
1022 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1023 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1024 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1025 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1026 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1027 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1028 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1029 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1030 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1031 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1032 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1033 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1034 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1035 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1036 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1037 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1038 &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,25,-1,-2,-3,-4,-5,-6/
1039 DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1040 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1041 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1042 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1043 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1044 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1045 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1046 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1047 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1048 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1049 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1050 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1051 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1052 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1053 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1054 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1055 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1056 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1057 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1058 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1059 DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1060 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1061 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1062 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1063 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1064 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1065 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1066 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1067 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1068 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1069 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1070 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1071 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1072 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1073 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1074 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1075 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1076 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1077 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1078 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1079 DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1080 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1081 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1082 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1083 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1084 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1085 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1086 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1087 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1088 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1089 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1090 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1091 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1092 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1093 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1094 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1095 &4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,11,13,15,1,4,3,4,1,3,11,
1096 &13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,4,
1097 &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,
1098 &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3/
1099 DATA (KFDP(I,2),I=1353,1822)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1100 &4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,
1101 &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,
1102 &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
1103 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1104 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1105 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1106 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1107 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1108 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1109 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1110 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1111 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1112 &1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,2,2*1,4*2,2*24,
1113 &2*37,2,1,3,5,1,3,5,1,3,5,3,2*4,4*3,2*-24,2*-37,3,1,3,5,1,3,5,1,3,
1114 &5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,4,2*3,4*4,2*24,2*37,4,1,3,
1115 &5,1,3,5,1,3,2*5,2*6,4*5,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,
1116 &5,6,1,2,3,4,5,6,1,2,3,4,5,2*6,2*5,4*6,2*24,2*37,6,4,-15,16,1,3,5,
1117 &1,3,5,1,3,5,11,2*12,4*11,2*-24,-37,13,15,11,15,11,13,11,13,15,11,
1118 &13,15,1,3,5,1,3,5,1,3,5,12,2*11,4*12,2*24,2*37,11,13,15,11,13,15/
1119 DATA (KFDP(I,2),I=1823,2288)/1,3,5,1,3,5,1,3,5,13,2*14,4*13,
1120 &2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3,
1121 &5,14,2*13,4*14,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15,
1122 &2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,5,
1123 &1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,
1124 &1,3,5,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,
1125 &-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,-1,3,-3,5,
1126 &-5,1,-1,3,-3,5,-5,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,-15,
1127 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,
1128 &11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,
1129 &-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,
1130 &-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,
1131 &-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,
1132 &-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,22,23,25,35,36,
1133 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,
1134 &15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,
1135 &-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,
1136 &6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,
1137 &-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,
1138 &15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11/
1139 DATA (KFDP(I,2),I=2289,2743)/11,-11,11,-13,13,-13,13,-13,13,-1,1,
1140 &-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,
1141 &-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,
1142 &-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,
1143 &-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,
1144 &-6,6,24,37,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,
1145 &-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,
1146 &2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,
1147 &-13,-15,16,2*-15,16,2*-15,16,-15,6*-11,-15,16,2*-15,16,2*-15,16,
1148 &-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,
1149 &-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,
1150 &-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,
1151 &6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,
1152 &-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,22,
1153 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,
1154 &13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1,
1155 &-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,
1156 &-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,
1157 &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
1158 &-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15/
1159 DATA (KFDP(I,2),I=2744,3191)/15,-11,11,-11,11,-11,11,-15,15,-15,
1160 &15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,
1161 &1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,
1162 &6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,
1163 &3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,
1164 &2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,22,
1165 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,
1166 &13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,
1167 &2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,
1168 &13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,
1169 &-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,
1170 &-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,
1171 &4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1172 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,
1173 &-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,
1174 &-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,
1175 &-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,
1176 &-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,
1177 &-5,5,-6,6,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1178 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11/
1179 DATA (KFDP(I,2),I=3192,3692)/-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,
1180 &2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,-3,-13,14,2*-13,
1181 &14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,-11,12,2*-11,12,
1182 &2*-11,12,-11,-15,16,2*-15,16,2*-15,16,-15,-11,12,2*-11,12,2*-11,
1183 &12,-11,-13,14,2*-13,14,2*-13,14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,
1184 &-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,
1185 &-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,
1186 &-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,
1187 &2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,
1188 &-5,6,-5,-6,-5,6,1,2*2,4*1,23,25,35,36,2*-24,2*-37,2*1,3,5,1,3,5,
1189 &1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,2,2*1,4*2,23,25,35,36,
1190 &2*24,2*37,2,1,3,5,1,3,5,1,3,5,3,2*4,4*3,23,25,35,36,2*-24,2*-37,
1191 &3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,4,2*3,
1192 &4*4,23,25,35,36,2*24,2*37,4,1,3,5,1,3,5,1,3,2*5,2*6,4*5,23,25,35,
1193 &36,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,
1194 &4,5,2*6,2*5,4*6,23,25,35,36,2*24,2*37,6,1,3,5,1,3,5,1,3,5,11,
1195 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1196 &13,15,1,3,5,1,3,5,1,3,5,13,2*14,4*13,23,25,35,36,2*-24,2*-37,13,
1197 &15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15,2*16,4*15,
1198 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3/
1199 DATA (KFDP(I,2),I=3693,8000)/5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,
1200 &-15,21,-1,-3,2*-5,5,12,14,16,-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,
1201 &-24,-3000211,-24,-3000211,3000111,3000221,3000111,3000221,-1,-2,
1202 &-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,23,3000111,23,
1203 &3000111,22,3000221,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
1204 &2*3000111,2*3000221,-3000211,2*-24,-3000211,-1,-2,-3,-4,-5,-6,-7,
1205 &-8,-11,-12,-13,-14,-15,-16,-17,-18,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,
1206 &-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,
1207 &-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1208 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1209 &21,22,23,-24,0,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3,
1210 &3*-5,3*1,3*3,3*5,2*-11,2*15,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-11,
1211 &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16,
1212 &9900016,2,4,6,2,4,6,2,4,6,9900012,9900014,9900016,-11,-13,-15,
1213 &-13,2*-15,24,-11,-13,-15,-13,2*-15,9900024,4011*0/
1214 DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1215 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1216 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1217 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1218 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1219 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1220 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1221 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1222 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1223 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1224 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1225 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1226 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1227 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1228 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1229 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1230 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1231 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1232 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1233 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1234 DATA (KFDP(I,3),I=1022,2197)/511,513,511,513,1,2,13*0,2*21,11*0,
1235 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1236 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1237 &4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,2*2,4*4,1,4,3,
1238 &2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,
1239 &2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
1240 &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
1241 &3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
1242 &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
1243 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1244 &-211,111,13*0,2*21,-211,111,175*0,2*5,207*0,-1,-3,-5,-2,-4,-6,-1,
1245 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1246 &6,-2,2,-4,4,-6,6,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,
1247 &-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,
1248 &-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,
1249 &3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,
1250 &3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,
1251 &5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,
1252 &5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,7*0,-11,-13,-15,-12,-14,-16,
1253 &-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14/
1254 DATA (KFDP(I,3),I=2198,2789)/14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,
1255 &-2,-4,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,
1256 &-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,
1257 &-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,
1258 &1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,
1259 &1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,
1260 &3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,
1261 &3,-3,5,-5,5,-5,3*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,
1262 &12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,
1263 &-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,14,-13,13,16,-15,15,
1264 &12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1265 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,
1266 &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1267 &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1268 &2*2,1,-1,2*4,3,-3,2*6,5,-5,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,
1269 &-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,
1270 &14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,
1271 &-3,-5,-2,-4,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,
1272 &-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,
1273 &-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5/
1274 DATA (KFDP(I,3),I=2790,3335)/-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1275 &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1276 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
1277 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,7*0,-11,-13,
1278 &-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,
1279 &-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,
1280 &-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,
1281 &-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,
1282 &13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,
1283 &13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,
1284 &5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,
1285 &5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,
1286 &1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,
1287 &1,-1,3,-3,3,-3,5,-5,5,-5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,
1288 &-4,4*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,
1289 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1290 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1291 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1292 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,
1293 &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3/
1294 DATA (KFDP(I,3),I=3336,8000)/2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1295 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,
1296 &2*4,3,-3,2*6,5,-5,324*0,-5,170*0,2,4,6,2,4,6,2,4,6,-2,-4,-6,-2,
1297 &-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,6,2,4,6,-2,-4,-6,-2,
1298 &-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,6,2,4,6,-2,-4,-6,-2,
1299 &-4,-6,-2,-4,-6,2*9900012,2*9900014,4052*0/
1300 DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1301 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1302 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1303 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1304 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1305 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1306 &-311,20*0,-3,43*0,6*1,39*0,6*2,42*0,6*3,14*0,8*4,4*0,4*-5,4*0,
1307 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1308 &4*0,4*81,6*0,4*81,0,28*81,13*0,6*2101,18*81,4*0,18*81,4*0,9*81,0,
1309 &162*81,31*0,-211,111,6516*0/
1310 DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1311 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1312 &3*111,-211,111,7193*0/
1314 C...PYDAT4, with particle names (character strings).
1315 DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''',
1316 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1317 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1318 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1319 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',4*' ',
1320 &'system','cluster','string','indep.','CMshower','SPHEaxis',
1321 &'THRUaxis','CLUSjet','CELLjet','table',' ','reggeon','pi0',
1322 &'rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega','f_2',
1323 &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1324 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1325 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1326 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1327 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1328 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1329 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1330 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1331 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1332 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1333 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1334 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1335 DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1336 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1337 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1338 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1339 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1340 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1341 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1342 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1343 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1344 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1345 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1346 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1347 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1348 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1349 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1350 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1351 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1352 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1353 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1354 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1355 DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1356 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1357 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1358 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1359 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1360 &'n_diffr0','p_diffr+',139*' '/
1361 DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1362 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1363 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1364 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1365 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1366 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1367 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1368 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1369 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1370 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1371 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1372 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1373 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1374 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1375 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1376 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1377 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1378 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1379 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1380 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1381 DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1382 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1383 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1384 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1385 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1386 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1387 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1388 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1389 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1390 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1391 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1392 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1393 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1394 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1395 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1396 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1397 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1398 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1399 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1400 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1401 DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1402 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1403 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1404 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',139*' '/
1406 C...PYDATR, with initial values for the random number generator.
1407 DATA MRPY/19780503,0,0,97,33,0/
1409 C...Default values for allowed processes and kinematics constraints.
1412 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1413 &5*1,5*0,6*1,4*0,4*1,16*0,16*0,4*1,4*0,6*1,5*0,5*1,0,5*1,5*0,
1416 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1417 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1418 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1419 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1420 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1421 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1422 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1423 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1424 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1425 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1426 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1427 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1428 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1429 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1430 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1431 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1434 C...Default values for main switches and parameters. Reset information.
1435 DATA (MSTP(I),I=1,100)/
1436 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1437 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1438 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1439 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1440 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1441 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1442 6 2, 3, 2, 2, 1, 5, 2, 1, 0, 0,
1443 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1444 8 1, 1, 100, 0, 0, 2, 0, 0, 0, 0,
1445 9 1, 3, 1, 3, 0, 0, 0, 0, 0, 0/
1446 DATA (MSTP(I),I=101,200)/
1447 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1448 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1449 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1450 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1451 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1452 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1453 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1454 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1455 8 6, 203, 2001, 11, 13, 0, 0, 0, 0, 0,
1456 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1457 DATA (PARP(I),I=1,100)/
1458 & 0.25D0, 10D0, 8*0D0,
1459 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1461 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,2.0D0,0.70D0,0.006D0,0D0,
1462 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1464 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 1.0D0,1D-3,2*0D0,
1465 7 4.0D0, 0.25D0, 8*0D0,
1466 8 1.90D0, 1.90D0, 0.5D0, 0.2D0, 0.33D0,
1467 8 0.66D0, 0.7D0, 0.5D0, 1000D0, 0.16D0,
1468 9 1.0D0,0.40D0,5.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1469 DATA (PARP(I),I=101,200)/
1470 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1471 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1472 2 1.0D0, 0.4D0, 8*0D0,
1473 3 0.01D0, 5*0D0, 200D0, 200D0, 0.333D0, 0.05D0,
1474 4 0.33333D0, 82D0, 1.33333D0, 4D0, 1D0,
1475 4 1D0, .0182D0, 1D0, 0D0, 1.33333D0,
1476 5 0D0, 0D0, 0D0, 0D0, 0.3651480D0, 200D0, 0D0, 0D0, 0D0, 0D0,
1477 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1478 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1479 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1481 9 0.64D0, 5.0D0, 8*0D0/
1487 C...Constants for the generation of the various processes.
1488 DATA (ISET(I),I=1,100)/
1489 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1490 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1491 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1492 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1493 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1494 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1495 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1496 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1497 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1498 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1499 DATA (ISET(I),I=101,200)/
1500 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1501 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1502 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1503 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1504 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1505 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1506 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1507 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1508 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1509 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1510 DATA (ISET(I),I=201,300)/
1511 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1512 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1513 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1514 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1515 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1516 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1517 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1518 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1519 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1520 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1521 DATA (ISET(I),I=301,500)/
1523 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1524 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1525 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1526 7 2, 2, 2, 2, 2, 2, 2, -1, -1, -1,
1528 9 1, 1, 2, 2, 2, 5*-2,
1530 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1531 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1532 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1533 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1534 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1535 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1536 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1537 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1538 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1539 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1540 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1541 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1542 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1543 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1544 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1545 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1546 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1547 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1548 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1549 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1550 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1551 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1552 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1553 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1554 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1555 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1556 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1557 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1558 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1559 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1560 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1561 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1562 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1563 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1564 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1565 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1566 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1567 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1568 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1569 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1570 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1571 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1572 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1573 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1574 DATA ((KFPR(I,J),J=1,2),I=201,250)/
1575 & 1000011, 1000011, 2000011, 2000011, 1000011,
1576 & 2000011, 1000013, 1000013, 2000013, 2000013,
1577 & 1000013, 2000013, 1000015, 1000015, 2000015,
1578 & 2000015, 1000015, 2000015, 1000011, 1000012,
1579 1 1000015, 1000016, 2000015, 1000016, 1000012,
1580 1 1000012, 1000016, 1000016, 0, 0,
1581 1 1000022, 1000022, 1000023, 1000023, 1000025,
1582 1 1000025, 1000035, 1000035, 1000022, 1000023,
1583 2 1000022, 1000025, 1000022, 1000035, 1000023,
1584 2 1000025, 1000023, 1000035, 1000025, 1000035,
1585 2 1000024, 1000024, 1000037, 1000037, 1000024,
1586 2 1000037, 1000022, 1000024, 1000023, 1000024,
1587 3 1000025, 1000024, 1000035, 1000024, 1000022,
1588 3 1000037, 1000023, 1000037, 1000025, 1000037,
1589 3 1000035, 1000037, 1000021, 1000022, 1000021,
1590 3 1000023, 1000021, 1000025, 1000021, 1000035,
1591 4 1000021, 1000024, 1000021, 1000037, 1000021,
1592 4 1000021, 1000021, 1000021, 0, 0,
1593 4 1000002, 1000022, 2000002, 1000022, 1000002,
1594 4 1000023, 2000002, 1000023, 1000002, 1000025/
1595 DATA ((KFPR(I,J),J=1,2),I=251,300)/
1596 5 2000002, 1000025, 1000002, 1000035, 2000002,
1597 5 1000035, 1000001, 1000024, 2000005, 1000024,
1598 5 1000001, 1000037, 2000005, 1000037, 1000002,
1599 5 1000021, 2000002, 1000021, 0, 0,
1600 6 1000006, 1000006, 2000006, 2000006, 1000006,
1601 6 2000006, 1000006, 1000006, 2000006, 2000006,
1604 7 1000002, 1000002, 2000002, 2000002, 1000002,
1605 7 2000002, 1000002, 1000002, 2000002, 2000002,
1606 7 1000002, 2000002, 1000002, 1000002, 2000002,
1607 7 2000002, 1000002, 1000002, 2000002, 2000002,
1608 8 1000005, 1000002, 2000005, 2000002, 1000005,
1609 8 2000002, 1000005, 1000002, 2000005, 2000002,
1610 8 1000005, 2000002, 1000005, 1000005, 2000005,
1611 8 2000005, 1000005, 1000005, 2000005, 2000005,
1612 9 1000005, 1000005, 2000005, 2000005, 1000005,
1613 9 2000005, 1000005, 1000021, 2000005, 1000021,
1614 9 1000005, 2000005, 37, 25, 37,
1615 9 35, 36, 25, 36, 35/
1616 DATA ((KFPR(I,J),J=1,2),I=301,500)/
1618 4 9900041, 0, 9900042, 0, 9900041,
1619 4 11, 9900042, 11, 9900041, 13,
1620 4 9900042, 13, 9900041, 15, 9900042,
1621 4 15, 9900041, 9900041, 9900042, 9900042,
1622 5 9900041, 0, 9900042, 0, 9900023,
1623 5 0, 9900024, 0, 0, 0,
1626 6 24, 24, 24, 3000211, 3000211,
1627 6 3000211, 22, 3000111, 22, 3000221,
1628 6 23, 3000111, 23, 3000221, 24,
1629 6 3000211, 0, 0, 24, 23,
1630 7 24, 3000111, 3000211, 23, 3000211,
1631 7 3000111, 22, 3000211, 23, 3000211,
1632 7 24, 3000111, 24, 3000221, 0,
1635 9 5000039, 0, 5000039, 0, 21,
1636 9 5000039, 0, 5000039, 21, 5000039,
1639 DATA COEF/10000*0D0/
1640 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1641 &4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2,
1642 &3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2,
1643 &3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1,
1644 &3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0,
1645 &4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3,
1646 &2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2,
1647 &4,0,0,0,4,0,1,3,0,0,3,0,2,4,3,0,3,4,0,0,1,0,0,1,0,0,3,4,2,0,0,2,
1648 &3,0,0,0,1,0,0,0,0,0,3,0,2,0,0,0,2,0,3,1,2,0,0,0,3,2,1,0,1,0,0,0,
1649 &4,4,3,3,2,2,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1650 &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
1652 C...Treatment of resonances.
1653 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1654 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,146*0/
1656 C...Character constants: name of processes.
1657 DATA PROC(0)/ 'All included subprocesses '/
1658 DATA (PROC(I),I=1,20)/
1659 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1660 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1661 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1662 &' ', 'W+ + W- -> h0 ',
1663 &' ', 'f + f'' -> f + f'' (QFD) ',
1664 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1665 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1666 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1667 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1668 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1669 DATA (PROC(I),I=21,40)/
1670 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1671 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1672 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1673 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1674 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1675 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1676 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1677 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1678 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1679 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1680 DATA (PROC(I),I=41,60)/
1681 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1682 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1683 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1684 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1685 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1686 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1687 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1688 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1689 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1690 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1691 DATA (PROC(I),I=61,80)/
1692 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1693 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1694 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1695 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1696 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1697 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1698 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1699 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1700 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1701 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1702 DATA (PROC(I),I=81,100)/
1703 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1704 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1705 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1706 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1707 8'g + g -> chi_2c + g ', ' ',
1708 9'Elastic scattering ', 'Single diffractive (XB) ',
1709 9'Single diffractive (AX) ', 'Double diffractive ',
1710 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1712 9'q + gamma* -> q ', ' '/
1713 DATA (PROC(I),I=101,120)/
1714 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1715 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1716 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1717 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1718 &' ', 'f + fbar -> gamma + h0 ',
1719 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1720 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1721 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1722 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1724 DATA (PROC(I),I=121,140)/
1725 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1726 2'f + f'' -> f + f'' + h0 ',
1727 2'f + f'' -> f" + f"'' + h0 ',
1731 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1732 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1733 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1734 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1735 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1736 DATA (PROC(I),I=141,160)/
1737 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1738 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1739 4'q + l -> LQ ', 'e + gamma -> e* ',
1740 4'd + g -> d* ', 'u + g -> u* ',
1741 4'g + g -> eta_tc ', ' ',
1742 5'f + fbar -> H0 ', 'g + g -> H0 ',
1743 5'gamma + gamma -> H0 ', ' ',
1744 5' ', 'f + fbar -> A0 ',
1745 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1747 DATA (PROC(I),I=161,180)/
1748 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1749 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1750 6'f + fbar -> f'' + fbar'' (g/Z)',
1751 6'f +fbar'' -> f" + fbar"'' (W) ',
1752 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1753 6'q + qbar -> e + e* ', ' ',
1754 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1755 7'f + f'' -> f + f'' + H0 ',
1756 7'f + f'' -> f" + f"'' + H0 ',
1757 7' ', 'f + fbar -> Z0 + A0 ',
1758 7'f + fbar'' -> W+/- + A0 ',
1759 7'f + f'' -> f + f'' + A0 ',
1760 7'f + f'' -> f" + f"'' + A0 ',
1762 DATA (PROC(I),I=181,200)/
1763 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1764 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
1765 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
1766 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
1767 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
1768 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
1769 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
1770 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
1773 DATA (PROC(I),I=201,220)/
1774 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1775 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1776 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1777 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1778 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1779 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1780 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1781 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1782 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1783 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1784 DATA (PROC(I),I=221,240)/
1785 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1786 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1787 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1788 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1789 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1790 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1791 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1792 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1793 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1794 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1795 DATA (PROC(I),I=241,260)/
1796 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1797 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1798 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1799 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1800 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1801 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1802 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1803 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1804 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1805 5'qj + g -> ~qj_R + ~g ', ' '/
1806 DATA (PROC(I),I=261,300)/
1807 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1808 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1809 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1812 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1813 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1814 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1815 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1816 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
1817 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
1818 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
1819 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
1820 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
1821 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
1822 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
1823 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
1824 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
1825 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
1826 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
1827 DATA (PROC(I),I=301,340)/
1828 &'f + fbar -> H+ + H- ', 39*' '/
1829 DATA (PROC(I),I=341,380)/
1830 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
1831 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
1832 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
1833 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
1834 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
1835 5'f + f -> f'' + f'' + H_L++/-- ',
1836 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
1837 5'f + fbar'' -> W_R+/- ',5*' ',
1838 6' ', 'f + fbar -> W_L+ W_L- ',
1839 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
1840 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
1841 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
1842 6'f + fbar -> W+/- pi_T-/+ ', ' ',
1843 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
1844 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
1845 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
1846 7'f + fbar'' -> W+/- pi_T0 ',
1847 7'f + fbar'' -> W+/- pi_T0'' ',
1850 DATA (PROC(I),I=381,500)/
1852 9'f + fbar -> G* ','g + g -> G* ',
1853 9'q + qbar -> g + G* ','q + g -> q + G* ',
1854 9'g + g -> g + G* ',' ',
1857 C...Cross sections and slope offsets.
1860 C...Supersymmetry switches and parameters.
1862 & 0, 0, 0, 1, 0, 0, 0, 1, 0, 0,
1865 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
1866 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
1867 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
1869 C...Initial values for R-violating SUSY couplings.
1870 C...Should not be changed here. See PYMSIN.
1875 C...Data for histogramming routines.
1876 DATA IHIST/1000,20000,55,1/
1881 C*********************************************************************
1884 C...A simple program (disguised as subroutine) to run at installation
1885 C...as a check that the program works as intended.
1887 SUBROUTINE PYTEST(MTEST)
1889 C...Double precision and integer declarations.
1890 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1891 IMPLICIT INTEGER(I-N)
1892 INTEGER PYK,PYCHGE,PYCOMP
1894 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1895 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1896 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1897 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
1898 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
1899 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
1900 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
1902 DIMENSION PSUM(5),PINI(6),PFIN(6)
1904 C...Save defaults for values that are changed.
1921 C...First part: loop over simple events to be generated.
1922 IF(MTEST.GE.1) CALL PYTABU(20)
1926 C...Reset parameter values. Switch on some nonstandard features.
1941 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
1943 C...Ten events each for some single jets configurations.
1947 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
1948 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
1949 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
1950 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
1951 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
1952 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
1954 C...Ten events each for some simple jet systems; string fragmentation.
1955 ELSEIF(IEV.LE.130) THEN
1957 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
1958 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
1959 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
1960 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
1961 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
1962 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
1963 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
1964 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
1965 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1967 C...Seventy events with independent fragmentation and momentum cons.
1968 ELSEIF(IEV.LE.200) THEN
1970 MSTJ(2)=1+MOD(IEV-131,4)
1971 MSTJ(3)=1+MOD((IEV-131)/4,4)
1972 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
1973 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
1974 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
1975 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1976 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
1977 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1979 C...A hundred events with random jets (check invariant mass).
1980 ELSEIF(IEV.LE.300) THEN
1987 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
1988 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
1989 EJET=5D0+20D0*PYR(0)
1990 THETA=ACOS(2D0*PYR(0)-1D0)
1992 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
1993 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
1994 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
1995 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
1997 PSUM(J)=PSUM(J)+P(I,J)
2000 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2001 & (PSUM(5)+PARJ(32))**2) GOTO 100
2003 C...Fifty e+e- continuum events with matrix elements.
2004 ELSEIF(IEV.LE.350) THEN
2008 C...Fifty e+e- continuum event with varying shower options.
2009 ELSEIF(IEV.LE.400) THEN
2010 MSTJ(42)=1+MOD(IEV,2)
2011 MSTJ(43)=1+MOD(IEV/2,4)
2012 MSTJ(44)=MOD(IEV/8,3)
2015 C...Fifty e+e- continuum events with coherent shower.
2016 ELSEIF(IEV.LE.450) THEN
2017 CALL PYEEVT(0,500D0)
2019 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2021 CALL PYONIA(5,9.46D0)
2024 C...Generate event. Find total momentum, energy and charge.
2035 C...Check conservation of energy, momentum and charge;
2036 C...usually exact, but only approximate for single jets.
2039 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2041 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2042 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2043 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2046 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2048 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2050 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2051 & (PFIN(J),J=1,4),PFIN(6)
2053 C...Check that all KF codes are known ones, and that partons/particles
2054 C...satisfy energy-momentum-mass relation. Store particle statistics.
2056 IF(K(I,1).GT.20) GOTO 170
2057 IF(PYCOMP(K(I,2)).EQ.0) THEN
2058 WRITE(MSTU(11),5100) I
2061 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2062 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2064 WRITE(MSTU(11),5200) I
2068 IF(MTEST.GE.1) CALL PYTABU(21)
2070 C...List all erroneous events and some normal ones.
2071 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2072 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2074 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2078 C...Stop execution if too many errors.
2079 IF(MERR.NE.0) NERR=NERR+1
2081 WRITE(MSTU(11),6300)
2087 C...Summarize result of run.
2088 IF(MTEST.GE.1) CALL PYTABU(22)
2090 C...Reset commonblock variables changed during run.
2107 C...Second part: complete events of various kinds.
2108 C...Common initial values. Loop over initiating conditions.
2109 MSTP(122)=MAX(0,MIN(2,MTEST))
2110 MDCY(PYCOMP(111),1)=0
2113 C...Reset process type, kinematics cuts, and the flags used.
2130 C...Prompt photon production at fixed target.
2133 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2137 CALL PYINIT('FIXT','pi+','p',PZSUM)
2139 C...QCD processes at ISR energies.
2140 ELSEIF(IPROC.EQ.2) THEN
2146 CALL PYINIT('CMS','p','p',PESUM)
2148 C...W production + multiple interactions at CERN Collider.
2149 ELSEIF(IPROC.EQ.3) THEN
2158 CALL PYINIT('CMS','p','pbar',PESUM)
2160 C...W/Z gauge boson pairs + pileup events at the Tevatron.
2161 ELSEIF(IPROC.EQ.4) THEN
2173 CALL PYINIT('CMS','p','pbar',PESUM)
2175 C...Higgs production at LHC.
2176 ELSEIF(IPROC.EQ.5) THEN
2188 CALL PYINIT('CMS','p','p',PESUM)
2190 C...Z' production at SSC.
2191 ELSEIF(IPROC.EQ.6) THEN
2200 CALL PYINIT('CMS','p','p',PESUM)
2202 C...W pair production at 1 TeV e+e- collider.
2203 ELSEIF(IPROC.EQ.7) THEN
2210 CALL PYINIT('CMS','e+','e-',PESUM)
2212 C...Deep inelastic scattering at a LEP+LHC ep collider.
2213 ELSEIF(IPROC.EQ.8) THEN
2226 CALL PYINIT('3MOM','p','e-',PESUM)
2229 C...Generate 20 events of each required type.
2233 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2235 C...Check conservation of energy/momentum/flavour.
2246 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2247 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2248 DEVQ=ABS(PFIN(6)-PINI(6))
2249 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2250 & DEVQ.GT.0.1D0) MERR=1
2251 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2252 & (PFIN(J),J=1,4),PFIN(6)
2254 C...Check that all KF codes are known ones, and that partons/particles
2255 C...satisfy energy-momentum-mass relation.
2257 IF(K(I,1).GT.20) GOTO 210
2258 IF(PYCOMP(K(I,2)).EQ.0) THEN
2259 WRITE(MSTU(11),5100) I
2262 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2264 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2265 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2266 WRITE(MSTU(11),5200) I
2271 C...Listing of erroneous events, and first event of each type.
2272 IF(MERR.GE.1) NERR=NERR+1
2274 WRITE(MSTU(11),6300)
2278 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2279 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2284 C...List statistics for each process type.
2285 IF(MTEST.GE.1) CALL PYSTAT(1)
2288 C...Summarize result of run.
2289 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2290 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2292 C...Format statements for output.
2293 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2294 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2295 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2296 &4(1X,F12.5),1X,F8.2)
2297 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2298 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2300 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2301 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2302 6400 FORMAT(5X,'Faulty event follows:')
2303 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2304 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2305 &5X,'This should not have happened!')
2310 C*********************************************************************
2313 C...Converts PYTHIA event record contents to or from
2314 C...the standard event record commonblock.
2316 SUBROUTINE PYHEPC(MCONV)
2318 C...Double precision and integer declarations.
2319 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2320 IMPLICIT INTEGER(I-N)
2321 INTEGER PYK,PYCHGE,PYCOMP
2323 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2324 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2325 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2326 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2327 C...HEPEVT commonblock.
2328 PARAMETER (NMXHEP=4000)
2329 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2330 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2331 DOUBLE PRECISION PHEP,VHEP
2334 C...Conversion from PYTHIA to standard, the easy part.
2337 IF(N.GT.NMXHEP) CALL PYERRM(8,
2338 & '(PYHEPC:) no more space in /HEPEVT/')
2342 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2343 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2344 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2345 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2349 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2363 C...Check if new event (from pileup).
2367 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2370 C...Fill in missing mother information.
2371 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2373 IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0)
2377 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2380 IF(I1.GE.I) CALL PYERRM(8,
2381 & '(PYHEPC:) translation of inconsistent event history')
2382 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
2384 IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
2385 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
2387 ELSEIF(K(I,2).EQ.94) THEN
2389 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2390 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2391 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2392 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2393 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2396 C...Fill in missing daughter information.
2397 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2398 DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
2399 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2403 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
2405 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
2406 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
2407 IF(JDAHEP(1,I1).EQ.0) THEN
2414 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
2415 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2418 C...Conversion from standard to PYTHIA, the easy part.
2420 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2421 & '(PYHEPC:) no more space in /PYJETS/')
2427 IF(ISTHEP(I).EQ.1) K(I,1)=1
2428 IF(ISTHEP(I).EQ.2) K(I,1)=11
2429 IF(ISTHEP(I).EQ.3) K(I,1)=21
2441 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2443 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2444 & PHEP(5,I)/PHEP(4,I)
2447 C...Fill in missing information on colour connection in jet systems.
2448 IF(ISTHEP(I).EQ.1) THEN
2451 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2452 IF(KQ.NE.0) NKQ=NKQ+1
2453 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2454 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2456 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2457 IF(K(I+1,2).EQ.21) K(I,1)=2
2461 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2462 & '(PYHEPC:) input parton configuration not colour singlet')
2467 C*********************************************************************
2470 C...Initializes the generation procedure; finds maxima of the
2471 C...differential cross-sections to be used for weighting.
2473 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2475 C...Double precision and integer declarations.
2476 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2477 IMPLICIT INTEGER(I-N)
2478 INTEGER PYK,PYCHGE,PYCOMP
2480 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2481 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2482 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2483 COMMON/PYDAT4/CHAF(500,2)
2485 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2486 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2487 COMMON/PYINT1/MINT(400),VINT(400)
2488 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2489 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2490 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2491 &/PYINT1/,/PYINT2/,/PYINT5/
2492 C...Local arrays and character variables.
2493 DIMENSION ALAMIN(20),NFIN(20)
2494 CHARACTER*(*) FRAME,BEAM,TARGET
2495 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2497 C...Interface to PDFLIB.
2498 COMMON/W50512/QCDL4,QCDL5
2500 DOUBLE PRECISION VALUE(20),QCDL4,QCDL5
2501 CHARACTER*20 PARM(20)
2502 DATA VALUE/20*0D0/,PARM/20*' '/
2504 C...Data:Lambda and n_f values for parton distributions..
2505 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2506 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2508 DATA CHLH/'lepton','hadron'/
2510 C...Reset MINT and VINT arrays. Write headers.
2516 IF(MSTU(12).GE.1) CALL PYLIST(0)
2517 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2519 C...Call user process initialization routine.
2520 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2526 C...Maximum 4 generations; set maximum number of allowed flavours.
2527 MSTP(1)=MIN(4,MSTP(1))
2528 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2529 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2531 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2535 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2538 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2539 IPM=(5-ISIGN(1,I))/2
2541 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2542 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2544 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2549 C...Initialize parton distributions: PDFLIB.
2550 IF(MSTP(52).EQ.2) THEN
2554 VALUE(2)=MSTP(51)/1000
2556 VALUE(3)=MOD(MSTP(51),1000)
2560 CALL PDFSET_ALICE(PARM,VALUE)
2561 MINT(93)=1000000+MSTP(51)
2564 C...Choose Lambda value to use in alpha-strong.
2566 IF(MSTP(3).GE.2) THEN
2569 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2570 ALAM=ALAMIN(MSTP(51))
2572 ELSEIF(MSTP(52).EQ.2) THEN
2581 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2584 C...Initialize the SUSY generation: couplings, masses,
2585 C...decay modes, branching ratios, and so on.
2587 C...Initialize widths and partial widths for resonances.
2589 C...Set Z0 mass and width for e+e- routines.
2590 PARJ(123)=PMAS(23,1)
2591 PARJ(124)=PMAS(23,2)
2593 C...Identify beam and target particles and frame of process.
2597 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2598 IF(MINT(65).EQ.1) GOTO 170
2600 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2601 C...For e-gamma allow 2 alternatives.
2603 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2604 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2605 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2606 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2607 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2608 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2609 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2610 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2611 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2612 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
2613 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2614 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2615 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
2616 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
2617 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2618 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2619 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
2620 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
2623 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
2624 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
2625 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
2626 IF(MSTP(14).EQ.11) MINT(123)=0
2627 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
2628 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
2629 IF(MSTP(14).EQ.15) MINT(123)=2
2630 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
2631 IF(MSTP(14).EQ.19) MINT(123)=3
2632 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
2633 IF(MSTP(14).EQ.21) MINT(123)=0
2634 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
2635 IF(MSTP(14).EQ.24) MINT(123)=1
2636 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
2637 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
2638 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
2641 C...Set up kinematics of process.
2644 C...Set up kinematics for photons inside leptons.
2645 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
2647 C...Precalculate flavour selection weights.
2650 C...Loop over gamma-p or gamma-gamma alternatives.
2653 DO 160 IGA=1,MINT(121)
2657 C...Select partonic subprocesses to be included in the simulation.
2664 C...Count number of subprocesses on.
2667 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2668 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
2670 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2671 & MSUB(ISUB).EQ.1) THEN
2672 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2674 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2675 WRITE(MSTU(11),5300) ISUB
2677 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2678 WRITE(MSTU(11),5400) ISUB
2680 ELSEIF(MSUB(ISUB).EQ.1) THEN
2685 C...Stop or raise warning flag if no subprocesses on.
2686 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
2687 IF(MSTP(127).NE.1) THEN
2688 WRITE(MSTU(11),5500)
2691 WRITE(MSTU(11),5700)
2695 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2696 MSAV48=MSAV48+MINT(48)
2698 C...Reset variables for cross-section calculation.
2706 C...Find parametrized total cross-sections.
2710 C...Maxima of differential cross-sections.
2711 IF(MSTP(121).LE.1) CALL PYMAXI
2713 C...Initialize possibility of pileup events.
2714 IF(MINT(121).GT.1) MSTP(131)=0
2715 IF(MSTP(131).NE.0) CALL PYPILE(1)
2717 C...Initialize multiple interactions with variable impact parameter.
2718 IF(MINT(50).EQ.1.AND.(MINT(49).NE.0.OR.MSTP(131).NE.0).AND.
2719 & MSTP(82).GE.2) CALL PYMULT(1)
2721 C...Save results for gamma-p and gamma-gamma alternatives.
2722 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2725 C...Initialization finished.
2726 IF(MSAV48.EQ.0) THEN
2727 IF(MSTP(127).NE.1) THEN
2728 WRITE(MSTU(11),5500)
2731 WRITE(MSTU(11),5700)
2735 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2737 C...Formats for initialization information.
2738 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
2739 &'routines',1X,17('*'))
2740 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
2741 &'-',A6,' interactions.'/1X,'Execution stopped!')
2742 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
2743 &1X,'Execution stopped!')
2744 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
2745 &1X,'Execution stopped!')
2746 5500 FORMAT(1X,'Error: no subprocess switched on.'/
2747 &1X,'Execution stopped.')
2748 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
2750 5700 FORMAT(1X,'Error: no subprocess switched on.'/
2751 &1X,'Execution will stop if you try to generate events.')
2756 C*********************************************************************
2759 C...Administers the generation of a high-pT event via calls to
2760 C...a number of subroutines.
2764 C...Double precision and integer declarations.
2765 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2766 IMPLICIT INTEGER(I-N)
2767 INTEGER PYK,PYCHGE,PYCOMP
2769 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2770 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2771 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2772 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2773 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2774 COMMON/PYINT1/MINT(400),VINT(400)
2775 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2776 COMMON/PYINT4/MWID(500),WIDS(500,5)
2777 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2778 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,
2779 &/PYINT2/,/PYINT4/,/PYINT5/
2783 C...Stop if no subprocesses on.
2784 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
2785 WRITE(MSTU(11),5100)
2789 C...Initial values for some counters.
2800 C...If variable energies: redo incoming kinematics and cross-section.
2802 IF(MSTP(171).EQ.1) THEN
2804 IF(MSTI(61).EQ.1) THEN
2808 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
2812 C...Loop over number of pileup events; check space left.
2813 IF(MSTP(131).LE.0) THEN
2819 DO 250 IPILE=1,NPILE
2820 IF(MINT(84)+100.GE.MSTU(4)) THEN
2822 & '(PYEVNT:) no more space in PYJETS for pileup events')
2823 IF(MSTU(21).GE.1) GOTO 260
2827 C...Generate variables of hard scattering.
2831 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
2836 IF(MSTI(61).EQ.1) THEN
2840 IF(MINT(51).EQ.2) RETURN
2842 IF(MSTP(111).EQ.-1) GOTO 240
2844 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
2845 C...Hard scattering (including low-pT):
2846 C...reconstruct kinematics and colour flow of hard scattering.
2851 IF(MINT(51).EQ.1) GOTO 100
2854 IF(ISUB.EQ.95) GOTO 120
2856 C...Showering of initial state partons (optional).
2860 IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2)
2862 IF(MINT(51).EQ.1) GOTO 100
2864 C...Showering of final state partons (optional).
2867 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
2871 IF(ISET(ISUB).EQ.5) IPU4=-3
2873 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
2874 CALL PYSHOW(IPU3,IPU4,QMAX)
2875 ELSEIF(ISET(ISUB).EQ.11) THEN
2880 C...Decay of final state resonances.
2882 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
2883 IF(MINT(51).EQ.1) GOTO 100
2886 C...Multiple interactions.
2887 IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6)
2890 C...Hadron remnants and primordial kT.
2891 120 CALL PYREMN(IPU1,IPU2)
2892 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO 110
2893 IF(MINT(51).EQ.1) GOTO 100
2895 ELSEIF(ISUB.NE.99) THEN
2896 C...Diffractive and elastic scattering.
2900 C...DIS scattering (photon flux external).
2902 IF(MINT(51).EQ.1) GOTO 100
2905 C...Check that no odd resonance left undecayed.
2906 IF(MSTP(111).GE.1) THEN
2908 DO 130 I=MINT(84)+1,NFIX
2909 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
2910 & K(I,2).NE.22) THEN
2912 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
2914 IF(MINT(51).EQ.1) GOTO 100
2920 C...Boost hadronic subsystem to overall rest frame.
2921 C..(Only relevant when photon inside lepton beam.)
2922 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
2924 C...Recalculate energies from momenta and masses (if desired).
2925 IF(MSTP(113).GE.1) THEN
2926 DO 140 I=MINT(83)+1,N
2927 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
2928 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
2933 C...Rearrange partons along strings, check invariant mass cuts.
2935 IF(MSTP(111).LE.0) MSTJ(14)=-1
2936 CALL PYPREP(MINT(84)+1)
2938 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
2939 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
2940 DO 170 I=MINT(84)+1,N
2941 IF(K(I,2).EQ.94) THEN
2942 DO 160 I1=I+1,MIN(N,I+3)
2943 IF(K(I1,3).EQ.I) THEN
2944 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
2945 IF(K(I1,3).EQ.0) THEN
2946 DO 150 II=MINT(84)+1,I-1
2947 IF(K(II,2).EQ.K(I1,2)) THEN
2948 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
2949 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
2952 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
2960 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
2961 IF(MSTP(125).EQ.0) MINT(4)=0
2962 DO 190 I=MINT(83)+1,N
2963 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
2965 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
2966 IF(K(I1,3).EQ.I) K(I,5)=I1
2972 C...Introduce separators between sections in PYLIST event listing.
2973 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
2976 ELSEIF(IPILE.EQ.1) THEN
2983 C...Go back to lab frame (needed for vertices, also in fragmentation).
2986 C...Set nonvanishing production vertex (optional).
2987 IF(MSTP(151).EQ.1) THEN
2989 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
2990 & SIN(PARU(2)*PYR(0))
2992 DO 220 I=MINT(83)+1,N
2994 V(I,J)=V(I,J)+VTX(J)
2999 C...Perform hadronization (if desired).
3000 IF(MSTP(111).GE.1) THEN
3002 IF(MSTU(24).NE.0) GOTO 100
3004 IF(MSTP(113).GE.1) THEN
3006 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3007 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3010 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3012 C...Store event information and calculate Monte Carlo estimates of
3013 C...subprocess cross-sections.
3014 240 IF(IPILE.EQ.1) CALL PYDOCU
3016 C...Set counters for current pileup event and loop to next one.
3018 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3019 IF(MSTU70.LT.10) THEN
3024 MINT(84)=N+MSTP(126)
3025 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3028 C...Generic information on pileup events. Reconstruct missing history.
3029 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3033 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3037 C...Transform to the desired coordinate frame.
3038 260 CALL PYFRAM(MSTP(124))
3043 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3044 &1X,'Execution stopped.')
3049 C***********************************************************************
3052 C...Prints out information about cross-sections, decay widths, branching
3053 C...ratios, kinematical limits, status codes and parameter values.
3055 SUBROUTINE PYSTAT(MSTAT)
3057 C...Double precision and integer declarations.
3058 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3059 IMPLICIT INTEGER(I-N)
3060 INTEGER PYK,PYCHGE,PYCOMP
3061 C...Parameter statement to help give large particle numbers.
3062 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3063 &KEXCIT=4000000,KDIMEN=5000000)
3064 PARAMETER (EPS=1D-3)
3066 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3067 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3068 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3069 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3070 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3071 COMMON/PYINT1/MINT(400),VINT(400)
3072 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3073 COMMON/PYINT4/MWID(500),WIDS(500,5)
3074 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3075 COMMON/PYINT6/PROC(0:500)
3076 CHARACTER PROC*28, CHTMP*16
3077 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3078 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
3079 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
3080 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
3081 C...Local arrays, character variables and data.
3082 DIMENSION WDTP(0:300),WDTE(0:300,0:5),NMODES(0:20),PBRAT(10)
3083 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
3084 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
3085 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
3086 CHARACTER*24 CHD0, CHDC(10)
3087 CHARACTER*6 DNAME(3)
3089 &'VMD/hadron * VMD ','VMD/hadron * direct ',
3090 &'VMD/hadron * anomalous ','direct * direct ',
3091 &'direct * anomalous ','anomalous * anomalous '/
3092 DATA DISGA/'e * VMD','e * anomalous'/
3094 &'direct * direct ','direct * VMD ',
3095 &'direct * anomalous ','VMD * direct ',
3096 &'VMD * VMD ','VMD * anomalous ',
3097 &'anomalous * direct ','anomalous * VMD ',
3098 &'anomalous * anomalous ','DIS * VMD ',
3099 &'DIS * anomalous ','VMD * DIS ',
3100 &'anomalous * DIS '/
3102 &'direct * direct ','direct * resolved ',
3103 &'resolved * direct ','resolved * resolved '/
3105 &'direct * hadron ','resolved * hadron '/
3107 &'VMD * hadron ','direct * hadron ',
3108 &'anomalous * hadron ','DIS * hadron '/
3109 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
3110 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
3111 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
3112 &' y*_small ',' eta*_large ',' eta*_small ',
3113 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
3114 &' x_2 ',' x_F ',' cos(theta_hard) ',
3115 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
3116 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
3118 DATA DNAME /'q ','lepton','nu '/
3122 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
3123 WRITE(MSTU(11),5000)
3124 WRITE(MSTU(11),5100)
3125 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
3127 IF(MSUB(I).NE.1) GOTO 100
3128 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
3130 IF(MINT(121).GT.1) THEN
3131 WRITE(MSTU(11),5300)
3132 DO 110 IGA=1,MINT(121)
3134 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3135 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
3137 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3138 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
3140 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
3141 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
3143 ELSEIF(MINT(121).EQ.4) THEN
3144 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
3146 ELSEIF(MINT(121).EQ.2) THEN
3147 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
3150 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
3156 WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
3157 & MAX(1D0,DBLE(NGEN(0,2)))
3159 C...Decay widths and branching ratios.
3160 ELSEIF(MSTAT.EQ.2) THEN
3161 WRITE(MSTU(11),5500)
3162 WRITE(MSTU(11),5600)
3165 CALL PYNAME(KF,CHKF)
3168 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
3169 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
3170 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
3171 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
3172 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
3174 IF(MWID(KC).LE.0) GOTO 140
3175 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
3176 & KF/KSUSY1.EQ.2)) GOTO 140
3178 C...Off-shell branchings.
3181 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
3182 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
3183 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
3184 DO 120 J=1,MDCY(KC,3)
3187 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3188 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3190 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3191 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3192 CALL PYNAME(KFDP(IDC,1),CHD1)
3193 CALL PYNAME(KFDP(IDC,2),CHD2)
3194 IF(KFDP(IDC,3).EQ.0) THEN
3195 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3196 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3197 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3199 CALL PYNAME(KFDP(IDC,3),CHD3)
3200 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3201 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3202 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3205 C...On-shell decays.
3207 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
3209 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
3210 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
3211 & STATE(MDCY(KC,1)),BRFIN
3212 DO 130 J=1,MDCY(KC,3)
3215 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3216 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3218 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3219 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3221 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
3222 CALL PYNAME(KFDP(IDC,1),CHD1)
3223 CALL PYNAME(KFDP(IDC,2),CHD2)
3224 IF(KFDP(IDC,3).EQ.0) THEN
3225 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3226 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3227 & CHD2(1:10),WDTP(J),WDTP(J)/WDTP(0),
3228 & STATE(MDME(IDC,1)),BRFIN
3230 CALL PYNAME(KFDP(IDC,3),CHD3)
3231 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3232 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3233 & CHD2(1:10),CHD3(1:10),WDTP(J),WDTP(J)/WDTP(0),
3234 & STATE(MDME(IDC,1)),BRFIN
3239 WRITE(MSTU(11),6000)
3241 C...Allowed incoming partons/particles at hard interaction.
3242 ELSEIF(MSTAT.EQ.3) THEN
3243 WRITE(MSTU(11),6100)
3244 CALL PYNAME(MINT(11),CHAU)
3246 CALL PYNAME(MINT(12),CHAU)
3248 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
3252 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
3253 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
3255 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
3258 WRITE(MSTU(11),6400)
3260 C...User-defined limits on kinematical variables.
3261 ELSEIF(MSTAT.EQ.4) THEN
3262 WRITE(MSTU(11),6500)
3263 WRITE(MSTU(11),6600)
3265 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
3266 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
3267 PTHMIN=MAX(CKIN(3),CKIN(5))
3269 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
3270 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
3271 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
3273 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
3276 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
3277 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
3278 WRITE(MSTU(11),7000)
3280 C...Status codes and parameter values.
3281 ELSEIF(MSTAT.EQ.5) THEN
3282 WRITE(MSTU(11),7100)
3283 WRITE(MSTU(11),7200)
3285 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
3289 C...List of all processes implemented in the program.
3290 ELSEIF(MSTAT.EQ.6) THEN
3291 WRITE(MSTU(11),7400)
3292 WRITE(MSTU(11),7500)
3294 IF(ISET(I).LT.0) GOTO 180
3295 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
3297 WRITE(MSTU(11),7700)
3299 ELSEIF(MSTAT.EQ.7) THEN
3300 WRITE (MSTU(11),8000)
3306 KFSUSY=ILR*KSUSY1+KFSM
3309 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
3315 CALL PYNAME(KFSUSY,CHTMP)
3317 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
3318 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
3320 DO 200 J=1,MDCY(KC,3)
3322 ID1=IABS(KFDP(IDC,1))
3323 ID2=IABS(KFDP(IDC,2))
3324 IF (KFDP(IDC,3).EQ.0) THEN
3325 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3326 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3327 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3328 NMODES(1)=NMODES(1)+1
3329 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3330 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3331 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3332 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
3333 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3334 NMODES(2)=NMODES(2)+1
3335 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3336 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3342 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
3348 CALL PYNAME(KFSUSY,CHTMP)
3350 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
3352 DO 220 J=1,MDCY(KC,3)
3354 ID1=IABS(KFDP(IDC,1))
3355 ID2=IABS(KFDP(IDC,2))
3356 IF (KFDP(IDC,3).EQ.0) THEN
3357 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
3358 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3359 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3360 NMODES(1)=NMODES(1)+1
3361 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3362 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3368 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
3374 CALL PYNAME(KFSUSY,CHTMP)
3376 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
3377 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3379 DO 240 J=1,MDCY(KC,3)
3381 ID1=IABS(KFDP(IDC,1))
3382 ID2=IABS(KFDP(IDC,2))
3383 IF (KFDP(IDC,3).EQ.0) THEN
3384 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3385 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
3386 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3387 NMODES(1)=NMODES(1)+1
3388 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3389 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3391 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
3392 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3393 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3394 NMODES(2)=NMODES(2)+1
3395 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3396 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3401 C...SNEUTRINO DECAYS
3402 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
3409 CALL PYNAME(KFSUSY,CHTMP)
3411 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
3412 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3414 DO 260 J=1,MDCY(KC,3)
3416 ID1=IABS(KFDP(IDC,1))
3417 ID2=IABS(KFDP(IDC,2))
3418 IF (KFDP(IDC,3).EQ.0) THEN
3419 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
3420 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
3421 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3422 NMODES(1)=NMODES(1)+1
3423 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3424 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3426 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
3427 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3428 NMODES(2)=NMODES(2)+1
3429 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3430 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3431 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3436 IF (NRVDC.NE.0) THEN
3438 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
3439 NMODES(0)=NMODES(0)+NMODES(I)
3447 C...NEUTRALINO DECAYS
3448 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
3454 CALL PYNAME(KFSUSY,CHTMP)
3456 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
3457 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3458 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3460 DO 310 J=1,MDCY(KC,3)
3462 ID1=IABS(KFDP(IDC,1))
3463 ID2=IABS(KFDP(IDC,2))
3464 ID3=IABS(KFDP(IDC,3))
3465 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3466 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
3467 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
3468 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3469 NMODES(1)=NMODES(1)+1
3470 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3471 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3472 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3473 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
3474 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3475 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3476 NMODES(2)=NMODES(2)+1
3477 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3478 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3479 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3480 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
3481 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3482 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3483 NMODES(3)=NMODES(3)+1
3484 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3485 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3490 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
3496 CALL PYNAME(KFSUSY,CHTMP)
3498 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
3499 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
3500 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3501 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3503 DO 330 J=1,MDCY(KC,3)
3505 ID1=IABS(KFDP(IDC,1))
3506 ID2=IABS(KFDP(IDC,2))
3507 ID3=IABS(KFDP(IDC,3))
3508 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3509 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
3510 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
3511 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3512 NMODES(1)=NMODES(1)+1
3513 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3514 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3515 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3516 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
3517 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
3518 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3519 NMODES(1)=NMODES(1)+1
3520 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3521 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3522 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3523 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
3524 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
3525 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3526 NMODES(2)=NMODES(2)+1
3527 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3528 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3529 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3530 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3531 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
3532 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3533 NMODES(3)=NMODES(3)+1
3534 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3535 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3536 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3537 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3538 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3539 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3540 NMODES(3)=NMODES(3)+1
3541 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3542 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3543 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3544 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3545 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
3546 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3547 NMODES(4)=NMODES(4)+1
3548 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3549 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3550 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3551 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3552 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3553 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3554 NMODES(4)=NMODES(4)+1
3555 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3556 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3560 IF (NRVDC.NE.0) THEN
3562 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
3563 NMODES(0)=NMODES(0)+NMODES(I)
3567 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
3569 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1) THEN
3570 WRITE (MSTU(11),8500)
3574 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
3575 & ,RVLAMP(IRV,JRV,KRV), 0D0
3579 WRITE (MSTU(11),8600)
3585 C...Formats for printouts.
3586 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
3587 &'Events and Cross-sections',1X,9('*'))
3588 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
3589 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
3590 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
3591 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
3592 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
3593 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
3595 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
3597 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
3598 &1X,'I',34X,'I',28X,'I',12X,'I')
3599 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
3600 &1X,'********* Fraction of events that fail fragmentation ',
3601 &'cuts =',1X,F8.5,' *********'/)
3602 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
3603 &'Ratios',1X,27('*'))
3604 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3605 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
3606 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
3607 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3609 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
3610 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
3611 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
3612 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
3613 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3614 &1P,D10.3,0P,1X,'I')
3615 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
3616 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3617 &1P,D10.3,0P,1X,'I')
3618 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
3619 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
3620 &'Particles at Hard Interaction',1X,7('*'))
3621 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
3622 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
3623 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
3624 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
3625 &78('=')/1X,'I',38X,'I',37X,'I')
3626 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
3627 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
3628 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
3629 &'Kinematical Variables',1X,12('*'))
3630 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
3631 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
3633 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
3634 &1X,'<',1X,1P,D10.3,0P,16X,'I')
3635 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
3636 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
3637 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
3638 &'Parameter Values',1X,12('*'))
3639 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
3641 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
3642 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
3644 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
3645 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
3646 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
3647 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
3648 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
3650 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
3651 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
3652 & ,'Mother --> Sum over final state flavours',4X,'I',2X
3653 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
3654 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
3655 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
3656 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
3657 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
3658 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
3660 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
3661 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
3662 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
3664 & 1X,'R-Violating couplings',1X/ 1X /
3666 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
3667 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
3668 & ,'I',15X,'I',15X,'I',15X,'I')
3669 8600 FORMAT(1X,55('='))
3670 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
3671 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
3676 C*********************************************************************
3679 C...Calculates full and effective widths of gauge bosons, stores
3680 C...masses and widths, rescales coefficients to be used for
3681 C...resonance production generation.
3685 C...Double precision and integer declarations.
3686 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3687 IMPLICIT INTEGER(I-N)
3688 INTEGER PYK,PYCHGE,PYCOMP
3689 C...Parameter statement to help give large particle numbers.
3690 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3691 &KEXCIT=4000000,KDIMEN=5000000)
3693 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3694 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3695 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3696 COMMON/PYDAT4/CHAF(500,2)
3698 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3699 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3700 COMMON/PYINT1/MINT(400),VINT(400)
3701 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3702 COMMON/PYINT4/MWID(500),WIDS(500,5)
3703 COMMON/PYINT6/PROC(0:500)
3705 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3706 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
3707 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
3708 C...Local arrays and data.
3709 DIMENSION WDTP(0:300),WDTE(0:300,0:5),WDTPM(0:300),
3710 &WDTEM(0:300,0:5),KCORD(500),PMORD(500)
3712 C...Born level couplings in MSSM Higgs doublet sector.
3715 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
3717 IF(MSTP(4).EQ.2) THEN
3719 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
3723 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
3724 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
3726 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
3727 WRITE(MSTU(11),5000)
3730 PMAS(35,1)=SQRT(SQMHP)
3731 PMAS(36,1)=SQRT(SQMA)
3732 PMAS(37,1)=SQRT(SQMHC)
3733 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
3738 PARU(161)=-SIN(ALSU)/COS(BESU)
3739 PARU(162)=COS(ALSU)/SIN(BESU)
3741 PARU(164)=SIN(BESU-ALSU)
3743 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
3744 PARU(171)=COS(ALSU)/COS(BESU)
3745 PARU(172)=SIN(ALSU)/SIN(BESU)
3747 PARU(174)=COS(BESU-ALSU)
3749 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
3751 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
3752 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
3758 PARU(186)=COS(BESU-ALSU)
3759 PARU(187)=SIN(BESU-ALSU)
3763 PARU(195)=COS(BESU-ALSU)
3766 C...Reset effective widths of gauge bosons.
3773 C...Order resonances by increasing mass (except Z0 and W+/-).
3777 IF(KF.EQ.0) GOTO 140
3778 IF(MWID(KC).EQ.0) GOTO 140
3779 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
3780 IF(MSTP(1).LE.3) GOTO 140
3782 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
3783 IF(IMSS(1).LE.0) GOTO 140
3787 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
3788 DO 120 I1=NRES-1,1,-1
3789 IF(PMRES.GE.PMORD(I1)) GOTO 130
3790 KCORD(I1+1)=KCORD(I1)
3791 PMORD(I1+1)=PMORD(I1)
3797 C...Loop over possible resonances.
3802 C...Check that no fourth generation channels on by mistake.
3803 IF(MSTP(1).LE.3) THEN
3804 DO 150 J=1,MDCY(KC,3)
3806 KFA1=IABS(KFDP(IDC,1))
3807 KFA2=IABS(KFDP(IDC,2))
3808 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
3809 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
3814 C...Check that no supersymmetric channels on by mistake.
3815 IF(IMSS(1).LE.0) THEN
3816 DO 160 J=1,MDCY(KC,3)
3818 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
3819 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
3820 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
3825 C...Find mass and evaluate width.
3827 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
3828 IF(MWID(KC).EQ.3) MINT(63)=1
3829 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
3832 C...Evaluate suppression factors due to non-simulated channels.
3833 IF(KCHG(KC,3).EQ.0) THEN
3834 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
3835 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3836 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3837 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3842 IF(MWID(KC).EQ.3) MINT(63)=1
3843 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
3845 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
3846 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
3847 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
3848 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
3849 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3850 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
3851 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
3852 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3853 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3854 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
3855 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
3856 & 2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
3859 C...Set resonance widths and branching ratios;
3860 C...also on/off switch for decays.
3861 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
3863 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
3864 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
3865 DO 170 J=1,MDCY(KC,3)
3868 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
3873 C...Flavours of leptoquark: redefine charge and name.
3874 KFLQQ=KFDP(MDCY(42,2),1)
3875 KFLQL=KFDP(MDCY(42,2),2)
3876 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
3877 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
3879 IF(IABS(KFLQL).EQ.13) LL=2
3880 IF(IABS(KFLQL).EQ.15) LL=3
3881 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
3882 &CHAF(IABS(KFLQL),1)(1:LL)//' '
3883 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
3885 C...Special cases in treatment of gamma*/Z0: redefine process name.
3886 IF(MSTP(43).EQ.1) THEN
3887 PROC(1)='f + fbar -> gamma*'
3888 PROC(15)='f + fbar -> g + gamma*'
3889 PROC(19)='f + fbar -> gamma + gamma*'
3890 PROC(30)='f + g -> f + gamma*'
3891 PROC(35)='f + gamma -> f + gamma*'
3892 ELSEIF(MSTP(43).EQ.2) THEN
3893 PROC(1)='f + fbar -> Z0'
3894 PROC(15)='f + fbar -> g + Z0'
3895 PROC(19)='f + fbar -> gamma + Z0'
3896 PROC(30)='f + g -> f + Z0'
3897 PROC(35)='f + gamma -> f + Z0'
3898 ELSEIF(MSTP(43).EQ.3) THEN
3899 PROC(1)='f + fbar -> gamma*/Z0'
3900 PROC(15)='f + fbar -> g + gamma*/Z0'
3901 PROC(19)='f + fbar -> gamma + gamma*/Z0'
3902 PROC(30)='f + g -> f + gamma*/Z0'
3903 PROC(35)='f + gamma -> f + gamma*/Z0'
3906 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
3907 IF(MSTP(44).EQ.1) THEN
3908 PROC(141)='f + fbar -> gamma*'
3909 ELSEIF(MSTP(44).EQ.2) THEN
3910 PROC(141)='f + fbar -> Z0'
3911 ELSEIF(MSTP(44).EQ.3) THEN
3912 PROC(141)='f + fbar -> Z''0'
3913 ELSEIF(MSTP(44).EQ.4) THEN
3914 PROC(141)='f + fbar -> gamma*/Z0'
3915 ELSEIF(MSTP(44).EQ.5) THEN
3916 PROC(141)='f + fbar -> gamma*/Z''0'
3917 ELSEIF(MSTP(44).EQ.6) THEN
3918 PROC(141)='f + fbar -> Z0/Z''0'
3919 ELSEIF(MSTP(44).EQ.7) THEN
3920 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
3923 C...Special cases in treatment of WW -> WW: redefine process name.
3924 IF(MSTP(45).EQ.1) THEN
3925 PROC(77)='W+ + W+ -> W+ + W+'
3926 ELSEIF(MSTP(45).EQ.2) THEN
3927 PROC(77)='W+ + W- -> W+ + W-'
3928 ELSEIF(MSTP(45).EQ.3) THEN
3929 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
3932 C...Format for error information.
3933 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
3934 &'combination'/1X,'Execution stopped!')
3939 C*********************************************************************
3942 C...Identifies the two incoming particles and the choice of frame.
3944 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
3946 C...Double precision and integer declarations.
3947 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3948 IMPLICIT INTEGER(I-N)
3949 INTEGER PYK,PYCHGE,PYCOMP
3951 C...User process initialization commonblock.
3953 PARAMETER (MAXPUP=100)
3954 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
3955 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
3956 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
3957 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
3962 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3963 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3964 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3965 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3966 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3967 COMMON/PYINT1/MINT(400),VINT(400)
3968 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3970 C...Local arrays, character variables and data.
3971 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
3972 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
3973 DIMENSION LEN(3),KCDE(39),PM(2)
3974 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
3975 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
3976 DATA CHCDE/ 'e- ','e+ ','nu_e ',
3977 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
3978 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
3979 &'nu_taubar ','pi+ ','pi- ','n0 ',
3980 &'nbar0 ','p+ ','pbar- ','gamma ',
3981 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
3982 &'xi- ','xi0 ','omega- ','pi0 ',
3983 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
3984 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
3985 &'k+ ','k- ','ks0 ','kl0 '/
3986 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
3987 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
3988 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
3990 C...Store initial energy. Default frame.
3994 C...Special user process initialization; convert to normal input.
3995 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
3997 CALL PYNAME(IDBMUP(1),CHNAME)
3999 CALL PYNAME(IDBMUP(2),CHNAME)
4003 C...Convert character variables to lowercase and find their length.
4010 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
4012 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
4018 C...Fix up bar, underscore and charge in particle name (if needed).
4020 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
4022 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
4025 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
4027 CHIDNT(I)='nu_'//CHTEMP(3:7)
4028 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
4029 CHIDNT(I)(1:3)='n0 '
4030 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
4031 CHIDNT(I)(1:5)='nbar0'
4032 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
4033 CHIDNT(I)(1:3)='p+ '
4034 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
4035 & CHIDNT(I)(1:2).EQ.'p-') THEN
4036 CHIDNT(I)(1:5)='pbar-'
4037 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
4039 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
4040 CHIDNT(I)(1:7)='reggeon'
4041 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
4042 CHIDNT(I)(1:7)='pomeron'
4046 C...Identify free initialization.
4047 IF(CHCOM(1)(1:2).EQ.'no') THEN
4052 C...Identify incoming beam and target particles.
4055 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
4057 PM(I)=PYMASS(MINT(10+I))
4060 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
4061 CHTEMP=CHIDNT(I+1)(7:12)//' '
4063 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
4065 PM(I)=PYMASS(MINT(140+I))
4069 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
4070 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
4071 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
4073 C...Identify choice of frame and input energies.
4076 C...Events defined in the CM frame.
4077 IF(CHCOM(1)(1:2).EQ.'cm') THEN
4080 IF(MSTP(122).GE.1) THEN
4081 IF(CHCOM(2)(1:1).NE.'e') THEN
4082 LOFFS=(31-(LEN(2)+LEN(3)))/2
4083 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
4084 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4087 LOFFS=(30-(LEN(2)+LEN(3)))/2
4088 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
4089 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4092 WRITE(MSTU(11),5200) CHINIT
4093 WRITE(MSTU(11),5300) WIN
4096 C...Events defined in fixed target frame.
4097 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
4099 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
4100 IF(MSTP(122).GE.1) THEN
4101 LOFFS=(29-(LEN(2)+LEN(3)))/2
4102 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4103 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4104 & ' fixed target'//' '
4105 WRITE(MSTU(11),5200) CHINIT
4106 WRITE(MSTU(11),5400) WIN
4107 WRITE(MSTU(11),5500) SQRT(S)
4110 C...Frame defined by user three-vectors.
4111 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
4115 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4116 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4117 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4118 & (P(1,3)+P(2,3))**2
4119 IF(MSTP(122).GE.1) THEN
4120 LOFFS=(22-(LEN(2)+LEN(3)))/2
4121 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4122 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4123 & ' user configuration'//' '
4124 WRITE(MSTU(11),5200) CHINIT
4125 WRITE(MSTU(11),5600)
4126 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4127 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4128 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4131 C...Frame defined by user four-vectors.
4132 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
4134 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4135 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4136 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4137 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4138 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4139 & (P(1,3)+P(2,3))**2
4140 IF(MSTP(122).GE.1) THEN
4141 LOFFS=(22-(LEN(2)+LEN(3)))/2
4142 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4143 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4144 & ' user configuration'//' '
4145 WRITE(MSTU(11),5200) CHINIT
4146 WRITE(MSTU(11),5600)
4147 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4148 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4149 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4152 C...Frame defined by user five-vectors.
4153 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
4155 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4156 & (P(1,3)+P(2,3))**2
4157 IF(MSTP(122).GE.1) THEN
4158 LOFFS=(22-(LEN(2)+LEN(3)))/2
4159 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4160 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4161 & ' user configuration'//' '
4162 WRITE(MSTU(11),5200) CHINIT
4163 WRITE(MSTU(11),5600)
4164 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4165 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4166 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4169 C...Frame defined by HEPRUP common block.
4170 ELSEIF(MINT(111).EQ.11) THEN
4171 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
4172 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
4173 IF(MSTP(122).GE.1) THEN
4174 LOFFS=(22-(LEN(2)+LEN(3)))/2
4175 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4176 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4177 & ' user configuration'//' '
4178 WRITE(MSTU(11),5200) CHINIT
4179 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
4180 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4183 C...Unknown frame. Error for too low CM energy.
4185 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
4188 IF(S.LT.PARP(2)**2) THEN
4189 WRITE(MSTU(11),5900) SQRT(S)
4193 C...Formats for initialization and error information.
4194 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
4195 &1X,'Execution stopped!')
4196 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
4197 &1X,'Execution stopped!')
4198 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
4199 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
4200 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
4201 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
4202 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
4203 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
4204 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
4205 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
4206 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
4207 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
4208 &1X,'Execution stopped!')
4209 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
4210 &'generation.'/1X,'Execution stopped!')
4211 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
4212 &'GeV beam energies',13X,'I')
4217 C*********************************************************************
4220 C...Sets up kinematics, including rotations and boosts to/from CM frame.
4222 SUBROUTINE PYINKI(MODKI)
4224 C...Double precision and integer declarations.
4225 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4226 IMPLICIT INTEGER(I-N)
4227 INTEGER PYK,PYCHGE,PYCOMP
4229 C...User process initialization commonblock.
4231 PARAMETER (MAXPUP=100)
4232 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4233 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4234 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4235 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4240 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4241 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4242 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4243 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4244 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4245 COMMON/PYINT1/MINT(400),VINT(400)
4246 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
4248 C...Set initial flavour state.
4253 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
4256 C...Reset boost. Do kinematics for various cases.
4261 C...Set up kinematics for events defined in CM frame.
4262 IF(MINT(111).EQ.1) THEN
4264 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4268 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4269 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4274 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
4277 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4278 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
4280 C...Set up kinematics for fixed target events.
4281 ELSEIF(MINT(111).EQ.2) THEN
4283 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4286 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4287 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4293 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4296 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
4297 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
4298 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4300 C...Set up kinematics for events in user-defined frame.
4301 ELSEIF(MINT(111).EQ.3) THEN
4304 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4305 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4306 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4307 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4309 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4311 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4312 VINT(7)=PYANGL(P(1,1),P(1,2))
4313 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4314 VINT(6)=PYANGL(P(1,3),P(1,1))
4315 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4316 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
4318 C...Set up kinematics for events with user-defined four-vectors.
4319 ELSEIF(MINT(111).EQ.4) THEN
4320 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4321 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4322 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4323 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4325 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4327 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4328 VINT(7)=PYANGL(P(1,1),P(1,2))
4329 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4330 VINT(6)=PYANGL(P(1,3),P(1,1))
4331 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4332 S=(P(1,4)+P(2,4))**2
4334 C...Set up kinematics for events with user-defined five-vectors.
4335 ELSEIF(MINT(111).EQ.5) THEN
4337 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4339 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4340 VINT(7)=PYANGL(P(1,1),P(1,2))
4341 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4342 VINT(6)=PYANGL(P(1,3),P(1,1))
4343 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4344 S=(P(1,4)+P(2,4))**2
4346 C...Set up kinematics for events with external user processes.
4347 ELSEIF(MINT(111).EQ.11) THEN
4350 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4351 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4356 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
4357 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
4360 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
4361 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4362 S=(P(1,4)+P(2,4))**2
4365 C...Return or error for too low CM energy.
4366 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
4367 IF(MSTP(172).LE.1) THEN
4369 & '(PYINKI:) too low invariant mass in this event')
4376 C...Save information on incoming particles.
4379 IF(MINT(111).GE.4) THEN
4380 IF(MINT(141).EQ.0) THEN
4382 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
4386 IF(MINT(142).EQ.0) THEN
4388 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
4394 IF(MODKI.EQ.0) VINT(289)=S
4402 C...Store pT cut-off and related constants to be used in generation.
4403 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
4404 IF(MSTP(82).LE.1) THEN
4405 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4407 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4409 VINT(149)=4D0*PTMN**2/S
4415 C*********************************************************************
4418 C...Selects partonic subprocesses to be included in the simulation.
4422 C...Double precision and integer declarations.
4423 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4424 IMPLICIT INTEGER(I-N)
4425 INTEGER PYK,PYCHGE,PYCOMP
4427 C...User process initialization commonblock.
4429 PARAMETER (MAXPUP=100)
4430 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4431 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4432 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4433 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4437 C...Commonblocks and character variables.
4438 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4439 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4440 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4441 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4442 COMMON/PYINT1/MINT(400),VINT(400)
4443 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4444 COMMON/PYINT6/PROC(0:500)
4446 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
4450 C...Reset processes to be included.
4457 C...Set running pTmin scale.
4458 IF(MSTP(82).LE.1) THEN
4459 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4461 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4464 C...Begin by assuming incoming photon to enter subprocess.
4465 IF(MINT(11).EQ.22) MINT(15)=22
4466 IF(MINT(12).EQ.22) MINT(16)=22
4468 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
4469 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4471 MINT(123)=MINT(122)+1
4473 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
4475 C...Here also set a few parameters otherwise normally not touched.
4476 ELSEIF(MINT(121).GT.1) THEN
4478 C...Parton distributions dampened at small Q2; go to low energies,
4479 C...alpha_s <1; no minimum pT cut-off a priori.
4480 IF(MSTP(18).EQ.2) THEN
4488 C...Define pT cut-off parameters and whether run involves low-pT.
4492 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
4494 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
4495 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
4497 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
4498 IF(MSEL.EQ.2) IPTL=1
4500 C...Set up for p/gamma * gamma; real or virtual photons.
4501 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
4502 & MSTP(14).EQ.30)) THEN
4504 C...Set up for p/VMD * VMD.
4505 IF(MINT(122).EQ.1) THEN
4513 IF(IPTL.EQ.1) MSUB(95)=1
4520 IF(IPTL.EQ.1) CKIN(3)=0D0
4522 C...Set up for p/VMD * direct gamma.
4523 ELSEIF(MINT(122).EQ.2) THEN
4525 IF(MINT(121).EQ.6) MINT(123)=5
4530 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4532 C...Set up for p/VMD * anomalous gamma.
4533 ELSEIF(MINT(122).EQ.3) THEN
4535 IF(MINT(121).EQ.6) MINT(123)=7
4542 IF(IPTL.EQ.1) MSUB(95)=1
4549 IF(IPTL.EQ.1) CKIN(3)=0D0
4551 C...Set up for DIS * p.
4552 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
4553 & IABS(MINT(12)).GT.100)) THEN
4555 IF(IPTL.EQ.1) MSUB(99)=1
4557 C...Set up for direct * direct gamma (switch off leptons).
4558 ELSEIF(MINT(122).EQ.4) THEN
4564 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4565 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4567 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4569 C...Set up for direct * anomalous gamma.
4570 ELSEIF(MINT(122).EQ.5) THEN
4576 IF(IPTL.EQ.1) CKIN(3)=PTMANO
4578 C...Set up for anomalous * anomalous gamma.
4579 ELSEIF(MINT(122).EQ.6) THEN
4587 IF(IPTL.EQ.1) MSUB(95)=1
4594 IF(IPTL.EQ.1) CKIN(3)=0D0
4597 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
4598 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4600 C...Set up for direct * direct gamma (switch off leptons).
4601 IF(MINT(122).EQ.1) THEN
4607 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4608 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4610 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4612 C...Set up for direct * VMD and VMD * direct gamma.
4613 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
4619 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4621 C...Set up for direct * anomalous and anomalous * direct gamma.
4622 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
4628 IF(IPTL.EQ.1) CKIN(3)=PTMANO
4630 C...Set up for VMD*VMD.
4631 ELSEIF(MINT(122).EQ.5) THEN
4639 IF(IPTL.EQ.1) MSUB(95)=1
4646 IF(IPTL.EQ.1) CKIN(3)=0D0
4648 C...Set up for VMD * anomalous and anomalous * VMD gamma.
4649 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
4657 IF(IPTL.EQ.1) MSUB(95)=1
4664 IF(IPTL.EQ.1) CKIN(3)=0D0
4666 C...Set up for anomalous * anomalous gamma.
4667 ELSEIF(MINT(122).EQ.9) THEN
4675 IF(IPTL.EQ.1) MSUB(95)=1
4682 IF(IPTL.EQ.1) CKIN(3)=0D0
4684 C...Set up for DIS * VMD and VMD * DIS gamma.
4685 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
4687 IF(IPTL.EQ.1) MSUB(99)=1
4689 C...Set up for DIS * anomalous and anomalous * DIS gamma.
4690 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
4692 IF(IPTL.EQ.1) MSUB(99)=1
4695 C...Set up for gamma* * p; virtual photons = dir, res.
4696 ELSEIF(MINT(121).EQ.2) THEN
4698 C...Set up for direct * p.
4699 IF(MINT(122).EQ.1) THEN
4705 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4707 C...Set up for resolved * p.
4708 ELSEIF(MINT(122).EQ.2) THEN
4716 IF(IPTL.EQ.1) MSUB(95)=1
4723 IF(IPTL.EQ.1) CKIN(3)=0D0
4726 C...Set up for gamma* * gamma*; virtual photons = dir, res.
4727 ELSEIF(MINT(121).EQ.4) THEN
4729 C...Set up for direct * direct gamma (switch off leptons).
4730 IF(MINT(122).EQ.1) THEN
4736 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4737 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4739 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4741 C...Set up for direct * resolved and resolved * direct gamma.
4742 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
4748 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4750 C...Set up for resolved * resolved gamma.
4751 ELSEIF(MINT(122).EQ.4) THEN
4759 IF(IPTL.EQ.1) MSUB(95)=1
4766 IF(IPTL.EQ.1) CKIN(3)=0D0
4769 C...End of special set up for gamma-p and gamma-gamma.
4774 C...Flavour information for individual beams.
4777 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
4778 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
4779 MINT(44+I)=MINT(40+I)
4780 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
4781 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
4784 C...If two real gammas, whereof one direct, pick the first.
4785 C...For two virtual photons, keep requested order.
4786 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4787 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
4790 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
4791 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
4794 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
4795 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
4798 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
4799 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
4802 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
4803 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
4806 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
4809 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
4813 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
4814 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
4815 IF(MINT(11).EQ.22) THEN
4823 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
4824 & '(PYINPR:) unallowed MSTP(14) code for single photon')
4827 C...Flavour information on combination of incoming particles.
4828 MINT(43)=2*MINT(41)+MINT(42)-2
4830 IF(MINT(123).LE.0) THEN
4831 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
4832 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
4833 ELSEIF(MINT(123).LE.3) THEN
4834 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
4835 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
4836 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4840 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
4841 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
4842 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
4843 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
4845 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
4848 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4849 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
4851 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
4853 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
4854 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
4855 & MINT(122).EQ.10) MINT(108)=2
4856 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
4857 & MINT(122).EQ.11) MINT(108)=3
4858 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
4859 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
4860 IF(MINT(122).GE.3) MINT(107)=1
4861 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
4862 ELSEIF(MINT(121).EQ.2) THEN
4863 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
4864 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
4866 IF(MINT(11).EQ.22) THEN
4868 IF(MINT(123).GE.4) MINT(107)=0
4869 IF(MINT(123).EQ.7) MINT(107)=2
4870 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
4871 IF(MSTP(14).EQ.28) MINT(107)=2
4872 IF(MSTP(14).EQ.29) MINT(107)=3
4873 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
4876 IF(MINT(12).EQ.22) THEN
4878 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
4879 IF(MINT(123).EQ.7) MINT(108)=3
4880 IF(MSTP(14).EQ.26) MINT(108)=2
4881 IF(MSTP(14).EQ.27) MINT(108)=3
4882 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
4883 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
4886 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
4887 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
4893 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
4894 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
4896 C...Select default processes according to incoming beams
4897 C...(already done for gamma-p and gamma-gamma with
4898 C...MSTP(14) = 10, 20, 25 or 30).
4899 IF(MINT(121).GT.1) THEN
4900 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
4902 IF(MINT(43).EQ.1) THEN
4903 C...Lepton + lepton -> gamma/Z0 or W.
4904 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
4905 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
4907 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
4908 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
4909 C...Unresolved photon + lepton: Compton scattering.
4913 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
4914 & .OR.MINT(12).EQ.22)) THEN
4915 C...DIS as pure gamma* + f -> f process.
4918 ELSEIF(MINT(43).LE.3) THEN
4919 C...Lepton + hadron: deep inelastic scattering.
4922 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
4923 & MINT(12).EQ.22) THEN
4924 C...Two unresolved photons: fermion pair production,
4925 C...exclude lepton pairs.
4929 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4930 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4933 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
4934 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
4935 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
4937 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
4938 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
4939 & MINT(12).EQ.22)) THEN
4940 C...Unresolved photon + hadron: photon-parton scattering.
4945 ELSEIF(MSEL.EQ.1) THEN
4946 C...High-pT QCD processes:
4955 IF(CKIN(3).LT.PTMN) MSUB(95)=1
4956 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
4959 C...All QCD processes:
4973 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
4974 C...Heavy quark production.
4978 DO 180 J=1,MIN(8,MDCY(21,3))
4979 MDME(MDCY(21,2)+J-1,1)=0
4981 MDME(MDCY(21,2)+MSEL-1,1)=1
4983 DO 190 J=1,MIN(12,MDCY(22,3))
4984 MDME(MDCY(22,2)+J-1,1)=0
4986 MDME(MDCY(22,2)+MSEL-1,1)=1
4988 ELSEIF(MSEL.EQ.10) THEN
4989 C...Prompt photon production:
4994 ELSEIF(MSEL.EQ.11) THEN
4995 C...Z0/gamma* production:
4998 ELSEIF(MSEL.EQ.12) THEN
4999 C...W+/- production:
5002 ELSEIF(MSEL.EQ.13) THEN
5007 ELSEIF(MSEL.EQ.14) THEN
5012 ELSEIF(MSEL.EQ.15) THEN
5013 C...Z0 & W+/- pair production:
5020 ELSEIF(MSEL.EQ.16) THEN
5028 ELSEIF(MSEL.EQ.17) THEN
5029 C...h0 & Z0 or W+/- pair production:
5033 ELSEIF(MSEL.EQ.18) THEN
5034 C...h0 production; interesting processes in e+e-.
5040 ELSEIF(MSEL.EQ.19) THEN
5041 C...h0, H0 and A0 production; interesting processes in e+e-.
5055 ELSEIF(MSEL.EQ.21) THEN
5059 ELSEIF(MSEL.EQ.22) THEN
5060 C...W'+/- production:
5063 ELSEIF(MSEL.EQ.23) THEN
5064 C...H+/- production:
5067 ELSEIF(MSEL.EQ.24) THEN
5071 ELSEIF(MSEL.EQ.25) THEN
5072 C...LQ (leptoquark) production.
5078 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
5079 C...Production of one heavy quark (W exchange):
5081 DO 200 J=1,MIN(8,MDCY(21,3))
5082 MDME(MDCY(21,2)+J-1,1)=0
5084 MDME(MDCY(21,2)+MSEL-31,1)=1
5086 CMRENNA++Define SUSY alternatives.
5087 ELSEIF(MSEL.EQ.39) THEN
5088 C...Turn on all SUSY processes.
5089 IF(MINT(43).EQ.4) THEN
5090 C...Hadron-hadron processes.
5092 IF(ISET(I).GE.0) MSUB(I)=1
5094 ELSEIF(MINT(43).EQ.1) THEN
5095 C...Lepton-lepton processes: QED production of squarks.
5112 ELSEIF(MSEL.EQ.40) THEN
5113 C...Gluinos and squarks.
5114 IF(MINT(43).EQ.4) THEN
5126 ELSEIF(MINT(43).EQ.1) THEN
5131 ELSEIF(MSEL.EQ.41) THEN
5132 C...Stop production.
5136 IF(MINT(43).EQ.4) THEN
5141 ELSEIF(MSEL.EQ.42) THEN
5142 C...Slepton production.
5146 IF(MINT(43).NE.4) THEN
5152 ELSEIF(MSEL.EQ.43) THEN
5153 C...Neutralino/Chargino + Gluino/Squark.
5154 IF(MINT(43).EQ.4) THEN
5163 ELSEIF(MSEL.EQ.44) THEN
5164 C...Neutralino/Chargino pair production.
5165 IF(MINT(43).EQ.4) THEN
5169 ELSEIF(MINT(43).EQ.1) THEN
5175 ELSEIF(MSEL.EQ.45) THEN
5176 C...Sbottom production.
5179 IF(MINT(43).EQ.4) THEN
5185 ELSEIF(MSEL.EQ.50) THEN
5189 IF(MINT(43).EQ.4) THEN
5197 C...Find heaviest new quark flavour allowed in processes 81-84.
5199 DO 340 I=1,MIN(8,MDCY(21,3))
5201 IF(MDME(IDC,1).LE.0) GOTO 340
5204 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
5215 C...Find heaviest new fermion flavour allowed in process 85.
5217 DO 350 I=1,MIN(12,MDCY(22,3))
5219 IF(MDME(IDC,1).LE.0) GOTO 350
5222 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
5223 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
5228 C...Import relevant information on external user processes.
5229 IF(MINT(111).EQ.11) THEN
5232 C...Find next empty PYTHIA process number slot and enable it.
5234 IF(IPYPR.GT.500) CALL PYERRM(26,
5235 & '(PYINPR.) no more empty slots for user processes')
5236 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 360
5238 C...Overwrite KFPR with references back to process number and ID.
5240 KFPR(IPYPR,2)=LPRUP(IUP)
5242 WRITE(CHIPR,'(I10)') LPRUP(IUP)
5245 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
5247 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
5248 C...Switch on process.
5256 C*********************************************************************
5259 C...Parametrizes total, elastic and diffractive cross-sections
5260 C...for different energies and beams. Donnachie-Landshoff for
5261 C...total and Schuler-Sjostrand for elastic and diffractive.
5262 C...Process code IPROC:
5269 C...= 7 : J/psi + p;
5270 C...= 11 : rho + rho;
5271 C...= 12 : rho + phi;
5272 C...= 13 : rho + J/psi;
5273 C...= 14 : phi + phi;
5274 C...= 15 : phi + J/psi;
5275 C...= 16 : J/psi + J/psi;
5276 C...= 21 : gamma + p (DL);
5277 C...= 22 : gamma + p (VDM).
5278 C...= 23 : gamma + pi (DL);
5279 C...= 24 : gamma + pi (VDM);
5280 C...= 25 : gamma + gamma (DL);
5281 C...= 26 : gamma + gamma (VDM).
5285 C...Double precision and integer declarations.
5286 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5287 IMPLICIT INTEGER(I-N)
5288 INTEGER PYK,PYCHGE,PYCOMP
5290 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5291 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5292 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5293 COMMON/PYINT1/MINT(400),VINT(400)
5294 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5295 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5296 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
5298 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
5299 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
5300 &CEFFD(10,9),SIGTMP(6,0:5)
5302 C...Common constants.
5303 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
5304 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
5307 C...Number of multiple processes to be evaluated (= 0 : undefined).
5308 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
5309 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
5310 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
5311 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
5312 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
5314 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
5315 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
5316 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
5318 C...Beam and target hadron class:
5319 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
5320 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
5321 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
5322 C...Characteristic class masses, slope parameters, beta = sqrt(X).
5323 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
5324 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
5325 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
5327 C...Fitting constants used in parametrizations of diffractive results.
5328 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5329 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5330 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
5331 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
5332 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
5333 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
5334 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
5335 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
5336 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
5337 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
5338 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
5339 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
5340 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
5341 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
5342 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
5343 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
5344 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
5345 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
5346 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
5347 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
5348 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
5349 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
5350 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
5351 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
5352 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
5353 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
5354 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
5355 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
5356 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
5358 C...Parameters. Combinations of the energy.
5367 C...Ratio of gamma/pi (for rescaling in parton distributions).
5368 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
5369 &(XPAR(5)*SEPS+YPAR(5)*SETA)
5371 IF(MINT(50).NE.1) RETURN
5373 C...Order flavours of incoming particles: KF1 < KF2.
5374 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
5383 ISGN12=ISIGN(1,MINT(11)*MINT(12))
5385 C...Find process number (for lookup tables).
5386 IF(KF1.GT.1000) THEN
5388 IF(ISGN12.LT.0) IPROC=2
5389 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
5391 IF(ISGN12.LT.0) IPROC=4
5392 IF(KF1.EQ.111) IPROC=5
5393 ELSEIF(KF1.GT.100) THEN
5395 ELSEIF(KF2.GT.1000) THEN
5397 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
5398 ELSEIF(KF2.GT.100) THEN
5400 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
5403 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
5406 C... Number of multiple processes to be stored; beam/target side.
5412 ELSEIF(NPR.EQ.6) THEN
5417 IF(MINT(101).EQ.4) N1=4
5419 IF(MINT(102).EQ.4) N2=4
5421 C...Do not do any more for user-set or undefined cross-sections.
5422 IF(MSTP(31).LE.0) RETURN
5423 IF(NPR.EQ.0) CALL PYERRM(26,
5424 &'(PYXTOT:) cross section for this process not yet implemented')
5426 C...Parameters. Combinations of the energy.
5435 C...Loop over multiple processes (for VDM).
5439 ELSEIF(NPR.EQ.3) THEN
5441 IF(KF2.LT.1000) IPR=I+10
5442 ELSEIF(NPR.EQ.6) THEN
5446 C...Evaluate hadron species, mass, slope contribution and fit number.
5456 C...Skip if energy too low relative to masses.
5460 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
5462 C...Total cross-section. Elastic slope parameter and cross-section.
5463 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
5464 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
5465 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
5467 C...Diffractive scattering A + B -> X + B.
5470 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
5471 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5472 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5473 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
5474 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
5475 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
5476 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
5478 C...Diffractive scattering A + B -> A + X.
5481 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
5482 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5483 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5484 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
5485 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
5486 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
5487 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
5489 C...Order single diffractive correctly.
5492 SIGTMP(I,2)=SIGTMP(I,3)
5496 C...Double diffractive scattering A + B -> X1 + X2.
5497 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
5498 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
5499 SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
5500 IF(YEFF.LE.0) SUM1=0D0
5501 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
5502 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
5503 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
5504 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
5506 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
5507 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
5508 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
5510 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
5511 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
5512 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
5513 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
5514 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
5516 C...Non-diffractive by unitarity.
5517 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
5521 C...Put temporary results in output array: only one process.
5522 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
5524 SIGT(0,0,J)=SIGTMP(1,J)
5527 C...Beam multiple processes.
5528 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
5529 IF(MINT(107).EQ.2) THEN
5530 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5532 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5533 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5535 IF(MSTP(20).GT.0) THEN
5536 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
5539 IF(MINT(107).EQ.2) THEN
5540 CONV=(AEM/PARP(160+I))*VINT(317)
5541 ELSEIF(VINT(154).GT.PARP(15)) THEN
5542 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5543 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5549 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
5553 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5556 C...Target multiple processes.
5557 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
5558 IF(MINT(108).EQ.2) THEN
5559 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5561 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5562 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5564 IF(MSTP(20).GT.0) THEN
5565 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
5568 IF(MINT(108).EQ.2) THEN
5569 CONV=(AEM/PARP(160+I))*VINT(317)
5570 ELSEIF(VINT(154).GT.PARP(15)) THEN
5571 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5572 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5578 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
5582 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
5585 C...Both beam and target multiple processes.
5587 IF(MINT(107).EQ.2) THEN
5588 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5590 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5591 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5593 IF(MINT(108).EQ.2) THEN
5594 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5596 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
5597 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5599 IF(MSTP(20).GT.0) THEN
5600 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
5601 & VINT(308)))**MSTP(20)
5605 IF(MINT(107).EQ.2) THEN
5606 CONV=(AEM/PARP(160+I1))*VINT(317)
5607 ELSEIF(VINT(154).GT.PARP(15)) THEN
5608 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
5609 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5613 IF(MINT(108).EQ.2) THEN
5614 CONV=CONV*(AEM/PARP(160+I2))
5615 ELSEIF(VINT(154).GT.PARP(15)) THEN
5616 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
5617 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
5623 ELSEIF(I2.LE.2) THEN
5625 ELSEIF(I1.EQ.I2) THEN
5632 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
5633 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
5639 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
5640 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
5642 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5646 C...Scale up uniformly for Donnachie-Landshoff parametrization.
5647 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
5648 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
5652 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
5661 C*********************************************************************
5664 C...Finds optimal set of coefficients for kinematical variable selection
5665 C...and the maximum of the part of the differential cross-section used
5666 C...in the event weighting.
5670 C...Double precision and integer declarations.
5671 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5672 IMPLICIT INTEGER(I-N)
5673 INTEGER PYK,PYCHGE,PYCOMP
5674 C...Parameter statement to help give large particle numbers.
5675 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5676 &KEXCIT=4000000,KDIMEN=5000000)
5678 C...User process initialization commonblock.
5680 PARAMETER (MAXPUP=100)
5681 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5682 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5683 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5684 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5689 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5690 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5691 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5692 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5693 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5694 COMMON/PYINT1/MINT(400),VINT(400)
5695 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5696 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
5697 COMMON/PYINT4/MWID(500),WIDS(500,5)
5698 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5699 COMMON/PYINT6/PROC(0:500)
5701 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5702 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
5703 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
5704 C...Local arrays, character variables and data.
5706 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
5707 &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
5708 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
5709 DATA CVAR/'tau ','tau''','y* ','cth '/
5712 C...Initial values and loop over subprocesses.
5721 C...Find maximum weight factors for photon flux.
5722 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
5723 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
5726 C...Select subprocess to study: skip cases not applicable.
5727 IF(ISET(ISUB).EQ.11) THEN
5728 IF(MSUB(ISUB).NE.1) GOTO 460
5729 C...User process intialization: cross section model dependent.
5730 IF(IABS(IDWTUP).EQ.1) THEN
5731 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5732 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5733 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
5735 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
5736 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
5737 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
5738 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5739 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5740 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
5742 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5743 & WTGAGA*XSEC(ISUB,1)
5746 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
5747 CALL PYSIGH(NCHN,SIGS)
5749 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5750 & WTGAGA*XSEC(ISUB,1)
5751 IF(MSUB(ISUB).NE.1) GOTO 460
5754 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
5755 CALL PYSIGH(NCHN,SIGS)
5757 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5758 & WTGAGA*XSEC(ISUB,1)
5759 IF(XSEC(ISUB,1).EQ.0D0) THEN
5765 ELSEIF(ISUB.EQ.96) THEN
5766 IF(MINT(50).EQ.0) GOTO 460
5767 IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
5769 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
5770 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
5771 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
5772 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
5774 IF(MSUB(ISUB).NE.1) GOTO 460
5777 IF(ISUB.EQ.96) ISTSB=2
5778 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
5780 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
5781 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
5783 C...Find resonances (explicit or implicit in cross-section).
5786 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
5788 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
5789 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
5791 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
5792 & .OR.ISUB.EQ.177) THEN
5794 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
5796 IF(MSTP(46).EQ.5) THEN
5799 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
5801 ELSEIF(ISUB.EQ.194) THEN
5803 ELSEIF(ISUB.EQ.195) THEN
5805 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
5807 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
5811 IF(CKMX.LE.0D0) CKMX=VINT(1)
5814 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
5815 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
5818 TAUR1=PMAS(KCR1,1)**2/VINT(2)
5819 IF(KFR1.EQ.KTECHN+113) THEN
5823 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
5830 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
5833 IF(ISUB.EQ.194) THEN
5835 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
5839 TAUR2=PMAS(KCR2,1)**2/VINT(2)
5840 IF(KFR2.EQ.KTECHN+223) THEN
5844 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
5845 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
5846 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
5847 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
5852 ELSEIF(KFR2.NE.0) THEN
5864 C...Find product masses and minimum pT of process.
5870 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5874 IF(KFPR(ISUB,I).EQ.0) THEN
5875 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
5877 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
5878 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
5881 C...This prevents SUSY/t particles from becoming too light.
5883 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
5886 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
5887 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
5888 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
5889 & PMAS(PYCOMP(KFDP(IDC,2)),1)
5890 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
5891 & PMAS(PYCOMP(KFDP(IDC,3)),1)
5892 PMMN(I)=MIN(PMMN(I),PMSUM)
5895 ELSEIF(KFLW.EQ.6) THEN
5896 PMMN(I)=PMAS(24,1)+PMAS(5,1)
5903 CKIN(41)=MAX(PMMN(1),CKIN(41))
5904 CKIN(43)=MAX(PMMN(2),CKIN(43))
5905 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
5908 IF(MINT(51).EQ.1) THEN
5909 WRITE(MSTU(11),5100) ISUB
5916 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
5917 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
5918 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
5919 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5920 ELSEIF(ISUB.EQ.96) THEN
5921 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5927 C...Prepare for additional variable choices in 2 -> 3.
5930 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
5932 VINT(204)=PMAS(23,1)
5933 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
5934 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
5935 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
5936 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
5940 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
5941 NPTS(1)=2+2*MINT(72)
5942 IF(MINT(47).EQ.1) THEN
5943 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
5944 ELSEIF(MINT(47).GE.5) THEN
5945 IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
5948 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5949 IF(MINT(47).GE.2) NPTS(2)=2
5950 IF(MINT(47).GE.5) NPTS(2)=3
5953 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
5955 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
5956 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
5959 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
5960 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
5962 C...Reset coefficients of cross-section weighting.
5978 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
5979 C...in grid of phase space points.
5985 IF(METAU.EQ.1) GOTO 150
5986 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
5987 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
5988 IF(MTAU.GT.2+2*MINT(72)) MTAU=7
5990 C...Special case when both resonances have same mass,
5991 C...as is often the case in process 194.
5992 IF(MINT(72).EQ.2) THEN
5993 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
5994 & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
5995 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
5997 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
6002 CALL PYKMAP(1,MTAU,RTAU)
6003 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
6006 IF(METAUP.EQ.1) GOTO 150
6007 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
6009 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
6010 CALL PYKMAP(4,MTAUP,0.5D0)
6012 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
6016 IF(MEYST.EQ.1) GOTO 150
6017 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
6018 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
6019 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
6020 CALL PYKMAP(2,MYST,0.5D0)
6024 IF(MECTH.EQ.1) GOTO 150
6025 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
6026 MCTH=1+MOD(ITRY-1,NPTS(4))
6027 CALL PYKMAP(3,MCTH,0.5D0)
6029 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
6031 C...Store position and limits.
6034 IF(MINT(51).EQ.1) GOTO 150
6037 MVARPT(NACC,2)=MTAUP
6041 VINTPT(NACC,J)=VINT(10+J)
6044 C...Normal case: calculate cross-section.
6046 CALL PYSIGH(NCHN,SIGS)
6052 C..2 -> 3: find highest value out of a number of tries.
6055 DO 140 IKIN3=1,MSTP(129)
6056 CALL PYKMAP(5,0,0D0)
6057 IF(MINT(51).EQ.1) GOTO 140
6058 CALL PYSIGH(NCHN,SIGTMP)
6063 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6067 C...Store cross-section.
6069 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6070 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
6071 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6074 WRITE(MSTU(11),5100) ISUB
6077 ELSEIF(SIGSAM.EQ.0D0) THEN
6078 WRITE(MSTU(11),5300) ISUB
6082 IF(ISUB.NE.96) NPOSI=NPOSI+1
6084 C...Calculate integrals in tau over maximal phase space limits.
6087 ATAU1=LOG(TAUMAX/TAUMIN)
6088 IF(NPTS(1).GE.2) THEN
6089 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
6091 IF(NPTS(1).GE.4) THEN
6092 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
6093 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
6096 IF(NPTS(1).GE.6) THEN
6097 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
6098 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
6101 IF(NPTS(1).GT.2+2*MINT(72)) THEN
6102 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
6105 C...Reset. Sum up cross-sections in points calculated.
6107 IF(NPTS(IVAR).EQ.1) GOTO 320
6108 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
6119 IBIN=MVARPT(IACC,IVAR)
6120 IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
6121 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
6122 NAREL(IBIN)=NAREL(IBIN)+1
6123 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
6125 C...Sum up tau cross-section pieces in points used.
6128 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6129 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
6131 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
6132 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
6133 & ((TAU-TAUR1)**2+GAMR1**2)
6136 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
6137 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
6138 & ((TAU-TAUR2)**2+GAMR2**2)
6140 IF(NBIN.GT.2+2*MINT(72)) THEN
6141 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
6142 & TAU/MAX(2D-10,1D0-TAU)
6145 C...Sum up tau' cross-section pieces in points used.
6146 ELSEIF(IVAR.EQ.2) THEN
6148 TAUP=VINTPT(IACC,16)
6149 TAUPMN=VINTPT(IACC,6)
6150 TAUPMX=VINTPT(IACC,26)
6151 ATAUP1=LOG(TAUPMX/TAUPMN)
6152 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
6153 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6154 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
6155 & (1D0-TAU/TAUP)**3/TAUP
6157 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
6158 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
6159 & TAUP/MAX(2D-10,1D0-TAUP)
6162 C...Sum up y* cross-section pieces in points used.
6163 ELSEIF(IVAR.EQ.3) THEN
6165 YSTMIN=VINTPT(IACC,2)
6166 YSTMAX=VINTPT(IACC,22)
6168 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
6170 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
6171 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
6172 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
6173 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
6174 IF(MINT(45).EQ.3) THEN
6175 TAUE=VINTPT(IACC,11)
6176 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6177 YST0=-0.5D0*LOG(TAUE)
6178 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
6179 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
6180 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
6181 & MAX(1D-10,1D0-EXP(YST-YST0))
6183 IF(MINT(46).EQ.3) THEN
6184 TAUE=VINTPT(IACC,11)
6185 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6186 YST0=-0.5D0*LOG(TAUE)
6187 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
6188 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
6189 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
6190 & MAX(1D-10,1D0-EXP(-YST-YST0))
6193 C...Sum up cos(theta-hat) cross-section pieces in points used.
6195 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
6197 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
6199 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
6202 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
6203 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
6204 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
6205 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
6207 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6208 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
6209 & MAX(RM34,RSQM-CTH)
6210 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
6211 & MAX(RM34,RSQM+CTH)
6212 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
6213 & MAX(RM34,RSQM-CTH)**2
6214 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
6215 & MAX(RM34,RSQM+CTH)**2
6219 C...Check that equation system solvable.
6220 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
6224 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
6225 & IRED=1,NBIN),WTREL(IBIN)
6226 IF(NAREL(IBIN).EQ.0) MSOLV=0
6227 WTRELS=WTRELS+WTREL(IBIN)
6229 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
6231 C...Solve to find relative importance of cross-section pieces.
6234 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
6236 DO 230 IRED=1,NBIN-1
6237 DO 220 IBIN=IRED+1,NBIN
6238 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
6242 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
6243 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
6244 DO 210 ICOE=IRED,NBIN
6245 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
6249 DO 250 IRED=NBIN,1,-1
6250 DO 240 ICOE=IRED+1,NBIN
6251 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
6253 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
6257 C...Share evenly if failure.
6258 260 IF(MSOLV.EQ.0) THEN
6262 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
6263 & WTREL(IBIN)/WTRELS)
6267 C...Normalize coefficients, with piece shared democratically.
6271 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
6272 COEFSU=COEFSU+COEFU(IBIN)
6273 WTRELS=WTRELS+WTRELN(IBIN)
6275 IF(COEFSU.GT.0D0) THEN
6277 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
6278 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
6282 COEFO(IBIN)=1D0/NBIN
6285 IF(IVAR.EQ.1) IOFF=0
6286 IF(IVAR.EQ.2) IOFF=17
6287 IF(IVAR.EQ.3) IOFF=7
6288 IF(IVAR.EQ.4) IOFF=12
6291 IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
6292 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
6293 COEF(ISUB,ICOF)=COEFO(IBIN)
6295 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
6296 & (COEFO(IBIN),IBIN=1,NBIN)
6299 C...Find two most promising maxima among points previously determined.
6307 VINT(10+J)=VINTPT(IACC,J)
6310 CALL PYSIGH(NCHN,SIGS)
6317 DO 350 IKIN3=1,MSTP(129)
6318 CALL PYKMAP(5,0,0D0)
6319 IF(MINT(51).EQ.1) GOTO 350
6320 CALL PYSIGH(NCHN,SIGTMP)
6325 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6330 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
6333 DO 370 IMV=NMAX,1,-1
6335 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
6336 IACCMX(IMV+1)=IACCMX(IMV)
6337 SIGSMX(IMV+1)=SIGSMX(IMV)
6340 380 IACCMX(IIN)=IACC
6342 IF(NMAX.LE.1) NMAX=NMAX+1
6346 C...Read out starting position for search.
6347 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
6352 MTAUP=MVARPT(IACC,2)
6360 C...Starting point and step size in parameter space.
6363 IF(NPTS(IVAR).EQ.1) GOTO 420
6364 IF(IVAR.EQ.1) VVAR=VTAU
6365 IF(IVAR.EQ.2) VVAR=VTAUP
6366 IF(IVAR.EQ.3) VVAR=VYST
6367 IF(IVAR.EQ.4) VVAR=VCTH
6368 IF(IVAR.EQ.1) MVAR=MTAU
6369 IF(IVAR.EQ.2) MVAR=MTAUP
6370 IF(IVAR.EQ.3) MVAR=MYST
6371 IF(IVAR.EQ.4) MVAR=MCTH
6372 IF(IRPT.EQ.1) VDEL=0.1D0
6373 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
6375 IF(IRPT.EQ.1) VMAR=0.02D0
6376 IF(IRPT.EQ.2) VMAR=0.002D0
6378 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
6381 C...Define new point in parameter space.
6385 ELSEIF(IMOV.EQ.1) THEN
6388 ELSEIF(IMOV.EQ.2) THEN
6391 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
6392 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
6398 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
6399 & VVAR-2D0*VDEL.GT.VMAR) THEN
6405 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
6419 C...Convert to relevant variables and find derived new limits.
6423 CALL PYKMAP(1,MTAU,VTAU)
6424 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
6426 IF(MINT(51).EQ.1) ILERR=1
6429 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
6431 IF(IVAR.EQ.2) VTAUP=VNEW
6432 CALL PYKMAP(4,MTAUP,VTAUP)
6434 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
6436 IF(MINT(51).EQ.1) ILERR=1
6438 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
6439 IF(IVAR.EQ.3) VYST=VNEW
6440 CALL PYKMAP(2,MYST,VYST)
6442 IF(MINT(51).EQ.1) ILERR=1
6444 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
6446 IF(IVAR.EQ.4) VCTH=VNEW
6447 CALL PYKMAP(3,MCTH,VCTH)
6449 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
6451 C...Evaluate cross-section. Save new maximum. Final maximum.
6454 ELSEIF(ISTSB.NE.5) THEN
6455 CALL PYSIGH(NCHN,SIGS)
6462 DO 400 IKIN3=1,MSTP(129)
6463 CALL PYKMAP(5,0,0D0)
6464 IF(MINT(51).EQ.1) GOTO 400
6465 CALL PYSIGH(NCHN,SIGTMP)
6470 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6474 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6475 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
6476 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6481 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
6482 XSEC(ISUB,1)=1.05D0*SIGSAM
6483 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
6484 & WTGAGA*XSEC(ISUB,1)
6486 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
6487 & PARP(174)*XSEC(ISUB,1)
6488 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
6492 C...Print summary table.
6493 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
6494 IF(MSTP(127).NE.1) THEN
6495 WRITE(MSTU(11),5900)
6498 WRITE(MSTU(11),6400)
6502 IF(MSTP(122).GE.1) THEN
6503 WRITE(MSTU(11),6000)
6504 WRITE(MSTU(11),6100)
6506 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
6507 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
6508 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
6509 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
6510 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
6511 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
6512 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
6514 WRITE(MSTU(11),6300)
6517 C...Format statements for maximization results.
6518 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
6519 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
6520 &'cth',9X,'tau''',7X,'sigma')
6521 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
6522 &'phase space.'/1X,'Process switched off!')
6523 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
6524 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
6525 &'cross-section.'/1X,'Process switched off!')
6526 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
6527 5500 FORMAT(1X,1P,8D11.3)
6528 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
6529 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
6530 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
6531 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
6532 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
6533 &'cross-section.'/1X,'Execution stopped!')
6534 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
6535 &'cross-section maximum search',1X,8('*'))
6536 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
6537 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
6538 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
6539 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
6540 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
6541 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
6543 &1X,'Execution will stop if you try to generate events.')
6548 C*********************************************************************
6551 C...Initializes multiplicity distribution and selects mutliplicity
6552 C...of pileup events, i.e. several events occuring at the same
6555 SUBROUTINE PYPILE(MPILE)
6557 C...Double precision and integer declarations.
6558 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6559 IMPLICIT INTEGER(I-N)
6560 INTEGER PYK,PYCHGE,PYCOMP
6562 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6563 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6564 COMMON/PYINT1/MINT(400),VINT(400)
6565 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6566 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
6567 C...Local arrays and saved variables.
6568 DIMENSION WTI(0:200)
6569 SAVE IMIN,IMAX,WTI,WTS
6571 C...Sum of allowed cross-sections for pileup events.
6573 VINT(131)=SIGT(0,0,5)
6574 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
6575 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
6576 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
6577 IF(MSTP(133).LE.0) RETURN
6579 C...Initialize multiplicity distribution at maximum.
6580 XNAVE=VINT(131)*PARP(131)
6581 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
6582 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
6585 WTN=WTI(INAVE)*INAVE
6587 C...Find shape of multiplicity distribution below maximum.
6589 DO 100 I=INAVE-1,1,-1
6590 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
6591 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
6592 IF(WTI(I).LT.1D-6) GOTO 110
6598 C...Find shape of multiplicity distribution above maximum.
6600 DO 120 I=INAVE+1,200
6601 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
6602 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
6603 IF(WTI(I).LT.1D-6) GOTO 130
6610 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
6611 & WTS/(WTS+WTI(1)/XNAVE)
6612 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
6613 IF(MSTP(133).GE.2) VINT(134)=XNAVE
6615 C...Pick multiplicity of pileup events.
6617 IF(MSTP(133).LE.0) THEN
6618 MINT(81)=MAX(1,MSTP(134))
6624 IF(WTR.LE.0D0) GOTO 150
6630 C...Format statement for error message.
6631 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
6632 &'crossing too large, ',1P,D12.4)
6637 C*********************************************************************
6640 C...Saves and restores parameter and cross section values for the
6641 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
6642 C...Also makes random choice between alternatives.
6644 SUBROUTINE PYSAVE(ISAVE,IGA)
6646 C...Double precision and integer declarations.
6647 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6648 IMPLICIT INTEGER(I-N)
6649 INTEGER PYK,PYCHGE,PYCOMP
6651 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6652 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6653 COMMON/PYINT1/MINT(400),VINT(400)
6654 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6655 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6656 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6657 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
6658 C...Local arrays and saved variables.
6659 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
6660 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
6661 &INTCP(15,20),RECP(15,20)
6662 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
6664 C...Save list of subprocesses and cross-section information.
6668 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
6671 MSUBCP(IGA,ICP)=MSUB(I)
6673 COEFCP(IGA,ICP,J)=COEF(I,J)
6676 NGENCP(IGA,ICP,J)=NGEN(I,J)
6677 XSECCP(IGA,ICP,J)=XSEC(I,J)
6682 NGENCP(IGA,0,J)=NGEN(0,J)
6683 XSECCP(IGA,0,J)=XSEC(0,J)
6688 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
6693 C...Save various common process variables.
6695 INTCP(IGA,J)=MINT(40+J)
6697 INTCP(IGA,11)=MINT(101)
6698 INTCP(IGA,12)=MINT(102)
6699 INTCP(IGA,13)=MINT(107)
6700 INTCP(IGA,14)=MINT(108)
6701 INTCP(IGA,15)=MINT(123)
6703 RECP(IGA,2)=VINT(318)
6705 C...Save cross-section information only.
6706 ELSEIF(ISAVE.EQ.2) THEN
6707 DO 190 ICP=1,NCP(IGA)
6710 NGENCP(IGA,ICP,J)=NGEN(I,J)
6711 XSECCP(IGA,ICP,J)=XSEC(I,J)
6715 NGENCP(IGA,0,J)=NGEN(0,J)
6716 XSECCP(IGA,0,J)=XSEC(0,J)
6719 C...Choose between allowed alternatives.
6720 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
6723 DO 210 IG=1,MINT(121)
6724 XSUMCP=XSUMCP+XSECCP(IG,0,1)
6726 XSUMCP=XSUMCP*PYR(0)
6727 DO 220 IG=1,MINT(121)
6729 XSUMCP=XSUMCP-XSECCP(IG,0,1)
6730 IF(XSUMCP.LE.0D0) GOTO 230
6735 C...Restore cross-section information.
6739 DO 270 ICP=1,NCP(IGA)
6741 MSUB(I)=MSUBCP(IGA,ICP)
6743 COEF(I,J)=COEFCP(IGA,ICP,J)
6746 NGEN(I,J)=NGENCP(IGA,ICP,J)
6747 XSEC(I,J)=XSECCP(IGA,ICP,J)
6751 NGEN(0,J)=NGENCP(IGA,0,J)
6752 XSEC(0,J)=XSECCP(IGA,0,J)
6757 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
6762 C...Restore various common process variables.
6764 MINT(40+J)=INTCP(IGA,J)
6766 MINT(101)=INTCP(IGA,11)
6767 MINT(102)=INTCP(IGA,12)
6768 MINT(107)=INTCP(IGA,13)
6769 MINT(108)=INTCP(IGA,14)
6770 MINT(123)=INTCP(IGA,15)
6773 VINT(318)=RECP(IGA,2)
6775 C...Sum up cross-section info (for PYSTAT).
6776 ELSEIF(ISAVE.EQ.5) THEN
6787 DO 350 IG=1,MINT(121)
6788 DO 340 ICP=1,NCP(IG)
6790 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
6791 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
6792 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
6793 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
6795 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
6796 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
6797 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
6798 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
6805 C*********************************************************************
6808 C...For lepton beams it gives photon-hadron or photon-photon systems
6809 C...to be treated with the ordinary machinery and combines this with a
6810 C...description of the lepton -> lepton + photon branching.
6812 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
6814 C...Double precision and integer declarations.
6815 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6816 IMPLICIT INTEGER(I-N)
6817 INTEGER PYK,PYCHGE,PYCOMP
6819 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
6820 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6821 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6822 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6823 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6824 COMMON/PYINT1/MINT(400),VINT(400)
6825 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6826 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
6828 C...Local variables and data statement.
6829 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
6830 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
6831 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
6834 C...Initialize generation of photons inside leptons.
6837 C...Save quantities on incoming lepton system.
6841 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
6843 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
6844 PMC(3)=VINT(302)-PMS(1)-PMS(2)
6845 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
6847 C...Calculate range of x and Q2 values allowed in generation.
6849 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
6850 IF(MINT(140+I).NE.0) THEN
6851 XMIN(I)=MAX(CKIN(59+2*I),EPS)
6852 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
6854 YMIN=MAX(CKIN(71+2*I),EPS)
6855 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
6856 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
6857 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
6858 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
6859 THEMIN=MAX(CKIN(67+2*I),0D0)
6860 THEMAX=MIN(CKIN(68+2*I),PARU(1))
6861 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
6862 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
6863 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
6864 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
6865 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
6866 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
6867 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
6868 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
6869 C...W limits when lepton on one side only.
6870 IF(MINT(143-I).EQ.0) THEN
6871 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
6872 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
6873 & (CKIN(78)**2-PMS(3-I))/PMC(I))
6878 C...W limits when lepton on both sides.
6879 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
6880 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
6881 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
6882 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
6883 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
6884 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
6885 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
6886 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
6887 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
6888 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
6890 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
6891 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
6895 C...Q2 and W values and photon flux weight factors for initialization.
6896 ELSEIF(IGAGA.EQ.2) THEN
6901 C...W value for photon on one or both sides, and for processes
6902 C...with gamma-gamma cross section peaked at small shat.
6903 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
6904 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
6905 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
6906 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
6907 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
6908 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
6909 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
6911 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
6912 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
6914 VINT(1)=SQRT(MAX(0D0,VINT(2)))
6916 C...Upper estimate of photon flux weight factor.
6917 C...Initialization Q2 scale. Flag incoming unresolved photon.
6920 IF(MINT(140+I).NE.0) THEN
6921 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
6922 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
6923 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
6925 Q2INIT=5D0+Q2MIN(3-I)
6926 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
6927 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
6928 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
6929 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
6930 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
6931 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
6933 ELSEIF(ISUB.EQ.140) THEN
6938 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
6939 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
6941 VINT(306+I)=VINT(2+I)**2
6946 C...Update pTmin and cross section information.
6947 IF(MSTP(82).LE.1) THEN
6948 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6950 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6952 VINT(149)=4D0*PTMN**2/VINT(2)
6957 C...Generate photons inside leptons and
6958 C...calculate photon flux weight factors.
6959 ELSEIF(IGAGA.EQ.3) THEN
6964 C...Generate phase space point and check against cuts.
6968 IF(MINT(140+I).NE.0) THEN
6970 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
6971 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
6972 C...Cuts on internal consistency in x and Q2.
6973 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
6974 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
6975 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
6976 C...Cuts on y and theta.
6977 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
6978 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
6979 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
6980 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
6981 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
6982 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
6983 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
6986 C...Phi angle isotropic. Reconstruct pT.
6987 PHI(I)=PARU(2)*PYR(0)
6988 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
6989 & PMS(I))*SIN(THETA(I))
6991 C...Store info on variables selected, for documentation purposes.
6992 VINT(2+I)=-SQRT(Q2(I))
6996 VINT(310+I)=THETA(I)
7007 C...Cut on W combines info from two sides.
7008 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7009 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
7010 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
7011 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
7012 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
7013 IF(W2.LT.W2MIN) GOTO 120
7014 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
7017 ELSEIF(MINT(141).NE.0) THEN
7018 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
7021 ELSEIF(MINT(142).NE.0) THEN
7022 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
7027 C...Store kinematics info for photon(s) in subsystem cm frame.
7032 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
7033 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
7034 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
7037 VINT(298)=-VINT(293)
7038 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
7039 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
7041 C...Assign weight for photon flux; different for transverse and
7042 C...longitudinal photons. Flag incoming unresolved photon.
7045 IF(MINT(140+I).NE.0) THEN
7046 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
7047 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
7048 IF(MSTP(16).EQ.0) THEN
7051 WTGAGA=WTGAGA*X(I)/Y(I)
7054 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
7055 WTGAGA=WTGAGA*(1D0-XY)
7056 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
7057 WTGAGA=WTGAGA*(1D0-XY)
7058 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
7059 WTGAGA=WTGAGA*(1D0-XY)
7061 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
7062 & PMS(I)*XY**2/Q2(I))
7064 IF(MINT(106+I).EQ.0) MINT(14+I)=22
7070 C...Update pTmin and cross section information.
7071 IF(MSTP(82).LE.1) THEN
7072 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7074 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7076 VINT(149)=4D0*PTMN**2/VINT(2)
7080 C...Reconstruct kinematics of photons inside leptons.
7081 ELSEIF(IGAGA.EQ.4) THEN
7083 C...Make place for incoming particles and scattered leptons.
7085 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
7086 MINT(4)=MINT(4)+MOVE
7087 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
7088 IF(K(I,1).EQ.21) THEN
7094 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7095 & K(I+MOVE,3)=K(I,3)+MOVE
7096 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
7097 & K(I+MOVE,4)=K(I,4)+MOVE
7098 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
7099 & K(I+MOVE,5)=K(I,5)+MOVE
7102 DO 170 I=MINT(84)+1,N
7103 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7104 & K(I,3)=K(I,3)+MOVE
7107 C...Fill in incoming particles.
7108 DO 190 I=MINT(83)+1,MINT(83)+MOVE
7117 IF(MINT(140+I).NE.0) THEN
7118 K(MINT(83)+I,2)=MINT(140+I)
7119 P(MINT(83)+I,5)=VINT(302+I)
7121 K(MINT(83)+I,2)=MINT(10+I)
7122 P(MINT(83)+I,5)=VINT(2+I)
7124 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
7125 & VINT(302))*(-1D0)**(I+1)
7126 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
7129 C...New mother-daughter relations in documentation section.
7130 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7131 K(MINT(83)+1,4)=MINT(83)+3
7132 K(MINT(83)+1,5)=MINT(83)+5
7133 K(MINT(83)+2,4)=MINT(83)+4
7134 K(MINT(83)+2,5)=MINT(83)+6
7135 K(MINT(83)+3,3)=MINT(83)+1
7136 K(MINT(83)+5,3)=MINT(83)+1
7137 K(MINT(83)+4,3)=MINT(83)+2
7138 K(MINT(83)+6,3)=MINT(83)+2
7139 ELSEIF(MINT(141).NE.0) THEN
7140 K(MINT(83)+1,4)=MINT(83)+3
7141 K(MINT(83)+1,5)=MINT(83)+4
7142 K(MINT(83)+2,4)=MINT(83)+5
7143 K(MINT(83)+3,3)=MINT(83)+1
7144 K(MINT(83)+4,3)=MINT(83)+1
7145 K(MINT(83)+5,3)=MINT(83)+2
7146 ELSEIF(MINT(142).NE.0) THEN
7147 K(MINT(83)+1,4)=MINT(83)+4
7148 K(MINT(83)+2,4)=MINT(83)+3
7149 K(MINT(83)+2,5)=MINT(83)+5
7150 K(MINT(83)+3,3)=MINT(83)+2
7151 K(MINT(83)+4,3)=MINT(83)+1
7152 K(MINT(83)+5,3)=MINT(83)+2
7155 C...Fill scattered lepton(s).
7157 IF(MINT(140+I).NE.0) THEN
7158 LSC=MINT(83)+MIN(I+2,MOVE)
7160 K(LSC,2)=MINT(140+I)
7161 P(LSC,1)=PT(I)*COS(PHI(I))
7162 P(LSC,2)=PT(I)*SIN(PHI(I))
7163 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
7164 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
7166 P(LSC,5)=VINT(302+I)
7170 C...Find incoming four-vectors to subprocess.
7172 IF(MINT(141).NE.0) THEN
7174 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
7178 P(N+1,J)=P(MINT(83)+1,J)
7182 IF(MINT(142).NE.0) THEN
7184 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
7188 P(N+2,J)=P(MINT(83)+2,J)
7192 C...Define boost and rotation between hadronic subsystem and
7193 C...collision rest frame; boost hadronic subsystem to this frame.
7195 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
7197 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
7198 BPHI=PYANGL(P(N+1,1),P(N+1,2))
7199 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
7200 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
7201 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
7204 C...Add on scattered leptons to final state.
7206 IF(MINT(140+I).NE.0) THEN
7207 LSC=MINT(83)+MIN(I+2,MOVE)
7223 C*********************************************************************
7226 C...Generates quantities characterizing the high-pT scattering at the
7227 C...parton level according to the matrix elements. Chooses incoming,
7228 C...reacting partons, their momentum fractions and one of the possible
7233 C...Double precision and integer declarations.
7234 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7235 IMPLICIT INTEGER(I-N)
7236 INTEGER PYK,PYCHGE,PYCOMP
7237 C...Parameter statement to help give large particle numbers.
7238 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7239 &KEXCIT=4000000,KDIMEN=5000000)
7241 C...User process initialization and event commonblocks.
7243 PARAMETER (MAXPUP=100)
7244 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7245 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7246 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7247 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7250 PARAMETER (MAXNUP=500)
7251 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
7252 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
7253 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
7254 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
7255 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
7256 SAVE /HEPRUP/,/HEPEUP/
7259 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7260 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7261 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7262 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7263 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7264 COMMON/PYINT1/MINT(400),VINT(400)
7265 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7266 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7267 COMMON/PYINT4/MWID(500),WIDS(500,5)
7268 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7269 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7270 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
7271 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7272 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/
7274 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
7276 C...Parameters and data used in elastic/diffractive treatment.
7277 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
7278 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
7280 C...Initial values, specifically for (first) semihard interaction.
7290 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
7298 C...Start by assuming incoming photon is entering subprocess.
7299 IF(MINT(11).EQ.22) THEN
7301 VINT(307)=VINT(3)**2
7303 IF(MINT(12).EQ.22) THEN
7305 VINT(308)=VINT(4)**2
7310 C...Choice of process type - first event of pileup.
7312 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
7313 ELSEIF(MINT(82).EQ.1) THEN
7315 C...For gamma-p or gamma-gamma first pick between alternatives.
7317 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
7320 C...For real gamma + gamma with different nature, flip at random.
7321 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
7322 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
7332 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
7335 C...Pick process type, possibly by user process machinery.
7336 C...(If the latter, also event will be picked here.)
7337 IF(MINT(111).EQ.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
7339 ELSEIF(MINT(111).EQ.11.AND.IABS(IDWTUP).GE.3) THEN
7343 IF(KFPR(ISUB,2).NE.IDPRUP.AND.ISUB.LT.500) GOTO 110
7345 RSUB=XSEC(0,1)*PYR(0)
7347 IF(MSUB(I).NE.1) GOTO 120
7350 IF(RSUB.LE.0D0) GOTO 130
7352 130 IF(ISUB.EQ.95) ISUB=96
7353 IF(ISUB.EQ.96) INMULT=1
7354 IF(ISET(ISUB).EQ.11) THEN
7360 C...Choice of inclusive process type - pileup events.
7361 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
7362 RSUB=VINT(131)*PYR(0)
7364 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
7365 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
7366 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
7367 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
7369 IF(ISUB.EQ.96) INMULT=1
7372 C...Choice of photon energy and flux factor inside lepton.
7373 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
7374 CALL PYGAGA(3,WTGAGA)
7375 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
7376 CKIN(3)=MAX(VINT(285),VINT(154))
7379 C...When necessary set direct/resolved photon by hand.
7380 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
7381 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
7382 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
7385 C...Restrict direct*resolved processes to pTmin >= Q,
7386 C...to avoid doublecounting with DIS.
7387 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
7388 IF(MINT(15).EQ.22) THEN
7389 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
7391 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
7396 C...Set up for multiple interactions.
7397 IF(INMULT.EQ.1) CALL PYMULT(2)
7399 C...Loopback point for minimum bias in photon physics.
7402 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
7403 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
7404 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
7405 &NGEN(97,1)=NGEN(97,1)+MINT(143)
7409 C...Random choice of flavour for some SUSY processes.
7410 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
7411 C...~e_L ~nu_e or ~mu_L ~nu_mu.
7412 IF(ISUB.EQ.210) THEN
7413 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
7414 KFPR(ISUB,2)=KFPR(ISUB,1)+1
7415 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
7416 ELSEIF(ISUB.EQ.213) THEN
7417 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
7418 KFPR(ISUB,2)=KFPR(ISUB,1)
7419 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
7420 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
7421 IF(ISUB.GE.258) THEN
7426 IF(MOD(ISUB,2).EQ.0) THEN
7427 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
7429 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
7431 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7432 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
7433 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
7436 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
7439 ELSEIF(PYR(0).LT.0.5D0) THEN
7446 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
7447 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
7448 C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
7449 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
7450 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
7451 KFPR(ISUB,2)=KFPR(ISUB,1)
7452 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
7453 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
7454 KFPR(ISUB,2)=KFPR(ISUB,1)
7455 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7456 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
7457 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
7460 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
7463 ELSEIF(PYR(0).LT.0.5D0) THEN
7470 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
7475 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
7479 C...Find resonances (explicit or implicit in cross-section).
7482 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7484 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
7485 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7487 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
7490 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7492 IF(MSTP(46).EQ.5) THEN
7495 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7497 ELSEIF(ISUB.EQ.194) THEN
7499 ELSEIF(ISUB.EQ.195) THEN
7501 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
7503 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
7507 IF(CKMX.LE.0D0) CKMX=VINT(1)
7510 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7511 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7514 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7515 IF(KFR1.EQ.KTECHN+113) THEN
7519 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7525 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
7528 IF(ISUB.EQ.194) THEN
7530 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
7534 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7535 IF(KFR2.EQ.KTECHN+223) THEN
7539 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7540 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7541 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
7542 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7547 ELSEIF(KFR2.NE.0) THEN
7558 C...Find product masses and minimum pT of process,
7559 C...optionally with broadening according to a truncated Breit-Wigner.
7564 IF(MINT(82).GE.2) VINT(71)=0D0
7566 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7570 IF(KFPR(ISUB,I).EQ.0) THEN
7571 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7573 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7576 C...This prevents SUSY/t particles from becoming too light.
7578 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7581 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7582 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7583 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7584 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7585 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7586 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7587 PMMN(I)=MIN(PMMN(I),PMSUM)
7590 ELSEIF(KFLW.EQ.6) THEN
7591 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7598 CKIN(41)=MAX(PMMN(1),CKIN(41))
7599 CKIN(43)=MAX(PMMN(2),CKIN(43))
7600 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7603 IF(MINT(51).EQ.1) THEN
7604 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7614 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
7615 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7618 C...Prepare for additional variable choices in 2 -> 3.
7621 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7623 VINT(204)=PMAS(23,1)
7624 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7625 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7626 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
7627 & ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
7631 C...Select incoming VDM particle (rho/omega/phi/J/psi).
7632 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
7633 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
7634 VRN=PYR(0)*SIGT(0,0,5)
7635 IF(MINT(101).LE.1) THEN
7642 IF(MINT(102).LE.1) THEN
7653 VRN=VRN-SIGT(I1,I2,5)
7654 IF(VRN.LE.0D0) GOTO 190
7657 190 IF(MINT(101).GE.2) MINT(103)=KFV1
7658 IF(MINT(102).GE.2) MINT(104)=KFV2
7662 C...Elastic scattering or single or double diffractive scattering.
7664 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
7669 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
7671 VRN=PYR(0)*SIGT(0,0,JJ)
7672 IF(MINT(101).LE.1) THEN
7679 IF(MINT(102).LE.1) THEN
7690 VRN=VRN-SIGT(I1,I2,JJ)
7691 IF(VRN.LE.0D0) GOTO 220
7694 220 IF(MINT(101).GE.2) THEN
7698 IF(MINT(102).GE.2) THEN
7706 C...Select mass for GVMD states (rejecting previous assignment).
7708 Q1S=4D0*VINT(154)**2
7712 IF(MINT(106+JT).EQ.3) THEN
7714 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
7715 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
7716 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
7717 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
7720 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
7721 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
7726 C...Side/sides of diffractive system.
7729 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
7730 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
7732 C...Find masses of particles and minimal masses of diffractive states.
7735 VINT(68+JT)=PDIF(JT)
7736 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
7743 SMRES1=(PMM(1)+PMRC)**2
7744 SMRES2=(PMM(2)+PMRC)**2
7746 C...Find elastic slope and lower limit diffractive slope.
7747 IHA=MAX(2,IABS(MINT(103))/110)
7749 IHB=MAX(2,IABS(MINT(104))/110)
7752 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
7753 ELSEIF(ISUB.EQ.92) THEN
7754 BMN=MAX(2D0,2D0*BHAD(IHB))
7755 ELSEIF(ISUB.EQ.93) THEN
7756 BMN=MAX(2D0,2D0*BHAD(IHA))
7757 ELSEIF(ISUB.EQ.94) THEN
7761 C...Determine maximum possible t range and coefficient of generation.
7762 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
7763 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7764 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7765 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7766 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7767 & (SQM1*SQM4-SQM2*SQM3)/SH
7768 THL=-0.5D0*(THA+THB)
7770 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
7772 C...Select diffractive mass/masses according to dm^2/m^2.
7776 IF(MINT(16+JT).EQ.0) THEN
7780 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
7781 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
7787 C..Additional mass factors, including resonance enhancement.
7788 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
7789 IF(LOOP3.LT.100) GOTO 260
7793 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
7794 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7795 ELSEIF(ISUB.EQ.93) THEN
7796 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
7797 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7798 ELSEIF(ISUB.EQ.94) THEN
7799 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
7800 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
7801 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
7802 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
7805 C...Select t according to exp(Bmn*t) and correct to right slope.
7806 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
7809 BADD=2D0*ALP*LOG(SH/SQM3)
7810 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
7811 ELSEIF(ISUB.EQ.93) THEN
7812 BADD=2D0*ALP*LOG(SH/SQM4)
7813 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
7814 ELSEIF(ISUB.EQ.94) THEN
7815 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
7817 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
7820 C...Check whether m^2 and t choices are consistent.
7821 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7822 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7823 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7824 IF(THB.LE.1D-8) GOTO 260
7825 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7826 & (SQM1*SQM4-SQM2*SQM3)/SH
7827 THLM=-0.5D0*(THA+THB)
7829 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
7831 C...Information to output.
7834 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
7836 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
7839 VINT(283)=PMM(1)**2/4D0
7840 VINT(284)=PMM(2)**2/4D0
7842 C...Note: in the following, by In is meant the integral over the
7843 C...quantity multiplying coefficient cn.
7844 C...Choose tau according to h1(tau)/tau, where
7845 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
7846 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
7847 C...I1/I5*c5*1/(tau+tau_R') +
7848 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
7849 C...I1/I7*c7*tau/(1.-tau), and
7850 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
7851 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
7853 IF(MINT(51).NE.0) THEN
7854 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7863 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
7864 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
7865 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
7866 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
7868 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
7869 & COEF(ISUB,5)) MTAU=6
7870 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
7871 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
7872 CALL PYKMAP(1,MTAU,PYR(0))
7874 C...2 -> 3, 4 processes:
7875 C...Choose tau' according to h4(tau,tau')/tau', where
7876 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
7877 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
7878 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7880 IF(MINT(51).NE.0) THEN
7881 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7890 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
7891 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
7892 CALL PYKMAP(4,MTAUP,PYR(0))
7895 C...Choose y* according to h2(y*), where
7896 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
7897 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
7898 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
7899 C...and c1 + c2 + c3 + c4 + c5 = 1.
7901 IF(MINT(51).NE.0) THEN
7902 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7911 IF(RYST.GT.COEF(ISUB,8)) MYST=2
7912 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
7913 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
7914 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
7915 & COEF(ISUB,11)) MYST=5
7916 CALL PYKMAP(2,MYST,PYR(0))
7918 C...2 -> 2 processes:
7919 C...Choose cos(theta-hat) (cth) according to h3(cth), where
7920 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
7921 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
7922 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
7923 C...and c0 + c1 + c2 + c3 + c4 = 1.
7925 IF(MINT(51).NE.0) THEN
7926 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7933 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7936 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
7937 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
7938 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
7939 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
7940 & COEF(ISUB,16)) MCTH=5
7941 CALL PYKMAP(3,MCTH,PYR(0))
7944 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
7946 CALL PYKMAP(5,0,0D0)
7947 IF(MINT(51).NE.0) THEN
7948 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7957 C...DIS as f + gamma* -> f process: set dummy values.
7958 ELSEIF(ISTSB.EQ.8) THEN
7965 C...Low-pT or multiple interactions (first semihard interaction).
7966 ELSEIF(ISTSB.EQ.9) THEN
7970 C...Study user-defined process: kinematics plus weight.
7971 ELSEIF(ISTSB.EQ.11) THEN
7972 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
7973 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
7978 IF(MINT(82).EQ.1) THEN
7979 NGEN(0,1)=NGEN(0,1)-1
7980 NGEN(ISUB,1)=NGEN(ISUB,1)-1
7982 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7986 C...Extract cross section event weight.
7987 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
7990 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
7992 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
7993 VINT(97)=SIGN(1D0,XWGTUP)
7995 VINT(97)=1D-9*XWGTUP
7998 C...Construct 'trivial' kinematical variables needed.
8001 VINT(41)=PUP(4,1)/EBMUP(1)
8002 VINT(42)=PUP(4,2)/EBMUP(2)
8003 VINT(21)=VINT(41)*VINT(42)
8004 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
8005 VINT(44)=VINT(21)*VINT(2)
8006 VINT(43)=SQRT(MAX(0D0,VINT(44)))
8008 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
8009 VINT(56)=VINT(55)**2
8013 C...Construct other kinematical variables needed (approximately).
8016 VINT(45)=-0.5D0*VINT(44)
8017 VINT(46)=-0.5D0*VINT(44)
8026 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
8027 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
8029 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
8030 & '(PYRAND:) unacceptable ISTUP code for particles')
8031 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
8032 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
8033 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
8036 VINT(47)=SQRT(VINT(48))
8039 C...Choose azimuthal angle.
8041 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
8043 C...Check against user cuts on kinematics at parton level.
8045 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
8046 IF(MINT(51).NE.0) THEN
8047 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8054 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
8056 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
8059 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8068 C...Calculate differential cross-section for different subprocesses.
8069 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
8071 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
8073 C...Multiply cross section by lepton -> photon flux factor.
8074 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
8077 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
8079 SIGLPT=WTGAGA*SIGLPT
8082 C...Multiply cross-section by user-defined weights.
8083 IF(MSTP(173).EQ.1) THEN
8086 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
8088 SIGLPT=PARP(173)*SIGLPT
8094 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
8095 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
8096 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
8099 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
8102 C...Calculations for Monte Carlo estimate of all cross-sections.
8103 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
8104 IF(MSTP(142).LE.1) THEN
8105 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8107 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
8109 ELSEIF(MINT(82).EQ.1) THEN
8110 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8112 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
8113 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
8115 C...Multiple interactions: store results of cross-section calculation.
8116 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
8121 C...Ratio of actual to maximum cross section.
8122 IF(ISTSB.NE.11) THEN
8123 VIOL=SIGSWT/XSEC(ISUB,1)
8124 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
8125 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
8126 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
8127 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
8128 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
8133 C...Check that weight not negative.
8134 IF(MSTP(123).LE.0) THEN
8135 IF(VIOL.LT.-1D-3) THEN
8136 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
8137 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8138 & VINT(22),VINT(23),VINT(26)
8142 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
8144 WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
8145 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8146 & VINT(22),VINT(23),VINT(26)
8150 C...Weighting using estimate of maximum of differential cross-section.
8151 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
8152 IF(VIOL.LT.PYR(0)) THEN
8153 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8154 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
8157 ELSEIF(MFAIL.EQ.0) THEN
8158 RATND=SIGLPT/XSEC(95,1)
8159 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
8160 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8165 IF(VIOL.LT.PYR(0)) THEN
8168 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
8169 IF(VIOL.LT.PYR(0)) THEN
8171 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8175 RATND=SIGLPT/XSEC(95,1)
8176 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
8178 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8182 IF(VIOL.LT.PYR(0)) THEN
8183 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8188 C...Check for possible violation of estimated maximum of differential
8189 C...cross-section used in weighting.
8190 IF(MSTP(123).LE.0) THEN
8191 IF(VIOL.GT.1D0) THEN
8192 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
8193 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8194 & VINT(22),VINT(23),VINT(26)
8197 ELSEIF(MSTP(123).EQ.1) THEN
8198 IF(VIOL.GT.VINT(108)) THEN
8200 IF(VIOL.GT.1.0001D0) THEN
8202 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8203 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8204 & VINT(22),VINT(23),VINT(26)
8207 ELSEIF(VIOL.GT.VINT(108)) THEN
8209 IF(VIOL.GT.1D0) THEN
8211 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8212 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
8214 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
8215 IF(KFPR(ISUB,1).LE.9) THEN
8216 WRITE(MSTU(11),5800) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8217 ELSEIF(KFPR(ISUB,1).LE.99) THEN
8218 WRITE(MSTU(11),5900) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8220 WRITE(MSTU(11),6000) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8223 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
8224 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
8225 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
8226 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
8227 & XSEC(0,1)=XSEC(0,1)+XDIF
8228 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8229 & VINT(22),VINT(23),VINT(26)
8231 WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
8232 ELSEIF(ISUB.LE.99) THEN
8233 WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
8235 WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
8242 C...Multiple interactions: choose impact parameter.
8244 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
8245 &MSTP(82).GE.3) THEN
8247 IF(VINT(150).LT.PYR(0)) THEN
8248 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8256 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
8257 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
8258 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
8259 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
8261 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
8263 C...Choose flavour of reacting partons (and subprocess).
8264 IF(ISTSB.GE.11) GOTO 320
8267 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
8268 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
8269 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
8270 &PYR(0).GT.RQQBAR)) THEN
8274 MINT(2)=ISIG(ICHN,3)
8275 RSIGS=RSIGS-SIGH(ICHN)
8276 IF(RSIGS.LE.0D0) GOTO 320
8279 C...Multiple interactions: choose qqbar preferentially at small pT.
8280 ELSEIF(ISUB.EQ.96) THEN
8283 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
8286 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
8289 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
8291 C...Low-pT: choose string drawing configuration.
8297 IF(RSIGS.GT.1D0) MINT(2)=2
8298 IF(RSIGS.GT.2D0) MINT(2)=3
8301 C...Reassign QCD process. Partons before initial state radiation.
8302 320 IF(MINT(2).GT.10) THEN
8304 MINT(2)=MOD(MINT(2),10)
8306 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
8317 C...Calculate x value of photon for parton inside photon inside e.
8322 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
8323 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
8324 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
8329 MINT(105)=MINT(102+JT)
8330 MINT(109)=MINT(106+JT)
8331 VINT(120)=VINT(2+JT)
8332 IF(MSTP(57).LE.1) THEN
8333 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
8335 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
8338 IF(MSTP(13).EQ.2) THEN
8339 Q2PMS=Q2HRD/PMAS(11,1)**2
8340 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
8343 XG=MIN(1D0-1D-10,XHRD/XE)
8344 IF(MSTP(57).LE.1) THEN
8345 CALL PYPDFU(22,XG,Q2HRD,XPQ)
8347 CALL PYPDFL(22,XG,Q2HRD,XPQ)
8349 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
8350 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
8351 IF(WT.LT.PYR(0)*WTMX) GOTO 330
8355 XSFX(JT,KFLS)=XPQ(KFLS)
8360 C...Pick scale where photon is resolved.
8364 IF(MINT(107).EQ.3) THEN
8365 IF(MSTP(66).EQ.1) THEN
8366 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
8367 ELSEIF(MSTP(66).EQ.2) THEN
8369 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8370 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8371 Q2INT=SQRT(Q0S*Q2EFF)
8372 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8373 ELSEIF(MSTP(66).EQ.3) THEN
8374 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
8375 ELSEIF(MSTP(66).GE.4) THEN
8376 PS=0.25D0*VINT(3)**2
8377 VINT(283)=(Q0S+PS)*(Q1S+PS)/
8378 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8382 IF(MINT(108).EQ.3) THEN
8383 IF(MSTP(66).EQ.1) THEN
8384 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
8385 ELSEIF(MSTP(66).EQ.2) THEN
8387 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8388 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8389 Q2INT=SQRT(Q0S*Q2EFF)
8390 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8391 ELSEIF(MSTP(66).EQ.3) THEN
8392 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
8393 ELSEIF(MSTP(66).GE.4) THEN
8394 PS=0.25D0*VINT(4)**2
8395 VINT(284)=(Q0S+PS)*(Q1S+PS)/
8396 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8399 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8401 C...Format statements for differential cross-section maximum violations.
8402 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
8403 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8404 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
8405 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
8406 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
8408 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
8409 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8410 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
8412 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
8413 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
8414 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
8415 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
8416 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
8417 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
8422 C*********************************************************************
8425 C...Finds outgoing flavours and event type; sets up the kinematics
8426 C...and colour flow of the hard scattering
8430 C...Double precision and integer declarations
8431 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8432 IMPLICIT INTEGER(I-N)
8433 INTEGER PYK,PYCHGE,PYCOMP
8434 C...Parameter statement to help give large particle numbers.
8435 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
8436 &KEXCIT=4000000,KDIMEN=5000000)
8438 C...User process event common block.
8440 PARAMETER (MAXNUP=500)
8441 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
8442 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
8443 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
8444 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
8445 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
8449 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8450 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8451 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8452 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
8453 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8454 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8455 COMMON/PYINT1/MINT(400),VINT(400)
8456 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8457 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8458 COMMON/PYINT4/MWID(500),WIDS(500,5)
8459 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8460 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
8461 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
8462 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
8463 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/
8464 C...Local arrays and saved variables
8465 DIMENSION WDTP(0:300),WDTE(0:300,0:5),PMQ(2),Z(2),CTHE(2),
8466 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
8469 C...Read out process
8473 C...Restore information for low-pT processes
8474 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
8476 100 VINT(J)=VINTSV(J)
8479 C...Convert H' or A process into equivalent H one
8482 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
8485 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
8487 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
8488 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
8489 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
8490 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
8491 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
8492 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
8493 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
8494 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
8495 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
8496 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
8497 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
8498 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
8501 C...Choice of subprocess, number of documentation lines
8503 IF(ISUB.EQ.95) IDOC=8
8504 IF(ISET(ISUB).EQ.5) IDOC=9
8505 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
8507 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
8516 C...Reset K, P and V vectors. Store incoming particles
8517 DO 120 JT=1,MSTP(126)+100
8519 IF(I.GT.MSTU(4)) GOTO 120
8531 P(I,J)=VINT(285+5*JT+J)
8537 C...Store incoming partons in their CM-frame
8540 SHP=VINT(26)*VINT(2)
8543 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
8548 K(I,3)=MINT(83)+2+JT
8549 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
8553 C...Copy incoming partons to documentation lines
8565 C...Choose new quark/lepton flavour for relevant annihilation graphs
8566 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
8567 &(ISUB.GE.135.AND.ISUB.LE.140)) THEN
8569 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
8570 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
8571 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
8572 DO 190 I=1,MDCY(IGLGA,3)
8573 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
8574 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
8575 IF(RKFL.LE.0D0) GOTO 200
8578 IF(ISUB.EQ.53.AND.MINT(2).LE.2) THEN
8579 IF(KFLF.GE.4) GOTO 180
8580 ELSEIF(ISUB.EQ.53.AND.MINT(2).LE.4) THEN
8583 ELSEIF(ISUB.EQ.53) THEN
8586 ELSEIF(ISUB.EQ.12.AND.MSTP(5).EQ.1.AND.IABS(MINT(15)).LE.2.AND.
8587 & IABS(KFLF).GE.3) THEN
8588 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
8590 FACCIB=VINT(46)**2/PARU(155)**4
8591 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
8592 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
8593 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
8594 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
8595 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
8599 C...Final state flavours and colour flow: default values
8606 KCS=ISIGN(1,MINT(15))
8608 IF(ISET(ISUB).EQ.11) THEN
8609 C...User-defined processes: find products
8612 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
8613 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
8614 MINT(21+IUP)=IDUP(IUP)
8615 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
8616 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
8617 ELSEIF(IDUP(IUP).EQ.0) THEN
8620 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
8624 ELSEIF(ISUB.LE.10) THEN
8626 C...f + fbar -> gamma*/Z0
8629 ELSEIF(ISUB.EQ.2) THEN
8630 C...f + fbar' -> W+/-
8631 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8632 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8633 KFRES=ISIGN(24,KCH1+KCH2)
8635 ELSEIF(ISUB.EQ.3) THEN
8636 C...f + fbar -> h0 (or H0, or A0)
8639 ELSEIF(ISUB.EQ.4) THEN
8640 C...gamma + W+/- -> W+/-
8642 ELSEIF(ISUB.EQ.5) THEN
8647 PMQ(1)=PYMASS(MINT(21))
8648 PMQ(2)=PYMASS(MINT(22))
8649 220 JT=INT(1.5D0+PYR(0))
8650 ZMIN=2D0*PMQ(JT)/SHPR
8651 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8652 & (SHPR*(SHPR-PMQ(3-JT)))
8653 ZMAX=MIN(1D0-XH,ZMAX)
8654 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8655 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8656 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
8657 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8658 IF(SQC1.LT.1D-8) GOTO 220
8660 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8661 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8662 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8663 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8664 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8665 IF(SQC1.LT.1D-8) GOTO 220
8667 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8668 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8669 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8672 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8673 & SQRT(1D0-CTHE(2)**2)*CPHI
8675 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8676 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8677 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8678 & PMQ(3-JT)**2/SHP))
8679 ZMIN=2D0*PMQ(3-JT)/SHPR
8680 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8681 ZMAX=MIN(1D0-XH,ZMAX)
8682 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
8686 ELSEIF(ISUB.EQ.6) THEN
8687 C...Z0 + W+/- -> W+/-
8689 ELSEIF(ISUB.EQ.7) THEN
8692 ELSEIF(ISUB.EQ.8) THEN
8699 RVCKM=VINT(180+I)*PYR(0)
8702 IPM=(5-ISIGN(1,I))/2
8704 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
8705 MINT(20+JT)=ISIGN(IB,I)
8706 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8707 IF(RVCKM.LE.0D0) GOTO 250
8710 IB=2*((IA+1)/2)-1+MOD(IA,2)
8711 MINT(20+JT)=ISIGN(IB,I)
8713 250 PMQ(JT)=PYMASS(MINT(20+JT))
8715 JT=INT(1.5D0+PYR(0))
8716 ZMIN=2D0*PMQ(JT)/SHPR
8717 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8718 & (SHPR*(SHPR-PMQ(3-JT)))
8719 ZMAX=MIN(1D0-XH,ZMAX)
8720 IF(ZMIN.GE.ZMAX) GOTO 230
8721 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8722 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8723 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
8724 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8725 IF(SQC1.LT.1D-8) GOTO 230
8727 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8728 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8729 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8730 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8731 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8732 IF(SQC1.LT.1D-8) GOTO 230
8734 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8735 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8736 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8739 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8740 & SQRT(1D0-CTHE(2)**2)*CPHI
8742 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8743 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8744 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8745 & PMQ(3-JT)**2/SHP))
8746 ZMIN=2D0*PMQ(3-JT)/SHPR
8747 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8748 ZMAX=MIN(1D0-XH,ZMAX)
8749 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
8753 ELSEIF(ISUB.EQ.10) THEN
8754 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
8755 IF(MINT(2).EQ.1) THEN
8758 C...W exchange: need to mix flavours according to CKM matrix
8763 RVCKM=VINT(180+I)*PYR(0)
8766 IPM=(5-ISIGN(1,I))/2
8768 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
8769 MINT(20+JT)=ISIGN(IB,I)
8770 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8771 IF(RVCKM.LE.0D0) GOTO 280
8774 IB=2*((IA+1)/2)-1+MOD(IA,2)
8775 MINT(20+JT)=ISIGN(IB,I)
8782 ELSEIF(ISUB.LE.20) THEN
8784 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
8786 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8788 ELSEIF(ISUB.EQ.12) THEN
8789 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
8790 MINT(21)=ISIGN(KFLF,MINT(15))
8794 ELSEIF(ISUB.EQ.13) THEN
8795 C...f + fbar -> g + g; th arbitrary
8800 ELSEIF(ISUB.EQ.14) THEN
8801 C...f + fbar -> g + gamma; th arbitrary
8802 IF(PYR(0).GT.0.5D0) JS=2
8807 ELSEIF(ISUB.EQ.15) THEN
8808 C...f + fbar -> g + Z0; th arbitrary
8809 IF(PYR(0).GT.0.5D0) JS=2
8814 ELSEIF(ISUB.EQ.16) THEN
8815 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8816 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8817 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8818 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8820 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8823 ELSEIF(ISUB.EQ.17) THEN
8824 C...f + fbar -> g + h0; th arbitrary
8825 IF(PYR(0).GT.0.5D0) JS=2
8830 ELSEIF(ISUB.EQ.18) THEN
8831 C...f + fbar -> gamma + gamma; th arbitrary
8835 ELSEIF(ISUB.EQ.19) THEN
8836 C...f + fbar -> gamma + Z0; th arbitrary
8837 IF(PYR(0).GT.0.5D0) JS=2
8841 ELSEIF(ISUB.EQ.20) THEN
8842 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
8843 C...(p(fbar')-p(W+))**2
8844 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8845 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8846 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8848 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8851 ELSEIF(ISUB.LE.30) THEN
8853 C...f + fbar -> gamma + h0; th arbitrary
8854 IF(PYR(0).GT.0.5D0) JS=2
8858 ELSEIF(ISUB.EQ.22) THEN
8859 C...f + fbar -> Z0 + Z0; th arbitrary
8863 ELSEIF(ISUB.EQ.23) THEN
8864 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8865 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8866 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8867 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8869 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8871 ELSEIF(ISUB.EQ.24) THEN
8872 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
8873 IF(PYR(0).GT.0.5D0) JS=2
8877 ELSEIF(ISUB.EQ.25) THEN
8878 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
8879 MINT(21)=-ISIGN(24,MINT(15))
8882 ELSEIF(ISUB.EQ.26) THEN
8883 C...f + fbar' -> W+/- + h0 (or H0, or A0);
8884 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8885 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8886 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8887 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
8888 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
8891 ELSEIF(ISUB.EQ.27) THEN
8892 C...f + fbar -> h0 + h0
8894 ELSEIF(ISUB.EQ.28) THEN
8895 C...f + g -> f + g; th = (p(f)-p(f))**2
8897 IF(MINT(15).EQ.21) KCC=KCC+2
8898 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
8899 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
8901 ELSEIF(ISUB.EQ.29) THEN
8902 C...f + g -> f + gamma; th = (p(f)-p(f))**2
8903 IF(MINT(15).EQ.21) JS=2
8906 KCS=ISIGN(1,MINT(14+JS))
8908 ELSEIF(ISUB.EQ.30) THEN
8909 C...f + g -> f + Z0; th = (p(f)-p(f))**2
8910 IF(MINT(15).EQ.21) JS=2
8913 KCS=ISIGN(1,MINT(14+JS))
8916 ELSEIF(ISUB.LE.40) THEN
8918 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
8919 IF(MINT(15).EQ.21) JS=2
8922 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
8923 RVCKM=VINT(180+I)*PYR(0)
8926 IPM=(5-ISIGN(1,I))/2
8928 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
8929 MINT(20+JS)=ISIGN(IB,I)
8930 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8931 IF(RVCKM.LE.0D0) GOTO 300
8934 KCS=ISIGN(1,MINT(14+JS))
8936 ELSEIF(ISUB.EQ.32) THEN
8937 C...f + g -> f + h0; th = (p(f)-p(f))**2
8938 IF(MINT(15).EQ.21) JS=2
8941 KCS=ISIGN(1,MINT(14+JS))
8943 ELSEIF(ISUB.EQ.33) THEN
8944 C...f + gamma -> f + g; th=(p(f)-p(f))**2
8945 IF(MINT(15).EQ.22) JS=2
8948 KCS=ISIGN(1,MINT(14+JS))
8950 ELSEIF(ISUB.EQ.34) THEN
8951 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
8952 IF(MINT(15).EQ.22) JS=2
8954 KCS=ISIGN(1,MINT(14+JS))
8956 ELSEIF(ISUB.EQ.35) THEN
8957 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
8958 IF(MINT(15).EQ.22) JS=2
8962 ELSEIF(ISUB.EQ.36) THEN
8963 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
8964 IF(MINT(15).EQ.22) JS=2
8967 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
8969 RVCKM=VINT(180+I)*PYR(0)
8972 IPM=(5-ISIGN(1,I))/2
8974 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
8975 MINT(20+JS)=ISIGN(IB,I)
8976 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8977 IF(RVCKM.LE.0D0) GOTO 320
8980 IB=2*((IA+1)/2)-1+MOD(IA,2)
8981 MINT(20+JS)=ISIGN(IB,I)
8985 ELSEIF(ISUB.EQ.37) THEN
8986 C...f + gamma -> f + h0
8988 ELSEIF(ISUB.EQ.38) THEN
8991 ELSEIF(ISUB.EQ.39) THEN
8992 C...f + Z0 -> f + gamma
8994 ELSEIF(ISUB.EQ.40) THEN
8995 C...f + Z0 -> f + Z0
8998 ELSEIF(ISUB.LE.50) THEN
9000 C...f + Z0 -> f' + W+/-
9002 ELSEIF(ISUB.EQ.42) THEN
9003 C...f + Z0 -> f + h0
9005 ELSEIF(ISUB.EQ.43) THEN
9006 C...f + W+/- -> f' + g
9008 ELSEIF(ISUB.EQ.44) THEN
9009 C...f + W+/- -> f' + gamma
9011 ELSEIF(ISUB.EQ.45) THEN
9012 C...f + W+/- -> f' + Z0
9014 ELSEIF(ISUB.EQ.46) THEN
9015 C...f + W+/- -> f' + W+/-
9017 ELSEIF(ISUB.EQ.47) THEN
9018 C...f + W+/- -> f' + h0
9020 ELSEIF(ISUB.EQ.48) THEN
9023 ELSEIF(ISUB.EQ.49) THEN
9024 C...f + h0 -> f + gamma
9026 ELSEIF(ISUB.EQ.50) THEN
9027 C...f + h0 -> f + Z0
9030 ELSEIF(ISUB.LE.60) THEN
9032 C...f + h0 -> f' + W+/-
9034 ELSEIF(ISUB.EQ.52) THEN
9035 C...f + h0 -> f + h0
9037 ELSEIF(ISUB.EQ.53) THEN
9038 C...g + g -> f + fbar; th arbitrary
9039 KCS=(-1)**INT(1.5D0+PYR(0))
9040 MINT(21)=ISIGN(KFLF,KCS)
9044 ELSEIF(ISUB.EQ.54) THEN
9045 C...g + gamma -> f + fbar; th arbitrary
9046 KCS=(-1)**INT(1.5D0+PYR(0))
9047 MINT(21)=ISIGN(KFLF,KCS)
9050 IF(MINT(16).EQ.21) KCC=28
9052 ELSEIF(ISUB.EQ.55) THEN
9053 C...g + Z0 -> f + fbar
9055 ELSEIF(ISUB.EQ.56) THEN
9056 C...g + W+/- -> f + fbar'
9058 ELSEIF(ISUB.EQ.57) THEN
9059 C...g + h0 -> f + fbar
9061 ELSEIF(ISUB.EQ.58) THEN
9062 C...gamma + gamma -> f + fbar; th arbitrary
9063 KCS=(-1)**INT(1.5D0+PYR(0))
9064 MINT(21)=ISIGN(KFLF,KCS)
9068 ELSEIF(ISUB.EQ.59) THEN
9069 C...gamma + Z0 -> f + fbar
9071 ELSEIF(ISUB.EQ.60) THEN
9072 C...gamma + W+/- -> f + fbar'
9075 ELSEIF(ISUB.LE.70) THEN
9077 C...gamma + h0 -> f + fbar
9079 ELSEIF(ISUB.EQ.62) THEN
9080 C...Z0 + Z0 -> f + fbar
9082 ELSEIF(ISUB.EQ.63) THEN
9083 C...Z0 + W+/- -> f + fbar'
9085 ELSEIF(ISUB.EQ.64) THEN
9086 C...Z0 + h0 -> f + fbar
9088 ELSEIF(ISUB.EQ.65) THEN
9089 C...W+ + W- -> f + fbar
9091 ELSEIF(ISUB.EQ.66) THEN
9092 C...W+/- + h0 -> f + fbar'
9094 ELSEIF(ISUB.EQ.67) THEN
9095 C...h0 + h0 -> f + fbar
9097 ELSEIF(ISUB.EQ.68) THEN
9098 C...g + g -> g + g; th arbitrary
9100 KCS=(-1)**INT(1.5D0+PYR(0))
9102 ELSEIF(ISUB.EQ.69) THEN
9103 C...gamma + gamma -> W+ + W-; th arbitrary
9108 ELSEIF(ISUB.EQ.70) THEN
9109 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
9110 IF(MINT(15).EQ.22) MINT(21)=23
9111 IF(MINT(16).EQ.22) MINT(22)=23
9115 ELSEIF(ISUB.LE.80) THEN
9116 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
9117 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
9121 PMQ(1)=PYMASS(MINT(21))
9122 PMQ(2)=PYMASS(MINT(22))
9123 330 JT=INT(1.5D0+PYR(0))
9124 ZMIN=2D0*PMQ(JT)/SHPR
9125 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9126 & (SHPR*(SHPR-PMQ(3-JT)))
9127 ZMAX=MIN(1D0-XH,ZMAX)
9128 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9129 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9130 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
9131 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9132 IF(SQC1.LT.1D-8) GOTO 330
9134 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9135 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9136 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9137 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9138 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9139 IF(SQC1.LT.1D-8) GOTO 330
9141 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9142 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9143 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9146 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9147 & SQRT(1D0-CTHE(2)**2)*CPHI
9149 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9150 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9151 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9152 & PMQ(3-JT)**2/SHP))
9153 ZMIN=2D0*PMQ(3-JT)/SHPR
9154 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9155 ZMAX=MIN(1D0-XH,ZMAX)
9156 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
9159 ELSEIF(ISUB.EQ.73) THEN
9160 C...Z0 + W+/- -> Z0 + W+/-
9167 RVCKM=VINT(180+I)*PYR(0)
9170 IPM=(5-ISIGN(1,I))/2
9172 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
9173 MINT(20+JT)=ISIGN(IB,I)
9174 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9175 IF(RVCKM.LE.0D0) GOTO 360
9178 IB=2*((IA+1)/2)-1+MOD(IA,2)
9179 MINT(20+JT)=ISIGN(IB,I)
9181 360 PMQ(JT)=PYMASS(MINT(20+JT))
9182 MINT(23-JT)=MINT(17-JT)
9183 PMQ(3-JT)=PYMASS(MINT(23-JT))
9184 JT=INT(1.5D0+PYR(0))
9185 ZMIN=2D0*PMQ(JT)/SHPR
9186 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9187 & (SHPR*(SHPR-PMQ(3-JT)))
9188 ZMAX=MIN(1D0-XH,ZMAX)
9189 IF(ZMIN.GE.ZMAX) GOTO 340
9190 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9191 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9192 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
9193 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9194 IF(SQC1.LT.1D-8) GOTO 340
9196 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9197 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9198 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9199 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9200 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9201 IF(SQC1.LT.1D-8) GOTO 340
9203 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9204 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9205 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9208 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9209 & SQRT(1D0-CTHE(2)**2)*CPHI
9211 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9212 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9213 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9214 & PMQ(3-JT)**2/SHP))
9215 ZMIN=2D0*PMQ(3-JT)/SHPR
9216 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9217 ZMAX=MIN(1D0-XH,ZMAX)
9218 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
9221 ELSEIF(ISUB.EQ.74) THEN
9222 C...Z0 + h0 -> Z0 + h0
9224 ELSEIF(ISUB.EQ.75) THEN
9225 C...W+ + W- -> gamma + gamma
9227 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
9228 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
9234 RVCKM=VINT(180+I)*PYR(0)
9237 IPM=(5-ISIGN(1,I))/2
9239 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
9240 MINT(20+JT)=ISIGN(IB,I)
9241 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9242 IF(RVCKM.LE.0D0) GOTO 390
9245 IB=2*((IA+1)/2)-1+MOD(IA,2)
9246 MINT(20+JT)=ISIGN(IB,I)
9248 390 PMQ(JT)=PYMASS(MINT(20+JT))
9250 JT=INT(1.5D0+PYR(0))
9251 ZMIN=2D0*PMQ(JT)/SHPR
9252 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9253 & (SHPR*(SHPR-PMQ(3-JT)))
9254 ZMAX=MIN(1D0-XH,ZMAX)
9255 IF(ZMIN.GE.ZMAX) GOTO 370
9256 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9257 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9258 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
9259 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9260 IF(SQC1.LT.1D-8) GOTO 370
9262 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9263 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9264 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9265 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9266 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9267 IF(SQC1.LT.1D-8) GOTO 370
9269 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9270 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9271 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9274 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9275 & SQRT(1D0-CTHE(2)**2)*CPHI
9277 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9278 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9279 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9280 & PMQ(3-JT)**2/SHP))
9281 ZMIN=2D0*PMQ(3-JT)/SHPR
9282 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9283 ZMAX=MIN(1D0-XH,ZMAX)
9284 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
9287 ELSEIF(ISUB.EQ.78) THEN
9288 C...W+/- + h0 -> W+/- + h0
9290 ELSEIF(ISUB.EQ.79) THEN
9291 C...h0 + h0 -> h0 + h0
9293 ELSEIF(ISUB.EQ.80) THEN
9294 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
9295 IF(MINT(15).EQ.22) JS=2
9298 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
9300 MINT(20+JS)=ISIGN(IB,I)
9304 ELSEIF(ISUB.LE.90) THEN
9306 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
9307 MINT(21)=ISIGN(MINT(55),MINT(15))
9311 ELSEIF(ISUB.EQ.82) THEN
9312 C...g + g -> Q + Qbar; th arbitrary
9313 KCS=(-1)**INT(1.5D0+PYR(0))
9314 MINT(21)=ISIGN(MINT(55),KCS)
9318 ELSEIF(ISUB.EQ.83) THEN
9319 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
9321 IF(MINT(2).EQ.2) KFOLD=MINT(15)
9323 IF(KFAOLD.GT.10) THEN
9324 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
9326 RCKM=VINT(180+KFOLD)*PYR(0)
9327 IPM=(5-ISIGN(1,KFOLD))/2
9328 KFANEW=-MOD(KFAOLD+1,2)
9330 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
9331 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
9332 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
9333 & VCKM(KFAOLD/2,(KFANEW+1)/2)
9334 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
9335 & VCKM(KFANEW/2,(KFAOLD+1)/2)
9337 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
9339 IF(MINT(2).EQ.1) THEN
9340 MINT(21)=ISIGN(MINT(55),MINT(15))
9341 MINT(22)=ISIGN(KFANEW,MINT(16))
9343 MINT(21)=ISIGN(KFANEW,MINT(15))
9344 MINT(22)=ISIGN(MINT(55),MINT(16))
9349 ELSEIF(ISUB.EQ.84) THEN
9350 C...g + gamma -> Q + Qbar; th arbitary
9351 KCS=(-1)**INT(1.5D0+PYR(0))
9352 MINT(21)=ISIGN(MINT(55),KCS)
9355 IF(MINT(16).EQ.21) KCC=28
9357 ELSEIF(ISUB.EQ.85) THEN
9358 C...gamma + gamma -> F + Fbar; th arbitary
9359 KCS=(-1)**INT(1.5D0+PYR(0))
9360 MINT(21)=ISIGN(MINT(56),KCS)
9364 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
9365 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
9366 MINT(21)=KFPR(ISUB,1)
9367 MINT(22)=KFPR(ISUB,2)
9369 KCS=(-1)**INT(1.5D0+PYR(0))
9372 ELSEIF(ISUB.LE.100) THEN
9374 C...Low-pT ( = energyless g + g -> g + g)
9376 KCS=(-1)**INT(1.5D0+PYR(0))
9378 ELSEIF(ISUB.EQ.96) THEN
9379 C...Multiple interactions (should be reassigned to QCD process)
9382 ELSEIF(ISUB.LE.110) THEN
9383 IF(ISUB.EQ.101) THEN
9384 C...g + g -> gamma*/Z0
9388 ELSEIF(ISUB.EQ.102) THEN
9389 C...g + g -> h0 (or H0, or A0)
9393 ELSEIF(ISUB.EQ.103) THEN
9394 C...gamma + gamma -> h0 (or H0, or A0)
9398 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
9399 C...g + g -> chi_0c or chi_2c.
9403 ELSEIF(ISUB.EQ.106) THEN
9404 C...g + g -> J/Psi + gamma
9405 MINT(21)=KFPR(ISUB,1)
9406 MINT(22)=KFPR(ISUB,2)
9409 ELSEIF(ISUB.EQ.107) THEN
9410 C...g + gamma -> J/Psi + g
9411 MINT(21)=KFPR(ISUB,1)
9412 MINT(22)=KFPR(ISUB,2)
9414 IF(MINT(16).EQ.22) KCC=33
9416 ELSEIF(ISUB.EQ.108) THEN
9417 C...gamma + gamma -> J/Psi + gamma
9418 MINT(21)=KFPR(ISUB,1)
9419 MINT(22)=KFPR(ISUB,2)
9421 ELSEIF(ISUB.EQ.110) THEN
9422 C...f + fbar -> gamma + h0; th arbitrary
9423 IF(PYR(0).GT.0.5D0) JS=2
9428 ELSEIF(ISUB.LE.120) THEN
9429 IF(ISUB.EQ.111) THEN
9430 C...f + fbar -> g + h0; th arbitrary
9431 IF(PYR(0).GT.0.5D0) JS=2
9436 ELSEIF(ISUB.EQ.112) THEN
9437 C...f + g -> f + h0; th = (p(f) - p(f))**2
9438 IF(MINT(15).EQ.21) JS=2
9441 KCS=ISIGN(1,MINT(14+JS))
9443 ELSEIF(ISUB.EQ.113) THEN
9444 C...g + g -> g + h0; th arbitrary
9445 IF(PYR(0).GT.0.5D0) JS=2
9448 KCS=(-1)**INT(1.5D0+PYR(0))
9450 ELSEIF(ISUB.EQ.114) THEN
9451 C...g + g -> gamma + gamma; th arbitrary
9452 IF(PYR(0).GT.0.5D0) JS=2
9457 ELSEIF(ISUB.EQ.115) THEN
9458 C...g + g -> g + gamma; th arbitrary
9459 IF(PYR(0).GT.0.5D0) JS=2
9462 KCS=(-1)**INT(1.5D0+PYR(0))
9464 ELSEIF(ISUB.EQ.116) THEN
9465 C...g + g -> gamma + Z0
9467 ELSEIF(ISUB.EQ.117) THEN
9468 C...g + g -> Z0 + Z0
9470 ELSEIF(ISUB.EQ.118) THEN
9471 C...g + g -> W+ + W-
9474 ELSEIF(ISUB.LE.140) THEN
9475 IF(ISUB.EQ.121) THEN
9476 C...g + g -> Q + Qbar + h0
9477 KCS=(-1)**INT(1.5D0+PYR(0))
9478 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
9480 KCC=11+INT(0.5D0+PYR(0))
9483 ELSEIF(ISUB.EQ.122) THEN
9484 C...q + qbar -> Q + Qbar + h0
9485 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
9490 ELSEIF(ISUB.EQ.123) THEN
9491 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
9496 ELSEIF(ISUB.EQ.124) THEN
9497 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
9503 RVCKM=VINT(180+I)*PYR(0)
9506 IPM=(5-ISIGN(1,I))/2
9508 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
9509 MINT(20+JT)=ISIGN(IB,I)
9510 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9511 IF(RVCKM.LE.0D0) GOTO 430
9514 IB=2*((IA+1)/2)-1+MOD(IA,2)
9515 MINT(20+JT)=ISIGN(IB,I)
9521 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
9522 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
9523 IF(MINT(15).EQ.22) JS=2
9526 KCS=ISIGN(1,MINT(14+JS))
9528 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
9529 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
9530 IF(MINT(15).EQ.22) JS=2
9532 KCS=ISIGN(1,MINT(14+JS))
9534 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
9535 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
9536 KCS=(-1)**INT(1.5D0+PYR(0))
9537 MINT(21)=ISIGN(KFLF,KCS)
9540 IF(MINT(16).EQ.21) KCC=28
9542 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
9543 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
9544 KCS=(-1)**INT(1.5D0+PYR(0))
9545 MINT(21)=ISIGN(KFLF,KCS)
9551 ELSEIF(ISUB.LE.160) THEN
9552 IF(ISUB.EQ.141) THEN
9553 C...f + fbar -> gamma*/Z0/Z'0
9556 ELSEIF(ISUB.EQ.142) THEN
9557 C...f + fbar' -> W'+/-
9558 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9559 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9560 KFRES=ISIGN(34,KCH1+KCH2)
9562 ELSEIF(ISUB.EQ.143) THEN
9563 C...f + fbar' -> H+/-
9564 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9565 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9566 KFRES=ISIGN(37,KCH1+KCH2)
9568 ELSEIF(ISUB.EQ.144) THEN
9570 KFRES=ISIGN(41,MINT(15)+MINT(16))
9572 ELSEIF(ISUB.EQ.145) THEN
9573 C...q + l -> LQ (leptoquark)
9574 IF(IABS(MINT(16)).LE.8) JS=2
9575 KFRES=ISIGN(42,MINT(14+JS))
9577 KCS=ISIGN(1,MINT(14+JS))
9579 ELSEIF(ISUB.EQ.146) THEN
9580 C...e + gamma -> e* (excited lepton)
9581 IF(MINT(15).EQ.22) JS=2
9582 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9585 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
9586 C...q + g -> q* (excited quark)
9587 IF(MINT(15).EQ.21) JS=2
9588 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9590 KCS=ISIGN(1,MINT(14+JS))
9592 ELSEIF(ISUB.EQ.149) THEN
9596 KCS=(-1)**INT(1.5D0+PYR(0))
9599 ELSEIF(ISUB.LE.200) THEN
9600 IF(ISUB.EQ.161) THEN
9601 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
9602 IF(MINT(15).EQ.21) JS=2
9605 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
9606 IB=IA+MOD(IA,2)-MOD(IA+1,2)
9607 MINT(20+JS)=ISIGN(IB,I)
9609 KCS=ISIGN(1,MINT(14+JS))
9611 ELSEIF(ISUB.EQ.162) THEN
9612 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
9613 IF(MINT(15).EQ.21) JS=2
9614 MINT(20+JS)=ISIGN(42,MINT(14+JS))
9615 KFLQL=KFDP(MDCY(42,2),2)
9616 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
9618 KCS=ISIGN(1,MINT(14+JS))
9620 ELSEIF(ISUB.EQ.163) THEN
9621 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
9622 KCS=(-1)**INT(1.5D0+PYR(0))
9623 MINT(21)=ISIGN(42,KCS)
9627 ELSEIF(ISUB.EQ.164) THEN
9628 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
9629 MINT(21)=ISIGN(42,MINT(15))
9633 ELSEIF(ISUB.EQ.165) THEN
9634 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
9635 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9638 ELSEIF(ISUB.EQ.166) THEN
9639 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9640 IF(MOD(MINT(15),2).EQ.0) THEN
9641 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9642 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9644 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9645 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9648 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
9649 C...q + q' -> q" + q* (excited quark)
9651 KFQEXC=MOD(KFQSTR,KEXCIT)
9653 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9654 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
9655 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9659 ELSEIF(ISUB.EQ.169) THEN
9660 C...q + qbar -> e + e* (excited lepton)
9662 KFQEXC=MOD(KFQSTR,KEXCIT)
9664 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9665 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9668 ELSEIF(ISUB.EQ.191) THEN
9669 C...f + fbar -> rho_tc0.
9672 ELSEIF(ISUB.EQ.192) THEN
9673 C...f + fbar' -> rho_tc+/-
9674 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9675 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9676 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
9678 ELSEIF(ISUB.EQ.193) THEN
9679 C...f + fbar -> omega_tc0.
9682 ELSEIF(ISUB.EQ.194) THEN
9683 C...f + fbar -> f' + fbar' via mixture of s-channel
9684 C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
9685 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9688 ELSEIF(ISUB.EQ.195) THEN
9689 C...f + fbar' -> f'' + fbar''' via s-channel
9690 C...rho_tc+ th=(p(f)-p(f'))**2
9691 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9692 IF(MOD(MINT(15),2).EQ.0) THEN
9693 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9694 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9696 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9697 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9702 ELSEIF(ISUB.LE.215) THEN
9703 IF(ISUB.EQ.201) THEN
9704 C...f + fbar -> ~e_L + ~e_Lbar
9705 MINT(21)=ISIGN(KSUSY1+11,KCS)
9708 ELSEIF(ISUB.EQ.202) THEN
9709 C...f + fbar -> ~e_R + ~e_Rbar
9710 MINT(21)=ISIGN(KSUSY2+11,KCS)
9713 ELSEIF(ISUB.EQ.203) THEN
9714 C...f + fbar -> ~e_L + ~e_Rbar
9716 IF(MINT(2).EQ.2) KCS=-1
9724 MINT(21)=ISIGN(KS1,MINT(15))
9725 MINT(22)=ISIGN(KS2,MINT(16))
9728 c IF(MINT(2).EQ.2) KCS=-1
9729 C MINT(21)=ISIGN(KSUSY1+11,KCS)
9730 C MINT(22)=-ISIGN(KSUSY2+11,KCS)
9731 c IF(KCS.EQ.-1) THEN
9736 c MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9737 c MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
9739 ELSEIF(ISUB.EQ.204) THEN
9740 C...f + fbar -> ~mu_L + ~mu_Lbar
9741 MINT(21)=ISIGN(KSUSY1+13,KCS)
9744 ELSEIF(ISUB.EQ.205) THEN
9745 C...f + fbar -> ~mu_R + ~mu_Rbar
9746 MINT(21)=ISIGN(KSUSY2+13,KCS)
9749 ELSEIF(ISUB.EQ.206) THEN
9750 C...f + fbar -> ~mu_L + ~mu_Rbar
9752 IF(MINT(2).EQ.2) KCS=-1
9760 MINT(21)=ISIGN(KS1,MINT(15))
9761 MINT(22)=ISIGN(KS2,MINT(16))
9762 c MINT(21)=ISIGN(KSUSY1+13,KCS)
9763 c MINT(22)=-ISIGN(KSUSY2+13,KCS)
9765 ELSEIF(ISUB.EQ.207) THEN
9766 C...f + fbar -> ~tau_1 + ~tau_1bar
9767 MINT(21)=ISIGN(KSUSY1+15,KCS)
9770 ELSEIF(ISUB.EQ.208) THEN
9771 C...f + fbar -> ~tau_2 + ~tau_2bar
9772 MINT(21)=ISIGN(KSUSY2+15,KCS)
9775 ELSEIF(ISUB.EQ.209) THEN
9776 C...f + fbar -> ~tau_1 + ~tau_2bar
9778 IF(MINT(2).EQ.2) KCS=-1
9786 MINT(21)=ISIGN(KS1,MINT(15))
9787 MINT(22)=ISIGN(KS2,MINT(16))
9788 C KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9789 C IF(MINT(2).EQ.1) THEN
9790 C MINT(21)= ISIGN(KSUSY1+15,KCH1)
9791 C MINT(22)= -ISIGN(KSUSY2+15,KCH1)
9793 C MINT(21)= ISIGN(KSUSY2+15,KCH1)
9794 C MINT(22)= -ISIGN(KSUSY1+15,KCH1)
9798 ELSEIF(ISUB.EQ.210) THEN
9799 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
9800 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9801 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9802 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
9803 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
9805 ELSEIF(ISUB.EQ.211) THEN
9806 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
9807 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9808 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9809 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
9810 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9812 ELSEIF(ISUB.EQ.212) THEN
9813 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
9814 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9815 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9816 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
9817 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9819 ELSEIF(ISUB.EQ.213) THEN
9820 C...f + fbar -> ~nul + ~nulbar
9821 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9824 ELSEIF(ISUB.EQ.214) THEN
9825 C...f + fbar -> ~nutau + ~nutaubar
9826 MINT(21)=ISIGN(KSUSY1+16,KCS)
9830 ELSEIF(ISUB.LE.225) THEN
9831 IF(ISUB.EQ.216) THEN
9832 C...f + fbar -> ~chi01 + ~chi01
9836 ELSEIF(ISUB.EQ.217) THEN
9837 C...f + fbar -> ~chi02 + ~chi02
9841 ELSEIF(ISUB.EQ.218 ) THEN
9842 C...f + fbar -> ~chi03 + ~chi03
9846 ELSEIF(ISUB.EQ.219 ) THEN
9847 C...f + fbar -> ~chi04 + ~chi04
9851 ELSEIF(ISUB.EQ.220 ) THEN
9852 C...f + fbar -> ~chi01 + ~chi02
9853 IF(MINT(15).LT.0) JS=2
9854 C IF(PYR(0).GT.0.5D0) JS=2
9855 MINT(20+JS)=KSUSY1+22
9856 MINT(23-JS)=KSUSY1+23
9858 ELSEIF(ISUB.EQ.221 ) THEN
9859 C...f + fbar -> ~chi01 + ~chi03
9860 IF(MINT(15).LT.0) JS=2
9861 C IF(PYR(0).GT.0.5D0) JS=2
9862 MINT(20+JS)=KSUSY1+22
9863 MINT(23-JS)=KSUSY1+25
9865 ELSEIF(ISUB.EQ.222) THEN
9866 C...f + fbar -> ~chi01 + ~chi04
9867 IF(MINT(15).LT.0) JS=2
9868 C IF(PYR(0).GT.0.5D0) JS=2
9869 MINT(20+JS)=KSUSY1+22
9870 MINT(23-JS)=KSUSY1+35
9872 ELSEIF(ISUB.EQ.223) THEN
9873 C...f + fbar -> ~chi02 + ~chi03
9874 IF(MINT(15).LT.0) JS=2
9875 C IF(PYR(0).GT.0.5D0) JS=2
9876 MINT(20+JS)=KSUSY1+23
9877 MINT(23-JS)=KSUSY1+25
9879 ELSEIF(ISUB.EQ.224) THEN
9880 C...f + fbar -> ~chi02 + ~chi04
9881 IF(MINT(15).LT.0) JS=2
9882 C IF(PYR(0).GT.0.5D0) JS=2
9883 MINT(20+JS)=KSUSY1+23
9884 MINT(23-JS)=KSUSY1+35
9886 ELSEIF(ISUB.EQ.225) THEN
9887 C...f + fbar -> ~chi03 + ~chi04
9888 IF(MINT(15).LT.0) JS=2
9889 C IF(PYR(0).GT.0.5D0) JS=2
9890 MINT(20+JS)=KSUSY1+25
9891 MINT(23-JS)=KSUSY1+35
9894 ELSEIF(ISUB.LE.236) THEN
9895 IF(ISUB.EQ.226) THEN
9896 C...f + fbar -> ~chi+-1 + ~chi-+1
9897 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
9898 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9899 MINT(21)=ISIGN(KSUSY1+24,KCH1)
9902 ELSEIF(ISUB.EQ.227) THEN
9903 C...f + fbar -> ~chi+-2 + ~chi-+2
9904 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9905 MINT(21)=ISIGN(KSUSY1+37,KCH1)
9908 ELSEIF(ISUB.EQ.228) THEN
9909 C...f + fbar -> ~chi+-1 + ~chi-+2
9910 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
9911 C...js=1 if pyr<.5, js=2 if pyr>.5
9912 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
9913 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
9914 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
9915 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
9916 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9918 IF(MINT(2).EQ.1) THEN
9919 MINT(21)= ISIGN(KSUSY1+24,KCH1)
9920 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
9921 c IF(KCH2.EQ.0) JS=2
9923 MINT(21)= ISIGN(KSUSY1+37,KCH1)
9924 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
9926 c IF(KCH2.EQ.1) JS=2
9929 ELSEIF(ISUB.EQ.229) THEN
9930 C...q + qbar' -> ~chi01 + ~chi+-1
9931 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
9932 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9933 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9935 IF(MOD(MINT(15),2).EQ.0) JS=2
9936 MINT(20+JS)=KSUSY1+22
9937 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9939 ELSEIF(ISUB.EQ.230) THEN
9940 C...q + qbar' -> ~chi02 + ~chi+-1
9941 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9942 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9943 IF(MOD(MINT(15),2).EQ.0) JS=2
9944 MINT(20+JS)=KSUSY1+23
9945 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9947 ELSEIF(ISUB.EQ.231) THEN
9948 C...q + qbar' -> ~chi03 + ~chi+-1
9949 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9950 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9951 IF(MOD(MINT(15),2).EQ.0) JS=2
9952 MINT(20+JS)=KSUSY1+25
9953 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9955 ELSEIF(ISUB.EQ.232) THEN
9956 C...q + qbar' -> ~chi04 + ~chi+-1
9957 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9958 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9959 IF(MOD(MINT(15),2).EQ.0) JS=2
9960 MINT(20+JS)=KSUSY1+35
9961 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
9963 ELSEIF(ISUB.EQ.233) THEN
9964 C...q + qbar' -> ~chi01 + ~chi+-2
9965 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9966 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9967 IF(MOD(MINT(15),2).EQ.0) JS=2
9968 MINT(20+JS)=KSUSY1+22
9969 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9971 ELSEIF(ISUB.EQ.234) THEN
9972 C...q + qbar' -> ~chi02 + ~chi+-2
9973 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9974 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9975 IF(MOD(MINT(15),2).EQ.0) JS=2
9976 MINT(20+JS)=KSUSY1+23
9977 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9979 ELSEIF(ISUB.EQ.235) THEN
9980 C...q + qbar' -> ~chi03 + ~chi+-2
9981 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9982 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9983 IF(MOD(MINT(15),2).EQ.0) JS=2
9984 MINT(20+JS)=KSUSY1+25
9985 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9987 ELSEIF(ISUB.EQ.236) THEN
9988 C...q + qbar' -> ~chi04 + ~chi+-2
9989 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9990 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9991 IF(MOD(MINT(15),2).EQ.0) JS=2
9992 MINT(20+JS)=KSUSY1+35
9993 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
9996 ELSEIF(ISUB.LE.245) THEN
9997 IF(ISUB.EQ.237) THEN
9998 C...q + qbar -> ~chi01 + ~g
10000 IF(PYR(0).GT.0.5D0) JS=2
10001 MINT(20+JS)=KSUSY1+21
10002 MINT(23-JS)=KSUSY1+22
10005 ELSEIF(ISUB.EQ.238) THEN
10006 C...q + qbar -> ~chi02 + ~g
10008 IF(PYR(0).GT.0.5D0) JS=2
10009 MINT(20+JS)=KSUSY1+21
10010 MINT(23-JS)=KSUSY1+23
10013 ELSEIF(ISUB.EQ.239) THEN
10014 C...q + qbar -> ~chi03 + ~g
10016 IF(PYR(0).GT.0.5D0) JS=2
10017 MINT(20+JS)=KSUSY1+21
10018 MINT(23-JS)=KSUSY1+25
10021 ELSEIF(ISUB.EQ.240) THEN
10022 C...q + qbar -> ~chi04 + ~g
10024 IF(PYR(0).GT.0.5D0) JS=2
10025 MINT(20+JS)=KSUSY1+21
10026 MINT(23-JS)=KSUSY1+35
10029 ELSEIF(ISUB.EQ.241) THEN
10030 C...q + qbar' -> ~chi+-1 + ~g
10031 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10032 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10033 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10034 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10035 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10036 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10037 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10039 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10040 MINT(20+JS)=KSUSY1+21
10041 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10044 ELSEIF(ISUB.EQ.242) THEN
10045 C...q + qbar' -> ~chi+-2 + ~g
10046 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10047 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10048 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10049 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10050 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10051 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10052 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10054 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10055 MINT(20+JS)=KSUSY1+21
10056 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10059 ELSEIF(ISUB.EQ.243) THEN
10060 C...q + qbar -> ~g + ~g ; th arbitrary
10065 ELSEIF(ISUB.EQ.244) THEN
10066 C...g + g -> ~g + ~g ; th arbitrary
10068 KCS=(-1)**INT(1.5D0+PYR(0))
10073 ELSEIF(ISUB.LE.260) THEN
10074 IF(ISUB.EQ.246) THEN
10075 C...qj + g -> ~qj_L + ~chi01
10076 IF(MINT(15).EQ.21) JS=2
10079 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10080 MINT(23-JS)=KSUSY1+22
10082 KCS=ISIGN(1,MINT(14+JS))
10084 ELSEIF(ISUB.EQ.247) THEN
10085 C...qj + g -> ~qj_R + ~chi01
10086 IF(MINT(15).EQ.21) JS=2
10089 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10090 MINT(23-JS)=KSUSY1+22
10092 KCS=ISIGN(1,MINT(14+JS))
10094 ELSEIF(ISUB.EQ.248) THEN
10095 C...qj + g -> ~qj_L + ~chi02
10096 IF(MINT(15).EQ.21) JS=2
10099 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10100 MINT(23-JS)=KSUSY1+23
10102 KCS=ISIGN(1,MINT(14+JS))
10104 ELSEIF(ISUB.EQ.249) THEN
10105 C...qj + g -> ~qj_R + ~chi02
10106 IF(MINT(15).EQ.21) JS=2
10109 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10110 MINT(23-JS)=KSUSY1+23
10112 KCS=ISIGN(1,MINT(14+JS))
10114 ELSEIF(ISUB.EQ.250) THEN
10115 C...qj + g -> ~qj_L + ~chi03
10116 IF(MINT(15).EQ.21) JS=2
10119 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10120 MINT(23-JS)=KSUSY1+25
10122 KCS=ISIGN(1,MINT(14+JS))
10124 ELSEIF(ISUB.EQ.251) THEN
10125 C...qj + g -> ~qj_R + ~chi03
10126 IF(MINT(15).EQ.21) JS=2
10129 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10130 MINT(23-JS)=KSUSY1+25
10132 KCS=ISIGN(1,MINT(14+JS))
10134 ELSEIF(ISUB.EQ.252) THEN
10135 C...qj + g -> ~qj_L + ~chi04
10136 IF(MINT(15).EQ.21) JS=2
10139 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10140 MINT(23-JS)=KSUSY1+35
10142 KCS=ISIGN(1,MINT(14+JS))
10144 ELSEIF(ISUB.EQ.253) THEN
10145 C...qj + g -> ~qj_R + ~chi04
10146 IF(MINT(15).EQ.21) JS=2
10149 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10150 MINT(23-JS)=KSUSY1+35
10152 KCS=ISIGN(1,MINT(14+JS))
10154 ELSEIF(ISUB.EQ.254) THEN
10155 C...qj + g -> ~qk_L + ~chi+-1
10156 IF(MINT(15).EQ.21) JS=2
10159 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10160 IB=-IA+INT((IA+1)/2)*4-1
10161 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10163 KCS=ISIGN(1,MINT(14+JS))
10165 ELSEIF(ISUB.EQ.255) THEN
10166 C...qj + g -> ~qk_L + ~chi+-1
10167 IF(MINT(15).EQ.21) JS=2
10170 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10171 IB=-IA+INT((IA+1)/2)*4-1
10172 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10174 KCS=ISIGN(1,MINT(14+JS))
10176 ELSEIF(ISUB.EQ.256) THEN
10177 C...qj + g -> ~qk_L + ~chi+-2
10178 IF(MINT(15).EQ.21) JS=2
10181 IB=-IA+INT((IA+1)/2)*4-1
10182 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10183 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10185 KCS=ISIGN(1,MINT(14+JS))
10187 ELSEIF(ISUB.EQ.257) THEN
10188 C...qj + g -> ~qk_R + ~chi+-2
10189 IF(MINT(15).EQ.21) JS=2
10192 IB=-IA+INT((IA+1)/2)*4-1
10193 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10194 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10196 KCS=ISIGN(1,MINT(14+JS))
10198 ELSEIF(ISUB.EQ.258) THEN
10199 C...qj + g -> ~qj_L + ~g
10200 IF(MINT(15).EQ.21) JS=2
10203 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10204 MINT(23-JS)=KSUSY1+21
10206 IF(JS.EQ.2) KCC=KCC+2
10209 ELSEIF(ISUB.EQ.259) THEN
10210 C...qj + g -> ~qj_R + ~g
10211 IF(MINT(15).EQ.21) JS=2
10214 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10215 MINT(23-JS)=KSUSY1+21
10217 IF(JS.EQ.2) KCC=KCC+2
10221 ELSEIF(ISUB.LE.270) THEN
10222 IF(ISUB.EQ.261) THEN
10223 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
10225 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10226 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10228 C...Correct color combination
10229 IF(MINT(43).EQ.4) KCC=4
10231 ELSEIF(ISUB.EQ.262) THEN
10232 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
10234 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10235 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10237 C...Correct color combination
10238 IF(MINT(43).EQ.4) KCC=4
10240 ELSEIF(ISUB.EQ.263) THEN
10241 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
10242 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
10243 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
10244 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10245 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
10248 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
10249 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
10251 C...Correct color combination
10252 IF(MINT(43).EQ.4) KCC=4
10254 ELSEIF(ISUB.EQ.264) THEN
10255 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
10256 KCS=(-1)**INT(1.5D0+PYR(0))
10257 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10261 ELSEIF(ISUB.EQ.265) THEN
10262 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
10263 KCS=(-1)**INT(1.5D0+PYR(0))
10264 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10269 ELSEIF(ISUB.LE.296) THEN
10270 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
10271 C...qi + qj -> ~qi_L + ~qj_L
10273 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10274 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10275 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10277 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
10278 C...qi + qj -> ~qi_R + ~qj_R
10280 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10281 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10282 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10284 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
10285 C...qi + qj -> ~qi_L + ~qj_R
10286 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10287 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10289 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10291 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
10292 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
10293 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10294 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10296 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10298 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
10299 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10300 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10301 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10303 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10305 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
10306 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10307 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10308 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10310 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10312 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
10313 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
10315 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10316 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10318 IF(MINT(43).EQ.4) KCC=4
10320 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
10321 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
10323 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10324 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10326 IF(MINT(43).EQ.4) KCC=4
10328 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
10329 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
10331 KCS=(-1)**INT(1.5D0+PYR(0))
10332 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10336 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
10337 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
10338 KCS=(-1)**INT(1.5D0+PYR(0))
10339 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10343 ELSEIF(ISUB.EQ.294) THEN
10344 C...qj + g -> ~qj_L + ~g
10345 IF(MINT(15).EQ.21) JS=2
10348 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10349 MINT(23-JS)=KSUSY1+21
10351 IF(JS.EQ.2) KCC=KCC+2
10354 ELSEIF(ISUB.EQ.295) THEN
10355 C...qj + g -> ~qj_R + ~g
10356 IF(MINT(15).EQ.21) JS=2
10359 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10360 MINT(23-JS)=KSUSY1+21
10362 IF(JS.EQ.2) KCC=KCC+2
10366 ELSEIF(ISUB.LE.340) THEN
10368 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
10369 C...q + qbar' -> H+ + H0
10370 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10371 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10372 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10373 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
10374 MINT(23-JS)=KFPR(ISUB,2)
10375 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
10376 C...f + fbar -> A0 + H0; th arbitrary
10377 IF(PYR(0).GT.0.5D0) JS=2
10378 MINT(20+JS)=KFPR(ISUB,1)
10379 MINT(23-JS)=KFPR(ISUB,2)
10380 ELSEIF(ISUB.EQ.301) THEN
10381 C...f + fbar -> H+ H-
10382 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10387 ELSEIF(ISUB.LE.360) THEN
10389 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
10390 C...l + l -> H_L++/--, H_R++/--
10391 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10392 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10393 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10395 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
10396 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
10397 IF(MINT(15).EQ.22) JS=2
10398 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
10399 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
10402 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
10403 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
10404 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
10407 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
10408 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
10409 C...as inner process).
10414 RVCKM=VINT(180+I)*PYR(0)
10417 IPM=(5-ISIGN(1,I))/2
10419 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
10420 MINT(20+JT)=ISIGN(IB,I)
10421 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10422 IF(RVCKM.LE.0D0) GOTO 450
10425 IB=2*((IA+1)/2)-1+MOD(IA,2)
10426 MINT(20+JT)=ISIGN(IB,I)
10430 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
10431 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
10433 ELSEIF(ISUB.EQ.353) THEN
10434 C...f + fbar -> Z_R0
10437 ELSEIF(ISUB.EQ.354) THEN
10438 C...f + fbar' -> W+/-
10439 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10440 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10441 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10445 ELSEIF(ISUB.LE.380) THEN
10447 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
10448 C...f + fbar -> charged+ charged- technicolor
10449 KSW=(-1)**INT(1.5D0+PYR(0))
10450 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
10451 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
10453 ELSEIF(ISUB.LE.367) THEN
10454 C...f + fbar -> neutral neutral technicolor
10455 MINT(21)=KFPR(ISUB,1)
10456 MINT(22)=KFPR(ISUB,2)
10458 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375) THEN
10459 C...f + fbar' -> neutral charged technicolor
10462 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10463 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10464 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10465 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10466 MINT(20+JS)=KFPR(ISUB,IN)
10468 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
10469 C...f + fbar' -> charged neutral technicolor
10472 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10473 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10474 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10475 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10476 MINT(23-JS)=KFPR(ISUB,IN)
10479 ELSEIF(ISUB.LE.400) THEN
10480 IF(ISUB.EQ.391) THEN
10481 C...f + fbar -> G*.
10484 ELSEIF(ISUB.EQ.392) THEN
10489 ELSEIF(ISUB.EQ.393) THEN
10490 C...q + qbar -> g + G*; th arbitrary.
10491 IF(PYR(0).GT.0.5D0) JS=2
10492 MINT(20+JS)=KFPR(ISUB,1)
10493 MINT(23-JS)=KFPR(ISUB,2)
10496 ELSEIF(ISUB.EQ.394) THEN
10497 C...q + g -> q + G*; th = (p(f) - p(f))**2
10498 IF(MINT(15).EQ.21) JS=2
10499 MINT(23-JS)=KFPR(ISUB,2)
10501 KCS=ISIGN(1,MINT(14+JS))
10503 ELSEIF(ISUB.EQ.395) THEN
10504 C...g + g -> G* + g; th arbitrary.
10505 IF(PYR(0).GT.0.5D0) JS=2
10506 MINT(23-JS)=KFPR(ISUB,2)
10511 IF(ISET(ISUB).EQ.11) THEN
10512 C...Store documentation for user-defined processes
10513 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
10514 KUPPO(1)=MINT(83)+5
10515 KUPPO(2)=MINT(83)+6
10519 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
10528 IF(IDUP(IUP).EQ.0) K(I,2)=90
10530 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
10538 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
10541 C...Store final state partons for user-defined processes
10546 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
10548 IF(IDUP(IUP).EQ.0) K(N,2)=90
10549 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
10552 K(N,3)=MINT(84)+MOTHUP(1,IUP)
10561 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
10563 C...Arrange colour flow for user-defined processes
10567 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
10568 IF(K(I1,1).EQ.1) K(I1,1)=3
10569 IF(K(I1,1).EQ.11) K(I1,1)=14
10570 C...Find a not yet considered colour/anticolour line.
10572 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
10575 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
10579 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
10580 C...Find all others belonging to same line.
10583 DO 520 IUP2=IUP1+1,NUP
10586 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
10587 IF(ISDE2.EQ.ISDE1) THEN
10588 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
10589 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
10591 ELSEIF(I4.NE.0) THEN
10592 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
10593 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
10595 ELSEIF(IUP2.LE.2) THEN
10596 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
10597 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
10600 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
10601 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
10611 ELSEIF(IDOC.EQ.7) THEN
10612 C...Resonance not decaying; store kinematics
10627 C...Special cases: colour flow in coloured resonances
10628 KCRES=PYCOMP(KFRES)
10629 IF(KCHG(KCRES,2).NE.0) THEN
10633 IF(KCS.EQ.-1) JC=3-J
10634 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
10635 & MINT(84)+ICOL(KCC,1,JC)
10636 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
10637 & MINT(84)+ICOL(KCC,2,JC)
10638 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
10639 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
10648 ELSEIF(IDOC.EQ.8) THEN
10649 C...2 -> 2 processes: store outgoing partons in their CM-frame
10652 KCA=PYCOMP(MINT(20+JT))
10654 IF(KCHG(KCA,2).NE.0) K(I,1)=3
10656 K(I,3)=MINT(83)+IDOC+JT-2
10658 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
10659 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10661 P(I,5)=PYMASS(K(I,2))
10663 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
10664 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
10666 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
10667 KFA1=IABS(MINT(21))
10668 KFA2=IABS(MINT(22))
10669 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
10677 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
10678 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
10679 P(IPU4,4)=SHR-P(IPU3,4)
10680 P(IPU4,3)=-P(IPU3,3)
10685 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
10686 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
10688 ELSEIF(IDOC.EQ.9) THEN
10689 C...2 -> 3 processes: store outgoing partons in their CM frame
10692 KCA=PYCOMP(MINT(20+JT))
10694 IF(KCHG(KCA,2).NE.0) K(I,1)=3
10696 K(I,3)=MINT(83)+IDOC+JT-3
10697 IF(IABS(K(I,2)).LE.22) THEN
10698 P(I,5)=PYMASS(K(I,2))
10700 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10702 PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
10703 P(I,1)=PT*COS(VINT(198+5*JT))
10704 P(I,2)=PT*SIN(VINT(198+5*JT))
10708 K(IPU5,3)=MINT(83)+IDOC
10710 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10711 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10712 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
10713 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
10714 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
10716 P(IPU5,3)=PMT3*SINH(VINT(211))
10717 P(IPU5,4)=PMT3*COSH(VINT(211))
10718 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
10719 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
10720 IF(SQL12.LE.0D0) THEN
10724 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
10725 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
10726 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
10727 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
10728 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
10734 ELSEIF(IDOC.EQ.11) THEN
10735 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
10736 PHI(1)=PARU(2)*PYR(0)
10741 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10743 K(I,3)=MINT(83)+IDOC+JT-2
10744 P(I,5)=PYMASS(K(I,2))
10745 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
10749 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10750 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10751 P(I,1)=PTABS*COS(PHI(JT))
10752 P(I,2)=PTABS*SIN(PHI(JT))
10753 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10754 P(I,4)=0.5D0*SHPR*Z(JT)
10758 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
10762 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
10763 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
10764 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
10771 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10772 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10773 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
10774 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
10783 ELSEIF(IDOC.EQ.12) THEN
10784 C...Z0 and W+/- scattering: store bosons and outgoing partons
10785 PHI(1)=PARU(2)*PYR(0)
10787 JTRAN=INT(1.5D0+PYR(0))
10791 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10793 K(I,3)=MINT(83)+IDOC+JT-2
10794 P(I,5)=PYMASS(K(I,2))
10795 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
10796 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10797 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10798 P(I,1)=PTABS*COS(PHI(JT))
10799 P(I,2)=PTABS*SIN(PHI(JT))
10800 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10801 P(I,4)=0.5D0*SHPR*Z(JT)
10804 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
10807 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
10812 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
10813 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
10814 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
10817 K(IPU,2)=KFPR(ISUB,JT)
10818 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
10819 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
10820 K(IPU,3)=MINT(83)+8+JT
10821 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
10822 P(IPU,5)=PYMASS(K(IPU,2))
10824 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10826 MINT(22+JT)=K(IPU,2)
10828 C...Find rotation and boost for hard scattering subsystem
10831 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
10832 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
10833 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
10834 GAMCM=(P(I1,4)+P(I2,4))/SHR
10835 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
10836 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
10837 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
10838 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
10839 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
10840 PHICM=PYANGL(PX,PY)
10841 C...Store hard scattering subsystem. Rotate and boost it
10842 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
10844 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
10846 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
10847 PHIWZ=VINT(24)-PHICM
10848 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
10849 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
10850 P(IPU5,3)=PABS*CTHWZ
10851 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
10852 P(IPU6,1)=-P(IPU5,1)
10853 P(IPU6,2)=-P(IPU5,2)
10854 P(IPU6,3)=-P(IPU5,3)
10855 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
10856 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
10868 MINT(8)=MINT(83)+10
10871 IF(ISET(ISUB).EQ.11) THEN
10872 ELSEIF(IDOC.GE.8) THEN
10873 C...Store colour connection indices
10876 IF(KCS.EQ.-1) JC=3-J
10877 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
10878 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
10879 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
10880 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
10881 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
10882 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
10883 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
10884 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
10887 C...Copy outgoing partons to documentation lines
10889 IF(IDOC.EQ.9) IMAX=3
10891 I1=MINT(83)+IDOC-IMAX+I
10895 IF(IDOC.LE.9) K(I1,3)=0
10896 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
10902 ELSEIF(IDOC.EQ.9) THEN
10903 C...Store colour connection indices
10906 IF(KCS.EQ.-1) JC=3-J
10907 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
10908 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
10909 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
10910 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
10911 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
10912 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
10913 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
10914 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
10915 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
10916 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
10919 C...Copy outgoing partons to documentation lines
10921 I1=MINT(83)+IDOC-3+I
10932 C...Low-pT events: remove gluons used for string drawing purposes
10933 IF(ISUB.EQ.95) THEN
10934 K(IPU3,1)=K(IPU3,1)+10
10935 K(IPU4,1)=K(IPU4,1)+10
10940 DO 710 I=MINT(83)+5,MINT(83)+8
10950 C*********************************************************************
10953 C...Generates spacelike parton showers.
10955 SUBROUTINE PYSSPA(IPU1,IPU2)
10957 C...Double precision and integer declarations.
10958 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10959 IMPLICIT INTEGER(I-N)
10960 INTEGER PYK,PYCHGE,PYCOMP
10962 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10963 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10964 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10965 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10966 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10967 COMMON/PYINT1/MINT(400),VINT(400)
10968 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10969 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10970 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
10972 C...Local arrays and data.
10973 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
10974 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
10975 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
10976 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
10977 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
10980 C...Read out basic information; set global Q^2 scale.
10985 IF(ISET(ISUB).EQ.2) Q2MX=MIN(VINT(2),PARP(67)*VINT(56))
10988 C...Define which processes ME corrections have been implemented for.
10990 IF(MSTP(68).EQ.1) THEN
10991 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
10992 & ISUB.EQ.144) MECOR=1
10993 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
10996 C...Initialize QCD evolution and check phase space.
11000 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
11003 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11004 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11005 Q2INT=SQRT(Q0S*Q2EFF)
11006 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
11007 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
11008 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
11010 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
11013 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11014 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11015 Q2INT=SQRT(Q0S*Q2EFF)
11016 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
11017 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
11018 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
11025 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
11027 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
11028 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
11029 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
11030 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
11034 C...Initialize QED evolution and check phase space.
11038 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
11039 &SPME=PMAS(13,1)**2
11040 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
11041 &SPME=PMAS(15,1)**2
11042 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
11045 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
11047 TEMX=LOG(Q2MX/SPME)
11048 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
11050 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11055 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
11057 C...Loopback point in case of failure to reconstruct kinematics.
11061 IF(LOOP.GT.100) THEN
11067 C...Initial values: flavours, momenta, virtualities.
11070 KFBEAM(JT)=MINT(10+JT)
11071 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
11072 KFLS(JT)=MINT(14+JT)
11073 KFLS(JT+2)=KFLS(JT)
11075 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
11077 Q2S(JT)=FCQ2MX*Q2MX
11084 C...Calculate initial parton distribution weights.
11085 MINT(105)=MINT(102+JT)
11086 MINT(109)=MINT(106+JT)
11087 VINT(120)=VINT(2+JT)
11089 C.... Store side in MINT(124)
11091 IF(XS(JT).LT.1D0-XEE) THEN
11092 IF(MSTP(57).LE.1) THEN
11093 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11095 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11099 XFS(JT,KFL)=XFB(KFL)
11101 C...Special kinematics check for c/b quarks (that g -> c cbar or
11102 C...b bbar kinematically possible).
11103 KFLCB=IABS(KFLS(JT))
11104 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
11105 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
11112 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
11114 C...Find if interference with final state partons.
11116 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
11120 KCA=PYCOMP(IABS(KFLS(I)))
11121 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
11123 IF(KCFI(I).NE.0) THEN
11124 IF(I.EQ.1) IPFS=IPUS1
11125 IF(I.EQ.2) IPFS=IPUS2
11127 ICSI=MOD(K(IPFS,3+J),MSTU(5))
11128 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
11129 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
11131 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
11133 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
11138 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
11141 C...Pick up leg with highest virtuality.
11145 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
11146 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
11147 IF(MORE(JT).EQ.0) JT=3-JT
11152 XFB(KFL)=XFS(JT,KFL)
11157 C...Check if allowed to branch.
11159 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
11161 XEC=MAX(PARP(65)*DSHR/VINT(2),XB*(1D0/(1D0-PARP(66))-1D0))
11162 IF(XB.GE.1D0-2D0*XEC) MCEV=0
11165 IF(MINT(44+JT).EQ.3) THEN
11167 IF(XB.GE.1D0-2D0*XEE) MEEV=0
11168 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
11170 C***Currently kill QED shower for resolved photoproduction.
11171 IF(MINT(18+JT).EQ.1) MEEV=0
11172 C***Currently kill shower for W inside electron.
11173 IF(IABS(KFLB).EQ.24) THEN
11178 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
11180 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11185 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
11189 IF(MSTP(62).LE.1) THEN
11190 IF(ZS(JT).GT.0.99999D0) THEN
11193 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
11194 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
11195 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
11197 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11198 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11201 ALSDUM=PYALPS(FQ2C*Q2B)
11202 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
11204 B0=(33D0-2D0*MSTU(118))/6D0
11206 IF(MEEV.EQ.2) TEVEB=TEVCB
11210 C...Select side for interference with final state partons.
11211 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
11214 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
11216 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
11217 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
11218 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
11220 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
11224 C...Calculate preweighting factor for ME-corrected processes.
11225 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
11227 C...Calculate Altarelli-Parisi weights.
11233 C...q -> q (g or gamma emission), g -> q.
11234 IF(IABS(KFLB).LE.10) THEN
11235 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
11236 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
11238 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
11239 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
11241 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11242 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
11243 WTAPC(21)=WTGF*WTAPC(21)
11244 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11246 C...f -> f, gamma -> f.
11247 ELSEIF(IABS(KFLB).LE.20) THEN
11248 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
11249 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
11250 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
11251 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
11252 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11253 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11254 WTAPE(22)=WTGF*WTAPE(22)
11256 C...f -> g, g -> g.
11257 ELSEIF(KFLB.EQ.21) THEN
11258 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
11259 DO 180 KFL=1,MSTP(58)
11263 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
11264 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11265 DO 190 KFL=1,MSTP(58)
11266 WTAPC(KFL)=WTFG*WTAPC(KFL)
11267 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
11269 WTAPC(21)=WTGG*WTAPC(21)
11271 C...f -> gamma, W+, W-.
11272 ELSEIF(KFLB.EQ.22) THEN
11273 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
11276 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11277 WTAPE(11)=WTFG*WTAPE(11)
11278 WTAPE(-11)=WTFG*WTAPE(-11)
11280 ELSEIF(KFLB.EQ.24) THEN
11281 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11282 & (XEE*(XB+XEE)))/XB
11283 ELSEIF(KFLB.EQ.-24) THEN
11284 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11285 & (XEE*(XB+XEE)))/XB
11288 C...Calculate parton distribution weights and sum.
11291 IF(NTRY.GT.500) THEN
11297 XFBO=MAX(1D-10,XFB(KFLB))
11299 WTSF(KFL)=XFB(KFL)/XFBO
11300 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
11301 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
11303 WTSUMC=MAX(0.0001D0,WTSUMC)
11304 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
11306 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
11309 IF(NTRY2.GT.500) THEN
11314 IF(MSTP(64).LE.0) THEN
11315 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
11316 ELSEIF(MSTP(64).EQ.1) THEN
11317 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
11319 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
11323 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
11324 & (PARU(101)*FWTE*WTSUME*TEMX)))
11325 ELSEIF(MEEV.EQ.2) THEN
11326 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
11329 C...Translate t into Q2 scale; choose between QCD and QED evolution.
11330 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
11331 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
11332 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
11333 C...Ensure that Q2 is above threshold for charm/bottom.
11335 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11337 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
11338 Q2CB=1.1D0*PMAS(KFLCB,1)**2
11339 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11340 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
11343 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11345 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
11348 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11349 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11350 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
11351 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
11352 IF(Q2EB.GT.Q2MNE) MCE=2
11353 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
11354 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
11355 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
11356 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
11357 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
11358 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
11360 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
11361 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
11364 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
11365 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
11368 C...Evolution possibly ended. Update t values.
11372 ELSEIF(MCE.EQ.1) THEN
11375 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11376 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11380 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11383 C...Select flavour for branching parton.
11384 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
11385 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
11388 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
11389 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
11390 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
11391 IF(KFLA.EQ.25) THEN
11396 C...Choose z value and corrective weight.
11398 C...q -> q + g or q -> q + gamma.
11399 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
11400 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
11401 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
11402 WTZ=0.5D0*(1D0+Z**2)
11404 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
11405 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
11406 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
11407 C...f -> f + gamma.
11408 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11409 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
11410 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
11411 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
11413 Z=XB+XB*(XEE/(1D0-XEE))*
11414 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11416 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
11417 C...f -> gamma + f.
11418 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
11419 Z=XB+XB*(XEE/(1D0-XEE))*
11420 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11421 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
11423 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
11424 Z=XB+XB*(XEE/(1D0-XEE))*
11425 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11426 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
11427 & (Q2B/(Q2B+PMAS(24,1)**2))
11429 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
11430 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
11431 WTZ=1D0-2D0*Z*(1D0-Z)
11433 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11434 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
11435 WTZ=(1D0-Z*(1D0-Z))**2
11436 C...gamma -> f + fbar.
11437 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
11438 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
11439 WTZ=1D0-2D0*Z*(1D0-Z)
11441 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
11443 C...Option with resummation of soft gluon emission as effective z shift.
11445 IF(MSTP(65).GE.1) THEN
11447 IF(KFLB.NE.21) RSOFT=8D0/3D0
11448 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
11449 IF(Z.LE.XB) GOTO 220
11452 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
11453 IF(MSTP(64).GE.2) THEN
11454 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
11455 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
11456 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
11457 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
11461 C...Remove kinematically impossible branchings.
11462 UHAT=Q2B-DSH*(1D0-Z)/Z
11463 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
11465 C...Select phi angle of branching at random.
11466 PHIBR=PARU(2)*PYR(0)
11468 C...Matrix-element corrections for some processes.
11469 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11470 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11471 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
11473 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
11474 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
11476 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
11477 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
11479 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11480 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
11485 C...Impose angular constraint in first branching from interference
11486 C...with final state partons.
11488 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
11489 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
11490 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
11491 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
11492 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
11493 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
11497 C...Option with angular ordering requirement.
11498 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
11499 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT(2))
11500 IF(THE2T.GT.THE2(JT)) GOTO 220
11504 C...Weighting with new parton distributions.
11505 MINT(105)=MINT(102+JT)
11506 MINT(109)=MINT(106+JT)
11507 VINT(120)=VINT(2+JT)
11509 C.... Store side in MINT(124)
11512 IF(MSTP(57).LE.1) THEN
11513 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
11515 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
11518 IF(XFBN.LT.1D-20) THEN
11519 IF(KFLA.EQ.KFLB) THEN
11525 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
11526 TEVCB=0.5D0*(TEVCBS+TEVCB)
11528 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
11529 TEVEB=0.5D0*(TEVEBS+TEVEB)
11541 C.... Store side in MINT(124)
11545 IF(MSTP(57).LE.1) THEN
11546 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
11548 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
11551 IF(XFAN.LT.1D-20) GOTO 200
11553 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
11555 C...Define two hard scatterers in their CM-frame.
11556 260 IF(N.EQ.NS+2) THEN
11558 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
11561 IF(JR.EQ.1) IPO=IPUS1
11562 IF(JR.EQ.2) IPO=IPUS2
11572 P(I,3)=DPLCM*(-1)**(JR+1)
11573 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
11574 P(I,5)=-SQRT(DQ2(JR))
11577 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
11578 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
11581 C...Find maximum allowed mass of timelike parton.
11582 ELSEIF(N.GT.NS+2) THEN
11587 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
11588 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
11589 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
11590 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
11591 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
11593 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
11594 & 1D-10*DPD(1)) IKIN=1
11595 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
11596 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
11597 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
11598 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
11600 C...Generate timelike parton shower (if required).
11607 C...f -> f + g (gamma).
11608 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
11610 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
11611 C...f -> g (gamma, W+-) + f.
11612 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
11614 IF(KFLS(JT+2).EQ.24) THEN
11616 ELSEIF(KFLS(JT+2).EQ.-24) THEN
11619 C...g (gamma) -> f + fbar, g + g.
11621 K(IT,2)=-KFLS(JT+2)
11622 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
11625 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
11626 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
11627 P(IT,5)=PYMASS(K(IT,2))
11628 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
11629 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
11632 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
11633 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
11634 IF(MSTP(63).EQ.1) THEN
11636 ELSEIF(MSTP(63).EQ.2) THEN
11637 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
11641 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11642 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
11643 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
11644 PARJ(85)=SQRT(MAX(0D0,DPT2))*
11645 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
11647 CALL PYSHOW(IT,0,SQRT(Q2TIM))
11650 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
11653 C...Reconstruct kinematics of branching: timelike parton shower.
11655 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11656 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
11657 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
11658 & (4D0*DSH*DPC(3)**2)
11659 IF(DPT2.LT.0D0) GOTO 100
11660 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
11661 & DSHR)/DPC(3)-DPC(3)
11663 P(IT,3)=DPB(1)*(-1)**(JT+1)
11664 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
11666 DPB(1)=SQRT(DPB(1)**2+DPT2)
11667 DPB(2)=SQRT(DPB(1)**2+DMS)
11669 DPB(4)=SQRT(DPB(3)**2+DMS)
11670 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
11672 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
11673 THE=PYANGL(P(IT,3),P(IT,1))
11674 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
11677 C...Reconstruct kinematics of branching: spacelike parton.
11686 P(N+1,3)=P(IT,3)+P(IS(JT),3)
11687 P(N+1,4)=P(IT,4)+P(IS(JT),4)
11688 P(N+1,5)=-SQRT(DQ2(3))
11690 C...Define colour flow of branching.
11695 C...f -> f + gamma (Z, W).
11696 IF(IABS(K(IT,2)).GE.22) THEN
11700 C...f -> gamma (Z, W) + f.
11701 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
11704 C...gamma -> q + qbar, g + g.
11705 ELSEIF(K(N+1,2).EQ.22) THEN
11711 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
11715 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
11718 C...qbar -> qbar + g.
11719 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
11722 C...qbar -> g + qbar.
11723 ELSEIF(K(N+1,2).LT.0) THEN
11726 C...g -> g + g; g -> q + qbar.
11727 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
11734 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
11735 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
11736 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
11737 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
11738 IF(ID1.NE.ID2) THEN
11739 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
11740 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
11744 C...Boost to new CM-frame.
11745 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
11746 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
11747 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
11748 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
11749 IR=N+(JT-1)*(IS(1)-N)
11750 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
11754 C...Update kinematics variables.
11757 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THE2(JT)=THE2T
11760 C...Save quantities; loop back.
11764 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
11765 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
11766 KFLS(JT+2)=KFLS(JT)
11771 XFS(JT,KFL)=XFA(KFL)
11780 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
11781 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
11782 IF(MSTU(21).GE.1) N=NS
11783 IF(MSTU(21).GE.1) RETURN
11785 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
11787 C...Boost hard scattering partons to frame of shower initiators.
11789 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
11795 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
11796 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
11797 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
11798 CALL PYROBO(MINT(83)+5,NS,0D0,-ROBO(2),0D0,0D0,0D0)
11799 CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
11802 C...Store user information. Reset Lambda value.
11803 K(IPU1,3)=MINT(83)+3
11804 K(IPU2,3)=MINT(83)+4
11806 MINT(12+JT)=KFLS(JT)
11807 VINT(140+JT)=XS(JT)
11808 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
11815 C*********************************************************************
11818 C...Generates maximum ME weight in some initial-state showers.
11819 C...Inparameter MECOR: kind of hard scattering process
11820 C...Outparameter WTFF: maximum weight for fermion -> fermion
11821 C... WTGF: maximum weight for gluon/photon -> fermion
11822 C... WTFG: maximum weight for fermion -> gluon/photon
11823 C... WTGG: maximum weight for gluon -> gluon
11825 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
11827 C...Double precision and integer declarations.
11828 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11829 IMPLICIT INTEGER(I-N)
11830 INTEGER PYK,PYCHGE,PYCOMP
11832 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11833 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11834 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11835 COMMON/PYINT1/MINT(400),VINT(400)
11836 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
11837 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
11839 C...Default maximum weight.
11845 C...Select maximum weight by process.
11846 IF(MECOR.EQ.1) THEN
11849 ELSEIF(MECOR.EQ.2) THEN
11857 C*********************************************************************
11860 C...Calculates actual ME weight in some initial-state showers.
11861 C...Inparameter MECOR: kind of hard scattering process
11862 C... IFLCB: flavour combination of branching,
11863 C... 1 for fermion -> fermion,
11864 C... 2 for gluon/photon -> fermion
11865 C... 3 for fermion -> gluon/photon,
11866 C... 4 for gluon -> gluon
11867 C... Q2: Q2 value of shower branching
11868 C... Z: Z value of branching
11869 C...In+outparameter PHIBR: azimuthal angle of branching
11870 C...Outparameter WTME: actual ME weight
11872 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
11874 C...Double precision and integer declarations.
11875 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11876 IMPLICIT INTEGER(I-N)
11877 INTEGER PYK,PYCHGE,PYCOMP
11879 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11880 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11881 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11882 COMMON/PYINT1/MINT(400),VINT(400)
11883 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
11884 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
11886 C...Default output.
11889 C...Define kinematics of shower branching in Mandelstam variables.
11893 UH=Q2-SQM*(1D0-Z)/Z
11895 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
11896 IF(MECOR.EQ.1) THEN
11897 IF(IFLCB.EQ.1) THEN
11898 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
11899 ELSEIF(IFLCB.EQ.2) THEN
11900 WTME=(SH**2+UH**2+2D0*SQM*TH)/((SH-SQM)**2+SQM**2)
11903 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
11904 ELSEIF(MECOR.EQ.2) THEN
11905 IF(IFLCB.EQ.3) THEN
11906 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
11907 ELSEIF(IFLCB.EQ.4) THEN
11908 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
11915 C*********************************************************************
11918 C...Administers the generation of successive final-state showers
11919 C...in external processes.
11921 SUBROUTINE PYADSH(NFIN)
11923 C...Double precision and integer declarations.
11924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11925 IMPLICIT INTEGER(I-N)
11926 INTEGER PYK,PYCHGE,PYCOMP
11928 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11929 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11930 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11931 COMMON/PYINT1/MINT(400),VINT(400)
11932 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
11934 DIMENSION IBEG(100),KSAV(10,5),IORD(10),PSUM(4),BETA(3)
11936 C...Set primary vertex.
11938 V(MINT(83)+5,J)=0D0
11939 V(MINT(83)+6,J)=0D0
11940 V(MINT(84)+1,J)=0D0
11941 V(MINT(84)+2,J)=0D0
11944 C...Isolate systems of particles with the same mother.
11947 DO 140 I=MINT(84)+3,NFIN
11949 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
11956 C...Set production vertices.
11957 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
11964 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
11967 IF(MSTP(125).GE.1) THEN
11975 C...End loop over systems. Return if no showers to be performed.
11976 IBEG(NSYS+1)=NFIN+1
11977 IF(MSTP(71).LE.0) RETURN
11979 C...Loop through systems of particles; check that sensible size.
11981 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
11982 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
11983 ELSEIF(NSIZ.LE.1) THEN
11984 CALL PYERRM(2,'(PYADSH:) only one particle in system')
11985 ELSEIF(NSIZ.GT.7) THEN
11986 CALL PYERRM(2,'(PYADSH:) more than seven particles in system')
11989 C...Save status codes and daughters of showering pair; reset them.
11996 IF(K(I,1).GT.10) THEN
11998 IF(KSAV(II,1).EQ.14) K(I,1)=3
12000 IF(KSAV(II,1).LE.10) THEN
12001 ELSEIF(K(I,1).EQ.1) THEN
12007 KSAV(II,4)=MOD(K(I,4),MSTU(5))
12008 KSAV(II,5)=MOD(K(I,5),MSTU(5))
12009 K(I,4)=K(I,4)-KSAV(II,4)
12010 K(I,5)=K(I,5)-KSAV(II,5)
12013 PSUM(J)=PSUM(J)+P(I,J)
12017 C...Perform shower.
12018 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
12020 IF(ISYS.EQ.1) QMAX=VINT(55)
12023 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
12025 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
12028 C...Look up showered copies of original showering particles.
12032 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
12033 ELSEIF(K(I,1).EQ.11) THEN
12034 180 IMV=MOD(K(IMV,4),MSTU(5))
12035 IF(K(IMV,1).EQ.11) GOTO 180
12037 KDA1=MOD(K(I,4),MSTU(5))
12038 KDA2=MOD(K(I,5),MSTU(5))
12040 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
12043 KDA1=MOD(K(I3,4),MSTU(5))
12044 KDA2=MOD(K(I3,5),MSTU(5))
12049 C...Restore daughter info of original partons to showered copies.
12050 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
12051 IF(KSAV(II,1).LE.10) THEN
12052 ELSEIF(K(I,1).EQ.1) THEN
12053 K(IMV,4)=KSAV(II,4)
12054 K(IMV,5)=KSAV(II,5)
12056 K(IMV,4)=K(IMV,4)+KSAV(II,4)
12057 K(IMV,5)=K(IMV,5)+KSAV(II,5)
12060 C...Reset mother info of existing daughters to showered copies.
12061 DO 200 I3=IBEG(ISYS+1),NFIN
12062 IF(K(I3,3).EQ.I) K(I3,3)=IMV
12063 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
12064 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
12065 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
12069 C...Boost all original daughters to new frame of showered copy.
12072 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
12074 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
12076 BETA(J)=FAC*BETA(J)
12078 DO 240 I3=IBEG(ISYS+1),NFIN
12081 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 230
12082 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
12083 & CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
12088 C...End of loop over showering systems
12095 C*********************************************************************
12098 C...Allows resonances to decay (including parton showers for hadronic
12101 SUBROUTINE PYRESD(IRES)
12103 C...Double precision and integer declarations.
12104 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12105 IMPLICIT INTEGER(I-N)
12106 INTEGER PYK,PYCHGE,PYCOMP
12107 C...Parameter statement to help give large particle numbers.
12108 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
12109 &KEXCIT=4000000,KDIMEN=5000000)
12111 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12112 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12113 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12114 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
12115 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12116 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12117 COMMON/PYINT1/MINT(400),VINT(400)
12118 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12119 COMMON/PYINT4/MWID(500),WIDS(500,5)
12120 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
12121 &/PYINT1/,/PYINT2/,/PYINT4/
12122 C...Local arrays and complex and character variables.
12123 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
12124 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
12125 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
12126 &PHI(3),WDTP(0:300),WDTE(0:300,0:5),DPMO(5),XM(5),VDCY(4)
12127 COMPLEX FGK,HA(6,6),HC(6,6)
12129 CHARACTER CODE*9,MASS*9
12131 C...The F, Xi and Xj functions of Gunion and Kunszt
12132 C...(Phys. Rev. D33, 665, plus errata from the authors).
12133 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
12134 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
12135 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
12136 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
12137 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
12138 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
12139 &2D0*(D34/D56+D56/D34))
12141 C...Some general constants.
12144 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
12147 GMMZ=PMAS(23,1)*PMAS(23,2)
12149 GMMW=PMAS(24,1)*PMAS(24,2)
12152 C...Boost and rotate to rest frame of incoming partons,
12153 C...to get proper amount of smearing of decay angles.
12157 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
12158 BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
12159 BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
12160 BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
12161 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
12162 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
12163 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
12164 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
12165 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
12168 C...Reset original resonance configuration.
12173 C...Define initial one, two or three objects for subprocess.
12177 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12178 IREF(1,1)=MINT(84)+2+ISET(ISUB)
12179 IREF(1,4)=MINT(83)+6+ISET(ISUB)
12181 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
12182 IREF(1,1)=MINT(84)+1+ISET(ISUB)
12183 IREF(1,2)=MINT(84)+2+ISET(ISUB)
12184 IREF(1,4)=MINT(83)+5+ISET(ISUB)
12185 IREF(1,5)=MINT(83)+6+ISET(ISUB)
12187 ELSEIF(ISET(ISUB).EQ.5) THEN
12188 IREF(1,1)=MINT(84)+3
12189 IREF(1,2)=MINT(84)+4
12190 IREF(1,3)=MINT(84)+5
12191 IREF(1,4)=MINT(83)+7
12192 IREF(1,5)=MINT(83)+8
12193 IREF(1,6)=MINT(83)+9
12197 C...Define original resonance for odd cases.
12200 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
12202 IF(IHDEC.EQ.1) ISUB=3
12204 IREF(1,4)=K(IRES,3)
12208 C...Check if initial resonance has been moved (in resonance + jet).
12210 IF(IREF(1,JT).GT.0) THEN
12211 IF(K(IREF(1,JT),1).GT.10) THEN
12212 KFA=IABS(K(IREF(1,JT),2))
12213 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
12214 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12215 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12216 DO 110 I=IREF(1,JT)+1,N
12217 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
12220 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12221 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12225 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
12226 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
12232 C.....Set decay vertex for initial resonances
12235 V(IREF(1,JT),I)=0D0
12239 C...Loop over decay history.
12245 IF(IREF(IP,2).EQ.0) JTMAX=1
12246 IF(IREF(IP,3).NE.0) JTMAX=3
12250 C...Start treatment of one, two or three resonances in parallel.
12261 C...Check whether particle can/is allowed to decay.
12262 IF(ID.EQ.0) GOTO 240
12265 IF(MWID(KCA).EQ.0) GOTO 240
12266 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 240
12267 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
12268 & KFA.EQ.18) IT4=IT4+1
12269 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
12270 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
12272 C...Choose lifetime and determine decay vertex.
12273 IF(K(ID,1).EQ.5) THEN
12275 ELSEIF(K(ID,1).NE.4) THEN
12276 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
12279 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
12282 C...Determine whether decay allowed or not.
12284 IF(MSTJ(22).EQ.2) THEN
12285 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
12286 ELSEIF(MSTJ(22).EQ.3) THEN
12287 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
12288 ELSEIF(MSTJ(22).EQ.4) THEN
12289 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
12290 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
12292 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
12297 C...Info for selection of decay channel: sign, pairings.
12298 IF(KCHG(KCA,3).EQ.0) THEN
12301 IPM=(5-ISIGN(1,K(ID,2)))/2
12304 IF(JTMAX.EQ.2) THEN
12305 KFB=IABS(K(IREF(IP,3-JT),2))
12306 ELSEIF(JTMAX.EQ.3) THEN
12308 KFB=IABS(K(IREF(IP,JT2),2))
12309 IF(KFB.NE.KFA) THEN
12310 JT2=JT+2-3*((JT+1)/3)
12311 KFB=IABS(K(IREF(IP,JT2),2))
12315 C...Select decay channel.
12316 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
12317 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
12318 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
12319 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
12320 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
12321 IF(WDTE0S.LE.0D0) GOTO 240
12325 IDC=IDL+MDCY(KCA,2)-1
12326 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
12327 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
12328 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 180
12330 C...Read out flavours and colour charges of decay channel chosen.
12331 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
12332 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
12333 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
12334 KFC1A=PYCOMP(IABS(KFL1(JT)))
12335 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
12336 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
12337 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
12338 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
12339 KFC2A=PYCOMP(IABS(KFL2(JT)))
12340 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
12341 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
12342 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
12343 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
12344 IF(KFL3(JT).NE.0) THEN
12345 KFC3A=PYCOMP(IABS(KFL3(JT)))
12346 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
12347 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
12348 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
12351 C...Set/save further info on channel.
12353 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
12355 HGZ(JT,1)=VINT(111)
12356 HGZ(JT,2)=VINT(112)
12357 HGZ(JT,3)=VINT(114)
12360 C...Select masses; to begin with assume resonances narrow.
12365 KFLW=IABS(KFL1(JT))
12367 ELSEIF(I.EQ.2) THEN
12368 KFLW=IABS(KFL2(JT))
12370 ELSEIF(I.EQ.3) THEN
12371 IF(KFL3(JT).EQ.0) GOTO 200
12372 KFLW=IABS(KFL3(JT))
12375 P(N+I,5)=PMAS(KCW,1)
12377 C...This prevents SUSY/t particles from becoming too light.
12378 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
12379 PMMN(I)=PMAS(KCW,1)
12380 DO 190 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
12381 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
12382 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
12383 & PMAS(PYCOMP(KFDP(IDC,2)),1)
12384 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
12385 & PMAS(PYCOMP(KFDP(IDC,3)),1)
12386 PMMN(I)=MIN(PMMN(I),PMSUM)
12390 ELSEIF(KFLW.EQ.6) THEN
12391 PMMN(I)=PMAS(24,1)+PMAS(5,1)
12395 C...Check which two out of three are widest.
12398 PWID1=PMAS(KFC1A,2)
12399 PWID2=PMAS(KFC2A,2)
12400 KFLW1=IABS(KFL1(JT))
12401 KFLW2=IABS(KFL2(JT))
12402 IF(KFL3(JT).NE.0) THEN
12403 PWID3=PMAS(KFC3A,2)
12404 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
12407 KFLW1=IABS(KFL3(JT))
12408 ELSEIF(PWID3.GT.PWID2) THEN
12411 KFLW2=IABS(KFL3(JT))
12415 C...If all narrow then only check that masses consistent.
12416 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
12417 & PWID2.LT.PARP(41))) THEN
12419 C....Handle near degeneracy cases.
12420 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
12421 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12422 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
12423 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
12427 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12428 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
12431 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
12432 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
12437 C...For three wide resonances select narrower of three
12438 C...according to BW decoupled from rest.
12441 IF(KFL3(JT).NE.0) THEN
12442 IWID3=6-IWID1-IWID2
12443 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
12447 P(N+IWID3,5)=PYMASS(KFLW3)
12448 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 210
12449 PMTOT=PMTOT-P(N+IWID3,5)
12451 C...Select other two correlated within remaining phase space.
12455 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
12456 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
12457 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12462 CKIN(49)=PMMN(IWID1)
12463 CKIN(50)=PMMN(IWID2)
12464 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12469 IF(MINT(51).EQ.1) GOTO 630
12472 C...Begin fill decay products, with colour flow for coloured objects.
12478 C...1) Three-body decays of SUSY particles (plus special case top).
12479 IF(KFL3(JT).NE.0) THEN
12496 C...Set colour flow for t -> W + b + Z.
12500 IF(KCQM(JT).EQ.-1) ISID=5
12502 K(ID,ISID)=K(ID,ISID)+IDAU
12503 K(IDAU,ISID)=MSTU(5)*ID
12505 C...Set colour flow in three-body decays - programmed as special cases.
12506 ELSEIF(KFC2A.LE.6) THEN
12510 IF(KFL2(JT).LT.0) ISID=5
12511 K(N+2,ISID)=MSTU(5)*(N+3)
12512 K(N+3,9-ISID)=MSTU(5)*(N+2)
12514 IF(KFL1(JT).EQ.KSUSY1+21) THEN
12519 IF(KFL2(JT).LT.0) ISID=5
12520 K(N+1,ISID)=MSTU(5)*(N+2)
12521 K(N+1,9-ISID)=MSTU(5)*(N+3)
12522 K(N+2,ISID)=MSTU(5)*(N+1)
12523 K(N+3,9-ISID)=MSTU(5)*(N+1)
12525 IF(KFA.EQ.KSUSY1+21) THEN
12529 IF(KFL2(JT).LT.0) ISID=5
12530 K(ID,ISID)=K(ID,ISID)+(N+2)
12531 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
12532 K(N+2,ISID)=MSTU(5)*ID
12533 K(N+3,9-ISID)=MSTU(5)*ID
12535 IF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
12536 & IABS(KCQ2(JT)).EQ.1) THEN
12540 IF(KFL2(JT).LT.0) ISID=5
12541 K(N+2,ISID)=MSTU(5)*(N+3)
12542 K(N+3,9-ISID)=MSTU(5)*(N+2)
12547 C...2) Everything else two-body decay.
12549 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
12550 C...First set colour flow as if mother colour singlet.
12551 IF(KCQ1(JT).NE.0) THEN
12553 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
12554 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
12556 IF(KCQ2(JT).NE.0) THEN
12558 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
12559 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
12561 C...Then redirect colour flow if mother (anti)triplet.
12562 IF(KCQM(JT).EQ.0) THEN
12563 ELSEIF(KCQM(JT).NE.2) THEN
12565 IF(KCQM(JT).EQ.-1) ISID=5
12567 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
12568 K(ID,ISID)=K(ID,ISID)+IDAU
12569 K(IDAU,ISID)=MSTU(5)*ID
12570 C...Then redirect colour flow if mother octet.
12571 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
12573 IF(KCQ1(JT).EQ.0) IDAU=N
12574 K(ID,4)=K(ID,4)+IDAU
12575 K(ID,5)=K(ID,5)+IDAU
12576 K(IDAU,4)=MSTU(5)*ID
12577 K(IDAU,5)=MSTU(5)*ID
12580 IF(KCQ1(JT).EQ.-1) ISID=5
12581 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
12582 K(ID,ISID)=K(ID,ISID)+(N-1)
12583 K(ID,9-ISID)=K(ID,9-ISID)+N
12584 K(N-1,ISID)=MSTU(5)*ID
12585 K(N,9-ISID)=MSTU(5)*ID
12589 C...End loop over resonances for daughter flavour and mass selection.
12591 240 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
12593 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
12594 & KFL1(JT).EQ.0) THEN
12595 WRITE(CODE,'(I9)') K(ID,2)
12596 WRITE(MASS,'(F9.3)') P(ID,5)
12597 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
12598 & CODE//' with mass'//MASS)
12604 C...Check for allowed combinations. Skip if no decays.
12605 IF(JTMAX.EQ.1) THEN
12606 IF(KDCY(1).EQ.0) GOTO 620
12607 ELSEIF(JTMAX.EQ.2) THEN
12608 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 620
12609 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12610 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12611 ELSEIF(JTMAX.EQ.3) THEN
12612 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 620
12613 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12614 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12615 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12616 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12617 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12618 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12621 C...Special case: matrix element option for Z0 decay to quarks.
12622 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
12623 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
12625 C...Check consistency of MSTJ options set.
12626 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
12628 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
12631 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
12633 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
12637 C...Select alpha_strong behaviour.
12640 MSTU(111)=MSTJ(108)
12641 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
12643 PARU(112)=PARJ(121)
12644 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
12646 C...Find axial fraction in total cross section for scalar gluon model.
12648 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
12649 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
12650 POLL=1D0-PARJ(131)*PARJ(132)
12651 SFF=1D0/(16D0*XW*XW1)
12652 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
12653 & (PARJ(123)*PARJ(124))**2)
12654 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
12656 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
12657 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
12658 & (PARJ(132)-PARJ(131)))
12661 QF=KCHG(KFLC,1)/3D0
12663 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
12664 & 1D0-(2D0*PMQ/P(ID,5))**2))
12665 VF=SIGN(1D0,QF)-4D0*QF*XW
12666 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
12667 & VF**2*HF1W)+VQ**3*HF1W
12668 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
12671 C...Choice of jet configuration.
12672 CALL PYXJET(P(ID,5),NJET,CUT)
12676 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
12677 ELSEIF(NJET.EQ.3) THEN
12678 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
12683 C...Fill jet configuration; return if incorrect kinematics.
12685 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
12686 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
12687 ELSEIF(NJET.EQ.2) THEN
12688 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
12689 ELSEIF(NJET.EQ.3) THEN
12690 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
12691 ELSEIF(KFLN.EQ.21) THEN
12692 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
12695 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
12698 IF(MSTU(24).NE.0) THEN
12705 C...Angular orientation according to matrix element.
12706 IF(MSTJ(106).EQ.1) THEN
12707 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
12708 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
12710 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
12711 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
12714 C...Boost partons to Z0 rest frame.
12715 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
12716 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
12718 C...Mark decayed resonance and add documentation lines,
12720 IDOC=MINT(83)+MINT(4)
12722 I1=MINT(83)+MINT(4)+1
12724 IF(MSTP(128).GE.1) K(I,3)=ID
12725 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
12736 C...Generate parton shower.
12737 IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
12739 C... End special case for Z0: skip ahead.
12745 C...Order incoming partons and outgoing resonances.
12746 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
12749 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
12750 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
12751 & ILIN(1)=2*MINT(84)+3-ILIN(1)
12752 ILIN(2)=2*MINT(84)+3-ILIN(1)
12754 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
12758 IF(K(IREF(IP,1),2).EQ.23) IORD=2
12759 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
12760 IAKIPD=IABS(K(IREF(IP,IORD),2))
12761 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
12762 IF(KDCY(IORD).EQ.0) IORD=3-IORD
12764 C...Order decay products of resonances.
12765 DO 280 JT=IORD,3-IORD,3-2*IORD
12766 IF(KDCY(JT).EQ.0) THEN
12767 ILIN(IMAX+1)=NSD(JT)
12769 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
12770 ILIN(IMAX+1)=N+2*JT-1
12771 ILIN(IMAX+2)=N+2*JT
12773 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
12774 K(N+2*JT,2)=K(NSD(JT)+2,2)
12776 ILIN(IMAX+1)=N+2*JT
12777 ILIN(IMAX+2)=N+2*JT-1
12779 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
12780 K(N+2*JT,2)=K(NSD(JT)+2,2)
12784 C...Find charge, isospin, left- and righthanded couplings.
12789 KFA=IABS(K(ILIN(I),2))
12790 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 300
12791 COUP(I,1)=KCHG(KFA,1)/3D0
12792 COUP(I,2)=(-1)**MOD(KFA,2)
12793 COUP(I,4)=-2D0*COUP(I,1)*XWV
12794 COUP(I,3)=COUP(I,2)+COUP(I,4)
12797 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
12798 IF(ISUB.EQ.22) THEN
12801 IF(I.EQ.5) I1=3-IORD
12804 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
12805 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
12806 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
12811 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
12812 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
12813 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
12814 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
12815 IF(COWT12.LT.PYR(0)*COMX12) GOTO 160
12819 C...Select angular orientation type - Z'/W' only.
12821 IF(ISUB.EQ.141) THEN
12822 IF(PYR(0).LT.PARU(130)) MZPWP=1
12824 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
12825 IAKIR=IABS(K(IREF(2,2),2))
12826 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
12827 IF(IAKIR.LE.20) MZPWP=2
12829 IF(IP.GE.3) MZPWP=2
12830 ELSEIF(ISUB.EQ.142) THEN
12831 IF(PYR(0).LT.PARU(136)) MZPWP=1
12833 IAKIR=IABS(K(IREF(2,2),2))
12834 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
12835 IF(IAKIR.LE.20) MZPWP=2
12837 IF(IP.GE.3) MZPWP=2
12840 C...Select random angles (begin of weighting procedure).
12841 340 DO 350 JT=1,JTMAX
12842 IF(KDCY(JT).EQ.0) GOTO 350
12843 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
12844 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
12845 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
12848 CTHE(JT)=2D0*PYR(0)-1D0
12849 PHI(JT)=PARU(2)*PYR(0)
12853 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
12854 C...Construct massless four-vectors.
12863 IF(KDCY(JT).EQ.0) GOTO 380
12865 P(N+2*JT-1,3)=0.5D0*P(ID,5)
12866 P(N+2*JT-1,4)=0.5D0*P(ID,5)
12867 P(N+2*JT,3)=-0.5D0*P(ID,5)
12868 P(N+2*JT,4)=0.5D0*P(ID,5)
12869 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
12870 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
12873 C...Store incoming and outgoing momenta, with random rotation to
12874 C...avoid accidental zeroes in HA expressions.
12878 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
12879 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
12880 P(N+4+I,5)=P(ILIN(I),5)
12882 P(N+4+I,J)=P(ILIN(I),J)
12885 410 THERR=ACOS(2D0*PYR(0)-1D0)
12886 PHIRR=PARU(2)*PYR(0)
12887 CALL PYROBO(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
12889 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2)
12897 C...Calculate internal products.
12898 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
12899 & ISUB.EQ.142) THEN
12900 DO 450 I1=IMIN,IMAX-1
12901 DO 440 I2=I1+1,IMAX
12902 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
12903 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
12904 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
12905 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
12906 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
12907 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
12908 HC(I1,I2)=CONJG(HA(I1,I2))
12909 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
12910 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
12911 HA(I2,I1)=-HA(I1,I2)
12912 HC(I2,I1)=-HC(I1,I2)
12917 C...Calculate four-products.
12924 DO 490 I1=IMIN,IMAX-1
12925 DO 480 I2=I1+1,IMAX
12926 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
12927 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
12928 PKK(I2,I1)=PKK(I1,I2)
12934 KFAGM=IABS(IREF(IP,7))
12935 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
12936 C...Isotropic decay selected by user.
12940 ELSEIF(JTMAX.EQ.3) THEN
12941 C...Isotropic decay when three mother particles.
12945 ELSEIF(IT4.GE.1) THEN
12946 C... Isotropic decay t -> b + W etc for 4th generation q and l.
12950 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
12951 & IREF(IP,7).EQ.36) THEN
12952 C...Angular weight for h0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
12953 IF(IP.EQ.1) WTMAX=SH**2
12954 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
12955 KFA=IABS(K(IREF(IP,1),2))
12957 KFLF1A=IABS(KFL1(1))
12958 EF1=KCHG(KFLF1A,1)/3D0
12959 AF1=SIGN(1D0,EF1+0.1D0)
12960 VF1=AF1-4D0*EF1*XWV
12961 KFLF2A=IABS(KFL1(2))
12962 EF2=KCHG(KFLF2A,1)/3D0
12963 AF2=SIGN(1D0,EF2+0.1D0)
12964 VF2=AF2-4D0*EF2*XWV
12965 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
12966 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
12967 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
12968 ELSEIF(KFA.EQ.24) THEN
12969 WT=16D0*PKK(3,5)*PKK(4,6)
12974 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
12975 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
12977 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
12979 IF(MOD(KFAGM,2).EQ.0) THEN
12987 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
12988 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
12989 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
12990 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
12992 ELSEIF(ISUB.EQ.1) THEN
12993 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
12994 EI=KCHG(IABS(MINT(15)),1)/3D0
12995 AI=SIGN(1D0,EI+0.1D0)
12997 EF=KCHG(IABS(KFL1(1)),1)/3D0
12998 AF=SIGN(1D0,EF+0.1D0)
13000 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
13001 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13002 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
13003 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13004 & (VI**2+AI**2)*VINT(114)*VF**2)
13005 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
13006 & 4D0*VI*AI*VINT(114)*VF*AF)
13007 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13008 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13009 WTMAX=2D0*(WT1+ABS(WT3))
13011 ELSEIF(ISUB.EQ.2) THEN
13012 C...Angular weight for W+/- -> 2 quarks/leptons.
13013 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
13014 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
13015 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13016 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13019 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
13020 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
13021 C...-> gluon/gamma + 2 quarks/leptons.
13022 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13023 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13024 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13025 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13026 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13027 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13028 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13029 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13030 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13031 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13032 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13033 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13034 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
13035 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
13036 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13037 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
13039 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
13040 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
13041 C...-> gluon/gamma + 2 quarks/leptons.
13042 WT=PKK(1,3)**2+PKK(2,4)**2
13043 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
13045 ELSEIF(ISUB.EQ.22) THEN
13046 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
13047 S34=P(IREF(IP,IORD),5)**2
13048 S56=P(IREF(IP,3-IORD),5)**2
13049 TI=PKK(1,3)+PKK(1,4)+S34
13050 UI=PKK(1,5)+PKK(1,6)+S56
13053 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
13054 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
13055 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
13056 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
13057 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
13058 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
13059 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
13060 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
13062 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
13063 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
13064 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
13065 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
13066 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
13067 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
13068 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
13071 ELSEIF(ISUB.EQ.23) THEN
13072 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
13073 D34=P(IREF(IP,IORD),5)**2
13074 D56=P(IREF(IP,3-IORD),5)**2
13075 DT=PKK(1,3)+PKK(1,4)+D34
13076 DU=PKK(1,5)+PKK(1,6)+D56
13077 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
13078 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13079 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13080 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
13081 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
13082 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
13083 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
13084 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13085 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
13086 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
13088 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
13089 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
13090 C...(or H0, or A0).
13091 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
13092 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
13093 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
13094 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
13095 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13097 ELSEIF(ISUB.EQ.25) THEN
13098 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
13099 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
13100 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
13101 D34=P(IREF(IP,IORD),5)**2
13102 D56=P(IREF(IP,3-IORD),5)**2
13103 DT=PKK(1,3)+PKK(1,4)+D34
13104 DU=PKK(1,5)+PKK(1,6)+D56
13105 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
13106 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
13107 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
13108 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
13109 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
13110 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
13111 & REAL(CBWW)*FGK(1,2,5,6,3,4))
13112 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13113 IF(MSTP(50).LE.0) THEN
13114 WT=FGK135**2+(CCWW*FGK253)**2
13115 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
13116 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
13119 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
13120 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
13121 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
13122 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
13125 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
13126 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
13127 C...(or H0, or A0).
13128 WT=PKK(1,3)*PKK(2,4)
13129 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13131 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
13132 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
13133 C...-> f + 2 quarks/leptons.
13134 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13135 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13136 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13137 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13138 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13139 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13140 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13141 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13142 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13143 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13144 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13145 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13146 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
13147 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
13148 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
13149 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
13150 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13151 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
13153 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
13154 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
13155 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
13156 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
13157 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
13159 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
13161 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
13162 WT=16D0*PKK(3,5)*PKK(4,6)
13165 ELSEIF(ISUB.EQ.110) THEN
13166 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
13170 ELSEIF(ISUB.EQ.141) THEN
13171 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13172 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
13173 C...Couplings of incoming flavour.
13174 KFAI=IABS(MINT(15))
13175 EI=KCHG(KFAI,1)/3D0
13176 AI=SIGN(1D0,EI+0.1D0)
13179 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
13180 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
13181 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
13182 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
13183 VPI=PARU(119+2*KFAIC)
13184 API=PARU(120+2*KFAIC)
13185 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
13186 VPI=PARJ(178+2*KFAIC)
13187 API=PARJ(179+2*KFAIC)
13189 VPI=PARJ(186+2*KFAIC)
13190 API=PARJ(187+2*KFAIC)
13192 C...Couplings of final flavour.
13194 EF=KCHG(KFAF,1)/3D0
13195 AF=SIGN(1D0,EF+0.1D0)
13198 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
13199 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
13200 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
13201 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
13202 VPF=PARU(119+2*KFAFC)
13203 APF=PARU(120+2*KFAFC)
13204 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
13205 VPF=PARJ(178+2*KFAFC)
13206 APF=PARJ(179+2*KFAFC)
13208 VPF=PARJ(186+2*KFAFC)
13209 APF=PARJ(187+2*KFAFC)
13211 C...Asymmetry and weight.
13212 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
13213 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
13214 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
13215 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13216 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
13217 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
13218 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
13219 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13220 WTMAX=2D0+ABS(ASYM)
13221 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
13222 C...Angular weight for f + fbar -> Z' -> W+ + W-.
13223 RM1=P(NSD(1)+1,5)**2/SH
13224 RM2=P(NSD(1)+2,5)**2/SH
13225 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13226 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13227 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13229 WT=CFLAT+CCOS2*CTHE(1)**2
13230 WTMAX=CFLAT+MAX(0D0,CCOS2)
13231 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
13232 & IABS(KFL1(1)).EQ.37)) THEN
13233 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
13236 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13237 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
13238 RM1=P(NSD(1)+1,5)**2/SH
13239 RM2=P(NSD(1)+2,5)**2/SH
13240 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13241 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13242 WTMAX=1D0+FLAM2/(8D0*RM1)
13243 ELSEIF(MZPWP.EQ.0) THEN
13244 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13245 C...(W:s like if intermediate Z).
13246 D34=P(IREF(IP,IORD),5)**2
13247 D56=P(IREF(IP,3-IORD),5)**2
13248 DT=PKK(1,3)+PKK(1,4)+D34
13249 DU=PKK(1,5)+PKK(1,6)+D56
13250 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13251 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13252 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
13253 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
13254 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13255 ELSEIF(MZPWP.EQ.1) THEN
13256 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13257 C...(W:s approximately longitudinal, like if intermediate H).
13258 WT=16D0*PKK(3,5)*PKK(4,6)
13261 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
13262 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
13267 ELSEIF(ISUB.EQ.142) THEN
13268 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13269 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
13270 KFAI=IABS(MINT(15))
13272 IF(KFAI.GT.10) KFAIC=2
13273 VI=PARU(129+2*KFAIC)
13274 AI=PARU(130+2*KFAIC)
13277 IF(KFAF.GT.10) KFAFC=2
13278 VF=PARU(129+2*KFAFC)
13279 AF=PARU(130+2*KFAFC)
13280 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
13281 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13282 WTMAX=2D0+ABS(ASYM)
13283 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
13284 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
13285 RM1=P(NSD(1)+1,5)**2/SH
13286 RM2=P(NSD(1)+2,5)**2/SH
13287 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13288 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13289 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13291 WT=CFLAT+CCOS2*CTHE(1)**2
13292 WTMAX=CFLAT+MAX(0D0,CCOS2)
13293 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13294 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
13295 RM1=P(NSD(1)+1,5)**2/SH
13296 RM2=P(NSD(1)+2,5)**2/SH
13297 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13298 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13299 WTMAX=1D0+FLAM2/(8D0*RM1)
13300 ELSEIF(MZPWP.EQ.0) THEN
13301 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13302 C...(W/Z like if intermediate W).
13303 D34=P(IREF(IP,IORD),5)**2
13304 D56=P(IREF(IP,3-IORD),5)**2
13305 DT=PKK(1,3)+PKK(1,4)+D34
13306 DU=PKK(1,5)+PKK(1,6)+D56
13307 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13308 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
13309 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13310 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
13311 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13312 ELSEIF(MZPWP.EQ.1) THEN
13313 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13314 C...(W/Z approximately longitudinal, like if intermediate H).
13315 WT=16D0*PKK(3,5)*PKK(4,6)
13318 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
13319 C...t + bbar -> t + W + bbar.
13324 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
13326 C...Isotropic decay of leptoquarks (assumed spin 0).
13330 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
13331 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
13333 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
13334 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
13335 WT=1D0+SIDE*CTHE(1)
13337 ELSEIF(IP.EQ.1) THEN
13338 RM1=P(NSD(1)+1,5)**2/SH
13339 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13340 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13342 C...W/Z decay assumed isotropic, since not known.
13347 ELSEIF(ISUB.EQ.149) THEN
13348 C...Isotropic decay of techni-eta.
13352 ELSEIF(ISUB.EQ.191) THEN
13353 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13354 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
13355 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
13358 ELSEIF(IP.EQ.1) THEN
13359 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
13360 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13361 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
13362 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13363 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13364 KFAI=IABS(MINT(15))
13365 EI=KCHG(KFAI,1)/3D0
13366 AI=SIGN(1D0,EI+0.1D0)
13370 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
13371 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
13373 EF=KCHG(KFAF,1)/3D0
13374 AF=SIGN(1D0,EF+0.1D0)
13378 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
13379 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
13380 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
13381 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
13382 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
13383 WTMAX=4D0*MAX(ASAME,AFLIP)
13385 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
13390 ELSEIF(ISUB.EQ.192) THEN
13391 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13392 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
13393 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
13396 ELSEIF(IP.EQ.1) THEN
13397 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
13398 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13402 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
13407 ELSEIF(ISUB.EQ.193) THEN
13408 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13409 C...Angular weight for f + fbar -> omega_tc0 ->
13410 C...gamma pi_tc0 or Z0 pi_tc0.
13413 ELSEIF(IP.EQ.1) THEN
13414 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
13415 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13416 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13417 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13418 KFAI=IABS(MINT(15))
13419 EI=KCHG(KFAI,1)/3D0
13420 AI=SIGN(1D0,EI+0.1D0)
13424 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
13425 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
13427 EF=KCHG(KFAF,1)/3D0
13428 AF=SIGN(1D0,EF+0.1D0)
13432 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
13433 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
13434 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
13435 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
13436 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
13437 WTMAX=4D0*MAX(BSAME,BFLIP)
13439 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
13444 ELSEIF(ISUB.EQ.353) THEN
13445 C...Angular weight for Z_R0 -> 2 quarks/leptons.
13446 EI=KCHG(IABS(MINT(15)),1)/3D0
13447 AI=SIGN(1D0,EI+0.1D0)
13449 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
13450 AF=SIGN(1D0,EF+0.1D0)
13452 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
13453 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
13454 WT2=RMF*(VI**2+AI**2)*VF**2
13455 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
13456 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13457 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13458 WTMAX=2D0*(WT1+ABS(WT3))
13460 ELSEIF(ISUB.EQ.354) THEN
13461 C...Angular weight for W_R+/- -> 2 quarks/leptons.
13462 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
13463 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
13464 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13465 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13468 ELSEIF(ISUB.EQ.391) THEN
13469 C...Angular weight for f + fbar -> G* -> f + fbar
13470 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13471 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
13473 C...Other G* decays not yet implemented angular distributions.
13479 ELSEIF(ISUB.EQ.392) THEN
13480 C...Angular weight for g + g -> G* -> f + fbar
13481 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13484 C...Other G* decays not yet implemented angular distributions.
13490 C...Obtain correct angular distribution by rejection techniques.
13495 IF(WT.LT.PYR(0)*WTMAX) GOTO 340
13497 C...Construct massive four-vectors using angles chosen.
13498 500 DO 600 JT=1,JTMAX
13499 IF(KDCY(JT).EQ.0) GOTO 600
13504 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
13506 IF(KFL3(JT).EQ.0) THEN
13507 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
13508 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13511 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
13512 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13517 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
13519 C...Fill in position of decay vertex.
13520 DO 540 I=NSD(JT)+1,N0
13528 C...Mark decayed resonances; trace history.
13532 IF(KCQM(JT).NE.0) THEN
13533 C...Do not kill colour flow through coloured resonance!
13537 IF(KFL3(JT).NE.0) K(ID,5)=NSD(JT)+3
13540 C...Add documentation lines.
13542 IDOC=MINT(83)+MINT(4)
13545 IF(KFL3(JT).NE.0) IHI=IHI+1
13546 DO 560 I=NSD(JT)+1,IHI
13548 I1=MINT(83)+MINT(4)+1
13550 IF(MSTP(128).GE.1) K(I,3)=ID
13551 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
13555 K(I1,3)=IREF(IP,JT+3)
13564 IF(KFL3(JT).NE.0) K(NSD(JT)+3,3)=ID
13567 C...Do showering of two or three objects.
13569 IF(MSTP(71).GE.1) THEN
13570 IF(KFL3(JT).EQ.0) THEN
13571 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
13573 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
13577 IF(JT.EQ.1) NAFT1=N
13579 C...Check if decay products moved by shower.
13583 IF(NSHAFT.GT.NSHBEF) THEN
13584 IF(K(NSD1,1).GT.10) THEN
13585 DO 570 I=NSHBEF+1,NSHAFT
13586 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
13589 IF(K(NSD2,1).GT.10) THEN
13590 DO 580 I=NSHBEF+1,NSHAFT
13591 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
13592 & I.NE.NSD1) NSD2=I
13595 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
13596 DO 590 I=NSHBEF+1,NSHAFT
13597 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
13598 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
13603 C...Store decay products for further treatment.
13608 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
13612 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
13613 IREF(NP,7)=K(IREF(IP,JT),2)
13614 IREF(NP,8)=IREF(IP,JT)
13617 C...Fill information for 2 -> 1 -> 2.
13618 610 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
13619 MINT(7)=MINT(83)+6+2*ISET(ISUB)
13620 MINT(8)=MINT(83)+7+2*ISET(ISUB)
13626 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13627 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
13628 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
13629 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
13630 VINT(47)=SQRT(VINT(48))
13633 C...Possibility of colour rearrangement in W+W- events.
13634 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
13635 IAKF1=IABS(KFL1(1))
13636 IAKF2=IABS(KFL1(2))
13637 IAKF3=IABS(KFL2(1))
13638 IAKF4=IABS(KFL2(2))
13639 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
13640 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
13641 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
13644 C...Loop back if needed.
13645 620 IF(IP.LT.NP) GOTO 150
13647 C...Boost back to standard frame.
13648 630 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
13654 C*********************************************************************
13657 C...Initializes treatment of multiple interactions, selects kinematics
13658 C...of hardest interaction if low-pT physics included in run, and
13659 C...generates all non-hardest interactions.
13661 SUBROUTINE PYMULT(MMUL)
13663 C...Double precision and integer declarations.
13664 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13665 IMPLICIT INTEGER(I-N)
13666 INTEGER PYK,PYCHGE,PYCOMP
13668 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13669 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13670 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13671 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13672 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13673 COMMON/PYINT1/MINT(400),VINT(400)
13674 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13675 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13676 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
13677 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
13678 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
13679 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
13680 C...Local arrays and saved variables.
13681 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
13682 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
13684 C...Initialization of multiple interaction treatment.
13686 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
13694 C...Loop over phase space points: xT2 choice in 20 bins.
13697 NMUL(IXT2)=MSTP(83)
13699 DO 110 ITRY=1,MSTP(83)
13700 RSCA=0.05D0*((21-IXT2)-PYR(0))
13701 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
13702 XT2=MAX(0.01D0*VINT(149),XT2)
13705 C...Choose tau and y*. Calculate cos(theta-hat).
13706 IF(PYR(0).LE.COEF(ISUB,1)) THEN
13707 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
13708 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
13710 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
13716 IF(RYST.GT.COEF(ISUB,8)) MYST=2
13717 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
13718 CALL PYKMAP(2,MYST,PYR(0))
13719 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
13721 C...Calculate differential cross-section.
13722 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
13723 CALL PYSIGH(NCHN,SIGS)
13724 SIGM(IXT2)=SIGM(IXT2)+SIGS
13726 SIGSUM=SIGSUM+SIGM(IXT2)
13728 SIGSUM=SIGSUM/(20D0*MSTP(83))
13730 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
13731 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
13732 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
13733 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
13734 PARP(82)=0.9D0*PARP(82)
13735 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
13739 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
13740 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
13742 C...Start iteration to find k factor.
13743 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
13751 130 IF(IIT.EQ.0) THEN
13753 ELSEIF(IIT.EQ.1) THEN
13756 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
13759 C...Evaluate overlap integrals.
13760 IF(MSTP(82).EQ.2) THEN
13761 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
13764 IF(MSTP(82).EQ.3) DELTAB=0.02D0
13765 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
13770 IF(MSTP(82).EQ.3) THEN
13771 OV=EXP(-B**2)/PARU(2)
13774 OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
13775 & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
13776 & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
13777 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
13779 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
13780 SP=SP+PARU(2)*B*DELTAB*PACC
13781 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
13782 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
13784 YK=PARU(1)*XK*SO/SP
13786 C...Continue iteration until convergence.
13796 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
13798 C...Store some results for subsequent use.
13803 C...Initialize iteration in xT2 for hardest interaction.
13804 ELSEIF(MMUL.EQ.2) THEN
13805 IF(MSTP(82).LE.0) THEN
13806 ELSEIF(MSTP(82).EQ.1) THEN
13808 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
13809 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
13810 & VINT(317)/(VINT(318)*VINT(320))
13811 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
13812 ELSEIF(MSTP(82).EQ.2) THEN
13814 XT2FAC=VINT(146)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
13815 & VINT(149)*(1D0+VINT(149))
13817 XC2=4D0*CKIN(3)**2/VINT(2)
13818 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
13821 ELSEIF(MMUL.EQ.3) THEN
13822 C...Low-pT or multiple interactions (first semihard interaction):
13823 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
13824 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
13826 IF(MSTP(82).LE.0) THEN
13828 ELSEIF(MSTP(82).EQ.1) THEN
13829 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
13830 ELSEIF(MSTP(82).EQ.2) THEN
13831 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
13832 & VINT(149)))).GT.PYR(0)) XT2=1D0
13833 IF(XT2.GE.1D0) THEN
13834 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
13835 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
13838 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
13839 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
13842 XT2=MAX(0.01D0*VINT(149),XT2)
13844 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
13845 & PYR(0)*(1D0-XC2))-VINT(149)
13846 XT2=MAX(0.01D0*VINT(149),XT2)
13850 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
13851 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
13852 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1
13853 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1
13856 VINT(21)=0.01D0*VINT(149)
13859 VINT(25)=0.01D0*VINT(149)
13862 C...Multiple interactions (first semihard interaction).
13863 C...Choose tau and y*. Calculate cos(theta-hat).
13864 IF(PYR(0).LE.COEF(ISUB,1)) THEN
13865 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
13866 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
13868 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
13874 IF(RYST.GT.COEF(ISUB,8)) MYST=2
13875 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
13876 CALL PYKMAP(2,MYST,PYR(0))
13877 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
13879 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
13881 C...Store results of cross-section calculation.
13882 ELSEIF(MMUL.EQ.4) THEN
13885 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
13886 IF(ISET(ISUB).EQ.2)
13887 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
13888 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
13889 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
13890 & (XTS+VINT(149))))
13891 IRBIN=INT(1D0+20D0*RBIN)
13892 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
13893 NMUL(IRBIN)=NMUL(IRBIN)+1
13894 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
13897 C...Choose impact parameter.
13898 ELSEIF(MMUL.EQ.5) THEN
13900 150 IF(MSTP(82).EQ.3) THEN
13901 VINT(148)=PYR(0)/(PARU(2)*VINT(147))
13905 IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
13907 ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
13908 B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
13910 B2=-CQ2*LOG(PYR(0))
13912 VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
13913 & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
13914 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
13917 C...Multiple interactions (variable impact parameter) : reject with
13918 C...probability exp(-overlap*cross-section above pT/normalization).
13919 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
13920 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
13921 DO 160 IBIN=IRBIN+1,20
13922 RNCOR=RNCOR+NMUL(IBIN)
13923 SIGCOR=SIGCOR+SIGM(IBIN)
13925 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
13926 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
13927 VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
13928 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
13929 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
13930 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
13931 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
13932 IF(VINT(150).LT.PYR(0)) GOTO 150
13936 C...Generate additional multiple semihard interactions.
13937 ELSEIF(MMUL.EQ.6) THEN
13947 C...Reconstruct strings in hard scattering.
13949 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
13950 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
13952 DO 190 I=MINT(84)+1,NMAX
13953 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
13954 IF(KCS.EQ.0) GOTO 190
13956 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 180
13957 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 180
13959 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
13961 IST=MOD(K(I,J+1),MSTU(5))
13963 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 180
13964 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 180
13966 IF(J.EQ.1.OR.J.EQ.4) THEN
13976 C...Set up starting values for iteration in xT2.
13977 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
13978 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
13979 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
13980 & ISUBSV.NE.96)) THEN
13981 XT2=(1D0-VINT(141))*(1D0-VINT(142))
13984 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
13985 IF(ISET(ISUBSV).EQ.2)
13986 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
13987 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
13989 IF(MSTP(82).LE.1) THEN
13990 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
13991 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
13992 & VINT(317)/(VINT(318)*VINT(320))
13993 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
13995 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
13996 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
14000 VINT(143)=1D0-VINT(141)
14001 VINT(144)=1D0-VINT(142)
14003 C...Iterate downwards in xT2.
14004 200 IF(MSTP(82).LE.1) THEN
14005 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
14006 IF(XT2.LT.VINT(149)) GOTO 250
14008 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 250
14009 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
14010 & LOG(PYR(0)))-VINT(149)
14011 IF(XT2.LE.0D0) GOTO 250
14012 XT2=MAX(0.01D0*VINT(149),XT2)
14016 C...Choose tau and y*. Calculate cos(theta-hat).
14017 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14018 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14019 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14021 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14027 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14028 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14029 CALL PYKMAP(2,MYST,PYR(0))
14030 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14032 C...Check that x not used up. Accept or reject kinematical variables.
14033 X1M=SQRT(TAU)*EXP(VINT(22))
14034 X2M=SQRT(TAU)*EXP(-VINT(22))
14035 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 200
14036 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
14037 CALL PYSIGH(NCHN,SIGS)
14038 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
14039 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 200
14041 C...Reset K, P and V vectors. Select some variables.
14050 PT=0.5D0*VINT(1)*SQRT(XT2)
14054 C...Add first parton to event record.
14057 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
14058 & 1+INT((2D0+PARJ(2))*PYR(0))
14059 P(N+1,1)=PT*COS(PHI)
14060 P(N+1,2)=PT*SIN(PHI)
14061 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
14062 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
14065 C...Add second parton to event record.
14068 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
14071 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
14072 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
14075 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
14076 C....Choose relevant string pieces to place gluons on.
14082 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
14083 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
14084 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
14085 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
14086 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
14094 C....Colour flow adjustments, new string pieces.
14095 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
14096 & MOD(K(IST1,4),MSTU(5))
14097 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
14098 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
14099 K(I,5)=MSTU(5)*IST1
14100 K(I,4)=MSTU(5)*IST2
14101 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
14102 & MOD(K(IST2,5),MSTU(5))
14103 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
14104 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
14107 KSTR(NSTR+1,2)=IST2
14111 C...String drawing and colour flow for gluon loop.
14112 ELSEIF(K(N+1,2).EQ.21) THEN
14113 K(N+1,4)=MSTU(5)*(N+2)
14114 K(N+1,5)=MSTU(5)*(N+2)
14115 K(N+2,4)=MSTU(5)*(N+1)
14116 K(N+2,5)=MSTU(5)*(N+1)
14123 C...String drawing and colour flow for qqbar pair.
14125 K(N+1,4)=MSTU(5)*(N+2)
14126 K(N+2,5)=MSTU(5)*(N+1)
14132 C...Update remaining energy; iterate.
14134 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14135 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
14136 IF(MSTU(21).GE.1) RETURN
14138 MINT(31)=MINT(31)+1
14139 VINT(151)=VINT(151)+VINT(41)
14140 VINT(152)=VINT(152)+VINT(42)
14141 VINT(143)=VINT(143)-VINT(41)
14142 VINT(144)=VINT(144)-VINT(42)
14143 IF(MINT(31).LT.240) GOTO 200
14151 C...Format statements for printout.
14152 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
14153 &'actions for MSTP(82) =',I2,' ******')
14154 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14155 &D9.2,' mb: rejected')
14156 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14157 &D9.2,' mb: accepted')
14162 C*********************************************************************
14165 C...Adds on target remnants (one or two from each side) and
14166 C...includes primordial kT for hadron beams.
14168 SUBROUTINE PYREMN(IPU1,IPU2)
14170 C...Double precision and integer declarations.
14171 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14172 IMPLICIT INTEGER(I-N)
14173 INTEGER PYK,PYCHGE,PYCOMP
14175 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14176 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14177 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14178 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14179 COMMON/PYINT1/MINT(400),VINT(400)
14180 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
14182 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
14183 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
14185 C...Find event type and remaining energy.
14188 IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
14189 VINT(143)=1D0-VINT(141)
14190 VINT(144)=1D0-VINT(142)
14193 C...Define initial partons.
14198 IF(JT.EQ.1) IPU=IPU1
14199 IF(JT.EQ.2) IPU=IPU2
14206 IF(MINT(47).EQ.1) THEN
14210 ELSEIF(ISUB.EQ.95) THEN
14215 C...No primordial kT, or chosen according to truncated Gaussian or
14216 C...exponential, or (for photon) predetermined or power law.
14217 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
14218 IF(MSTP(91).LE.0) THEN
14220 ELSEIF(MSTP(91).EQ.1) THEN
14221 PT=PARP(91)*SQRT(-LOG(PYR(0)))
14225 PT=-PARP(92)*LOG(RPT1*RPT2)
14227 IF(PT.GT.PARP(93)) GOTO 120
14228 ELSEIF(MINT(106+JT).EQ.3) THEN
14229 PTA=SQRT(VINT(282+JT))
14231 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
14232 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
14233 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
14236 PTB=-PARP(99)*LOG(RPT1*RPT2)
14238 IF(PTB.GT.PARP(100)) GOTO 120
14239 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
14240 PT=PT*0.8D0**MINT(57)
14241 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
14242 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
14243 IF(MSTP(93).LE.0) THEN
14245 ELSEIF(MSTP(93).EQ.1) THEN
14246 PT=PARP(99)*SQRT(-LOG(PYR(0)))
14247 ELSEIF(MSTP(93).EQ.2) THEN
14250 PT=-PARP(99)*LOG(RPT1*RPT2)
14251 ELSEIF(MSTP(93).EQ.3) THEN
14254 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
14258 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
14259 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
14261 IF(PT.GT.PARP(100)) GOTO 120
14269 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14272 IF(MINT(47).EQ.1) RETURN
14274 C...Kinematics construction for initial partons.
14277 IF(ISUB.EQ.95) THEN
14281 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
14282 & (P(I1,2)+P(I2,2))**2
14283 SHR=SQRT(MAX(0D0,SHS))
14284 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
14285 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
14286 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
14287 P(I2,4)=SHR-P(I1,4)
14290 C...Transform partons to overall CM-frame.
14291 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
14292 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
14293 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
14294 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
14295 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
14296 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
14297 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
14298 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
14299 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
14300 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
14301 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
14304 C...Optionally fix up x and Q2 definitions for leptoproduction.
14306 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
14307 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
14308 IF(IDISXQ.EQ.1) THEN
14310 C...Find where incoming and outgoing leptons/partons are sitting.
14312 IF(MINT(42).EQ.1) LESD=2
14313 LPIN=MINT(83)+3-LESD
14315 LQIN=MINT(84)+3-LESD
14316 LEOUT=MINT(84)+2+LESD
14317 LQOUT=MINT(84)+5-LESD
14318 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
14319 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
14321 DO 140 I=MINT(84)+5,N
14322 IF(K(I,2).EQ.94) THEN
14329 IF(LESD.EQ.1) LQBG=IPU2
14331 C...Calculate actual and wanted momentum transfer.
14334 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
14335 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
14336 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
14337 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
14338 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
14339 P(N+1,1)=FAC*P(LEOUT,1)
14340 P(N+1,2)=FAC*P(LEOUT,2)
14341 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
14342 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
14343 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
14346 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
14347 QNEW(J)=P(LEIN,J)-P(N+1,J)
14350 C...Boost outgoing electron and daughters.
14351 IF(LSCMS.EQ.0) THEN
14353 P(LEOUT,J)=P(N+1,J)
14357 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
14359 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
14361 DBE(J)=PINV*P(N+2,J)
14365 190 IORIG=K(IORIG,3)
14366 IF(IORIG.GT.LEOUT) GOTO 190
14367 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
14368 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
14372 C...Copy shower initiator and all outgoing partons.
14376 P(NCOP,J)=P(LQBG,J)
14378 DO 240 I=MINT(84)+1,N
14380 IF(K(I,1).GT.10) GOTO 240
14381 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
14385 220 IORIG=K(IORIG,3)
14386 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
14388 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
14401 C...Calculate relative rescaling factors.
14405 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
14408 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
14411 C...Transfer extra three-momentum of current.
14414 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
14416 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14419 C...Iterate change of initiator momentum to get energy right.
14422 PEEX=-P(N+1,4)-QNEW(4)
14423 PEMV=-P(N+1,3)/P(N+1,4)
14426 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
14428 IF(ABS(PEMV).LT.1D-10) THEN
14430 MINT(57)=MINT(57)+1
14434 P(N+1,3)=P(N+1,3)+PZCH
14435 P(N+1,4)=SQRT(P(N+1,5)**2+P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
14437 P(I,3)=P(I,3)+V(I,1)*PZCH
14438 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14440 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
14442 C...Modify momenta in event record.
14443 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
14444 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
14445 IF(ABS(HBE).GE.1D0) THEN
14447 MINT(57)=MINT(57)+1
14451 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
14460 C...Check minimum invariant mass of remnant system(s).
14461 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
14462 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
14463 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
14464 PMIN(0)=SQRT(PMS(0))
14466 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
14467 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
14469 IF(MINT(44+JT).EQ.1) GOTO 340
14470 MINT(105)=MINT(102+JT)
14471 MINT(109)=MINT(106+JT)
14472 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
14473 IF(MINT(51).NE.0) THEN
14474 MINT(57)=MINT(57)+1
14477 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
14478 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
14479 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
14480 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
14481 & P(MINT(83)+JT+2,2)**2)
14483 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
14484 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
14487 MINT(57)=MINT(57)+1
14491 C...Loop over two remnants; skip if none there.
14495 IF(MINT(44+JT).EQ.1) GOTO 410
14496 IF(JT.EQ.1) IPU=IPU1
14497 IF(JT.EQ.2) IPU=IPU2
14499 C...Store first remnant parton.
14511 P(I,5)=PYMASS(K(I,2))
14513 C...First parton colour connections and kinematics.
14514 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
14517 K(I,4)=MSTU(5)*IPU+IPU
14518 K(I,5)=MSTU(5)*IPU+IPU
14519 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14520 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14521 ELSEIF(KCOL.NE.0) THEN
14523 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
14525 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14527 IF(KFLCH(JT).EQ.0) THEN
14528 P(I,1)=-P(MINT(83)+JT+2,1)
14529 P(I,2)=-P(MINT(83)+JT+2,2)
14530 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14531 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
14535 C...When extra remnant parton or hadron: store extra remnant.
14547 P(I,5)=PYMASS(K(I,2))
14549 C...Find parton colour connections of extra remnant.
14550 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
14553 K(I,4)=MSTU(5)*IPU+IPU
14554 K(I,5)=MSTU(5)*IPU+IPU
14555 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14556 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14557 ELSEIF(KCOL.NE.0) THEN
14559 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
14561 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14564 C...Relative transverse momentum when two remnants.
14567 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
14568 IF(IABS(MINT(10+JT)).LT.20) THEN
14572 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
14573 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
14575 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
14576 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
14577 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
14578 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14580 C...Meson or baryon; photon as meson. For splitup below.
14582 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
14584 C***Relative distribution for electron into two electrons. Temporary!
14585 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
14589 C...Relative distribution of electron energy into electron plus parton.
14590 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
14593 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
14595 C...Relative distribution of energy for particle into two jets.
14596 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
14597 CHIK=PARP(92+2*IMB)
14598 IF(MSTP(92).LE.1) THEN
14599 IF(IMB.EQ.1) CHI(JT)=PYR(0)
14600 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
14601 ELSEIF(MSTP(92).EQ.2) THEN
14602 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
14603 ELSEIF(MSTP(92).EQ.3) THEN
14604 CUT=2D0*0.3D0/VINT(1)
14605 380 CHI(JT)=PYR(0)**2
14606 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
14607 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
14608 ELSEIF(MSTP(92).EQ.4) THEN
14609 CUT=2D0*0.3D0/VINT(1)
14610 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
14611 390 CHIR=CUT*CUTR**PYR(0)
14612 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
14613 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
14615 CUT=2D0*0.3D0/VINT(1)
14616 CUTA=CUT**(1D0-PARP(98))
14617 CUTB=(1D0+CUT)**(1D0-PARP(98))
14618 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
14619 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
14620 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
14623 C...Relative distribution of energy for particle into jet plus particle.
14625 IF(MSTP(94).LE.1) THEN
14626 IF(IMB.EQ.1) CHI(JT)=PYR(0)
14627 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
14628 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
14629 ELSEIF(MSTP(94).EQ.2) THEN
14630 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
14631 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
14632 ELSEIF(MSTP(94).EQ.3) THEN
14633 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
14636 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
14641 C...Construct total transverse mass; reject if too large.
14642 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
14643 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
14644 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
14645 IF(LOOP.LT.100) THEN
14649 MINT(57)=MINT(57)+1
14653 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
14654 VINT(158+JT)=CHI(JT)
14656 C...Subdivide longitudinal momentum according to value selected above.
14657 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
14658 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
14659 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
14660 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
14661 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
14666 C...Check if longitudinal boosts needed - if so pick two systems.
14667 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
14668 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
14669 IF(PDEV.LE.1D-6*VINT(1)) RETURN
14670 IF(ISN(1).EQ.0) THEN
14673 ELSEIF(ISN(2).EQ.0) THEN
14676 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
14679 ELSEIF(VINT(143).GT.0.2D0) THEN
14682 ELSEIF(VINT(144).GT.0.2D0) THEN
14685 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
14694 C...E+-pL wanted for system to be modified.
14695 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
14699 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
14700 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
14703 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
14704 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
14705 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
14706 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
14710 DO 450 I=MINT(84)+1,NS
14711 IF(K(I,1).GT.10) GOTO 450
14714 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
14716 IF(IORIG.GT.LPIN) GOTO 430
14717 IF(INCL.EQ.0) GOTO 450
14719 PSYS(0,J)=PSYS(0,J)+P(I,J)
14722 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
14723 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
14724 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
14727 C...Construct longitudinal boosts.
14731 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
14732 IF(DSQLAM.LE.1D-6*DPMTB) THEN
14734 MINT(57)=MINT(57)+1
14737 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
14738 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
14739 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
14740 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
14741 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
14742 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
14743 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
14745 C...Perform longitudinal boosts.
14746 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
14748 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
14749 ELSEIF(IR.EQ.1) THEN
14750 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
14751 ELSEIF(IDISXQ.EQ.1) THEN
14755 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
14757 IF(IORIG.GT.LPIN) GOTO 460
14758 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
14761 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
14763 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
14765 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
14766 ELSEIF(IL.EQ.2) THEN
14767 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
14768 ELSEIF(IDISXQ.EQ.1) THEN
14772 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
14774 IF(IORIG.GT.LPIN) GOTO 480
14775 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
14778 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
14781 C...Final check that energy-momentum conservation worked.
14784 DO 500 I=MINT(84)+1,N
14785 IF(K(I,1).GT.10) GOTO 500
14789 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
14790 IF(PDEV.GT.1D-4*VINT(1)) THEN
14792 MINT(57)=MINT(57)+1
14796 C...Calculate rotation and boost from overall CM frame to
14797 C...hadronic CM frame in leptoproduction.
14799 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
14802 IF(MINT(42).EQ.1) LESD=2
14803 LPIN=MINT(83)+3-LESD
14805 C...Sum upp momenta of everything not lepton or photon to define boost.
14810 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
14811 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
14812 IF(K(I,2).EQ.22) GOTO 530
14814 PSUM(J)=PSUM(J)+P(I,J)
14817 VINT(223)=-PSUM(1)/PSUM(4)
14818 VINT(224)=-PSUM(2)/PSUM(4)
14819 VINT(225)=-PSUM(3)/PSUM(4)
14821 C...Boost incoming hadron to hadronic CM frame to determine rotations.
14827 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
14828 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
14829 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
14831 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
14833 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
14840 C*********************************************************************
14843 C...Handles diffractive and elastic scattering.
14847 C...Double precision and integer declarations.
14848 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14849 IMPLICIT INTEGER(I-N)
14850 INTEGER PYK,PYCHGE,PYCOMP
14852 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14853 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14854 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14855 COMMON/PYINT1/MINT(400),VINT(400)
14856 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
14858 C...Reset K, P and V vectors. Store incoming particles.
14859 DO 110 JT=1,MSTP(126)+10
14879 P(I,J)=VINT(285+5*JT+J)
14884 C...Subprocess; kinematics.
14885 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
14886 PZ=SQRT(SQLAM)/(2D0*VINT(1))
14889 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
14892 C...Elastically scattered particle. (Except elastic GVMD states.)
14893 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
14894 & MINT(106+JT).NE.3)) THEN
14899 P(N,3)=PZ*(-1)**(JT+1)
14901 P(N,5)=SQRT(VINT(62+JT))
14903 C...Decay rho from elastic scattering of gamma with sin**2(theta)
14904 C...distribution of decay products (in rho rest frame).
14905 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
14907 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
14911 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
14912 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
14913 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
14914 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
14915 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
14916 140 CTHE=2D0*PYR(0)-1D0
14917 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
14918 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
14920 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
14923 C...Diffracted particle: low-mass system to two particles.
14924 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
14930 PMMAS=SQRT(VINT(62+JT))
14933 IF(NTRY.LT.20) THEN
14934 MINT(105)=MINT(102+JT)
14935 MINT(109)=MINT(106+JT)
14936 CALL PYSPLI(KFH,21,KFL1,KFL2)
14937 CALL PYKFDI(KFL1,0,KFL3,KF1)
14938 IF(KF1.EQ.0) GOTO 150
14939 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
14940 IF(KF2.EQ.0) GOTO 150
14947 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
14952 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
14953 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
14956 P(N-1,4)=SQRT(PM1**2+PZP**2)
14957 P(N,4)=SQRT(PM2**2+PZP**2)
14958 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
14960 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
14961 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
14963 C...Diffracted particle: valence quark kicked out.
14964 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
14971 MINT(105)=MINT(102+JT)
14972 MINT(109)=MINT(106+JT)
14973 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
14974 P(N-1,5)=PYMASS(K(N-1,2))
14975 P(N,5)=PYMASS(K(N,2))
14976 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
14977 & 4D0*P(N-1,5)**2*P(N,5)**2
14978 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
14979 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
14980 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
14981 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
14982 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
14984 C...Diffracted particle: gluon kicked out.
14993 MINT(105)=MINT(102+JT)
14994 MINT(109)=MINT(106+JT)
14995 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
14997 P(N-2,5)=PYMASS(K(N-2,2))
14999 P(N,5)=PYMASS(K(N,2))
15000 C...Energy distribution for particle into two jets.
15002 IF(MOD(KFH/1000,10).NE.0) IMB=2
15003 CHIK=PARP(92+2*IMB)
15004 IF(MSTP(92).LE.1) THEN
15005 IF(IMB.EQ.1) CHI=PYR(0)
15006 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15007 ELSEIF(MSTP(92).EQ.2) THEN
15008 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
15009 ELSEIF(MSTP(92).EQ.3) THEN
15010 CUT=2D0*0.3D0/VINT(1)
15012 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
15014 ELSEIF(MSTP(92).EQ.4) THEN
15015 CUT=2D0*0.3D0/VINT(1)
15016 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
15017 180 CHIR=CUT*CUTR**PYR(0)
15018 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
15019 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
15021 CUT=2D0*0.3D0/VINT(1)
15022 CUTA=CUT**(1D0-PARP(98))
15023 CUTB=(1D0+CUT)**(1D0-PARP(98))
15024 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
15025 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
15026 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
15028 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
15029 & VINT(62+JT)) GOTO 160
15030 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
15031 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
15032 & (2D0*VINT(62+JT))
15033 PEI=SQRT(PZI**2+SQM)
15034 PQQP=(1D0-CHI)*(PEI+PZI)
15035 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
15036 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
15037 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
15038 P(N-1,3)=P(N-1,4)*(-1)**JT
15039 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
15040 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
15043 C...Documentation lines.
15045 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
15046 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
15047 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
15049 P(I+2,3)=PZ*(-1)**(JT+1)
15051 P(I+2,5)=SQRT(VINT(62+JT))
15054 C...Rotate outgoing partons/particles using cos(theta).
15055 IF(VINT(23).LT.0.9D0) THEN
15056 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
15058 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
15064 C*********************************************************************
15067 C...Set up a DIS process as gamma* + f -> f, with beam remnant
15068 C...and showering added consecutively. Photon flux by the PYGAGA
15069 C...routine (if at all).
15073 C...Double precision and integer declarations.
15074 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15075 IMPLICIT INTEGER(I-N)
15076 INTEGER PYK,PYCHGE,PYCOMP
15077 C...Parameter statement to help give large particle numbers.
15078 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
15079 &KEXCIT=4000000,KDIMEN=5000000)
15081 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15082 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15083 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15084 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15085 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15086 COMMON/PYINT1/MINT(400),VINT(400)
15087 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
15091 C...Choice of subprocess, number of documentation lines
15099 IF(MINT(107).EQ.4) ISIDE=2
15101 C...Reset K, P and V vectors. Store incoming particles
15102 DO 110 JT=1,MSTP(126)+20
15115 P(I,J)=VINT(285+5*JT+J)
15120 C...Store incoming partons in hadronic CM-frame
15125 K(I,3)=MINT(83)+2+JT
15127 IF(MINT(15).EQ.22) THEN
15128 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
15129 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
15130 P(MINT(84)+1,5)=-SQRT(VINT(307))
15131 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
15132 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
15136 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
15137 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
15138 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
15139 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
15140 P(MINT(84)+1,5)=-SQRT(VINT(308))
15144 SIDESG=(-1D0)**(ISIDE-1)
15146 C...Copy incoming partons to documentation lines.
15157 C...Second copy for partons before ISR shower, since no such.
15167 C...Define initial partons.
15170 IF(NTRY.GT.100) THEN
15175 C...Scattered quark in hadronic CM frame.
15180 P(IPU3,5)=PYMASS(KFRES)
15181 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
15182 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
15186 K(I,3)=MINT(83)+4+ISIDE
15194 C...No primordial kT, or chosen according to truncated Gaussian or
15195 C...exponential, or (for photon) predetermined or power law.
15196 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
15197 IF(MSTP(91).LE.0) THEN
15199 ELSEIF(MSTP(91).EQ.1) THEN
15200 PT=PARP(91)*SQRT(-LOG(PYR(0)))
15204 PT=-PARP(92)*LOG(RPT1*RPT2)
15206 IF(PT.GT.PARP(93)) GOTO 190
15207 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
15208 PTA=SQRT(VINT(282+ISIDE))
15210 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
15211 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
15212 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
15215 PTB=-PARP(99)*LOG(RPT1*RPT2)
15217 IF(PTB.GT.PARP(100)) GOTO 190
15218 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
15219 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
15220 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
15221 IF(MSTP(93).LE.0) THEN
15223 ELSEIF(MSTP(93).EQ.1) THEN
15224 PT=PARP(99)*SQRT(-LOG(PYR(0)))
15225 ELSEIF(MSTP(93).EQ.2) THEN
15228 PT=-PARP(99)*LOG(RPT1*RPT2)
15229 ELSEIF(MSTP(93).EQ.3) THEN
15232 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
15236 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
15237 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
15239 IF(PT.GT.PARP(100)) GOTO 190
15245 P(IPU3,1)=PT*COS(PHI)
15246 P(IPU3,2)=PT*SIN(PHI)
15247 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
15248 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
15249 PCP=P(IPU3,4)+ABS(P(IPU3,3))
15251 C...Find one or two beam remnants.
15252 MINT(105)=MINT(102+ISIDE)
15253 MINT(109)=MINT(106+ISIDE)
15254 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
15255 IF(MINT(51).NE.0) THEN
15260 C...Store first remnant parton, with colour info and kinematics.
15264 K(I,3)=MINT(83)+ISIDE
15265 P(I,5)=PYMASS(K(I,2))
15266 KCOL=KCHG(PYCOMP(KFLSP),2)
15269 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
15270 K(I,KFLS+3)=MSTU(5)*IPU3
15271 K(IPU3,6-KFLS)=MSTU(5)*I
15274 IF(KFLCH.EQ.0) THEN
15277 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15279 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
15280 PRP=P(I,4)+ABS(P(I,3))
15282 C...When extra remnant parton or hadron: store extra remnant.
15287 K(I,3)=MINT(83)+ISIDE
15288 P(I,5)=PYMASS(K(I,2))
15289 KCOL=KCHG(PYCOMP(KFLCH),2)
15292 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
15293 K(I,KFLS+3)=MSTU(5)*IPU3
15294 K(IPU3,6-KFLS)=MSTU(5)*I
15298 C...Relative transverse momentum when two remnants.
15301 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
15302 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
15303 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
15304 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
15305 P(I,1)=-P(IPU3,1)-P(I-1,1)
15306 P(I,2)=-P(IPU3,2)-P(I-1,2)
15307 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15309 C...Relative distribution of energy for particle into jet plus particle.
15311 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
15312 IF(MSTP(94).LE.1) THEN
15313 IF(IMB.EQ.1) CHI=PYR(0)
15314 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15315 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15316 ELSEIF(MSTP(94).EQ.2) THEN
15317 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
15318 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15319 ELSEIF(MSTP(94).EQ.3) THEN
15320 CALL PYZDIS(1,0,PMS(4),ZZ)
15323 CALL PYZDIS(1000,0,PMS(4),ZZ)
15327 C...Construct total transverse mass; reject if too large.
15328 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
15329 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
15330 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
15331 IF(LOOP.LT.10) GOTO 200
15334 VINT(158+ISIDE)=CHI
15336 C...Subdivide longitudinal momentum according to value selected above.
15337 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
15339 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
15340 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
15342 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
15343 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
15347 C...Boost current and remnant systems to correct frame.
15348 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
15349 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
15350 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
15352 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
15354 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
15355 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
15356 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
15357 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
15359 C...Let current quark shower; recoil but no showering by colour partner.
15360 QMAX=2D0*SQRT(VINT(309-ISIDE))
15365 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
15372 C*********************************************************************
15375 C...Handles the documentation of the process in MSTI and PARI,
15376 C...and also computes cross-sections based on accumulated statistics.
15380 C...Double precision and integer declarations.
15381 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15382 IMPLICIT INTEGER(I-N)
15383 INTEGER PYK,PYCHGE,PYCOMP
15385 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15386 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15387 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15388 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15389 COMMON/PYINT1/MINT(400),VINT(400)
15390 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15391 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15392 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
15395 C...Calculate Monte Carlo estimates of cross-sections.
15397 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
15398 NGEN(0,3)=NGEN(0,3)+1
15401 IF(I.EQ.96.OR.I.EQ.97) THEN
15403 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
15404 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
15405 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
15406 & DBLE(NGEN(96,2)))
15407 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
15409 ELSEIF(NGEN(I,2).EQ.0) THEN
15410 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
15413 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
15416 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
15419 C...Rescale to known low-pT cross-section for standard QCD processes.
15420 IF(MSUB(95).EQ.1) THEN
15421 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
15422 & XSEC(68,3)+XSEC(95,3)
15423 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
15424 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
15426 XSEC(11,3)=FAC*XSEC(11,3)
15427 XSEC(12,3)=FAC*XSEC(12,3)
15428 XSEC(13,3)=FAC*XSEC(13,3)
15429 XSEC(28,3)=FAC*XSEC(28,3)
15430 XSEC(53,3)=FAC*XSEC(53,3)
15431 XSEC(68,3)=FAC*XSEC(68,3)
15432 XSEC(95,3)=FAC*XSEC(95,3)
15433 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
15437 C...Save information for gamma-p and gamma-gamma.
15438 IF(MINT(121).GT.1) THEN
15444 C...Reset information on hard interaction.
15450 C...Copy integer valued information from MINT into MSTI.
15454 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
15456 C...Store cross-section variables in PARI.
15458 PARI(2)=XSEC(0,3)/MINT(5)
15462 VINT(98)=VINT(98)+VINT(100)
15463 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
15465 C...Store kinematics variables in PARI.
15468 IF(ISUB.NE.95) THEN
15476 PARI(35)=PARI(33)-PARI(34)
15483 PARI(42)=2D0*VINT(47)/VINT(1)
15486 C...Store information on scattered partons in PARI.
15487 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
15490 PARI(36+IS)=P(I,3)/VINT(1)
15491 PARI(38+IS)=P(I,4)/VINT(1)
15492 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
15493 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15494 & SQRT(PR),1D20)),P(I,3))
15495 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
15496 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15497 & SQRT(PR),1D20)),P(I,3))
15498 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
15499 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
15500 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
15504 C...Store sum up transverse and longitudinal momenta.
15505 PARI(65)=2D0*PARI(17)
15506 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
15507 DO 150 I=MSTP(126)+1,N
15508 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
15509 PT=SQRT(P(I,1)**2+P(I,2)**2)
15510 PARI(69)=PARI(69)+PT
15511 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
15512 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
15524 C...Store various other pieces of information into PARI.
15532 C...Store information on lepton -> lepton + gamma in PYGAGA.
15535 PARI(101)=VINT(301)
15536 PARI(102)=VINT(302)
15538 PARI(I)=VINT(I+202)
15541 C...Set information for PYTABU.
15542 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
15545 ELSEIF(ISET(ISUB).EQ.5) THEN
15556 C*********************************************************************
15559 C...Performs transformations between different coordinate frames.
15561 SUBROUTINE PYFRAM(IFRAME)
15563 C...Double precision and integer declarations.
15564 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15565 IMPLICIT INTEGER(I-N)
15566 INTEGER PYK,PYCHGE,PYCOMP
15568 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15569 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15570 COMMON/PYINT1/MINT(400),VINT(400)
15571 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
15573 C...Check that transformation can and should be done.
15574 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
15575 &MINT(91).EQ.1)) THEN
15576 IF(IFRAME.EQ.MINT(6)) RETURN
15578 WRITE(MSTU(11),5000) IFRAME,MINT(6)
15582 IF(MINT(6).EQ.1) THEN
15583 C...Transform from fixed target or user specified frame to
15584 C...overall CM frame.
15585 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
15586 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
15587 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
15588 ELSEIF(MINT(6).EQ.3) THEN
15589 C...Transform from hadronic CM frame in DIS to overall CM frame.
15590 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
15594 IF(IFRAME.EQ.1) THEN
15595 C...Transform from overall CM frame to fixed target or user specified
15597 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
15598 ELSEIF(IFRAME.EQ.3) THEN
15599 C...Transform from overall CM frame to hadronic CM frame in DIS.
15600 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
15601 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
15602 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
15605 C...Set information about new frame.
15609 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
15610 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
15616 C*********************************************************************
15619 C...Calculates full and partial widths of resonances.
15621 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
15623 C...Double precision and integer declarations.
15624 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15625 IMPLICIT INTEGER(I-N)
15626 INTEGER PYK,PYCHGE,PYCOMP
15627 C...Parameter statement to help give large particle numbers.
15628 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
15629 &KEXCIT=4000000,KDIMEN=5000000)
15631 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15632 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15633 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15634 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15635 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15636 COMMON/PYINT1/MINT(400),VINT(400)
15637 COMMON/PYINT4/MWID(500),WIDS(500,5)
15638 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
15639 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
15640 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
15641 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
15642 &/PYINT4/,/PYMSSM/,/PYSSMT/
15643 C...Local arrays and saved variables.
15644 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
15645 DIMENSION WDTP(0:300),WDTE(0:300,0:5),MOFSV(3,2),WIDWSV(3,2),
15646 &WID2SV(3,2),WDTPP(0:300),WDTEP(0:300,0:5)
15647 SAVE MOFSV,WIDWSV,WID2SV
15648 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
15650 C...Compressed code and sign; mass.
15657 C...Reset width information.
15665 C...Allow for fudge factor to rescale resonance width.
15667 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
15668 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
15669 IF(MSTP(110).EQ.KFLA) THEN
15671 ELSEIF(MSTP(110).EQ.-1) THEN
15672 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
15673 ELSEIF(MSTP(110).EQ.-2) THEN
15678 C...Not to be treated as a resonance: return.
15679 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
15688 C...Treatment as a resonance based on tabulated branching ratios.
15689 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
15690 C...Loop over possible decay channels; skip irrelevant ones.
15691 DO 120 I=1,MDCY(KC,3)
15693 IF(MDME(IDC,1).LT.0) GOTO 120
15695 C...Read out decay products and nominal masses.
15698 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
15702 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
15708 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
15712 C...Naive partial width and alternative threshold factors.
15713 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
15714 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
15715 & PM1+PM2+PM3.GE.SHR) THEN
15717 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
15718 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
15719 & 4D0*PM1**2*PM2**2))/SH
15720 ELSEIF(MDME(IDC,2).EQ.52) THEN
15721 PMA=MAX(PM1,PM2,PM3)
15722 PMC=MIN(PM1,PM2,PM3)
15723 PMB=PM1+PM2+PM3-PMA-PMC
15724 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
15729 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
15730 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
15731 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
15732 & ((SHR-PMA)**2-(PMB+PMC)**2)*
15733 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
15734 & ((1D0-PMBCN)*PMBCN*SH)
15735 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
15736 WDTP(I)=WDTP(I)*SQRT(
15737 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
15738 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
15739 ELSEIF(MDME(IDC,2).EQ.53) THEN
15740 PMA=MAX(PM1,PM2,PM3)
15741 PMC=MIN(PM1,PM2,PM3)
15742 PMB=PM1+PM2+PM3-PMA-PMC
15743 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
15748 FACACT=SQRT(MAX(0D0,
15749 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
15750 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
15751 & ((SHR-PMA)**2-(PMB+PMC)**2)*
15752 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
15753 & ((1D0-PMBCN)*PMBCN*SH)
15754 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
15758 PMBCN=PMBC**2/PMR**2
15759 FACNOM=SQRT(MAX(0D0,
15760 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
15761 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
15762 & ((PMR-PMA)**2-(PMB+PMC)**2)*
15763 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
15764 & ((1D0-PMBCN)*PMBCN*PMR**2)
15765 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
15767 WDTP(I)=FUDGE*WDTP(I)
15768 WDTP(0)=WDTP(0)+WDTP(I)
15770 C...Calculate secondary width (at most two identical/opposite).
15772 IF(MDME(IDC,1).GT.0) THEN
15773 IF(KFD2.EQ.KFD1) THEN
15774 IF(KCHG(KFC1,3).EQ.0) THEN
15776 ELSEIF(KFD1.GT.0) THEN
15782 WID2=WID2*WIDS(KFC3,2)
15783 ELSEIF(KFD3.LT.0) THEN
15784 WID2=WID2*WIDS(KFC3,3)
15786 ELSEIF(KFD2.EQ.-KFD1) THEN
15789 WID2=WID2*WIDS(KFC3,2)
15790 ELSEIF(KFD3.LT.0) THEN
15791 WID2=WID2*WIDS(KFC3,3)
15793 ELSEIF(KFD3.EQ.KFD1) THEN
15794 IF(KCHG(KFC1,3).EQ.0) THEN
15796 ELSEIF(KFD1.GT.0) THEN
15802 WID2=WID2*WIDS(KFC2,2)
15803 ELSEIF(KFD2.LT.0) THEN
15804 WID2=WID2*WIDS(KFC2,3)
15806 ELSEIF(KFD3.EQ.-KFD1) THEN
15809 WID2=WID2*WIDS(KFC2,2)
15810 ELSEIF(KFD2.LT.0) THEN
15811 WID2=WID2*WIDS(KFC2,3)
15813 ELSEIF(KFD3.EQ.KFD2) THEN
15814 IF(KCHG(KFC2,3).EQ.0) THEN
15816 ELSEIF(KFD2.GT.0) THEN
15822 WID2=WID2*WIDS(KFC1,2)
15823 ELSEIF(KFD1.LT.0) THEN
15824 WID2=WID2*WIDS(KFC1,3)
15826 ELSEIF(KFD3.EQ.-KFD2) THEN
15829 WID2=WID2*WIDS(KFC1,2)
15830 ELSEIF(KFD1.LT.0) THEN
15831 WID2=WID2*WIDS(KFC1,3)
15840 WID2=WID2*WIDS(KFC2,2)
15842 WID2=WID2*WIDS(KFC2,3)
15845 WID2=WID2*WIDS(KFC3,2)
15846 ELSEIF(KFD3.LT.0) THEN
15847 WID2=WID2*WIDS(KFC3,3)
15851 C...Store effective widths according to case.
15852 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15853 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15854 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15855 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15865 C...Here begins detailed dynamical calculation of resonance widths.
15866 C...Shared treatment of Higgs states.
15869 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
15874 C...Common electroweak and strong constants.
15877 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
15880 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
15882 RADC=1D0+AS/PARU(1)
15886 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
15887 RADCT=1D0-2.5D0*AS/PARU(1)
15888 DO 140 I=1,MDCY(KC,3)
15890 IF(MDME(IDC,1).LT.0) GOTO 140
15891 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15892 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15893 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
15895 IF(I.GE.4.AND.I.LE.7) THEN
15896 C...t -> W + q; including approximate QCD correction factor.
15897 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
15898 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
15899 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
15902 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
15905 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
15907 ELSEIF(I.EQ.9) THEN
15909 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
15910 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
15912 IF(KFLR.LT.0) WID2=WIDS(37,3)
15914 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
15915 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
15918 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
15921 KFC1=PYCOMP(KFDP(IDC,1))
15922 KFC2=PYCOMP(KFDP(IDC,2))
15923 PMNCHI=PMAS(KFC1,1)
15924 PMSTOP=PMAS(KFC2,1)
15925 IF(SHR.GT.PMNCHI+PMSTOP) THEN
15928 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
15930 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
15931 AR=-ET*ZMIXC(IZ,1)*TANW
15932 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
15934 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
15935 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
15936 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
15937 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
15938 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
15939 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
15940 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
15942 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
15944 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
15947 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
15949 KFC1=PYCOMP(KFDP(IDC,1))
15950 KFC2=PYCOMP(KFDP(IDC,2))
15951 PMNCHI=PMAS(KFC1,1)
15952 PMSTOP=PMAS(KFC2,1)
15953 IF(SHR.GT.PMNCHI+PMSTOP) THEN
15956 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
15957 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
15958 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
15959 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
15961 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
15963 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
15966 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
15967 C...t -> ~gravitino + ~t
15969 KFC1=PYCOMP(KFDP(IDC,1))
15970 XMGR2=PMAS(KFC1,1)**2
15971 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
15972 KFC2=PYCOMP(KFDP(IDC,2))
15974 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
15977 WDTP(I)=FUDGE*WDTP(I)
15978 WDTP(0)=WDTP(0)+WDTP(I)
15979 IF(MDME(IDC,1).GT.0) THEN
15980 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
15981 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
15982 WDTE(I,0)=WDTE(I,MDME(IDC,1))
15983 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
15987 ELSEIF(KFLA.EQ.7) THEN
15989 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
15990 DO 150 I=1,MDCY(KC,3)
15992 IF(MDME(IDC,1).LT.0) GOTO 150
15993 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
15994 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
15995 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
15997 IF(I.GE.4.AND.I.LE.7) THEN
15999 WDTP(I)=FAC*VCKM(I-3,4)*
16000 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16001 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16004 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
16005 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
16008 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
16009 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
16012 IF(KFLR.LT.0) WID2=WIDS(24,2)
16013 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16015 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16016 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16019 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
16022 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
16025 WDTP(I)=FUDGE*WDTP(I)
16026 WDTP(0)=WDTP(0)+WDTP(I)
16027 IF(MDME(IDC,1).GT.0) THEN
16028 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16029 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16030 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16031 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16035 ELSEIF(KFLA.EQ.8) THEN
16037 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16038 DO 160 I=1,MDCY(KC,3)
16040 IF(MDME(IDC,1).LT.0) GOTO 160
16041 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16042 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16043 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
16045 IF(I.GE.4.AND.I.LE.7) THEN
16047 WDTP(I)=FAC*VCKM(4,I-3)*
16048 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16049 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16052 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
16055 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
16057 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16059 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16060 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16063 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
16066 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
16069 WDTP(I)=FUDGE*WDTP(I)
16070 WDTP(0)=WDTP(0)+WDTP(I)
16071 IF(MDME(IDC,1).GT.0) THEN
16072 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16073 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16074 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16075 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16079 ELSEIF(KFLA.EQ.17) THEN
16081 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16082 DO 170 I=1,MDCY(KC,3)
16084 IF(MDME(IDC,1).LT.0) GOTO 170
16085 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16086 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16087 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
16090 C...tau' -> W + nu'_tau.
16091 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16092 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16095 WID2=WID2*WIDS(18,2)
16098 WID2=WID2*WIDS(18,3)
16100 ELSEIF(I.EQ.5) THEN
16101 C...tau' -> H + nu'_tau.
16102 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16103 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16106 WID2=WID2*WIDS(18,2)
16109 WID2=WID2*WIDS(18,3)
16112 WDTP(I)=FUDGE*WDTP(I)
16113 WDTP(0)=WDTP(0)+WDTP(I)
16114 IF(MDME(IDC,1).GT.0) THEN
16115 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16116 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16117 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16118 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16122 ELSEIF(KFLA.EQ.18) THEN
16123 C...nu'_tau neutrino.
16124 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16125 DO 180 I=1,MDCY(KC,3)
16127 IF(MDME(IDC,1).LT.0) GOTO 180
16128 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16129 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16130 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
16133 C...nu'_tau -> W + tau'.
16134 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16135 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16138 WID2=WID2*WIDS(17,2)
16141 WID2=WID2*WIDS(17,3)
16143 ELSEIF(I.EQ.3) THEN
16144 C...nu'_tau -> H + tau'.
16145 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16146 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16149 WID2=WID2*WIDS(17,2)
16152 WID2=WID2*WIDS(17,3)
16155 WDTP(I)=FUDGE*WDTP(I)
16156 WDTP(0)=WDTP(0)+WDTP(I)
16157 IF(MDME(IDC,1).GT.0) THEN
16158 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16159 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16160 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16161 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16165 ELSEIF(KFLA.EQ.21) THEN
16167 C***Note that widths are not given in dimensional quantities here.
16168 DO 190 I=1,MDCY(KC,3)
16170 IF(MDME(IDC,1).LT.0) GOTO 190
16171 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16172 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16173 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
16176 C...QCD -> q + qbar
16177 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16178 IF(I.EQ.6) WID2=WIDS(6,1)
16179 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16181 WDTP(I)=FUDGE*WDTP(I)
16182 WDTP(0)=WDTP(0)+WDTP(I)
16183 IF(MDME(IDC,1).GT.0) THEN
16184 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16185 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16186 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16187 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16191 ELSEIF(KFLA.EQ.22) THEN
16193 C***Note that widths are not given in dimensional quantities here.
16194 DO 200 I=1,MDCY(KC,3)
16196 IF(MDME(IDC,1).LT.0) GOTO 200
16197 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16198 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16199 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
16202 C...QED -> q + qbar.
16205 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16206 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16207 IF(I.EQ.6) WID2=WIDS(6,1)
16208 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16209 ELSEIF(I.LE.12) THEN
16210 C...QED -> l+ + l-.
16211 EF=KCHG(9+2*(I-8),1)/3D0
16212 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16213 IF(I.EQ.12) WID2=WIDS(17,1)
16215 WDTP(I)=FUDGE*WDTP(I)
16216 WDTP(0)=WDTP(0)+WDTP(I)
16217 IF(MDME(IDC,1).GT.0) THEN
16218 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16219 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16220 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16221 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16225 ELSEIF(KFLA.EQ.23) THEN
16228 XWC=1D0/(16D0*XW*XW1)
16229 FAC=(AEM*XWC/3D0)*SHR
16231 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
16236 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16238 IF(KFI.GT.20) KFI=IABS(MINT(16))
16244 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
16245 IF(MSTP(43).EQ.3) VINT(112)=
16246 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
16247 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16248 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
16250 DO 220 I=1,MDCY(KC,3)
16252 IF(MDME(IDC,1).LT.0) GOTO 220
16253 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16254 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16255 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
16260 AF=SIGN(1D0,EF+0.1D0)
16263 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16264 IF(I.EQ.6) WID2=WIDS(6,1)
16265 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16266 ELSEIF(I.LE.16) THEN
16267 C...Z0 -> l+ + l-, nu + nubar
16269 AF=SIGN(1D0,EF+0.1D0)
16272 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
16274 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16275 IF(ICASE.EQ.1) THEN
16276 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
16278 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16279 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
16280 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
16281 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
16282 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16283 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
16284 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16285 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
16287 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
16288 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
16289 IF(MDME(IDC,1).GT.0) THEN
16290 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
16291 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
16292 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16293 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
16294 & WDTE(I,MDME(IDC,1))
16295 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16296 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16298 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16299 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
16300 & VINT(111)+FGGF*WID2
16301 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
16302 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16303 & VINT(114)+FZZF*WID2
16307 IF(MINT(61).GE.1) ICASE=3-ICASE
16308 IF(ICASE.EQ.2) GOTO 210
16310 ELSEIF(KFLA.EQ.24) THEN
16312 FAC=(AEM/(24D0*XW))*SHR
16313 DO 230 I=1,MDCY(KC,3)
16315 IF(MDME(IDC,1).LT.0) GOTO 230
16316 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16317 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16318 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
16321 C...W+/- -> q + qbar'
16322 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
16324 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
16325 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
16326 IF(I.GE.13) WID2=WID2*WIDS(7,3)
16328 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
16329 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
16330 IF(I.GE.13) WID2=WID2*WIDS(7,2)
16332 ELSEIF(I.LE.20) THEN
16333 C...W+/- -> l+/- + nu
16336 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
16338 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
16341 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
16342 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16343 WDTP(I)=FUDGE*WDTP(I)
16344 WDTP(0)=WDTP(0)+WDTP(I)
16345 IF(MDME(IDC,1).GT.0) THEN
16346 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16347 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16348 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16349 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16353 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
16354 C...h0 (or H0, or A0):
16355 IF(MSTP(49).EQ.0) THEN
16358 SHFS=PMAS(KFHIGG,1)**2
16360 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
16361 DO 270 I=1,MDCY(KFHIGG,3)
16362 IDC=I+MDCY(KFHIGG,2)-1
16363 IF(MDME(IDC,1).LT.0) GOTO 270
16364 KFC1=PYCOMP(KFDP(IDC,1))
16365 KFC2=PYCOMP(KFDP(IDC,2))
16366 RM1=PMAS(KFC1,1)**2/SH
16367 RM2=PMAS(KFC2,1)**2/SH
16368 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
16374 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
16375 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
16376 C...A0 behaves like beta, ho and H0 like beta**3.
16377 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16378 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16379 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
16380 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
16381 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
16382 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
16383 IF(IHIGG.NE.3) THEN
16384 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
16385 & PARU(151+10*IHIGG))**2
16389 IF(I.EQ.6) WID2=WIDS(6,1)
16390 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16391 ELSEIF(I.LE.12) THEN
16393 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
16394 C...A0 behaves like beta, ho and H0 like beta**3.
16395 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16396 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
16397 & PARU(153+10*IHIGG)**2
16398 IF(I.EQ.12) WID2=WIDS(17,1)
16400 ELSEIF(I.EQ.13) THEN
16401 C...h0 -> g + g; quark loop contribution only
16404 DO 240 J=1,2*MSTP(1)
16405 EPS=(2D0*PMAS(J,1))**2/SH
16406 C...Loop integral; function of eps=4m^2/shat; different for A0.
16407 IF(EPS.LE.1D0) THEN
16408 IF(EPS.GT.1D-4) THEN
16410 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16412 RLN=LOG(4D0/EPS-2D0)
16414 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16415 PHIIM=0.5D0*PARU(1)*RLN
16417 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16420 IF(IHIGG.LE.2) THEN
16421 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16422 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
16424 ETAREJ=-0.5D0*EPS*PHIRE
16425 ETAIMJ=-0.5D0*EPS*PHIIM
16427 C...Couplings (=1 for standard model Higgs).
16428 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16429 IF(MOD(J,2).EQ.1) THEN
16430 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
16431 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
16433 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
16434 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
16440 ETA2=ETARE**2+ETAIM**2
16441 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
16443 ELSEIF(I.EQ.14) THEN
16444 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
16448 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16450 IF(J.LE.2*MSTP(1)) THEN
16452 EPS=(2D0*PMAS(J,1))**2/SH
16453 ELSEIF(J.LE.3*MSTP(1)) THEN
16454 JL=2*(J-2*MSTP(1))-1
16455 EJ=KCHG(10+JL,1)/3D0
16456 EPS=(2D0*PMAS(10+JL,1))**2/SH
16457 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16458 EPS=(2D0*PMAS(24,1))**2/SH
16460 EPS=(2D0*PMAS(37,1))**2/SH
16462 C...Loop integral; function of eps=4m^2/shat.
16463 IF(EPS.LE.1D0) THEN
16464 IF(EPS.GT.1D-4) THEN
16466 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16468 RLN=LOG(4D0/EPS-2D0)
16470 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16471 PHIIM=0.5D0*PARU(1)*RLN
16473 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16476 IF(J.LE.3*MSTP(1)) THEN
16477 C...Fermion loops: loop integral different for A0; charges.
16478 IF(IHIGG.LE.2) THEN
16479 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16480 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
16482 PHIPRE=-0.5D0*EPS*PHIRE
16483 PHIPIM=-0.5D0*EPS*PHIIM
16485 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16487 EJH=PARU(151+10*IHIGG)
16488 ELSEIF(J.LE.2*MSTP(1)) THEN
16490 EJH=PARU(152+10*IHIGG)
16493 EJH=PARU(153+10*IHIGG)
16495 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16496 ETAREJ=EJC*EJH*PHIPRE
16497 ETAIMJ=EJC*EJH*PHIPIM
16498 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16499 C...W loops: loop integral and charges.
16500 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
16501 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
16502 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16503 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16504 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16507 C...Charged H loops: loop integral and charges.
16508 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
16509 & PARU(158+10*IHIGG+2*(IHIGG/3))
16510 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
16511 ETAIMJ=-EPS**2*PHIIM*FACHHH
16516 ETA2=ETARE**2+ETAIM**2
16517 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
16519 ELSEIF(I.EQ.15) THEN
16520 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
16524 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16526 IF(J.LE.2*MSTP(1)) THEN
16528 AJ=SIGN(1D0,EJ+0.1D0)
16530 EPS=(2D0*PMAS(J,1))**2/SH
16531 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
16532 ELSEIF(J.LE.3*MSTP(1)) THEN
16533 JL=2*(J-2*MSTP(1))-1
16534 EJ=KCHG(10+JL,1)/3D0
16535 AJ=SIGN(1D0,EJ+0.1D0)
16537 EPS=(2D0*PMAS(10+JL,1))**2/SH
16538 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
16540 EPS=(2D0*PMAS(24,1))**2/SH
16541 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
16543 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
16544 IF(EPS.LE.1D0) THEN
16546 IF(EPS.GT.1D-4) THEN
16547 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16549 RLN=LOG(4D0/EPS-2D0)
16551 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16552 PHIIM=0.5D0*PARU(1)*RLN
16553 PSIRE=0.5D0*ROOT*RLN
16554 PSIIM=-0.5D0*ROOT*PARU(1)
16556 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16558 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
16561 IF(EPSP.LE.1D0) THEN
16562 ROOT=SQRT(1D0-EPSP)
16563 IF(EPSP.GT.1D-4) THEN
16564 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16566 RLN=LOG(4D0/EPSP-2D0)
16568 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
16569 PHIIMP=0.5D0*PARU(1)*RLN
16570 PSIREP=0.5D0*ROOT*RLN
16571 PSIIMP=-0.5D0*ROOT*PARU(1)
16573 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
16575 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
16578 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
16579 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
16580 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
16581 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
16582 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
16583 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
16584 IF(J.LE.3*MSTP(1)) THEN
16585 C...Fermion loops: loop integral different for A0; charges.
16586 IF(IHIGG.EQ.3) FXYRE=0D0
16587 IF(IHIGG.EQ.3) FXYIM=0D0
16588 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16590 EJH=PARU(151+10*IHIGG)
16591 ELSEIF(J.LE.2*MSTP(1)) THEN
16593 EJH=PARU(152+10*IHIGG)
16596 EJH=PARU(153+10*IHIGG)
16598 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16599 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
16600 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
16601 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16602 C...W loops: loop integral and charges.
16603 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
16604 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
16605 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
16606 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16607 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16608 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16611 C...Charged H loops: loop integral and charges.
16612 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
16613 & PARU(158+10*IHIGG+2*(IHIGG/3))
16614 ETAREJ=FACHHH*FXYRE
16615 ETAIMJ=FACHHH*FXYIM
16620 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
16621 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
16624 ELSEIF(I.LE.17) THEN
16625 C...h0 -> Z0 + Z0, W+ + W-
16626 PM1=PMAS(IABS(KFDP(IDC,1)),1)
16627 PG1=PMAS(IABS(KFDP(IDC,1)),2)
16628 IF(MINT(62).GE.1) THEN
16629 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
16630 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
16631 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
16632 MOFSV(IHIGG,I-15)=0
16633 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
16637 MOFSV(IHIGG,I-15)=1
16638 RMAS=SQRT(MAX(0D0,SH))
16639 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
16641 WIDWSV(IHIGG,I-15)=WIDW
16642 WID2SV(IHIGG,I-15)=WID2
16645 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
16646 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
16650 WIDW=WIDWSV(IHIGG,I-15)
16651 WID2=WID2SV(IHIGG,I-15)
16654 WDTP(I)=FAC*WIDW/(2D0*(18-I))
16655 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
16656 & PARU(138+I+10*IHIGG)**2
16657 WID2=WID2*WIDS(7+I,1)
16659 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
16660 C...H0 -> Z0 + h0, A0-> Z0 + h0
16661 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
16662 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16663 IF(IHIGG.EQ.2) THEN
16664 WDTP(I)=WDTP(I)*PARU(179)**2
16665 ELSEIF(IHIGG.EQ.3) THEN
16666 WDTP(I)=WDTP(I)*PARU(186)**2
16668 WID2=WIDS(23,2)*WIDS(25,2)
16670 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
16671 C...H0 -> h0 + h0, A0-> h0 + h0
16672 WDTP(I)=FAC*0.25D0*
16673 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
16674 IF(IHIGG.EQ.2) THEN
16675 WDTP(I)=WDTP(I)*PARU(176)**2
16676 ELSEIF(IHIGG.EQ.3) THEN
16677 WDTP(I)=WDTP(I)*PARU(169)**2
16680 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
16681 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
16682 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
16683 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16684 & *PARU(195+IHIGG)**2
16686 WID2=WIDS(24,2)*WIDS(37,3)
16687 ELSEIF(I.EQ.21) THEN
16688 WID2=WIDS(24,3)*WIDS(37,2)
16691 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
16693 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
16694 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*0.0D0
16695 WID2=WIDS(36,2)*WIDS(23,2)
16697 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
16699 WDTP(I)=FAC*0.5D0*PARU(180)**2*
16700 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
16701 WID2=WIDS(25,2)*WIDS(36,2)
16703 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
16705 WDTP(I)=FAC*0.25D0*PARU(177)**2*
16706 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
16711 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
16714 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
16715 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
16716 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
16721 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
16723 IF(KFC2.EQ.KFC1) THEN
16727 IF(KFDP(IDC,1).LT.0) KSGN1=3
16729 IF(KFDP(IDC,2).LT.0) KSGN2=3
16730 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
16733 WDTP(I)=FUDGE*WDTP(I)
16734 WDTP(0)=WDTP(0)+WDTP(I)
16735 IF(MDME(IDC,1).GT.0) THEN
16736 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16737 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16738 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16739 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16743 ELSEIF(KFLA.EQ.32) THEN
16746 XWC=1D0/(16D0*XW*XW1)
16747 FAC=(AEM*XWC/3D0)*SHR
16750 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
16758 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16759 KFAI=IABS(MINT(15))
16760 EI=KCHG(KFAI,1)/3D0
16761 AI=SIGN(1D0,EI+0.1D0)
16764 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
16765 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
16766 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
16767 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
16768 VPI=PARU(119+2*KFAIC)
16769 API=PARU(120+2*KFAIC)
16770 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
16771 VPI=PARJ(178+2*KFAIC)
16772 API=PARJ(179+2*KFAIC)
16774 VPI=PARJ(186+2*KFAIC)
16775 API=PARJ(187+2*KFAIC)
16779 SQMZP=PMAS(32,1)**2
16781 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
16782 & MSTP(44).EQ.7) VINT(111)=1D0
16783 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
16784 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
16785 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
16786 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
16787 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
16788 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
16789 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
16790 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
16791 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
16792 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
16793 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
16795 DO 290 I=1,MDCY(KC,3)
16797 IF(MDME(IDC,1).LT.0) GOTO 290
16798 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16799 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16800 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
16804 C...Z'0 -> q + qbar
16806 AF=SIGN(1D0,EF+0.1D0)
16809 VPF=PARU(123-2*MOD(I,2))
16810 APF=PARU(124-2*MOD(I,2))
16811 ELSEIF(I.LE.4) THEN
16812 VPF=PARJ(182-2*MOD(I,2))
16813 APF=PARJ(183-2*MOD(I,2))
16815 VPF=PARJ(190-2*MOD(I,2))
16816 APF=PARJ(191-2*MOD(I,2))
16819 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
16820 & PYHFTH(SH,SH*RM1,1D0)
16821 IF(I.EQ.6) WID2=WIDS(6,1)
16822 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16823 ELSEIF(I.LE.16) THEN
16824 C...Z'0 -> l+ + l-, nu + nubar
16826 AF=SIGN(1D0,EF+0.1D0)
16829 VPF=PARU(127-2*MOD(I,2))
16830 APF=PARU(128-2*MOD(I,2))
16831 ELSEIF(I.LE.12) THEN
16832 VPF=PARJ(186-2*MOD(I,2))
16833 APF=PARJ(187-2*MOD(I,2))
16835 VPF=PARJ(194-2*MOD(I,2))
16836 APF=PARJ(195-2*MOD(I,2))
16839 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
16841 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16842 IF(ICASE.EQ.1) THEN
16843 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
16844 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
16845 & APF**2*(1D0-4D0*RM1))*BE34
16846 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16847 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
16848 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
16849 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
16850 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
16851 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
16852 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
16853 ELSEIF(MINT(61).EQ.2) THEN
16854 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
16855 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16856 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
16857 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
16858 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
16860 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
16863 ELSEIF(I.EQ.17) THEN
16865 WDTPZP=PARU(129)**2*XW1**2*
16866 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
16867 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
16868 IF(ICASE.EQ.1) THEN
16871 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16872 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
16873 ELSEIF(MINT(61).EQ.2) THEN
16882 ELSEIF(I.EQ.18) THEN
16884 CZC=2D0*(1D0-2D0*XW)
16885 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16886 IF(ICASE.EQ.1) THEN
16887 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
16888 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
16889 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16890 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
16891 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
16892 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
16893 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
16894 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
16895 ELSEIF(MINT(61).EQ.2) THEN
16897 FGZF=0.25D0*PARU(142)*CZC*BE34C
16898 FGZPF=0.25D0*PARU(143)*CZC*BE34C
16899 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
16900 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
16901 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
16904 ELSEIF(I.EQ.19) THEN
16905 C...Z'0 -> Z0 + gamma.
16906 ELSEIF(I.EQ.20) THEN
16908 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16909 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
16910 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
16911 IF(ICASE.EQ.1) THEN
16914 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16915 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
16916 ELSEIF(MINT(61).EQ.2) THEN
16924 WID2=WIDS(23,2)*WIDS(25,2)
16925 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
16926 C...Z' -> h0 + A0 or H0 + A0.
16927 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
16935 IF(ICASE.EQ.1) THEN
16936 WDTPZ=CZAH**2*BE34C
16937 WDTP(I)=FAC*CZPAH**2*BE34C
16938 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16939 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
16940 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
16942 ELSEIF(MINT(61).EQ.2) THEN
16947 FZZPF=CZAH*CZPAH*BE34C
16948 FZPZPF=CZPAH**2*BE34C
16950 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
16951 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
16953 IF(ICASE.EQ.1) THEN
16954 VINT(117)=VINT(117)+FAC*WDTPZ
16955 WDTP(I)=FUDGE*WDTP(I)
16956 WDTP(0)=WDTP(0)+WDTP(I)
16958 IF(MDME(IDC,1).GT.0) THEN
16959 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
16960 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
16961 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16962 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
16963 & WDTE(I,MDME(IDC,1))
16964 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16965 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16967 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16968 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
16969 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
16970 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
16972 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
16974 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
16975 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
16976 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
16978 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
16979 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
16983 IF(MINT(61).GE.1) ICASE=3-ICASE
16984 IF(ICASE.EQ.2) GOTO 280
16986 ELSEIF(KFLA.EQ.34) THEN
16988 FAC=(AEM/(24D0*XW))*SHR
16989 DO 300 I=1,MDCY(KC,3)
16991 IF(MDME(IDC,1).LT.0) GOTO 300
16992 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16993 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16994 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
16998 C...W'+/- -> q + qbar'
16999 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
17000 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
17002 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
17003 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
17004 IF(I.GE.13) WID2=WID2*WIDS(7,3)
17006 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
17007 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
17008 IF(I.GE.13) WID2=WID2*WIDS(7,2)
17010 ELSEIF(I.LE.20) THEN
17011 C...W'+/- -> l+/- + nu
17012 FCOF=PARU(133)**2+PARU(134)**2
17014 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17016 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17019 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
17020 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17021 ELSEIF(I.EQ.21) THEN
17022 C...W'+/- -> W+/- + Z0
17023 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
17024 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17025 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17026 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
17027 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
17028 ELSEIF(I.EQ.23) THEN
17029 C...W'+/- -> W+/- + h0
17030 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17031 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
17032 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17033 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17035 WDTP(I)=FUDGE*WDTP(I)
17036 WDTP(0)=WDTP(0)+WDTP(I)
17037 IF(MDME(IDC,1).GT.0) THEN
17038 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17039 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17040 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17041 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17045 ELSEIF(KFLA.EQ.37) THEN
17047 IF(MSTP(49).EQ.0) THEN
17052 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
17053 DO 310 I=1,MDCY(KC,3)
17055 IF(MDME(IDC,1).LT.0) GOTO 310
17056 KFC1=PYCOMP(KFDP(IDC,1))
17057 KFC2=PYCOMP(KFDP(IDC,2))
17058 RM1=PMAS(KFC1,1)**2/SH
17059 RM2=PMAS(KFC2,1)**2/SH
17060 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
17063 C...H+/- -> q + qbar'
17064 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
17065 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
17066 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
17067 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
17068 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17070 IF(I.EQ.3) WID2=WIDS(6,2)
17071 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
17073 IF(I.EQ.3) WID2=WIDS(6,3)
17074 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
17076 ELSEIF(I.LE.8) THEN
17077 C...H+/- -> l+/- + nu
17078 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
17079 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
17080 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17082 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
17084 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
17086 ELSEIF(I.EQ.9) THEN
17087 C...H+/- -> W+/- + h0.
17088 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
17089 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17090 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17091 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17095 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
17098 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
17099 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
17100 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
17105 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
17108 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
17110 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
17111 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
17113 WDTP(I)=FUDGE*WDTP(I)
17114 WDTP(0)=WDTP(0)+WDTP(I)
17115 IF(MDME(IDC,1).GT.0) THEN
17116 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17117 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17118 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17119 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17123 ELSEIF(KFLA.EQ.41) THEN
17125 FAC=(AEM/(12D0*XW))*SHR
17126 DO 320 I=1,MDCY(KC,3)
17128 IF(MDME(IDC,1).LT.0) GOTO 320
17129 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17130 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17131 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
17136 ELSEIF(I.LE.9) THEN
17140 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17141 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17143 IF(I.EQ.4) WID2=WIDS(6,3)
17144 IF(I.EQ.5) WID2=WIDS(7,3)
17145 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
17146 IF(I.EQ.9) WID2=WIDS(17,3)
17148 IF(I.EQ.4) WID2=WIDS(6,2)
17149 IF(I.EQ.5) WID2=WIDS(7,2)
17150 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
17151 IF(I.EQ.9) WID2=WIDS(17,2)
17153 WDTP(I)=FUDGE*WDTP(I)
17154 WDTP(0)=WDTP(0)+WDTP(I)
17155 IF(MDME(IDC,1).GT.0) THEN
17156 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17157 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17158 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17159 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17163 ELSEIF(KFLA.EQ.42) THEN
17164 C...LQ (leptoquark).
17165 FAC=(AEM/4D0)*PARU(151)*SHR
17166 DO 330 I=1,MDCY(KC,3)
17168 IF(MDME(IDC,1).LT.0) GOTO 330
17169 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17170 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17171 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
17172 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17174 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
17175 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
17176 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
17177 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
17178 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
17179 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
17180 WDTP(I)=FUDGE*WDTP(I)
17181 WDTP(0)=WDTP(0)+WDTP(I)
17182 IF(MDME(IDC,1).GT.0) THEN
17183 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17184 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17185 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17186 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17190 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
17191 C...Techni-pi0 and techni-pi0':
17192 FAC=(1D0/(32D0*PARU(1)*PARP(142)**2))*SHR
17193 DO 340 I=1,MDCY(KC,3)
17195 IF(MDME(IDC,1).LT.0) GOTO 340
17196 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17197 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17200 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
17204 FACP=(AS/(4D0*PARU(1))*PARP(144)/PARP(142))**2
17205 & /(8D0*PARU(1))*SH*SHR
17206 IF(KFLA.EQ.KTECHN+111) THEN
17207 FACP=FACP*PARP(149)
17209 FACP=FACP*PARP(150)
17213 C...pi_tc -> f + fbar.
17215 IKA=IABS(KFDP(IDC,1))
17216 IF(IKA.LT.10) FCOF=3D0*RADC
17219 IF(IKA.GE.4.AND.IKA.LE.6) THEN
17220 FCOF=FCOF*PARP(141+IKA)**2
17221 HM1=PYMRUN(KFDP(IDC,1),SH)
17222 HM2=PYMRUN(KFDP(IDC,2),SH)
17223 ELSEIF(IKA.EQ.15) THEN
17224 FCOF=FCOF*PARP(148)**2
17226 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17227 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17229 WDTP(I)=FUDGE*WDTP(I)
17230 WDTP(0)=WDTP(0)+WDTP(I)
17231 IF(MDME(IDC,1).GT.0) THEN
17232 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17233 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17234 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17235 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17239 ELSEIF(KFLA.EQ.KTECHN+211) THEN
17241 FAC=(1D0/(32D0*PARU(1)*PARP(142)**2))*SHR
17242 DO 350 I=1,MDCY(KC,3)
17244 IF(MDME(IDC,1).LT.0) GOTO 350
17245 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17246 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17248 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
17252 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
17254 C...pi_tc -> f + f'.
17256 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
17257 C...pi_tc+ -> W b b~
17258 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
17260 XMT2=PMAS(6,1)**2/SH
17261 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*PARP(147)**2
17262 KFC3=PYCOMP(KFDP(IDC,3))
17263 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
17265 T0 = (1D0-CHECK**2)*
17266 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
17267 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
17268 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
17269 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
17270 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
17271 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
17280 IKA=IABS(KFDP(IDC,1))
17281 IF(IKA.LT.10) FCOF=3D0*RADC
17284 IF(I.GE.1.AND.I.LE.5) THEN
17286 FCOF=FCOF*PARP(145)**2
17287 ELSEIF(I.LE.4) THEN
17288 FCOF=FCOF*PARP(146)**2
17289 ELSEIF(I.EQ.5) THEN
17290 FCOF=FCOF*PARP(147)**2
17292 HM1=PYMRUN(KFDP(IDC,1),SH)
17293 HM2=PYMRUN(KFDP(IDC,2),SH)
17294 ELSEIF(I.EQ.8) THEN
17295 FCOF=FCOF*PARP(148)**2
17297 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17298 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17300 WDTP(I)=FUDGE*WDTP(I)
17301 WDTP(0)=WDTP(0)+WDTP(I)
17302 IF(MDME(IDC,1).GT.0) THEN
17303 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17304 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17305 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17306 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17310 ELSEIF(KFLA.EQ.KTECHN+331) THEN
17312 FAC=(SH/PARP(46)**2)*SHR
17313 DO 360 I=1,MDCY(KC,3)
17315 IF(MDME(IDC,1).LT.0) GOTO 360
17316 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17317 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17318 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
17321 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
17322 IF(I.EQ.2) WID2=WIDS(6,1)
17324 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
17326 WDTP(I)=FUDGE*WDTP(I)
17327 WDTP(0)=WDTP(0)+WDTP(I)
17328 IF(MDME(IDC,1).GT.0) THEN
17329 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17330 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17331 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17332 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17336 ELSEIF(KFLA.EQ.KTECHN+113) THEN
17338 ALPRHT=2.91D0*(3D0/PARP(144))
17339 FAC=(ALPRHT/12D0)*SHR
17340 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
17344 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17346 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
17347 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17348 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17349 DO 370 I=1,MDCY(KC,3)
17351 IF(MDME(IDC,1).LT.0) GOTO 370
17352 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17353 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17354 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
17357 C...rho_tc0 -> W+ + W-.
17358 WDTP(I)=FAC*PARP(141)**4*
17359 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17361 ELSEIF(I.EQ.2) THEN
17362 C...rho_tc0 -> W+ + pi_tc-.
17363 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
17364 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17365 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17366 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17367 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(138)**2*SHR**3
17368 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17369 ELSEIF(I.EQ.3) THEN
17370 C...rho_tc0 -> pi_tc+ + W-.
17371 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
17372 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17373 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17374 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17375 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(138)**2*SHR**3
17376 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
17377 ELSEIF(I.EQ.4) THEN
17378 C...rho_tc0 -> pi_tc+ + pi_tc-.
17379 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
17380 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17381 WID2=WIDS(PYCOMP(KTECHN+211),1)
17382 ELSEIF(I.EQ.5) THEN
17383 C...rho_tc0 -> gamma + pi_tc0
17384 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17385 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2*
17387 WID2=WIDS(PYCOMP(KTECHN+111),2)
17388 ELSEIF(I.EQ.6) THEN
17389 C...rho_tc0 -> gamma + pi_tc0'
17390 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17391 & (1D0-PARP(139)**2)/24D0/PARP(137)**2*SHR**3
17392 WID2=WIDS(PYCOMP(KTECHN+221),2)
17393 ELSEIF(I.EQ.7) THEN
17394 C...rho_tc0 -> Z0 + pi_tc0
17395 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17396 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2*
17398 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17399 ELSEIF(I.EQ.8) THEN
17400 C...rho_tc0 -> Z0 + pi_tc0'
17401 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17402 & (1D0-PARP(139)**2)/24D0/PARP(137)**2*(1D0-2D0*XW)**2/4D0/
17404 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17406 C...rho_tc0 -> f + fbar.
17411 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
17415 IF(IA.GE.17) WID2=WIDS(IA,1)
17418 AI=SIGN(1D0,EI+0.1D0)
17422 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
17423 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
17424 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
17425 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
17427 WDTP(I)=FUDGE*WDTP(I)
17428 WDTP(0)=WDTP(0)+WDTP(I)
17429 IF(MDME(IDC,1).GT.0) THEN
17430 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17431 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17432 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17433 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17437 ELSEIF(KFLA.EQ.KTECHN+213) THEN
17439 ALPRHT=2.91D0*(3D0/PARP(144))
17440 FAC=(ALPRHT/12D0)*SHR
17444 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
17446 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
17447 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
17448 DO 380 I=1,MDCY(KC,3)
17450 IF(MDME(IDC,1).LT.0) GOTO 380
17451 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17452 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17453 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
17456 C...rho_tc+ -> W+ + Z0.
17457 WDTP(I)=FAC*PARP(141)**4*
17458 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17460 WID2=WIDS(24,2)*WIDS(23,2)
17462 WID2=WIDS(24,3)*WIDS(23,2)
17464 ELSEIF(I.EQ.2) THEN
17465 C...rho_tc+ -> W+ + pi_tc0.
17466 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
17467 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17468 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17469 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17470 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(138)**2*SHR**3
17472 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
17474 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
17476 ELSEIF(I.EQ.3) THEN
17477 C...rho_tc+ -> pi_tc+ + Z0.
17478 WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
17479 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17480 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17481 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
17482 & (1D0-PARP(141)**2)/4D0/XW/XW1/24D0/PARP(138)**2*SHR**3+
17483 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17484 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2*
17487 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
17489 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
17491 ELSEIF(I.EQ.4) THEN
17492 C...rho_tc+ -> pi_tc+ + pi_tc0.
17493 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
17494 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17496 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
17498 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
17500 ELSEIF(I.EQ.5) THEN
17501 C...rho_tc+ -> pi_tc+ + gamma
17502 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17503 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2*
17506 WID2=WIDS(PYCOMP(KTECHN+211),2)
17508 WID2=WIDS(PYCOMP(KTECHN+211),3)
17510 ELSEIF(I.EQ.6) THEN
17511 C...rho_tc+ -> W+ + pi_tc0'
17512 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17513 & (1D0-PARP(139)**2)/4D0/XW/24D0/PARP(137)**2*SHR**3
17515 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
17517 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
17520 C...rho_tc+ -> f + fbar'.
17524 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
17526 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
17527 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
17528 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
17530 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
17531 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
17532 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
17537 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17539 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17542 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17543 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17545 WDTP(I)=FUDGE*WDTP(I)
17546 WDTP(0)=WDTP(0)+WDTP(I)
17547 IF(MDME(IDC,1).GT.0) THEN
17548 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17549 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17550 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17551 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17555 ELSEIF(KFLA.EQ.KTECHN+223) THEN
17557 ALPRHT=2.91D0*(3D0/PARP(144))
17558 FAC=(ALPRHT/12D0)*SHR
17559 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*PARP(143)-1D0)**2
17562 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17564 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17565 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17566 DO 390 I=1,MDCY(KC,3)
17568 IF(MDME(IDC,1).LT.0) GOTO 390
17569 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17570 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17571 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
17574 C...omega_tc0 -> gamma + pi_tc0.
17575 WDTP(I)=AEM/24D0/PARP(137)**2*(1D0-PARP(141)**2)*
17576 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
17577 WID2=WIDS(PYCOMP(KTECHN+111),2)
17578 ELSEIF(I.EQ.2) THEN
17579 C...omega_tc0 -> Z0 + pi_tc0
17580 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17581 & (1D0-PARP(141)**2)/24D0/PARP(137)**2*(1D0-2D0*XW)**2/4D0/
17583 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17584 ELSEIF(I.EQ.3) THEN
17585 C...omega_tc0 -> gamma + pi_tc0'
17586 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17587 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(139)**2)/24D0/PARP(137)**2*
17589 WID2=WIDS(PYCOMP(KTECHN+221),2)
17590 ELSEIF(I.EQ.4) THEN
17591 C...omega_tc0 -> Z0 + pi_tc0'
17592 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17593 & (2D0*PARP(143)-1D0)**2*(1D0-PARP(139)**2)/24D0/PARP(137)**2*
17595 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17596 ELSEIF(I.EQ.5) THEN
17597 C...omega_tc0 -> W+ + pi_tc-
17598 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17599 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(137)**2*SHR**3+
17600 & FAC*PARP(141)**2*(1D0-PARP(141)**2)*PARP(140)**2*
17601 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17602 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17603 ELSEIF(I.EQ.6) THEN
17604 C...omega_tc0 -> pi_tc+ + W-
17605 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17606 & (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(137)**2*SHR**3+
17607 & FAC*PARP(141)**2*(1D0-PARP(141)**2)*PARP(140)**2*
17608 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17609 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
17610 ELSEIF(I.EQ.7) THEN
17611 C...omega_tc0 -> W+ + W-.
17612 WDTP(I)=FAC*PARP(141)**4*PARP(140)**2*
17613 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17615 ELSEIF(I.EQ.8) THEN
17616 C...omega_tc0 -> pi_tc+ + pi_tc-.
17617 WDTP(I)=FAC*(1D0-PARP(141)**2)**2*PARP(140)**2*
17618 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17619 WID2=WIDS(PYCOMP(KTECHN+211),1)
17621 C...omega_tc0 -> f + fbar.
17626 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
17630 IF(IA.GE.17) WID2=WIDS(IA,1)
17633 AI=SIGN(1D0,EI+0.1D0)
17637 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
17638 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
17639 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
17640 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
17642 WDTP(I)=FUDGE*WDTP(I)
17643 WDTP(0)=WDTP(0)+WDTP(I)
17644 IF(MDME(IDC,1).GT.0) THEN
17645 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17646 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17647 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17648 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17652 C.....V8 -> quark anti-quark
17653 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
17655 TANT3=ABS(PARP(155))
17656 IF(PARP(155).GT.0) THEN
17661 DO 400 I=1,MDCY(KC,3)
17663 IF(MDME(IDC,1).LT.0) GOTO 400
17664 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17666 IF(RM1.GT.0.25D0) GOTO 400
17668 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
17673 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
17674 IF(I.EQ.6) WID2=WIDS(6,1)
17675 WDTP(I)=FUDGE*WDTP(I)
17676 WDTP(0)=WDTP(0)+WDTP(I)
17677 IF(MDME(IDC,1).GT.0) THEN
17678 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17679 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17680 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17681 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17685 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
17686 FAC=(1D0/(4D0*PARU(1)*PARP(142)**2))*SHR
17688 DO 410 I=1,MDCY(KC,3)
17690 IF(MDME(IDC,1).LT.0) GOTO 410
17691 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17692 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17693 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
17697 IF(KFLA.EQ.KTECHN+100111) THEN
17702 FACP=(AS/(8D0*PARU(1))*PARP(144)/PARP(142))**2
17703 & /(2D0*PARU(1))*SH*SHR*CLEBG
17706 C...pi_tc -> f + fbar.
17707 IF(I.EQ.6) WID2=WIDS(6,1)
17709 IKA=IABS(KFDP(IDC,1))
17710 IF(IKA.LT.10) FCOF=3D0*RADC
17711 HM1=PYMRUN(KFDP(IDC,1),SH)
17712 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
17713 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17715 WDTP(I)=FUDGE*WDTP(I)
17716 WDTP(0)=WDTP(0)+WDTP(I)
17717 IF(MDME(IDC,1).GT.0) THEN
17718 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17719 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17720 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17721 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17725 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
17727 ALPRHT=2.91D0*(3D0/PARP(144))
17728 TANT3=ABS(PARP(155))
17729 SIN2T=2D0*TANT3/(TANT3**2+1D0)
17730 SINT3=TANT3/SQRT(TANT3**2+1D0)
17731 CSXPP=1D0/SQRT(2D0)
17733 X12=(1D0/SQRT(2D0)*1D0/SQRT(2D0)+
17734 & 1D0/SQRT(2D0)*1D0/SQRT(2D0))/SQRT(2D0)
17736 X11=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2+2D0)-
17738 X22=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2)-
17740 IF(PARP(155).GT.0) THEN
17745 DO 420 I=1,MDCY(KC,3)
17746 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
17747 & KFLA.EQ.KTECHN+300113)) GOTO 420
17749 IF(MDME(IDC,1).LT.0) GOTO 420
17750 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17751 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17752 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
17755 IF(I.EQ.6) WID2=WIDS(6,1)
17757 IF(KFLA.EQ.KTECHN+200113) THEN
17760 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
17763 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
17768 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
17769 FMIX=1D0/TANT3/SIN2T
17773 XFAC=(XIG+FMIX*XIJ)**2
17774 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
17775 ELSEIF(I.EQ.7) THEN
17776 WDTP(I)=SHR*AS**2/(2D0*ALPRHT)
17777 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
17778 PSH=SHR*(1D0-RM1)/2D0
17779 WDTP(I)=AS/9D0*PSH**3/RM82
17781 WDTP(I)=2D0*WDTP(I)*CSXPP**2
17782 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
17784 WDTP(I)=5D0*WDTP(I)
17785 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
17788 WDTP(I)=FUDGE*WDTP(I)
17789 WDTP(0)=WDTP(0)+WDTP(I)
17790 IF(MDME(IDC,1).GT.0) THEN
17791 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17792 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17793 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17794 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17798 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
17799 C...d* excited quark.
17800 FAC=(SH/PARU(155)**2)*SHR
17801 DO 430 I=1,MDCY(KC,3)
17803 IF(MDME(IDC,1).LT.0) GOTO 430
17804 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17805 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17806 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
17810 WDTP(I)=FAC*AS*PARU(159)**2/3D0
17812 ELSEIF(I.EQ.2) THEN
17813 C...d* -> gamma + d.
17814 QF=-PARU(157)/2D0+PARU(158)/6D0
17815 WDTP(I)=FAC*AEM*QF**2/4D0
17817 ELSEIF(I.EQ.3) THEN
17819 QF=-PARU(157)*XW1/2D0-PARU(158)*XW/6D0
17820 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
17821 & (1D0-RM1)**2*(2D0+RM1)
17823 ELSEIF(I.EQ.4) THEN
17825 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
17826 & (1D0-RM1)**2*(2D0+RM1)
17827 IF(KFLR.GT.0) WID2=WIDS(24,3)
17828 IF(KFLR.LT.0) WID2=WIDS(24,2)
17830 WDTP(I)=FUDGE*WDTP(I)
17831 WDTP(0)=WDTP(0)+WDTP(I)
17832 IF(MDME(IDC,1).GT.0) THEN
17833 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17834 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17835 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17836 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17840 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
17841 C...u* excited quark.
17842 FAC=(SH/PARU(155)**2)*SHR
17843 DO 440 I=1,MDCY(KC,3)
17845 IF(MDME(IDC,1).LT.0) GOTO 440
17846 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17847 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17848 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
17852 WDTP(I)=FAC*AS*PARU(159)**2/3D0
17854 ELSEIF(I.EQ.2) THEN
17855 C...u* -> gamma + u.
17856 QF=PARU(157)/2D0+PARU(158)/6D0
17857 WDTP(I)=FAC*AEM*QF**2/4D0
17859 ELSEIF(I.EQ.3) THEN
17861 QF=PARU(157)*XW1/2D0-PARU(158)*XW/6D0
17862 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
17863 & (1D0-RM1)**2*(2D0+RM1)
17865 ELSEIF(I.EQ.4) THEN
17867 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
17868 & (1D0-RM1)**2*(2D0+RM1)
17869 IF(KFLR.GT.0) WID2=WIDS(24,2)
17870 IF(KFLR.LT.0) WID2=WIDS(24,3)
17872 WDTP(I)=FUDGE*WDTP(I)
17873 WDTP(0)=WDTP(0)+WDTP(I)
17874 IF(MDME(IDC,1).GT.0) THEN
17875 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17876 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17877 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17878 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17882 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
17883 C...e* excited lepton.
17884 FAC=(SH/PARU(155)**2)*SHR
17885 DO 450 I=1,MDCY(KC,3)
17887 IF(MDME(IDC,1).LT.0) GOTO 450
17888 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17889 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17890 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
17893 C...e* -> gamma + e.
17894 QF=-PARU(157)/2D0-PARU(158)/2D0
17895 WDTP(I)=FAC*AEM*QF**2/4D0
17897 ELSEIF(I.EQ.2) THEN
17899 QF=-PARU(157)*XW1/2D0+PARU(158)*XW/2D0
17900 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
17901 & (1D0-RM1)**2*(2D0+RM1)
17903 ELSEIF(I.EQ.3) THEN
17905 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
17906 & (1D0-RM1)**2*(2D0+RM1)
17907 IF(KFLR.GT.0) WID2=WIDS(24,3)
17908 IF(KFLR.LT.0) WID2=WIDS(24,2)
17910 WDTP(I)=FUDGE*WDTP(I)
17911 WDTP(0)=WDTP(0)+WDTP(I)
17912 IF(MDME(IDC,1).GT.0) THEN
17913 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17914 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17915 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17916 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17920 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
17921 C...nu*_e excited neutrino.
17922 FAC=(SH/PARU(155)**2)*SHR
17923 DO 460 I=1,MDCY(KC,3)
17925 IF(MDME(IDC,1).LT.0) GOTO 460
17926 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17927 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17928 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
17931 C...nu*_e -> Z0 + nu*_e.
17932 QF=PARU(157)*XW1/2D0+PARU(158)*XW/2D0
17933 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
17934 & (1D0-RM1)**2*(2D0+RM1)
17936 ELSEIF(I.EQ.2) THEN
17937 C...nu*_e -> W+ + e.
17938 WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
17939 & (1D0-RM1)**2*(2D0+RM1)
17940 IF(KFLR.GT.0) WID2=WIDS(24,2)
17941 IF(KFLR.LT.0) WID2=WIDS(24,3)
17943 WDTP(I)=FUDGE*WDTP(I)
17944 WDTP(0)=WDTP(0)+WDTP(I)
17945 IF(MDME(IDC,1).GT.0) THEN
17946 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17947 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17948 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17949 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17953 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
17954 C...G* (graviton resonance):
17955 FAC=(PARP(50)**2/PARU(1))*SHR
17956 DO 470 I=1,MDCY(KC,3)
17958 IF(MDME(IDC,1).LT.0) GOTO 470
17959 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17960 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17961 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
17966 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
17967 & PYHFTH(SH,SH*RM1,1D0)
17968 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
17969 & (1D0+8D0*RM1/3D0)/320D0
17970 IF(I.EQ.6) WID2=WIDS(6,1)
17971 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
17972 ELSEIF(I.LE.16) THEN
17973 C...G* -> l+ + l-, nu + nubar
17975 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
17976 & (1D0+8D0*RM1/3D0)/320D0
17977 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
17978 ELSEIF(I.EQ.17) THEN
17981 ELSEIF(I.EQ.18) THEN
17982 C...G* -> gamma + gamma.
17984 ELSEIF(I.EQ.19) THEN
17986 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
17987 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
17989 ELSEIF(I.EQ.20) THEN
17991 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
17992 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
17995 WDTP(I)=FUDGE*WDTP(I)
17996 WDTP(0)=WDTP(0)+WDTP(I)
17997 IF(MDME(IDC,1).GT.0) THEN
17998 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17999 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18000 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18001 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18005 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
18006 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
18007 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
18008 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
18009 DO 480 I=1,MDCY(KC,3)
18011 IF(MDME(IDC,1).LT.0) GOTO 480
18012 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
18013 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
18014 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
18015 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
18018 C...nu_lR -> l- qbar q'
18019 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18020 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18021 ELSEIF(I.LE.18) THEN
18022 C...nu_lR -> l+ q qbar'
18023 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
18024 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
18026 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
18028 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
18030 X=(PM1+PM2+PM3)/SHR
18031 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
18033 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
18034 WDTP(I)=FAC*FCOF*FX*FY
18035 WDTP(I)=FUDGE*WDTP(I)
18036 WDTP(0)=WDTP(0)+WDTP(I)
18037 IF(MDME(IDC,1).GT.0) THEN
18038 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18039 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18040 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18041 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18045 ELSEIF(KFLA.EQ.9900023) THEN
18047 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
18048 DO 490 I=1,MDCY(KC,3)
18050 IF(MDME(IDC,1).LT.0) GOTO 490
18051 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18052 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18053 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
18057 C...Z_R0 -> q + qbar
18059 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
18060 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
18062 IF(I.EQ.6) WID2=WIDS(6,1)
18063 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
18064 C...Z_R0 -> l+ + l-
18068 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
18069 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
18074 ELSEIF(I.LE.15) THEN
18075 C...Z0 -> nu_R + nu_R, assumed Majorana.
18079 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
18082 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
18083 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
18084 WDTP(I)=FUDGE*WDTP(I)
18085 WDTP(0)=WDTP(0)+WDTP(I)
18086 IF(MDME(IDC,1).GT.0) THEN
18087 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18088 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18089 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18090 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18094 ELSEIF(KFLA.EQ.9900024) THEN
18096 FAC=(AEM/(24D0*XW))*SHR
18097 DO 500 I=1,MDCY(KC,3)
18099 IF(MDME(IDC,1).LT.0) GOTO 500
18100 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18101 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18102 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
18105 C...W_R+/- -> q + qbar'
18106 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18108 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18110 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
18112 ELSEIF(I.LE.12) THEN
18113 C...W_R+/- -> l+/- + nu_R
18116 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
18117 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18118 WDTP(I)=FUDGE*WDTP(I)
18119 WDTP(0)=WDTP(0)+WDTP(I)
18120 IF(MDME(IDC,1).GT.0) THEN
18121 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18122 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18123 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18124 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18128 ELSEIF(KFLA.EQ.9900041) THEN
18130 FAC=(1D0/(8D0*PARU(1)))*SHR
18131 DO 510 I=1,MDCY(KC,3)
18133 IF(MDME(IDC,1).LT.0) GOTO 510
18134 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18135 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18136 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
18139 C...H_L++/-- -> l+/- + l'+/-
18140 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18141 & (IABS(KFDP(IDC,2))-9)/2)**2
18142 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18143 ELSEIF(I.EQ.7) THEN
18144 C...H_L++/-- -> W_L+/- + W_L+/-
18145 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
18146 & (3D0*RM1+0.25D0/RM1-1D0)
18147 WID2=WIDS(24,4+(1-KFLS)/2)
18150 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18151 WDTP(I)=FUDGE*WDTP(I)
18152 WDTP(0)=WDTP(0)+WDTP(I)
18153 IF(MDME(IDC,1).GT.0) THEN
18154 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18155 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18156 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18157 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18161 ELSEIF(KFLA.EQ.9900042) THEN
18163 FAC=(1D0/(8D0*PARU(1)))*SHR
18164 DO 520 I=1,MDCY(KC,3)
18166 IF(MDME(IDC,1).LT.0) GOTO 520
18167 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18168 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18169 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
18172 C...H_R++/-- -> l+/- + l'+/-
18173 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18174 & (IABS(KFDP(IDC,2))-9)/2)**2
18175 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18176 ELSEIF(I.EQ.7) THEN
18177 C...H_R++/-- -> W_R+/- + W_R+/-
18178 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
18179 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
18182 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18183 WDTP(I)=FUDGE*WDTP(I)
18184 WDTP(0)=WDTP(0)+WDTP(I)
18185 IF(MDME(IDC,1).GT.0) THEN
18186 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18187 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18188 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18189 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18200 C***********************************************************************
18203 C...Calculates partial width and differential cross-section maxima
18204 C...of channels/processes not allowed on mass-shell, and selects
18205 C...masses in such channels/processes.
18207 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
18209 C...Double precision and integer declarations.
18210 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18211 IMPLICIT INTEGER(I-N)
18212 INTEGER PYK,PYCHGE,PYCOMP
18214 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18215 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18216 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
18217 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
18218 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18219 COMMON/PYINT1/MINT(400),VINT(400)
18220 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
18221 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
18222 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
18225 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
18226 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
18227 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:300),
18230 C...Find if particles equal, maximum mass, matrix elements, etc.
18236 IF(KFD(1).EQ.KFD(2)) MEQL=1
18238 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
18239 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
18245 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
18248 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
18249 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
18250 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
18251 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
18252 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
18253 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
18256 C...Find where Breit-Wigners are required, else select discrete masses.
18258 KFCA=PYCOMP(KFD(I))
18260 PMD(I)=PMAS(KFCA,1)
18261 PGD(I)=PMAS(KFCA,2)
18266 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
18269 RMG(I)=(PMG(I)/PMMX)**2
18275 C...Find allowed mass range and Breit-Wigner parameters.
18277 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
18279 PMU(I)=PMMX-PARP(42)
18280 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18281 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18282 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
18284 IF(MLM.EQ.2) ILM=3-I
18285 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
18286 IF(MBW(3-I).EQ.0) THEN
18287 PMU(I)=PMMX-PMD(3-I)
18289 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
18291 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
18292 & MIN(PMU(I),CKIN(NOFF+2*ILM))
18293 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18294 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18295 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18296 IF(MBW(I).EQ.1) THEN
18297 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18298 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18299 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18302 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
18304 IF(MLM.EQ.2) ILM=3-I
18305 PML(I)=MAX(CKIN(48+I),PARP(42))
18306 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
18307 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18308 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18309 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18310 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18311 IF(MBW(I).EQ.1) THEN
18312 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18313 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18314 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18319 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
18321 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
18326 C...Calculation of partial width of resonance.
18327 IF(MOFSH.EQ.1) THEN
18329 C..If only one integration, pick that to be the inner.
18330 IF(MBW(1).EQ.0) THEN
18336 ELSEIF(MBW(2).EQ.0) THEN
18340 C...Start outer loop of integration.
18341 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18342 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18343 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18349 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18350 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
18351 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
18355 C...Start inner loop of integration.
18357 PMU1=MIN(PMU(1),PMMX-PM2)
18358 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
18359 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18360 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18361 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
18369 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
18370 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
18373 C...Evaluate function value - inner loop.
18374 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18375 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
18376 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
18377 & RM2**2+10D0*RM1*RM2)
18378 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
18381 C...Go to next position in inner loop.
18387 ELSEIF(NPT1.LE.8) THEN
18389 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
18391 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18392 INX1(NPT1)=INX1(ISH1)
18395 ELSEIF(NPT1.LT.100) THEN
18398 IF(ISH1.GT.NPT1) ISH1=2
18399 IF(ISH1.EQ.ISN1) GOTO 160
18400 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
18401 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
18403 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18404 INX1(NPT1)=INX1(ISH1)
18409 C...Calculate integral over inner loop.
18412 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
18413 & (XPT1(INX1(IPT1))-XPT1(IPT1))
18415 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
18416 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18417 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
18420 C...Go to next position in outer loop.
18426 ELSEIF(NPT2.LE.8) THEN
18428 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
18430 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18431 INX2(NPT2)=INX2(ISH2)
18434 ELSEIF(NPT2.LT.100) THEN
18437 IF(ISH2.GT.NPT2) ISH2=2
18438 IF(ISH2.EQ.ISN2) GOTO 200
18439 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
18440 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
18442 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18443 INX2(NPT2)=INX2(ISH2)
18448 C...Calculate integral over outer loop.
18451 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
18452 & (XPT2(INX2(IPT2))-XPT2(IPT2))
18454 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
18455 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
18460 C...Save result; second integration for user-selected mass range.
18461 IF(LOOP.EQ.1) WIDW=FSUM2
18463 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
18464 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
18471 C...Select two decay product masses of a resonance.
18472 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
18474 IF(MBW(I).EQ.0) GOTO 230
18475 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
18477 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
18478 RMG(I)=(PMG(I)/PMMX)**2
18480 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18481 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
18483 C...Weight with matrix element (if none known, use beta factor).
18484 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
18486 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
18487 ELSEIF(MMED.EQ.2) THEN
18488 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
18489 & RMG(2)**2+10D0*RMG(1)*RMG(2))
18490 ELSEIF(MMED.EQ.3) THEN
18491 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
18495 IF(WTBE.LT.PYR(0)) GOTO 220
18499 C...Find suitable set of masses for initialization of 2 -> 2 processes.
18500 ELSEIF(MOFSH.EQ.3) THEN
18501 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
18502 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
18504 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
18506 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
18510 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
18511 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
18512 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
18517 C...Evaluate importance of excluded tails of Breit-Wigners.
18518 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18519 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18523 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
18527 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
18528 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
18530 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
18531 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
18532 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
18533 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
18535 C...Pick one particle to be the lighter (if improves efficiency).
18536 ELSEIF(MOFSH.EQ.4) THEN
18537 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18538 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18539 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
18541 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
18543 IF(MBW(I).EQ.0) GOTO 270
18545 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18547 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18549 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18550 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
18551 IF(RBR.LT.0.8D0) THEN
18552 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
18553 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
18554 ELSEIF(RBR.LT.0.9D0) THEN
18555 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
18556 ELSEIF(RBR.LT.1.5D0) THEN
18557 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
18559 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
18560 & (PMV**2-PML(I)**2))))
18563 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18564 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
18565 IF(MINT(48).EQ.1) THEN
18566 NGEN(0,1)=NGEN(0,1)+1
18567 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
18577 C...Give weight for selected mass distribution.
18580 IF(MBW(I).EQ.0) GOTO 280
18582 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18584 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18585 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
18586 & (PMD(I)*PGD(I))**2)/PARU(1)
18590 FI0=(ATV-ATL(I))/PARU(1)
18591 FI1=PMV**2-PML(I)**2
18592 FI2=2D0*LOG(PMV/PML(I))
18593 FI3=1D0/PML(I)**2-1D0/PMV**2
18594 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18595 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
18596 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
18599 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
18601 VINT(80)=VINT(80)*FI0
18603 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
18609 C***********************************************************************
18612 C...Handles the possibility of colour reconnection in W+W- events,
18613 C...Based on the main scenarios of the Sjostrand and Khoze study:
18614 C...I, II, II', intermediate and instantaneous; plus one model
18615 C...along the lines of the Gustafson and Hakkinen: GH.
18616 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
18617 C...is as if first resonance is W+ and second W-.
18619 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
18621 C...Double precision and integer declarations.
18622 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18623 IMPLICIT INTEGER(I-N)
18624 INTEGER PYK,PYCHGE,PYCOMP
18625 C...Parameter value; number of points in MC integration.
18626 PARAMETER (NPT=100)
18628 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
18629 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18630 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18631 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18632 COMMON/PYINT1/MINT(400),VINT(400)
18633 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
18635 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
18636 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
18637 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
18638 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
18639 &TMC(20),IJOIN(100)
18641 C...Functions to give four-product and to do determinants.
18642 FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
18643 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
18644 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
18645 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
18647 C...Only allow fraction of recoupling for GH, intermediate and
18649 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
18650 IF(PYR(0).GT.PARP(120)) RETURN
18654 C...Common part for scenarios I, II, II', and GH.
18655 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
18656 &MSTP(115).EQ.5) THEN
18658 C...Read out frequently-used parameters.
18662 IF(ISUB.EQ.22) PMW=PMAS(23,1)
18664 IF(ISUB.EQ.22) PGW=PMAS(23,2)
18671 C...Find range of decay products of the W's.
18672 C...Background: the W's are stored in IW1 and IW2.
18673 C...Their direct decay products in NSD1+1 through NSD1+4.
18674 C...Products after shower (if any) in NSD1+5 through NAFT1
18675 C...for first W and in NAFT1+1 through N for the second.
18676 IF(NAFT1.GT.NSD1+4) THEN
18683 IF(N.GT.NAFT1) THEN
18691 C...Rearrange parton shower products along strings.
18693 CALL PYPREP(NSD1+1)
18695 C...Find partons pointing back to W+ and W-; store them with quark
18696 C...end of string first.
18702 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
18703 IF(IABS(K(I,2)).GE.22) GOTO 120
18704 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
18705 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
18715 IF(K(I,1).EQ.1) ISGP=0
18716 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
18717 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
18727 IF(K(I,1).EQ.1) ISGM=0
18731 C...Boost to W+W- rest frame (not strictly needed).
18733 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
18735 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
18736 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
18737 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
18739 C...Select decay vertices of W+ and W-.
18740 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
18741 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
18742 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
18743 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
18746 XP(J)=TP*P(IW1,J)/P(IW1,4)
18747 XM(J)=TM*P(IW2,J)/P(IW2,4)
18750 C...Begin scenario I specifics.
18751 IF(MSTP(115).EQ.1) THEN
18753 C...Reconstruct velocity and direction of W+ string pieces.
18755 IF(K(INP(IIP),2).LT.0) GOTO 170
18758 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
18759 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
18763 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
18764 DIRP(IIP,J)=V1(J)-V2(J)
18766 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
18768 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
18770 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
18774 C...Reconstruct velocity and direction of W- string pieces.
18776 IF(K(INM(IIM),2).LT.0) GOTO 200
18779 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
18780 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
18784 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
18785 DIRM(IIM,J)=V1(J)-V2(J)
18787 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
18789 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
18791 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
18795 C...Loop over number of space-time points.
18800 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
18801 R=SQRT(-LOG(PYR(0)))
18803 X=BLOWR*RHAD*R*COS(PHI)
18804 Y=BLOWR*RHAD*R*SIN(PHI)
18805 R=SQRT(-LOG(PYR(0)))
18807 Z=BLOWR*RHAD*R*COS(PHI)
18808 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
18810 C...Reject impossible points. Weight for sample distribution.
18811 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
18812 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
18813 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
18815 C...Loop over W+ string pieces and find one with largest weight.
18823 IF(K(INP(IIP),2).LT.0) GOTO 220
18824 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
18825 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
18827 XB(J)=XD(J)+BEDG*BETP(IIP,J)
18829 XB(4)=BETP(IIP,4)*(XD(4)-BED)
18830 SR2=XB(1)**2+XB(2)**2+XB(3)**2
18831 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
18832 & DIRP(IIP,3)*XB(3))**2
18833 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
18835 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
18836 IF(WTP.GT.WTMAXP) THEN
18842 C...Loop over W- string pieces and find one with largest weight.
18850 IF(K(INM(IIM),2).LT.0) GOTO 240
18851 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
18852 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
18854 XB(J)=XD(J)+BEDG*BETM(IIM,J)
18856 XB(4)=BETM(IIM,4)*(XD(4)-BED)
18857 SR2=XB(1)**2+XB(2)**2+XB(3)**2
18858 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
18859 & DIRM(IIM,3)*XB(3))**2
18860 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
18862 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
18863 IF(WTM.GT.WTMAXM) THEN
18869 C...Result of integration.
18871 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
18872 WT=WTMAXP*WTMAXM/WTSMP
18880 RES=BLOWR**3*BLOWT*SUM/NPT
18882 C...Decide whether to reconnect and, if so, where.
18884 PREC=1D0-EXP(-FACT*RES)
18885 IF(PREC.GT.PYR(0)) THEN
18890 IF(RSUM.LE.0D0) GOTO 270
18896 C...Begin scenario II and II' specifics.
18897 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
18899 C...Loop through all string pieces, one from W+ and one from W-.
18903 IF(K(INP(IIP),2).LT.0) GOTO 340
18907 IF(K(INM(IIM),2).LT.0) GOTO 330
18911 C...Find endpoint velocity vectors.
18913 V1P(J)=P(I1P,J)/P(I1P,4)
18914 V2P(J)=P(I2P,J)/P(I2P,4)
18915 V1M(J)=P(I1M,J)/P(I1M,4)
18916 V2M(J)=P(I2M,J)/P(I2M,4)
18919 C...Define q matrix and find t.
18921 Q(1,J)=V2P(J)-V1P(J)
18922 Q(2,J)=-(V2M(J)-V1M(J))
18923 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
18924 Q(4,J)=V1P(J)-V1M(J)
18926 T=-DETER(1,2,3)/DETER(1,2,4)
18928 C...Find alpha and beta; i.e. coordinates of crossing point.
18931 S13=Q(3,1)+Q(4,1)*T
18934 S23=Q(3,2)+Q(4,2)*T
18935 DEN=S11*S22-S12*S21
18936 ALP=(S12*S23-S22*S13)/DEN
18937 BET=(S21*S13-S11*S23)/DEN
18939 C...Check if solution acceptable.
18941 IF(T.LT.GTMAX) IANSW=0
18942 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
18943 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
18945 C...Find point of crossing and check that not inconsistent.
18947 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
18948 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
18950 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
18951 & (XPP(3)-XMM(3))**2
18952 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
18953 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
18954 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
18956 C...Find string eigentimes at crossing.
18957 IF(IANSW.EQ.1) THEN
18958 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
18959 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
18960 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
18961 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
18967 C...Order crossings by time. End loop over crossings.
18968 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
18970 DO 310 I1=NCROSS,1,-1
18971 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
18991 C...Loop over crossings; find first (if any) acceptable one.
18993 IF(NCROSS.GE.1) THEN
18995 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
18996 IF(PNFRAG.GT.PYR(0)) THEN
18997 C...Scenario II: only compare with fragmentation time.
18998 IF(MSTP(115).EQ.2) THEN
19003 C...Scenario II': also require that string length decreases.
19011 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19012 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19013 IF(ELNEW.LT.ELOLD) THEN
19025 C...Begin scenario GH specifics.
19026 ELSEIF(MSTP(115).EQ.5) THEN
19028 C...Loop through all string pieces, one from W+ and one from W-.
19032 IF(K(INP(IIP),2).LT.0) GOTO 380
19036 IF(K(INM(IIM),2).LT.0) GOTO 370
19040 C...Look for largest decrease of (exponent of) Lambda measure.
19041 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19042 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19043 ELDIF=ELNEW/MAX(1D-10,ELOLD)
19044 IF(ELDIF.LT.ELMIN) THEN
19056 C...Common for scenarios I, II, II' and GH: reconnect strings.
19060 DO 390 IS=1,NNP+NNM
19064 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
19066 ELSEIF(IS.LE.IIP+NNM) THEN
19067 I=INM(IS-IIP-NNM+IIM)
19072 IF(K(I,2).LT.0) THEN
19073 CALL PYJOIN(NJOIN,IJOIN)
19078 C...Restore original event record if no reconnection.
19080 DO 400 I=NSD1+1,NOLD
19081 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
19082 K(I,4)=MOD(K(I,4),MSTU(5)**2)
19083 K(I,5)=MOD(K(I,5),MSTU(5)**2)
19092 C...Boost back system.
19093 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19094 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19095 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
19096 & BEWW(1),BEWW(2),BEWW(3))
19098 C...Common part for intermediate and instantaneous scenarios.
19099 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
19102 C...Remove old shower products and reset showering ones.
19104 DO 420 I=NSD1+1,NSD1+4
19106 K(I,4)=MOD(K(I,4),MSTU(5)**2)
19107 K(I,5)=MOD(K(I,5),MSTU(5)**2)
19110 C...Identify quark-antiquark pairs.
19114 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
19117 C...Reconnect strings.
19120 CALL PYJOIN(2,IJOIN)
19123 CALL PYJOIN(2,IJOIN)
19125 C...Do new parton showers in intermediate scenario.
19126 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
19129 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
19130 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
19133 C...Do new parton showers in instantaneous scenario.
19134 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
19135 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
19136 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
19137 PPM=SQRT(MAX(0D0,PPM2))
19138 CALL PYSHOW(IQ1,IQ4,PPM)
19139 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
19140 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
19141 PPM=SQRT(MAX(0D0,PPM2))
19142 CALL PYSHOW(IQ3,IQ2,PPM)
19149 C***********************************************************************
19152 C...Checks generated variables against pre-set kinematical limits;
19153 C...also calculates limits on variables used in generation.
19155 SUBROUTINE PYKLIM(ILIM)
19157 C...Double precision and integer declarations.
19158 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19159 IMPLICIT INTEGER(I-N)
19160 INTEGER PYK,PYCHGE,PYCOMP
19162 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19163 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19164 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19165 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19166 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19167 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19168 COMMON/PYINT1/MINT(400),VINT(400)
19169 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19170 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19173 C...Common kinematical expressions.
19177 IF(ISUB.EQ.96) GOTO 100
19181 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
19182 CKIN09=MAX(CKIN(9),CKIN(13))
19183 CKIN10=MIN(CKIN(10),CKIN(14))
19184 CKIN11=MAX(CKIN(11),CKIN(15))
19185 CKIN12=MIN(CKIN(12),CKIN(16))
19187 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
19188 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
19189 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
19190 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
19195 RM3=SQM3/(TAU*VINT(2))
19196 RM4=SQM4/(TAU*VINT(2))
19197 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19200 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
19201 &PTHMIN=MAX(CKIN(3),CKIN(5))
19204 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
19205 C...pre-set kinematical limits.
19210 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
19211 X1=SQRT(TAUE)*EXP(YST)
19212 X2=SQRT(TAUE)*EXP(-YST)
19214 IF(MINT(47).NE.1) THEN
19215 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
19216 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
19217 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
19218 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
19220 IF(MINT(45).NE.1) THEN
19221 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
19223 IF(MINT(46).NE.1) THEN
19224 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
19226 IF(MINT(45).EQ.2) THEN
19227 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19229 IF(MINT(46).EQ.2) THEN
19230 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19232 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
19233 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
19234 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
19235 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
19236 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
19237 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
19238 Y3=YST+0.5D0*LOG(EXPY3)
19239 Y4=YST+0.5D0*LOG(EXPY4)
19244 STH=SQRT(MAX(0D0,1D0-CTH**2))
19245 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
19246 & CTH)**2-4D0*RM3))
19247 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
19248 & CTH)**2-4D0*RM4))
19249 IF(STH.GE.1D-10) THEN
19250 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
19252 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
19254 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
19255 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
19256 ETALAR=MAX(ETA3,ETA4)
19257 ETASMA=MIN(ETA3,ETA4)
19259 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
19260 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
19261 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
19262 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
19264 RPTS=4D0*VINT(71)**2/SH
19265 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
19266 RM34=MAX(1D-20,2D0*RM3*RM4)
19267 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
19268 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
19269 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
19270 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
19271 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
19272 IF(PTH.LT.PTHMIN) MINT(51)=1
19273 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
19274 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
19275 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
19276 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
19277 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
19278 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
19279 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
19280 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
19281 IF(THA.LT.CKIN(35)) MINT(51)=1
19282 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
19283 IF(UHA.LT.CKIN(37)) MINT(51)=1
19284 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
19286 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
19287 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
19288 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
19291 C...Additional cuts on W2 (approximately) in DIS.
19292 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
19294 IF(IABS(MINT(12)).LT.20) XBJ=X1
19296 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
19297 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
19298 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
19301 ELSEIF(ILIM.EQ.1) THEN
19302 C...Calculate limits on tau
19303 C...0) due to definition
19306 C...1) due to limits on subsystem mass
19307 TAUMN1=CKIN(1)**2/VINT(2)
19309 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
19310 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
19311 TM3=SQRT(SQM3+PTHMIN**2)
19312 TM4=SQRT(SQM4+PTHMIN**2)
19314 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
19315 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
19317 C...3) due to limits on pT-hat and cos(theta-hat)
19318 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
19319 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
19321 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
19322 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
19323 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
19325 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
19326 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
19327 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
19328 C...4) due to limits on x1 and x2
19329 TAUMN4=CKIN(21)*CKIN(23)
19330 TAUMX4=CKIN(22)*CKIN(24)
19331 C...5) due to limits on xF
19333 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
19334 C...6) due to limits on that and uhat
19335 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
19337 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
19338 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
19340 C...Net effect of all separate limits.
19341 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
19342 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
19343 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19346 ELSEIF(MINT(47).EQ.5) THEN
19347 VINT(31)=MIN(VINT(31),1D0-2D-10)
19348 ELSEIF(MINT(47).GE.6) THEN
19349 VINT(31)=MIN(VINT(31),1D0-1D-10)
19351 IF(VINT(31).LE.VINT(11)) MINT(51)=1
19353 ELSEIF(ILIM.EQ.2) THEN
19354 C...Calculate limits on y*
19356 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
19358 C...0) due to kinematics
19361 C...1) due to explicit limits
19364 C...2) due to limits on x1
19365 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
19366 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
19367 C...3) due to limits on x2
19368 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
19369 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
19370 C...4) due to limits on xF
19371 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
19372 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
19373 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
19374 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
19375 C...5) due to simultaneous limits on y-large and y-small
19376 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
19377 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
19378 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
19379 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
19380 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
19381 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
19382 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
19384 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
19385 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
19386 RZMX=BE34*MIN(CKIN(28),CTHLIM)
19387 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
19388 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
19389 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
19390 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
19391 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
19392 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
19394 C...Net effect of all separate limits.
19395 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
19396 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
19397 IF(MINT(47).EQ.1) THEN
19400 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
19401 VINT(12)=(1D0-1D-9)*YSTMX0
19402 VINT(32)=(1D0+1D-9)*YSTMX0
19403 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
19404 VINT(12)=-(1D0+1D-9)*YSTMX0
19405 VINT(32)=-(1D0-1D-9)*YSTMX0
19406 ELSEIF(MINT(47).EQ.5) THEN
19407 YSTEE=LOG((1D0-1D-10)/TAURT)
19408 VINT(12)=MAX(VINT(12),-YSTEE)
19409 VINT(32)=MIN(VINT(32),YSTEE)
19411 IF(VINT(32).LE.VINT(12)) MINT(51)=1
19413 ELSEIF(ILIM.EQ.3) THEN
19414 C...Calculate limits on cos(theta-hat)
19416 C...0) due to definition
19421 C...1) due to explicit limits
19422 CTNMN1=MIN(0D0,CKIN(27))
19423 CTNMX1=MIN(0D0,CKIN(28))
19424 CTPMN1=MAX(0D0,CKIN(27))
19425 CTPMX1=MAX(0D0,CKIN(28))
19426 C...2) due to limits on pT-hat
19427 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
19431 IF(CKIN(4).GE.0D0) THEN
19432 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
19433 & (BE34**2*TAU*VINT(2))))
19436 C...3) due to limits on y-large and y-small
19437 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
19438 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
19439 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
19440 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
19441 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
19442 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
19443 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
19444 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
19445 C...4) due to limits on that
19451 IF(CKIN(35).GT.0D0) THEN
19452 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
19453 IF(CTLIM.GT.0D0) THEN
19460 IF(CKIN(36).GT.0D0) THEN
19461 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
19462 IF(CTLIM.LT.0D0) THEN
19469 C...5) due to limits on uhat
19474 IF(CKIN(37).GT.0D0) THEN
19475 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
19476 IF(CTLIM.LT.0D0) THEN
19483 IF(CKIN(38).GT.0D0) THEN
19484 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
19485 IF(CTLIM.GT.0D0) THEN
19493 C...Net effect of all separate limits.
19494 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
19495 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
19496 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
19497 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
19498 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
19500 ELSEIF(ILIM.EQ.4) THEN
19501 C...Calculate limits on tau'
19502 C...0) due to kinematics
19504 IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
19505 PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
19506 TAPMN0=(SQRT(TAU)+PQRAT)**2
19509 C...1) due to explicit limits
19510 TAPMN1=CKIN(31)**2/VINT(2)
19512 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
19514 C...Net effect of all separate limits.
19515 VINT(16)=MAX(TAPMN0,TAPMN1)
19516 VINT(36)=MIN(TAPMX0,TAPMX1)
19517 IF(MINT(47).EQ.1) THEN
19520 ELSEIF(MINT(47).EQ.5) THEN
19521 VINT(36)=MIN(VINT(36),1D0-2D-10)
19522 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
19523 VINT(36)=MIN(VINT(36),1D0-1D-10)
19525 IF(VINT(36).LE.VINT(16)) MINT(51)=1
19530 C...Special case for low-pT and multiple interactions:
19531 C...effective kinematical limits for tau, y*, cos(theta-hat).
19532 100 IF(ILIM.EQ.0) THEN
19533 ELSEIF(ILIM.EQ.1) THEN
19534 IF(MSTP(82).LE.1) THEN
19535 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19538 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
19541 ELSEIF(ILIM.EQ.2) THEN
19542 VINT(12)=0.5D0*LOG(VINT(21))
19544 ELSEIF(ILIM.EQ.3) THEN
19545 IF(MSTP(82).LE.1) THEN
19546 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19547 & (VINT(21)*VINT(2))
19549 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19550 & (VINT(21)*VINT(2))
19552 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
19561 C*********************************************************************
19564 C...Maps a uniform distribution into a distribution of a kinematical
19565 C...variable according to one of the possibilities allowed. It is
19566 C...assumed that kinematical limits have been set by a PYKLIM call.
19568 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
19570 C...Double precision and integer declarations.
19571 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19572 IMPLICIT INTEGER(I-N)
19573 INTEGER PYK,PYCHGE,PYCOMP
19575 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19576 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19577 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19578 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19579 COMMON/PYINT1/MINT(400),VINT(400)
19580 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19581 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
19583 C...Convert VVAR to tau variable.
19589 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
19592 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
19596 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19598 ELSEIF(MVAR.EQ.1) THEN
19599 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
19600 ELSEIF(MVAR.EQ.2) THEN
19601 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
19602 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
19603 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
19604 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
19605 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
19606 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
19607 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
19608 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
19609 ELSEIF(MINT(47).EQ.5) THEN
19610 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
19611 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
19612 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
19614 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
19615 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
19616 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
19618 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
19620 C...Convert VVAR to y* variable.
19621 ELSEIF(IVAR.EQ.2) THEN
19625 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
19626 IF(MINT(47).EQ.1) THEN
19628 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
19629 YST=-0.5D0*LOG(TAUE)
19630 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
19631 YST=0.5D0*LOG(TAUE)
19632 ELSEIF(MVAR.EQ.1) THEN
19633 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
19634 ELSEIF(MVAR.EQ.2) THEN
19635 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
19636 ELSEIF(MVAR.EQ.3) THEN
19637 AUPP=ATAN(EXP(YSTMAX))
19638 ALOW=ATAN(EXP(YSTMIN))
19639 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
19640 ELSEIF(MVAR.EQ.4) THEN
19641 YST0=-0.5D0*LOG(TAUE)
19642 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
19643 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
19644 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
19646 YST0=-0.5D0*LOG(TAUE)
19647 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
19648 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
19649 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
19651 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
19653 C...Convert VVAR to cos(theta-hat) variable.
19654 ELSEIF(IVAR.EQ.3) THEN
19655 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
19657 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
19658 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
19666 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
19667 VCTN=VVAR*(ANEG+APOS)/ANEG
19668 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
19670 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
19671 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
19673 ELSEIF(MVAR.EQ.2) THEN
19674 RMNMIN=MAX(RM34,RSQM-CTNMIN)
19675 RMNMAX=MAX(RM34,RSQM-CTNMAX)
19676 RMPMIN=MAX(RM34,RSQM-CTPMIN)
19677 RMPMAX=MAX(RM34,RSQM-CTPMAX)
19678 ANEG=LOG(RMNMIN/RMNMAX)
19679 APOS=LOG(RMPMIN/RMPMAX)
19680 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
19681 VCTN=VVAR*(ANEG+APOS)/ANEG
19682 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
19684 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
19685 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
19687 ELSEIF(MVAR.EQ.3) THEN
19688 RMNMIN=MAX(RM34,RSQM+CTNMIN)
19689 RMNMAX=MAX(RM34,RSQM+CTNMAX)
19690 RMPMIN=MAX(RM34,RSQM+CTPMIN)
19691 RMPMAX=MAX(RM34,RSQM+CTPMAX)
19692 ANEG=LOG(RMNMAX/RMNMIN)
19693 APOS=LOG(RMPMAX/RMPMIN)
19694 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
19695 VCTN=VVAR*(ANEG+APOS)/ANEG
19696 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
19698 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
19699 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
19701 ELSEIF(MVAR.EQ.4) THEN
19702 RMNMIN=MAX(RM34,RSQM-CTNMIN)
19703 RMNMAX=MAX(RM34,RSQM-CTNMAX)
19704 RMPMIN=MAX(RM34,RSQM-CTPMIN)
19705 RMPMAX=MAX(RM34,RSQM-CTPMAX)
19706 ANEG=1D0/RMNMAX-1D0/RMNMIN
19707 APOS=1D0/RMPMAX-1D0/RMPMIN
19708 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
19709 VCTN=VVAR*(ANEG+APOS)/ANEG
19710 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
19712 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
19713 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
19715 ELSEIF(MVAR.EQ.5) THEN
19716 RMNMIN=MAX(RM34,RSQM+CTNMIN)
19717 RMNMAX=MAX(RM34,RSQM+CTNMAX)
19718 RMPMIN=MAX(RM34,RSQM+CTPMIN)
19719 RMPMAX=MAX(RM34,RSQM+CTPMAX)
19720 ANEG=1D0/RMNMIN-1D0/RMNMAX
19721 APOS=1D0/RMPMIN-1D0/RMPMAX
19722 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
19723 VCTN=VVAR*(ANEG+APOS)/ANEG
19724 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
19726 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
19727 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
19730 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
19731 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
19734 C...Convert VVAR to tau' variable.
19735 ELSEIF(IVAR.EQ.4) THEN
19739 IF(MINT(47).EQ.1) THEN
19741 ELSEIF(MVAR.EQ.1) THEN
19742 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
19743 ELSEIF(MVAR.EQ.2) THEN
19744 AUPP=(1D0-TAU/TAUPMX)**4
19745 ALOW=(1D0-TAU/TAUPMN)**4
19746 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
19747 ELSEIF(MINT(47).EQ.5) THEN
19748 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
19749 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
19750 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
19752 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
19753 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
19754 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
19756 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
19758 C...Selection of extra variables needed in 2 -> 3 process:
19759 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
19760 C...Since no options are available, the functions of PYKLIM
19761 C...and PYKMAP are joint for these choices.
19762 ELSEIF(IVAR.EQ.5) THEN
19764 C...Read out total energy and particle masses.
19767 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
19768 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
19770 SHP=VINT(26)*VINT(2)
19774 PM3=SQRT(VINT(21))*VINT(1)
19775 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
19782 C...Specify coefficients of pT choice; upper and lower limits.
19783 IF(MPTPK.EQ.1) THEN
19791 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
19793 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
19795 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
19797 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
19800 C...Select transverse momenta according to
19801 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
19804 IF(HMX.LT.1.0001D0*HMN) THEN
19810 IF(RPT.LT.HWT1) THEN
19811 PTS1=PTSMN1+PYR(0)*HDE
19812 ELSEIF(RPT.LT.HWT1+HWT2) THEN
19813 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
19815 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
19817 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
19818 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
19821 IF(HMX.LT.1.0001D0*HMN) THEN
19827 IF(RPT.LT.HWT1) THEN
19828 PTS2=PTSMN2+PYR(0)*HDE
19829 ELSEIF(RPT.LT.HWT1+HWT2) THEN
19830 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
19832 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
19834 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
19835 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
19837 C...Select azimuthal angles and check pT choice.
19838 PHI1=PARU(2)*PYR(0)
19839 PHI2=PARU(2)*PYR(0)
19841 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
19842 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
19843 & CKIN(56)**2)) THEN
19848 C...Calculate transverse masses and check phase space not closed.
19855 PM12=(PMT1+PMT2)**2
19856 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
19861 C...Select rapidity for particle 3 and check phase space not closed.
19862 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
19863 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
19864 IF(Y3MAX.LT.1D-6) THEN
19868 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
19872 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
19875 PMS12=PE12**2-PZ12**2
19876 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
19877 IF(SQL12.LT.1D-6*SHP) THEN
19881 PMM1=PMS12+PMS1-PMS2
19882 PMM2=PMS12+PMS2-PMS1
19883 TFAC=-SHPR/(2D0*PMS12)
19884 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
19885 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
19886 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
19887 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
19889 C...Construct relative mirror weights and make choice.
19890 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
19894 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
19895 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
19897 WTP=WTPU/(WTPU+WTNU)
19898 WTN=WTNU/(WTPU+WTNU)
19900 IF(WTN.GT.PYR(0)) EPS=-1D0
19902 C...Store result of variable choice and associated weights.
19912 IF(EPS.GT.0D0) THEN
19921 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
19922 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
19923 VINT(219)=0.5D0*(PMS12-PTS3)
19930 C***********************************************************************
19933 C...Differential matrix elements for all included subprocesses
19934 C...Note that what is coded is (disregarding the COMFAC factor)
19935 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
19936 C...when d(sigma-hat) is given in the zero-width limit, the delta
19937 C...function in tau is replaced by a (modified) Breit-Wigner:
19938 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
19939 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
19940 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
19941 C...i.e., dimensionless quantities
19942 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
19943 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
19944 C...(2pi)^4 delta^4(P - sum p_i)
19945 C...COMFAC contains the factor pi/s (or equivalent) and
19946 C...the conversion factor from GeV^-2 to mb
19948 SUBROUTINE PYSIGH(NCHN,SIGS)
19950 C...Double precision and integer declarations
19951 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19952 IMPLICIT INTEGER(I-N)
19953 INTEGER PYK,PYCHGE,PYCOMP
19954 C...Parameter statement to help give large particle numbers.
19955 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
19956 &KEXCIT=4000000,KDIMEN=5000000)
19958 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19959 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19960 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19961 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19962 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19963 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19964 COMMON/PYINT1/MINT(400),VINT(400)
19965 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19966 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19967 COMMON/PYINT4/MWID(500),WIDS(500,5)
19968 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19969 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19970 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
19971 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
19972 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
19973 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19974 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
19976 C...Local arrays and complex variables
19977 DIMENSION X(2),XPQ(-25:25),KFAC(2,-40:40),WDTP(0:300),
19978 &WDTE(0:300,0:5),HGZ(6,3),HL3(3),HR3(3),HL4(3),HR4(3)
19979 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
19980 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF,
19981 &COULCK,COULCP,COULCD,COULCR,COULCS
19982 REAL*8 A00L,A11L,A20L,COULXX
19983 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
19984 COMPLEX*16 DAA,DZZ,DAZ
19985 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU
19986 COMPLEX*16 DQQS,DQQT,DQQU,DQTS
19987 COMPLEX*16 DVVS,DVVT,DVVU
19988 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
19989 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
19990 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
19993 C...Reset number of channels and cross-section
19997 C...Convert H or A process into equivalent h one
20002 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
20003 &ISUB.LE.190)) THEN
20005 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
20007 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
20008 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
20009 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
20010 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
20011 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
20012 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
20013 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
20014 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
20015 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
20016 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
20017 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
20018 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
20022 C...Convert almost equivalent SUSY processes into each other
20023 C...Extract differences in flavours and couplings
20024 IF(ISUB.GE.200.AND.ISUB.LE.301) THEN
20026 C...Sleptons and sneutrinos
20027 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
20028 KFID=MOD(KFPR(ISUB,1),KSUSY1)
20031 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
20032 KFID=MOD(KFPR(ISUB,1),KSUSY1)
20035 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
20036 KFID=MOD(KFPR(ISUB,1),KSUSY1)
20038 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
20039 IF(ISUB.EQ.210) THEN
20041 ELSEIF(ISUB.EQ.211) THEN
20043 ELSEIF(ISUB.EQ.212) THEN
20047 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
20048 IF(ISUB.EQ.213) THEN
20049 KFID=MOD(KFPR(ISUB,1),KSUSY1)
20051 ELSEIF(ISUB.EQ.214) THEN
20058 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
20059 IF(ISUB.EQ.216) THEN
20062 ELSEIF(ISUB.EQ.217) THEN
20065 ELSEIF(ISUB.EQ.218) THEN
20068 ELSEIF(ISUB.EQ.219) THEN
20071 ELSEIF(ISUB.EQ.220) THEN
20074 ELSEIF(ISUB.EQ.221) THEN
20077 ELSEIF(ISUB.EQ.222) THEN
20080 ELSEIF(ISUB.EQ.223) THEN
20083 ELSEIF(ISUB.EQ.224) THEN
20086 ELSEIF(ISUB.EQ.225) THEN
20093 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
20094 IF(ISUB.EQ.226) THEN
20097 ELSEIF(ISUB.EQ.227) THEN
20100 ELSEIF(ISUB.EQ.228) THEN
20106 C...Neutralino + chargino
20107 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
20108 IF(ISUB.EQ.229) THEN
20111 ELSEIF(ISUB.EQ.230) THEN
20114 ELSEIF(ISUB.EQ.231) THEN
20117 ELSEIF(ISUB.EQ.232) THEN
20120 ELSEIF(ISUB.EQ.233) THEN
20123 ELSEIF(ISUB.EQ.234) THEN
20126 ELSEIF(ISUB.EQ.235) THEN
20129 ELSEIF(ISUB.EQ.236) THEN
20135 C...Gluino + neutralino
20136 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
20137 IF(ISUB.EQ.237) THEN
20139 ELSEIF(ISUB.EQ.238) THEN
20141 ELSEIF(ISUB.EQ.239) THEN
20143 ELSEIF(ISUB.EQ.240) THEN
20148 C...Gluino + chargino
20149 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
20150 IF(ISUB.EQ.241) THEN
20152 ELSEIF(ISUB.EQ.242) THEN
20157 C...Squark + neutralino
20158 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
20160 IF(MOD(ISUB,2).NE.0) ILR=1
20161 IF(ISUB.LE.247) THEN
20163 ELSEIF(ISUB.LE.249) THEN
20165 ELSEIF(ISUB.LE.251) THEN
20167 ELSEIF(ISUB.LE.253) THEN
20173 C...Squark + chargino
20174 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
20175 IF(ISUB.LE.255) THEN
20177 ELSEIF(ISUB.LE.257) THEN
20180 IF(MOD(ISUB,2).EQ.0) THEN
20188 C...Squark + gluino
20189 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
20194 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
20196 IF(ISUB.EQ.262) ILR=1
20198 ELSEIF(ISUB.EQ.265) THEN
20202 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
20204 IF(ISUB.LE.273) THEN
20205 IF(ISUB.EQ.273) ILR=1
20208 ELSEIF(ISUB.LE.276) THEN
20209 IF(ISUB.EQ.276) ILR=1
20212 ELSEIF(ISUB.LE.278) THEN
20213 IF(ISUB.EQ.278) ILR=1
20217 IF(ISUB.EQ.280) ILR=1
20222 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
20224 IF(ISUB.LE.283) THEN
20225 IF(ISUB.EQ.283) ILR=1
20228 ELSEIF(ISUB.LE.286) THEN
20229 IF(ISUB.EQ.286) ILR=1
20232 ELSEIF(ISUB.LE.288) THEN
20233 IF(ISUB.EQ.288) ILR=1
20236 ELSEIF(ISUB.LE.290) THEN
20237 IF(ISUB.EQ.290) ILR=1
20240 ELSEIF(ISUB.LE.293) THEN
20241 IF(ISUB.EQ.293) ILR=1
20244 ELSEIF(ISUB.EQ.296) THEN
20248 C...Squark + gluino
20249 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
20254 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
20255 IF(ISUB.EQ.297) THEN
20256 RKF=.5D0*PARU(195)**2
20257 ELSEIF(ISUB.EQ.298) THEN
20258 RKF=.5D0*(1D0-PARU(195)**2)
20262 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
20263 IF(ISUB.EQ.299) THEN
20266 ELSEIF(ISUB.EQ.300) THEN
20272 ELSEIF(ISUB.EQ.301) THEN
20278 C...Convert almost equivalent technicolor processes into
20279 C...a few basic processes, and set distinguishing parameters.
20280 ELSEIF(ISUB.GE.361.AND.ISUB.LE.379) THEN
20283 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
20284 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
20285 CSXI=COS(ASIN(PARP(141)))
20286 CSXIP=COS(ASIN(PARP(139)))
20287 QUPD=2D0*PARP(143)-1D0
20288 C... rho_tc0 -> W_L W_L
20289 IF(ISUB.EQ.361) THEN
20293 C... rho_tc0 -> W_L pi_tc-
20294 ELSEIF(ISUB.EQ.362) THEN
20298 CAB2=PARP(141)**2*(1D0-PARP(141)**2)
20300 ELSEIF(ISUB.EQ.363) THEN
20304 CAB2=(1D0-PARP(141)**2)**2
20305 C... rho_tc0/omega_tc -> gamma pi_tc
20306 ELSEIF(ISUB.EQ.364) THEN
20314 ELSEIF(ISUB.EQ.365) THEN
20323 ELSEIF(ISUB.EQ.366) THEN
20328 VRGP=-QUPD*CSXI*TANW
20332 ELSEIF(ISUB.EQ.367) THEN
20337 VOGP=-QUPD*CSXIP*TANW
20341 ELSEIF(ISUB.EQ.368) THEN
20345 VOGP=CSXI/(2D0*SQRT(PARU(102)))
20349 C... rho_tc+ -> W_L Z_L
20350 ELSEIF(ISUB.EQ.370) THEN
20355 ELSEIF(ISUB.EQ.371) THEN
20359 CAB2=PARP(141)**2*(1D0-PARP(141)**2)
20361 ELSEIF(ISUB.EQ.372) THEN
20365 CAB2=PARP(141)**2*(1D0-PARP(141)**2)
20367 ELSEIF(ISUB.EQ.373) THEN
20371 CAB2=(1D0-PARP(141)**2)**2
20373 ELSEIF(ISUB.EQ.374) THEN
20379 ELSEIF(ISUB.EQ.375) THEN
20383 VRGP=-QUPD*CSXI*TANW
20384 ARGP=CSXI/(2D0*SQRT(PARU(102)*(1D0-PARU(102))))
20386 ELSEIF(ISUB.EQ.376) THEN
20391 ARGP=-CSXI/(2D0*SQRT(PARU(102)))
20393 ELSEIF(ISUB.EQ.377) THEN
20398 VRGP=CSXIP/(2D0*SQRT(PARU(102)))
20403 C...Read kinematical variables and limits
20421 C...Derive kinematical quantities
20423 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
20424 X(1)=SQRT(TAUE)*EXP(YST)
20425 X(2)=SQRT(TAUE)*EXP(-YST)
20426 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
20427 IF(X(1).GT.1D0-1D-7) RETURN
20428 ELSEIF(MINT(45).EQ.3) THEN
20429 X(1)=MIN(1D0-1.1D-10,X(1))
20431 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
20432 IF(X(2).GT.1D0-1D-7) RETURN
20433 ELSEIF(MINT(46).EQ.3) THEN
20434 X(2)=MIN(1D0-1.1D-10,X(2))
20436 SH=MAX(1D0,TAU*VINT(2))
20441 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
20442 RPTS=4D0*VINT(71)**2/SH
20443 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
20444 RM34=MAX(1D-20,2D0*RM3*RM4)
20446 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
20447 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
20448 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
20449 IF(ISTSB.EQ.0) THEN
20451 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
20452 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
20454 C...Kinematics with incoming masses tricky: now depends on how
20455 C...subprocess has been set up w.r.t. order of incoming partons.
20457 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
20459 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
20460 IF(ISUB.EQ.35) THEN
20464 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
20465 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
20466 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
20468 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
20470 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
20477 C...Choice of Q2 scale: hard, parton distributions, parton showers
20478 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
20480 ELSEIF(ISTSB.EQ.8) THEN
20481 IF(MINT(107).EQ.4) Q2=VINT(307)
20482 IF(MINT(108).EQ.4) Q2=VINT(308)
20483 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
20485 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
20487 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
20488 IF(MSTP(32).EQ.1) THEN
20489 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
20490 ELSEIF(MSTP(32).EQ.2) THEN
20491 Q2=SQPTH+0.5D0*(SQM3+SQM4)
20492 ELSEIF(MSTP(32).EQ.3) THEN
20494 ELSEIF(MSTP(32).EQ.4) THEN
20496 ELSEIF(MSTP(32).EQ.5) THEN
20498 ELSEIF(MSTP(32).EQ.6) THEN
20500 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
20502 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
20503 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
20504 & (SQPTH+0.5D0*(SQM3+SQM4))
20505 ELSEIF(MSTP(32).EQ.7) THEN
20506 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
20507 ELSEIF(MSTP(32).EQ.8) THEN
20508 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
20509 ELSEIF(MSTP(32).EQ.9) THEN
20510 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
20511 ELSEIF(MSTP(32).EQ.10) THEN
20514 IF(ISTSB.EQ.9) Q2=SQPTH
20515 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
20516 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
20519 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20521 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
20522 & ISUB.EQ.351) Q2SF=PMAS(24,1)**2
20523 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
20524 IF(ISUB.EQ.121.OR.ISUB.EQ.122) THEN
20525 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
20526 IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
20527 IF(MSTP(39).EQ.3) Q2SF=SH
20528 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
20529 IF(MSTP(39).EQ.5) Q2SF=PMAS(KFHIGG,1)**2
20534 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
20535 IF(MSTP(69).GE.2) Q2SF=VINT(2)
20536 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
20537 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20539 IF(MINT(43).EQ.3) XBJ=X(1)
20540 IF(MSTP(22).EQ.1) THEN
20542 ELSEIF(MSTP(22).EQ.2) THEN
20543 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
20544 ELSEIF(MSTP(22).EQ.3) THEN
20545 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
20547 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
20550 IF(MSTP(68).EQ.1.AND.(ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.
20551 &ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
20552 &ISUBSV.EQ.144.OR.ISUBSV.EQ.152.OR.ISUBSV.EQ.157)) THEN
20554 ELSEIF(MSTP(68).GE.2.AND.(ISUBSV.NE.11.AND.ISUBSV.NE.12.AND.
20555 &ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.ISUBSV.NE.53.AND.
20556 &ISUBSV.NE.68)) THEN
20560 C...Store derived kinematical quantities
20567 IF(ISTSB.NE.8) VINT(48)=SQPTH
20568 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
20569 VINT(50)=TAUP*VINT(2)
20570 VINT(49)=SQRT(MAX(0D0,VINT(50)))
20574 VINT(53)=SQRT(Q2SF)
20576 VINT(55)=SQRT(Q2PS)
20578 C...Calculate parton distributions
20579 IF(ISTSB.LE.0) GOTO 160
20580 IF(MINT(47).GE.2) THEN
20581 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
20583 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
20584 IF(ISUB.EQ.99) THEN
20585 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
20588 MINT(105)=MINT(102+I)
20589 MINT(109)=MINT(106+I)
20590 VINT(120)=VINT(2+I)
20592 C.... Store side in MINT(124)
20595 IF(MSTP(57).LE.1) THEN
20596 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
20598 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
20601 XSFX(I,KFL)=XPQ(KFL)
20606 C...Calculate alpha_em, alpha_strong and K-factor
20609 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
20610 &1D0-(PMAS(24,1)/PMAS(23,1))**2
20612 XWC=1D0/(16D0*XW*XW1)
20614 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
20615 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
20618 IF(MSTP(33).EQ.1) THEN
20620 ELSEIF(MSTP(33).EQ.2) THEN
20622 FACA=PARP(32)/PARP(31)
20623 ELSEIF(MSTP(33).EQ.3) THEN
20625 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
20626 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
20633 C...Set flags for allowed reacting partons/leptons
20638 IF(MINT(44+I).EQ.1) THEN
20639 KFAC(I,MINT(10+I))=1
20640 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
20641 KFAC(I,MINT(10+I))=1
20647 KFAC(I,J)=KFIN(I,J)
20648 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
20649 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
20654 C...Lower and upper limit for fermion flavour loops
20660 IF(KFAC(1,-J).EQ.1) MMIN1=-J
20661 IF(KFAC(1,J).EQ.1) MMAX1=J
20662 IF(KFAC(2,-J).EQ.1) MMIN2=-J
20663 IF(KFAC(2,J).EQ.1) MMAX2=J
20665 MMINA=MIN(MMIN1,MMIN2)
20666 MMAXA=MAX(MMAX1,MMAX2)
20668 C...Common resonance mass and width combinations
20671 SQMH=PMAS(KFHIGG,1)**2
20672 GMMZ=PMAS(23,1)*PMAS(23,2)
20673 GMMW=PMAS(24,1)*PMAS(24,2)
20674 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
20679 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
20681 C...Polarization factors...implemented so far for W+W-(25)
20682 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
20683 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
20684 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
20685 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
20687 C...Phase space integral in tau
20688 COMFAC=PARU(1)*PARU(5)/VINT(2)
20689 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
20690 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
20691 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
20692 ATAU1=LOG(TAUMAX/TAUMIN)
20693 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
20694 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
20695 IF(MINT(72).GE.1) THEN
20698 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
20700 IF(ATAUD.GT.1D-10) H1=H1+
20701 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
20702 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
20704 IF(ATAUD.GT.1D-10) H1=H1+
20705 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
20707 IF(MINT(72).EQ.2) THEN
20710 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
20712 IF(ATAUD.GT.1D-10) H1=H1+
20713 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
20714 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
20716 IF(ATAUD.GT.1D-10) H1=H1+
20717 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
20719 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20720 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
20721 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20722 & MAX(2D-10,1D0-TAU)
20723 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20724 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
20725 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20726 & MAX(1D-10,1D0-TAU)
20728 COMFAC=COMFAC*ATAU1/(TAU*H1)
20731 C...Phase space integral in y*
20732 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
20734 AYST0=YSTMAX-YSTMIN
20735 IF(AYST0.LT.1D-10) THEN
20738 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20740 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20741 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20742 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20743 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20744 IF(MINT(45).EQ.3) THEN
20745 YST0=-0.5D0*LOG(TAUE)
20746 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
20747 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
20748 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
20749 & MAX(1D-10,1D0-EXP(YST-YST0))
20751 IF(MINT(46).EQ.3) THEN
20752 YST0=-0.5D0*LOG(TAUE)
20753 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
20754 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
20755 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
20756 & MAX(1D-10,1D0-EXP(-YST-YST0))
20758 COMFAC=COMFAC*AYST0/H2
20762 C...2 -> 1 processes: reduction in angular part of phase space integral
20763 C...for case of decaying resonance
20764 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
20765 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
20766 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
20767 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
20768 & KFPR(ISUB,1).EQ.39) THEN
20769 COMFAC=COMFAC*0.5D0*ACTH0
20771 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
20772 & CTPMAX**3-CTPMIN**3)
20776 C...2 -> 2 processes: angular part of phase space integral
20777 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
20778 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
20779 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
20780 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
20781 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
20782 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
20783 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
20784 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
20785 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
20786 H3=COEF(ISUBSV,13)+
20787 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
20788 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
20789 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
20790 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
20791 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
20793 C...2 -> 2 processes: take into account final state Breit-Wigners
20794 COMFAC=COMFAC*VINT(80)
20797 C...2 -> 3, 4 processes: phace space integral in tau'
20798 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20799 ATAUP1=LOG(TAUPMX/TAUPMN)
20800 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
20801 H4=COEF(ISUBSV,18)+
20802 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
20803 IF(MINT(47).EQ.5) THEN
20804 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
20805 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
20806 ELSEIF(MINT(47).GE.6) THEN
20807 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
20808 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
20810 COMFAC=COMFAC*ATAUP1/H4
20813 C...2 -> 3, 4 processes: effective W/Z parton distributions
20814 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
20815 IF(1D0-TAU/TAUP.GT.1D-4) THEN
20816 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
20818 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
20823 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
20824 IF(ISTSB.EQ.5) THEN
20825 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
20826 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
20829 C...Phase space integral for low-pT and multiple interactions
20830 IF(ISTSB.EQ.9) THEN
20831 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
20832 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
20833 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
20834 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
20835 COMFAC=COMFAC*ATAU1/H1
20836 AYST0=YSTMAX-YSTMIN
20837 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20838 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20839 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20840 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20841 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20842 COMFAC=COMFAC*AYST0/H2
20843 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
20844 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
20845 C...introduced to make cross-section finite for xT2 -> 0
20846 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
20850 C...Real gamma + gamma: include factor 2 when different nature
20851 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
20852 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
20854 C...Extra factors to include the effects of
20855 C...longitudinal resolved photons (but not direct or DIS ones).
20857 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
20858 & MINT(106+ISDE).LE.3) THEN
20861 IF(MSTP(16).EQ.0) THEN
20862 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
20863 & XY=VINT(304+ISDE)
20865 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
20866 & XY=VINT(308+ISDE)
20868 Q2GA=VINT(306+ISDE)
20869 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
20870 & Q2GA.GT.0D0) THEN
20872 IF(MSTP(17).EQ.1) THEN
20873 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
20874 ELSEIF(MSTP(17).EQ.2) THEN
20875 REDUCE=4D0*Q2GA/(Q2+Q2GA)
20876 ELSEIF(MSTP(17).EQ.3) THEN
20877 PMVIRT=PMAS(PYCOMP(113),1)
20878 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20879 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
20880 PMVIRT=PMAS(PYCOMP(113),1)
20881 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20882 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
20883 PMVIRT=PMAS(PYCOMP(113),1)
20884 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20885 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
20886 PMVSMN=4D0*PARP(15)**2
20887 PMVSMX=4D0*VINT(154)**2
20888 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20889 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
20890 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
20891 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
20892 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
20893 PMVIRT=PMAS(PYCOMP(113),1)
20894 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20895 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
20896 PMVIRT=PMAS(PYCOMP(113),1)
20897 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20898 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
20899 PMVSMN=4D0*PARP(15)**2
20900 PMVSMX=4D0*VINT(154)**2
20901 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20902 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
20903 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
20906 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
20907 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
20908 & (1D0-2D0*BEAMAS**2/Q2GA))
20909 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
20914 COMFAC=COMFAC*VINT(314+ISDE)
20917 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
20918 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
20919 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
20920 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
20921 IF(MSTP(46).LE.4) THEN
20922 HDTLH=LOG(PMAS(25,1)/PARP(44))
20923 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
20924 HDTNR=-1D0/18D0+HDTLH/6D0
20926 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
20927 HDTLQ=LOG(PARP(45)/PARP(44))
20928 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
20929 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
20932 C...Calculate lowest and next-to-lowest order partial wave amplitudes
20933 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
20937 HDTLS=LOG(SH/PARP(44)**2)
20938 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
20939 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
20940 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
20941 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
20942 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
20943 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
20944 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
20945 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
20947 C...Unitarize partial wave amplitudes with Pade or K-matrix method
20948 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
20949 A00U=A00L/(1D0-A004/A00L)
20950 A20U=A20L/(1D0-A204/A20L)
20951 A11U=A11L/(1D0-A114/A11L)
20953 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
20954 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
20955 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
20959 C...Supersymmetric processes - all of type 2 -> 2 :
20960 C...correct final-state Breit-Wigners from fixed to running width.
20961 IF(ISUB.GE.200.AND.ISUB.LE.301.AND.MSTP(42).GT.0) THEN
20963 KFLW=KFPR(ISUBSV,I)
20965 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 180
20966 IF(I.EQ.1) SQMI=SQM3
20967 IF(I.EQ.2) SQMI=SQM4
20968 SQMS=PMAS(KCW,1)**2
20969 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
20970 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
20971 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
20972 GMMI=SQRT(SQMI)*WDTP(0)
20973 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
20974 COMFAC=COMFAC*(HBWI/HBWS)
20978 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
20979 IF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.
20980 $ISUB.EQ.68.OR.ISUB.EQ.81.OR.ISUB.EQ.82) THEN
20981 IF(MSTP(5).LE.4) THEN
20999 ELSEIF(MSTP(5).EQ.5) THEN
21000 TANT3=ABS(PARP(155))
21001 IF(PARP(155).GT.0) THEN
21006 ALPRHT=2.91D0*(3D0/PARP(144))
21007 SIN2T=2D0*TANT3/(TANT3**2+1D0)
21008 SINT3=TANT3/SQRT(TANT3**2+1D0)
21009 XIG=SQRT(PYALPS(SH)/ALPRHT)
21010 X12=(1D0/SQRT(2D0)*1D0/SQRT(2D0)+
21011 & 1D0/SQRT(2D0)*1D0/SQRT(2D0))/SQRT(2D0)/SIN2T
21013 X11=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2+2D0)-
21014 & SINT3**2)*2D0/SIN2T
21015 X22=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2)-
21016 & SINT3**2)*2D0/SIN2T
21017 IF(PARP(156).GT.0.5D0) THEN
21026 X11=(1D0-SINT3**2)*2D0/SIN2T
21027 X22=-SINT3**2*2D0/SIN2T
21038 ZTC(1,1)=DCMPLX(SH,0D0)
21039 CALL PYWIDT(3100021,SH,WDTP,WDTE)
21040 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
21041 CALL PYWIDT(3100113,SH,WDTP,WDTE)
21042 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
21043 CALL PYWIDT(3400113,SH,WDTP,WDTE)
21044 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
21045 CALL PYWIDT(3200113,SH,WDTP,WDTE)
21046 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
21047 CALL PYWIDT(3300113,SH,WDTP,WDTE)
21048 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
21050 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
21054 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
21055 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
21056 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
21057 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
21071 CALL PYLDCM(ZTC,6,6,INDX,D)
21075 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
21080 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
21085 XIG=SQRT(PYALPS(-TH)/ALPRHT)
21087 ZTC(1,1)=DCMPLX(TH)
21088 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
21089 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
21090 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
21091 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
21092 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
21094 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
21098 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
21099 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
21100 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
21101 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
21113 CALL PYLDCM(ZTC,6,6,INDX,D)
21117 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
21121 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
21126 XIG=SQRT(PYALPS(-UH)/ALPRHT)
21128 ZTC(1,1)=DCMPLX(UH,0D0)
21129 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
21130 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
21131 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
21132 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
21133 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
21135 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
21139 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
21140 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
21141 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
21142 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
21154 CALL PYLDCM(ZTC,6,6,INDX,D)
21158 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
21162 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
21168 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)
21169 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)
21170 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)
21173 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)
21174 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)
21175 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)
21176 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)
21179 SQDQTS=ABS(DQTS)**2
21180 SQDQQS=ABS(DQQS)**2
21181 SQDQQT=ABS(DQQT)**2
21182 SQDQQU=ABS(DQQU)**2
21183 SQDLGS=ABS(DCMPLX(SH)*DGGS-DCMPLX(1D0))**2
21184 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
21186 SQDGGS=ABS(DGGS)**2
21187 SQDGGT=ABS(DGGT)**2
21188 SQDGGU=ABS(DGGU)**2
21192 REDGTU=DBLE(DGGU*DCONJG(DGGT))
21193 REDGSU=DBLE(DGGU*DCONJG(DGGS))
21194 REDGST=DBLE(DGGS*DCONJG(DGGT))
21195 REDQST=DBLE(DQQS*DCONJG(DQQT))
21196 REDQTU=DBLE(DQQT*DCONJG(DQQU))
21200 C...A: 2 -> 1, tree diagrams
21202 IF(ISUB.LE.10) THEN
21204 C...f + fbar -> gamma*/Z0
21206 CALL PYWIDT(23,SH,WDTP,WDTE)
21208 FACZ=4D0*COMFAC*3D0
21211 DO 340 I=MMINA,MMAXA
21212 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 340
21213 EI=KCHG(IABS(I),1)/3D0
21217 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
21219 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
21224 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
21225 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
21226 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
21227 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
21230 ELSEIF(ISUB.EQ.2) THEN
21231 C...f + fbar' -> W+/-
21232 CALL PYWIDT(24,SH,WDTP,WDTE)
21234 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
21235 HP=AEM/(24D0*XW)*SH
21236 DO 360 I=MMIN1,MMAX1
21237 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 360
21239 DO 350 J=MMIN2,MMAX2
21240 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 350
21242 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 350
21243 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
21245 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
21247 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
21252 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
21253 SIGH(NCHN)=HI*FACBW*HF
21257 ELSEIF(ISUB.EQ.3) THEN
21258 C...f + fbar -> h0 (or H0, or A0)
21259 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
21261 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
21262 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
21264 HP=AEM/(8D0*XW)*SH/SQMW*SH
21265 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21266 DO 370 I=MMINA,MMAXA
21267 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
21269 RMQ=PYMRUN(IA,SH)**2/SH
21271 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
21272 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
21274 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
21275 IF(IA.GT.10) IKFI=3
21276 HI=HI*PARU(150+10*IHIGG+IKFI)**2
21277 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
21278 HI=HI/(1D0+RMSS(41))**2
21279 IF(IHIGG.NE.3) THEN
21280 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
21281 & PARU(151+10*IHIGG))**2
21289 SIGH(NCHN)=HI*FACBW*HF
21292 ELSEIF(ISUB.EQ.4) THEN
21293 C...gamma + W+/- -> W+/-
21295 ELSEIF(ISUB.EQ.5) THEN
21297 CALL PYWIDT(25,SH,WDTP,WDTE)
21299 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
21300 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
21301 HP=AEM/(8D0*XW)*SH/SQMW*SH
21302 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21304 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
21305 DO 390 I=MMIN1,MMAX1
21306 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 390
21307 DO 380 J=MMIN2,MMAX2
21308 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 380
21309 EI=KCHG(IABS(I),1)/3D0
21312 EJ=KCHG(IABS(J),1)/3D0
21319 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
21323 ELSEIF(ISUB.EQ.6) THEN
21324 C...Z0 + W+/- -> W+/-
21326 ELSEIF(ISUB.EQ.7) THEN
21329 ELSEIF(ISUB.EQ.8) THEN
21331 CALL PYWIDT(25,SH,WDTP,WDTE)
21333 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
21334 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
21335 HP=AEM/(8D0*XW)*SH/SQMW*SH
21336 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21338 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
21339 DO 410 I=MMIN1,MMAX1
21340 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
21341 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
21342 DO 400 J=MMIN2,MMAX2
21343 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
21344 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
21345 IF(EI*EJ.GT.0D0) GOTO 400
21350 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
21354 C...B: 2 -> 2, tree diagrams
21356 ELSEIF(ISUB.EQ.10) THEN
21357 C...f + f' -> f + f' (gamma/Z/W exchange)
21358 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
21359 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
21360 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
21361 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
21362 DO 430 I=MMIN1,MMAX1
21363 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 430
21365 DO 420 J=MMIN2,MMAX2
21366 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 420
21368 C...Electroweak couplings
21369 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
21370 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
21372 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
21373 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
21376 C...gamma/Z exchange, only gamma exchange, or only Z exchange
21377 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
21378 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
21379 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
21380 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
21381 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
21382 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21383 ELSEIF(MSTP(21).EQ.2) THEN
21384 FACNCF=FACGGF*EI**2*EJ**2
21386 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
21387 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21389 C...Extrafactor 2 for only one incoming neutrino spin state.
21390 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
21391 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
21399 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
21400 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
21401 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
21402 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
21403 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
21414 ELSEIF(ISUB.LE.20) THEN
21415 IF(ISUB.EQ.11) THEN
21416 C...f + f' -> f + f' (g exchange)
21417 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
21418 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
21419 & MSTP(34)*2D0/3D0*UH2*REDQST)
21420 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
21421 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
21422 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
21423 IF(MSTP(5).GE.1.AND.MSTP(5).LE.4) THEN
21424 C...Modifications from contact interactions (compositeness)
21425 FACCI1=FACQQ1+COMFAC*(SH2/PARU(155)**4)
21426 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
21427 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/PARU(155)**4)
21428 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
21429 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/PARU(155)**4)
21430 FACCI3=FACQQ1+COMFAC*(UH2/PARU(155)**4)
21431 RATCII=(FACCI1*FACCI2+FACQQI)/(FACCI1+FACCI2)
21432 ELSEIF(MSTP(5).EQ.5) THEN
21439 DO 450 I=MMIN1,MMAX1
21441 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
21442 DO 440 J=MMIN2,MMAX2
21444 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
21449 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.(IA.GE.3.OR.
21452 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
21455 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
21456 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
21463 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IA.GE.3)) THEN
21464 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
21465 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
21467 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
21468 SIGH(NCHN)=0.5D0*FACCI2*RATCII
21474 ELSEIF(ISUB.EQ.12) THEN
21475 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
21476 CALL PYWIDT(21,SH,WDTP,WDTE)
21477 C.........Do not use for b bbar in Standard TC2
21478 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)*SQDQQS*
21479 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21480 IF(MSTP(5).EQ.1) THEN
21481 C...Modifications from contact interactions (compositeness)
21484 FACCIB=FACCIB+COMFAC*(UH2/PARU(155)**4)*(WDTE(I,1)+
21485 & WDTE(I,2)+WDTE(I,4))
21487 ELSEIF(MSTP(5).GE.2.AND.MSTP(5).LE.4) THEN
21488 FACCIB=FACQQB+COMFAC*(UH2/PARU(155)**4)*
21489 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21491 DO 470 I=MMINA,MMAXA
21492 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21493 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
21498 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IABS(I).GE.3)) THEN
21505 ELSEIF(ISUB.EQ.13) THEN
21506 C...f + fbar -> g + g (q + qbar -> g + g only)
21507 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21508 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
21509 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21510 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
21511 DO 480 I=MMINA,MMAXA
21512 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21513 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 480
21518 SIGH(NCHN)=0.5D0*FACGG1
21523 SIGH(NCHN)=0.5D0*FACGG2
21526 ELSEIF(ISUB.EQ.14) THEN
21527 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
21528 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
21529 DO 490 I=MMINA,MMAXA
21530 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21531 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 490
21532 EI=KCHG(IABS(I),1)/3D0
21537 SIGH(NCHN)=FACGG*EI**2
21540 ELSEIF(ISUB.EQ.15) THEN
21541 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
21542 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
21543 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
21547 RADC4=1D0+PYALPS(SQM4)/PARU(1)
21548 DO 500 I=1,MIN(16,MDCY(23,3))
21550 IF(MDME(IDC,1).LT.0) GOTO 500
21552 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
21556 AF=SIGN(1D0,EF+0.1D0)
21558 ELSEIF(I.LE.16) THEN
21560 AF=SIGN(1D0,EF+0.1D0)
21563 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
21564 IF(4D0*RM1.LT.1D0) THEN
21566 IF(I.LE.8) FCOF=3D0*RADC4
21567 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
21569 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
21570 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
21571 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
21572 & AF**2*(1D0-4D0*RM1))*BE34
21576 C...Propagators: as simulated in PYOFSH and as desired
21577 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
21581 CALL PYWIDT(23,SQM4,WDTP,WDTE)
21583 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
21584 HFGG=HFGG*HFAEM*VINT(111)/SQM4
21585 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
21586 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
21587 C...Loop over flavours; consider full gamma/Z structure
21588 DO 510 I=MMINA,MMAXA
21589 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21590 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 510
21591 EI=KCHG(IABS(I),1)/3D0
21598 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
21599 & (VI**2+AI**2)*HFZZ)/HBW4
21602 ELSEIF(ISUB.EQ.16) THEN
21603 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
21604 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
21605 C...Propagators: as simulated in PYOFSH and as desired
21606 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
21607 CALL PYWIDT(24,SQM4,WDTP,WDTE)
21608 GMMWC=SQRT(SQM4)*WDTP(0)
21609 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
21610 FACWG=FACWG*HBW4C/HBW4
21611 DO 530 I=MMIN1,MMAX1
21613 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 530
21614 DO 520 J=MMIN2,MMAX2
21616 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 520
21617 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 520
21618 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
21619 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
21620 FCKM=VCKM((IA+1)/2,(JA+1)/2)
21625 SIGH(NCHN)=FACWG*FCKM*WIDSC
21629 ELSEIF(ISUB.EQ.17) THEN
21630 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
21632 ELSEIF(ISUB.EQ.18) THEN
21633 C...f + fbar -> gamma + gamma
21634 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
21635 DO 540 I=MMINA,MMAXA
21636 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 540
21637 EI=KCHG(IABS(I),1)/3D0
21639 IF(IABS(I).LE.10) FCOI=FACA/3D0
21644 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
21647 ELSEIF(ISUB.EQ.19) THEN
21648 C...f + fbar -> gamma + (gamma*/Z0)
21649 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
21650 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
21654 RADC4=1D0+PYALPS(SQM4)/PARU(1)
21655 DO 550 I=1,MIN(16,MDCY(23,3))
21657 IF(MDME(IDC,1).LT.0) GOTO 550
21659 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
21663 AF=SIGN(1D0,EF+0.1D0)
21665 ELSEIF(I.LE.16) THEN
21667 AF=SIGN(1D0,EF+0.1D0)
21670 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
21671 IF(4D0*RM1.LT.1D0) THEN
21673 IF(I.LE.8) FCOF=3D0*RADC4
21674 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
21676 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
21677 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
21678 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
21679 & AF**2*(1D0-4D0*RM1))*BE34
21683 C...Propagators: as simulated in PYOFSH and as desired
21684 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
21688 CALL PYWIDT(23,SQM4,WDTP,WDTE)
21690 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
21691 HFGG=HFGG*HFAEM*VINT(111)/SQM4
21692 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
21693 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
21694 C...Loop over flavours; consider full gamma/Z structure
21695 DO 560 I=MMINA,MMAXA
21696 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 560
21697 EI=KCHG(IABS(I),1)/3D0
21701 IF(IABS(I).LE.10) FCOI=FACA/3D0
21706 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
21707 & (VI**2+AI**2)*HFZZ)/HBW4
21710 ELSEIF(ISUB.EQ.20) THEN
21711 C...f + fbar' -> gamma + W+/-
21712 FACGW=COMFAC*0.5D0*AEM**2/XW
21713 C...Propagators: as simulated in PYOFSH and as desired
21714 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
21715 CALL PYWIDT(24,SQM4,WDTP,WDTE)
21716 GMMWC=SQRT(SQM4)*WDTP(0)
21717 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
21718 FACGW=FACGW*HBW4C/HBW4
21719 C...Anomalous couplings
21720 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
21723 IF(MSTP(5).GE.1.AND.MSTP(5).LE.4) THEN
21724 TERM2=PARU(153)*(TH-UH)/(TH+UH)
21725 TERM3=0.5D0*PARU(153)**2*(TH*UH+(TH2+UH2)*SH/
21726 & (4D0*SQMW))/(TH+UH)**2
21728 DO 580 I=MMIN1,MMAX1
21730 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 580
21731 DO 570 J=MMIN2,MMAX2
21733 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 570
21734 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 570
21735 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
21737 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
21738 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
21740 FACWR=UH/(TH+UH)-1D0/3D0
21741 FCKM=VCKM((IA+1)/2,(JA+1)/2)
21748 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
21753 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
21758 ELSEIF(ISUB.LE.30) THEN
21759 IF(ISUB.EQ.21) THEN
21760 C...f + fbar -> gamma + h0
21762 ELSEIF(ISUB.EQ.22) THEN
21763 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
21764 C...Kinematics dependence
21765 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
21766 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
21767 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
21773 RADC3=1D0+PYALPS(SQM3)/PARU(1)
21774 RADC4=1D0+PYALPS(SQM4)/PARU(1)
21775 DO 610 I=1,MIN(16,MDCY(23,3))
21777 IF(MDME(IDC,1).LT.0) GOTO 610
21779 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
21780 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
21783 AF=SIGN(1D0,EF+0.1D0)
21785 ELSEIF(I.LE.16) THEN
21787 AF=SIGN(1D0,EF+0.1D0)
21790 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
21791 IF(4D0*RM1.LT.1D0) THEN
21793 IF(I.LE.8) FCOF=3D0*RADC3
21794 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
21796 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
21797 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
21798 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
21799 & AF**2*(1D0-4D0*RM1))*BE34
21802 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
21803 IF(4D0*RM1.LT.1D0) THEN
21805 IF(I.LE.8) FCOF=3D0*RADC4
21806 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
21808 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
21809 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
21810 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
21811 & AF**2*(1D0-4D0*RM1))*BE34
21815 C...Propagators: as simulated in PYOFSH and as desired
21816 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
21817 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
21821 CALL PYWIDT(23,SQM3,WDTP,WDTE)
21823 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
21825 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
21826 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
21827 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
21832 CALL PYWIDT(23,SQM4,WDTP,WDTE)
21834 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
21836 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
21837 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
21838 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
21840 C...Loop over flavours; separate left- and right-handed couplings
21841 DO 650 I=MMINA,MMAXA
21842 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 650
21843 EI=KCHG(IABS(I),1)/3D0
21849 IF(IABS(I).LE.10) FCOI=FACA/3D0
21851 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
21852 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
21853 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
21854 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
21856 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
21857 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
21858 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
21859 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
21864 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
21867 ELSEIF(ISUB.EQ.23) THEN
21868 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
21869 FACZW=COMFAC*0.5D0*(AEM/XW)**2
21870 FACZW=FACZW*WIDS(23,2)
21871 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
21872 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
21873 DO 670 I=MMIN1,MMAX1
21875 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 670
21876 DO 660 J=MMIN2,MMAX2
21878 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 660
21879 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 660
21880 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
21882 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
21884 AI=SIGN(1D0,EI+0.1D0)
21887 AJ=SIGN(1D0,EJ+0.1D0)
21889 IF(VI+AI.GT.0) THEN
21898 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
21900 IF(IA.LE.10) FCOI=FACA/3D0
21905 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
21906 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
21907 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
21908 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
21909 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
21910 & WIDS(24,(5-KCHW)/2)
21911 C***Protect against slightly negative cross sections. (Reason yet to be
21912 C***sorted out. One possibility: addition of width to the W propagator.)
21913 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
21917 ELSEIF(ISUB.EQ.24) THEN
21918 C...f + fbar -> Z0 + h0 (or H0, or A0)
21919 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
21920 FACHZ=COMFAC*8D0*(AEM*XWC)**2*
21921 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
21922 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
21923 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
21924 & PARU(154+10*IHIGG)**2
21925 DO 680 I=MMINA,MMAXA
21926 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 680
21927 EI=KCHG(IABS(I),1)/3D0
21931 IF(IABS(I).LE.10) FCOI=FACA/3D0
21936 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
21939 ELSEIF(ISUB.EQ.25) THEN
21940 C...f + fbar -> W+ + W-
21941 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
21943 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
21944 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
21945 CALL PYWIDT(24,SQM3,WDTP,WDTE)
21946 GMMW3=SQRT(SQM3)*WDTP(0)
21947 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
21948 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
21949 CALL PYWIDT(24,SQM4,WDTP,WDTE)
21950 GMMW4=SQRT(SQM4)*WDTP(0)
21951 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
21952 C...Kinematical functions
21953 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
21954 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
21955 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
21956 GT=THUH34+4D0*THUH/TH2
21957 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
21958 GU=THUH34+4D0*THUH/UH2
21959 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
21960 C...Common factors and couplings
21961 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
21962 FACWW=FACWW*WIDS(24,1)
21964 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
21965 CZZ=AEM**2/(32D0*XW**2)*HBWZC
21966 CNG=AEM**2/(4D0*XW)
21967 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
21968 CNN=AEM**2/(16D0*XW**2)
21969 C...Coulomb factor for W+W- pair
21970 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
21971 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
21972 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
21973 IF(COULE.LT.100D0*PMAS(24,2)) THEN
21974 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
21975 & PMAS(24,2)**2)-COULE))
21977 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
21979 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
21980 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
21981 & PMAS(24,2)**2)+COULE))
21983 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
21986 IF(MSTP(40).EQ.1) THEN
21987 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
21988 & MAX(1D-10,2D0*COULP*COULP1))
21989 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
21990 ELSEIF(MSTP(40).EQ.2) THEN
21991 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
21992 COULCP=DCMPLX(0D0,DBLE(COULP))
21993 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
21994 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
21995 & (4D0*COULCP)*LOG(COULCD)
21996 COULCS=DCMPLX(0D0,0D0)
21999 COULXX=(ISTP-0.5)/NSTP
22000 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
22001 & (1D0+COULXX/COULCD))
22003 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
22005 FACCOU=ABS(COULCR)**2
22006 ELSEIF(MSTP(40).EQ.3) THEN
22007 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
22008 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
22009 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
22011 ELSEIF(MSTP(40).EQ.4) THEN
22012 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
22018 C...Loop over allowed flavours
22019 DO 700 I=MMINA,MMAXA
22020 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 700
22021 EI=KCHG(IABS(I),1)/3D0
22022 AI=SIGN(1D0,EI+0.1D0)
22025 IF(IABS(I).LE.10) FCOI=FACA/3D0
22026 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
22028 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
22029 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
22031 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
22032 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
22035 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22036 BET=SQRT(1D0-4D0*XMW02/SH)
22037 GAT=1D0/SQRT(1D0-BET**2)
22039 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
22040 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
22041 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
22042 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
22043 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
22044 & (1D0-2D0*BET*CTH+BET**2))
22045 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
22046 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
22047 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
22048 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
22049 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
22050 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
22051 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
22058 SIGH(NCHN)=FACWW*FCOI*DSIGWW
22061 ELSEIF(ISUB.EQ.26) THEN
22062 C...f + fbar' -> W+/- + h0 (or H0, or A0)
22063 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
22064 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
22065 & ((SH-SQMW)**2+GMMW**2)
22066 FACHW=FACHW*WIDS(KFHIGG,2)
22067 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
22068 & PARU(155+10*IHIGG)**2
22069 DO 720 I=MMIN1,MMAX1
22071 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 720
22072 DO 710 J=MMIN2,MMAX2
22074 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 710
22075 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 710
22076 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22078 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22080 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
22082 IF(IA.LE.10) FCOI=FACA/3D0
22087 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
22091 ELSEIF(ISUB.EQ.27) THEN
22092 C...f + fbar -> h0 + h0
22094 ELSEIF(ISUB.EQ.28) THEN
22095 C...f + g -> f + g (q + g -> q + g only)
22096 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
22097 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
22098 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
22099 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
22100 DO 740 I=MMINA,MMAXA
22101 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 740
22103 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 730
22104 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 730
22107 ISIG(NCHN,3-ISDE)=21
22112 ISIG(NCHN,3-ISDE)=21
22118 ELSEIF(ISUB.EQ.29) THEN
22119 C...f + g -> f + gamma (q + g -> q + gamma only)
22120 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
22121 DO 760 I=MMINA,MMAXA
22122 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 760
22123 EI=KCHG(IABS(I),1)/3D0
22126 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 750
22127 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 750
22130 ISIG(NCHN,3-ISDE)=21
22136 ELSEIF(ISUB.EQ.30) THEN
22137 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
22138 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
22140 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22144 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22145 DO 770 I=1,MIN(16,MDCY(23,3))
22147 IF(MDME(IDC,1).LT.0) GOTO 770
22149 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22153 AF=SIGN(1D0,EF+0.1D0)
22155 ELSEIF(I.LE.16) THEN
22157 AF=SIGN(1D0,EF+0.1D0)
22160 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22161 IF(4D0*RM1.LT.1D0) THEN
22163 IF(I.LE.8) FCOF=3D0*RADC4
22164 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22166 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22167 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22168 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22169 & AF**2*(1D0-4D0*RM1))*BE34
22173 C...Propagators: as simulated in PYOFSH and as desired
22174 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22178 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22180 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22181 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22182 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22183 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22184 C...Loop over flavours; consider full gamma/Z structure
22185 DO 790 I=MMINA,MMAXA
22186 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 790
22187 EI=KCHG(IABS(I),1)/3D0
22190 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
22191 & (VI**2+AI**2)*HFZZ)/HBW4
22193 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 780
22194 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 780
22197 ISIG(NCHN,3-ISDE)=21
22204 ELSEIF(ISUB.LE.40) THEN
22205 IF(ISUB.EQ.31) THEN
22206 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
22207 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
22208 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
22209 C...Propagators: as simulated in PYOFSH and as desired
22210 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22211 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22212 GMMWC=SQRT(SQM4)*WDTP(0)
22213 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22214 FACWQ=FACWQ*HBW4C/HBW4
22215 DO 810 I=MMINA,MMAXA
22216 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 810
22218 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22219 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22221 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 800
22222 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 800
22225 ISIG(NCHN,3-ISDE)=21
22227 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
22231 ELSEIF(ISUB.EQ.32) THEN
22232 C...f + g -> f + h0 (q + g -> q + h0 only)
22233 SQMHC=PMAS(25,1)**2
22234 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
22235 DO 830 I=MMINA,MMAXA
22237 IF(IA.NE.5) GOTO 830
22239 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
22240 & (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
22241 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
22244 FACHCQ=FHCQ*SQML/SQMW*
22245 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
22246 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
22247 & (SQMHC-SQMQ-SH)/SH)
22248 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22250 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 820
22251 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 820
22254 ISIG(NCHN,3-ISDE)=21
22256 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
22260 ELSEIF(ISUB.EQ.33) THEN
22261 C...f + gamma -> f + g (q + gamma -> q + g only)
22262 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
22263 DO 850 I=MMINA,MMAXA
22264 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 850
22265 EI=KCHG(IABS(I),1)/3D0
22268 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 840
22269 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 840
22272 ISIG(NCHN,3-ISDE)=22
22278 ELSEIF(ISUB.EQ.34) THEN
22279 C...f + gamma -> f + gamma
22280 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
22281 DO 870 I=MMINA,MMAXA
22282 IF(I.EQ.0) GOTO 870
22283 EI=KCHG(IABS(I),1)/3D0
22286 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 860
22287 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 860
22290 ISIG(NCHN,3-ISDE)=22
22296 ELSEIF(ISUB.EQ.35) THEN
22297 C...f + gamma -> f + (gamma*/Z0)
22298 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
22299 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
22300 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
22301 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
22302 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
22303 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
22305 FZQN=SH2+UH2+2D0*SQM4*TH
22308 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
22309 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22313 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22314 DO 880 I=1,MIN(16,MDCY(23,3))
22316 IF(MDME(IDC,1).LT.0) GOTO 880
22318 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22322 AF=SIGN(1D0,EF+0.1D0)
22324 ELSEIF(I.LE.16) THEN
22326 AF=SIGN(1D0,EF+0.1D0)
22329 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22330 IF(4D0*RM1.LT.1D0) THEN
22332 IF(I.LE.8) FCOF=3D0*RADC4
22333 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22335 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22336 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22337 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22338 & AF**2*(1D0-4D0*RM1))*BE34
22342 C...Propagators: as simulated in PYOFSH and as desired
22343 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22347 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22349 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22350 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22351 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22352 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22353 C...Loop over flavours; consider full gamma/Z structure
22354 DO 900 I=MMINA,MMAXA
22355 IF(I.EQ.0) GOTO 900
22356 EI=KCHG(IABS(I),1)/3D0
22359 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
22360 & (VI**2+AI**2)*HFZZ)/HBW4
22361 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
22363 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 890
22364 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 890
22367 ISIG(NCHN,3-ISDE)=22
22369 SIGH(NCHN)=FACZQ*FZQN/FZQD
22373 ELSEIF(ISUB.EQ.36) THEN
22374 C...f + gamma -> f' + W+/-
22375 FWQ=COMFAC*AEM**2/(2D0*XW)*
22376 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
22377 C...Propagators: as simulated in PYOFSH and as desired
22378 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22379 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22380 GMMWC=SQRT(SQM4)*WDTP(0)
22381 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22383 DO 920 I=MMINA,MMAXA
22384 IF(I.EQ.0) GOTO 920
22386 EIA=ABS(KCHG(IABS(I),1)/3D0)
22387 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
22388 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22389 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22391 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 910
22392 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 910
22395 ISIG(NCHN,3-ISDE)=22
22397 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
22401 ELSEIF(ISUB.EQ.37) THEN
22402 C...f + gamma -> f + h0
22404 ELSEIF(ISUB.EQ.38) THEN
22405 C...f + Z0 -> f + g (q + Z0 -> q + g only)
22407 ELSEIF(ISUB.EQ.39) THEN
22408 C...f + Z0 -> f + gamma
22410 ELSEIF(ISUB.EQ.40) THEN
22411 C...f + Z0 -> f + Z0
22414 ELSEIF(ISUB.LE.50) THEN
22415 IF(ISUB.EQ.41) THEN
22416 C...f + Z0 -> f' + W+/-
22418 ELSEIF(ISUB.EQ.42) THEN
22419 C...f + Z0 -> f + h0
22421 ELSEIF(ISUB.EQ.43) THEN
22422 C...f + W+/- -> f' + g (q + W+/- -> q' + g only)
22424 ELSEIF(ISUB.EQ.44) THEN
22425 C...f + W+/- -> f' + gamma
22427 ELSEIF(ISUB.EQ.45) THEN
22428 C...f + W+/- -> f' + Z0
22430 ELSEIF(ISUB.EQ.46) THEN
22431 C...f + W+/- -> f' + W+/-
22433 ELSEIF(ISUB.EQ.47) THEN
22434 C...f + W+/- -> f' + h0
22436 ELSEIF(ISUB.EQ.48) THEN
22437 C...f + h0 -> f + g (q + h0 -> q + g only)
22439 ELSEIF(ISUB.EQ.49) THEN
22440 C...f + h0 -> f + gamma
22442 ELSEIF(ISUB.EQ.50) THEN
22443 C...f + h0 -> f + Z0
22446 ELSEIF(ISUB.LE.60) THEN
22447 IF(ISUB.EQ.51) THEN
22448 C...f + h0 -> f' + W+/-
22450 ELSEIF(ISUB.EQ.52) THEN
22451 C...f + h0 -> f + h0
22453 ELSEIF(ISUB.EQ.53) THEN
22454 C...g + g -> f + fbar (g + g -> q + qbar only)
22455 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 940
22457 C...Begin by d, u, s flavours.
22459 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
22460 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
22461 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
22462 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
22463 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
22464 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
22465 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
22466 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
22467 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
22468 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
22479 C...Next c and b flavours: modified that and uhat for fixed
22480 C...cos(theta-hat).
22482 SQMAVG=PMAS(IFL,1)**2
22483 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
22484 BE34=SQRT(1D0-4D0*SQMAVG/SH)
22485 THQ=-0.5D0*SH*(1D0-BE34*CTH)
22486 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
22487 THUHQ=THQ*UHQ-SQMAVG*SH
22488 IF(MSTP(34).EQ.0) THEN
22489 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
22490 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
22492 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
22493 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
22494 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
22495 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
22497 IF(MSTP(5).GE.5) THEN
22498 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDGGS+
22499 & 2.25D0*THQ*UHQ/SH2*SQDLGS
22500 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDGGS+
22501 & 2.25D0*THQ*UHQ/SH2*SQDLGS
22503 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
22504 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
22508 ISIG(NCHN,3)=1+2*(IFL-3)
22513 ISIG(NCHN,3)=2+2*(IFL-3)
22519 ELSEIF(ISUB.EQ.54) THEN
22520 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
22521 CALL PYWIDT(21,SH,WDTP,WDTE)
22523 DO 950 I=1,MIN(8,MDCY(21,3))
22525 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
22528 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
22529 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
22536 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
22544 ELSEIF(ISUB.EQ.55) THEN
22545 C...g + Z -> f + fbar (g + Z -> q + qbar only)
22547 ELSEIF(ISUB.EQ.56) THEN
22548 C...g + W -> f + f'bar (g + W -> q + q'bar only)
22550 ELSEIF(ISUB.EQ.57) THEN
22551 C...g + h0 -> f + fbar (g + h0 -> q + qbar only)
22553 ELSEIF(ISUB.EQ.58) THEN
22554 C...gamma + gamma -> f + fbar
22555 CALL PYWIDT(22,SH,WDTP,WDTE)
22557 DO 960 I=1,MIN(12,MDCY(22,3))
22558 IF(I.LE.8) EF= KCHG(I,1)/3D0
22559 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
22560 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
22563 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
22564 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
22572 ELSEIF(ISUB.EQ.59) THEN
22573 C...gamma + Z0 -> f + fbar
22575 ELSEIF(ISUB.EQ.60) THEN
22576 C...gamma + W+/- -> f + fbar'
22579 ELSEIF(ISUB.LE.70) THEN
22580 IF(ISUB.EQ.61) THEN
22581 C...gamma + h0 -> f + fbar
22583 ELSEIF(ISUB.EQ.62) THEN
22584 C...Z0 + Z0 -> f + fbar
22586 ELSEIF(ISUB.EQ.63) THEN
22587 C...Z0 + W+/- -> f + fbar'
22589 ELSEIF(ISUB.EQ.64) THEN
22590 C...Z0 + h0 -> f + fbar
22592 ELSEIF(ISUB.EQ.65) THEN
22593 C...W+ + W- -> f + fbar
22595 ELSEIF(ISUB.EQ.66) THEN
22596 C...W+/- + h0 -> f + fbar'
22598 ELSEIF(ISUB.EQ.67) THEN
22599 C...h0 + h0 -> f + fbar
22601 ELSEIF(ISUB.EQ.68) THEN
22603 IF(MSTP(5).LE.4) THEN
22604 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
22605 & 2D0*TH/SH+TH2/SH2)*FACA
22606 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
22607 & 2D0*SH/UH+SH2/UH2)*FACA
22608 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
22609 & 2D0*UH/TH+UH2/TH2)
22611 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
22612 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
22613 & 4D0*REDGST*(SH + 2D0*TH)*
22614 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
22615 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
22616 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
22617 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
22618 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
22619 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
22620 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
22621 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
22622 & 4D0*REDGSU*(SH + 2D0*UH)*
22623 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
22624 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
22625 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
22626 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
22627 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
22628 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
22629 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
22630 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
22631 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
22632 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
22633 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
22634 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
22635 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
22636 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
22637 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
22638 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
22639 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
22640 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
22641 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
22642 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
22643 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
22644 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
22646 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 970
22651 SIGH(NCHN)=0.5D0*FACGG1
22656 SIGH(NCHN)=0.5D0*FACGG2
22661 SIGH(NCHN)=0.5D0*FACGG3
22664 ELSEIF(ISUB.EQ.69) THEN
22665 C...gamma + gamma -> W+ + W-
22666 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
22667 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
22668 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
22669 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
22670 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 980
22678 ELSEIF(ISUB.EQ.70) THEN
22679 C...gamma + W+/- -> Z0 + W+/-
22680 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
22681 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
22682 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
22683 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
22684 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
22685 DO 1000 KCHW=1,-1,-2
22687 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 990
22690 ISIG(NCHN,3-ISDE)=24*KCHW
22692 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
22697 ELSEIF(ISUB.LE.80) THEN
22698 IF(ISUB.EQ.71) THEN
22699 C...Z0 + Z0 -> Z0 + Z0
22700 IF(SH.LE.4.01D0*SQMZ) GOTO 1030
22702 IF(MSTP(46).LE.2) THEN
22703 C...Exact scattering ME:s for on-mass-shell gauge bosons
22704 BE2=1D0-4D0*SQMZ/SH
22705 TH=-0.5D0*SH*BE2*(1D0-CTH)
22706 UH=-0.5D0*SH*BE2*(1D0+CTH)
22707 IF(MAX(TH,UH).GT.-1D0) GOTO 1030
22708 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
22709 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
22710 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
22711 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
22712 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
22713 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
22714 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
22715 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
22716 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
22717 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
22718 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
22719 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
22720 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
22721 & (ASHIM+ATHIM+AUHIM)**2)
22722 IF(MSTP(46).EQ.2) FACZZ=0D0
22725 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
22726 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
22727 & ABS(A00U+2D0*A20U)**2
22729 FACZZ=FACZZ*WIDS(23,1)
22731 DO 1020 I=MMIN1,MMAX1
22732 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1020
22733 EI=KCHG(IABS(I),1)/3D0
22737 DO 1010 J=MMIN2,MMAX2
22738 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1010
22739 EJ=KCHG(IABS(J),1)/3D0
22747 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
22752 ELSEIF(ISUB.EQ.72) THEN
22753 C...Z0 + Z0 -> W+ + W-
22754 IF(SH.LE.4.01D0*SQMZ) GOTO 1060
22756 IF(MSTP(46).LE.2) THEN
22757 C...Exact scattering ME:s for on-mass-shell gauge bosons
22758 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
22760 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
22761 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
22762 IF(MAX(TH,UH).GT.-1D0) GOTO 1060
22763 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
22764 & (1D0-2D0*SQMZ/SH)
22765 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
22766 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
22767 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
22768 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
22769 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
22770 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
22771 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
22773 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
22774 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
22775 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
22776 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
22777 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
22779 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
22781 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
22782 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
22783 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
22784 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
22785 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
22786 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
22787 & (ATWIM+AUWIM+A4IM)**2)
22790 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
22791 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
22792 & ABS(A00U-A20U)**2
22794 FACWW=FACWW*WIDS(24,1)
22796 DO 1050 I=MMIN1,MMAX1
22797 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1050
22798 EI=KCHG(IABS(I),1)/3D0
22802 DO 1040 J=MMIN2,MMAX2
22803 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1040
22804 EJ=KCHG(IABS(J),1)/3D0
22812 SIGH(NCHN)=FACWW*AVI*AVJ
22817 ELSEIF(ISUB.EQ.73) THEN
22818 C...Z0 + W+/- -> Z0 + W+/-
22819 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 1090
22821 IF(MSTP(46).LE.2) THEN
22822 C...Exact scattering ME:s for on-mass-shell gauge bosons
22823 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
22824 EP1=1D0-(SQMZ-SQMW)/SH
22825 EP2=1D0+(SQMZ-SQMW)/SH
22826 TH=-0.5D0*SH*BE2*(1D0-CTH)
22827 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
22828 IF(MAX(TH,UH).GT.-1D0) GOTO 1090
22829 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
22830 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
22831 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
22832 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
22833 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
22834 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
22835 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
22837 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
22838 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
22839 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
22840 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
22841 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
22842 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
22843 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
22844 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
22845 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
22846 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
22847 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
22848 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
22850 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
22851 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
22853 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
22854 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
22855 IF(MSTP(46).LE.0) FACZW=0D0
22856 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
22857 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
22858 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
22859 & (ASWIM+AUWIM+A4IM)**2)
22862 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
22863 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
22864 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
22866 FACZW=FACZW*WIDS(23,2)
22868 DO 1080 I=MMIN1,MMAX1
22869 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1080
22870 EI=KCHG(IABS(I),1)/3D0
22874 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
22875 DO 1070 J=MMIN2,MMAX2
22876 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1070
22877 EJ=KCHG(IABS(J),1)/3D0
22881 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
22886 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
22891 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
22896 ELSEIF(ISUB.EQ.75) THEN
22897 C...W+ + W- -> gamma + gamma
22899 ELSEIF(ISUB.EQ.76) THEN
22900 C...W+ + W- -> Z0 + Z0
22901 IF(SH.LE.4.01D0*SQMZ) GOTO 1120
22903 IF(MSTP(46).LE.2) THEN
22904 C...Exact scattering ME:s for on-mass-shell gauge bosons
22905 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
22907 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
22908 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
22909 IF(MAX(TH,UH).GT.-1D0) GOTO 1120
22910 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
22911 & (1D0-2D0*SQMZ/SH)
22912 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
22913 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
22914 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
22915 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
22916 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
22917 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
22918 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
22920 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
22921 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
22922 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
22923 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
22924 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
22926 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
22928 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
22930 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
22931 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
22932 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
22933 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
22934 & (ATWIM+AUWIM+A4IM)**2)
22937 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
22938 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
22939 & ABS(A00U-A20U)**2
22941 FACZZ=FACZZ*WIDS(23,1)
22943 DO 1110 I=MMIN1,MMAX1
22944 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1110
22945 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
22946 DO 1100 J=MMIN2,MMAX2
22947 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1100
22948 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
22949 IF(EI*EJ.GT.0D0) GOTO 1100
22954 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
22959 ELSEIF(ISUB.EQ.77) THEN
22960 C...W+/- + W+/- -> W+/- + W+/-
22961 IF(SH.LE.4.01D0*SQMW) GOTO 1150
22963 IF(MSTP(46).LE.2) THEN
22964 C...Exact scattering ME:s for on-mass-shell gauge bosons
22965 BE2=1D0-4D0*SQMW/SH
22969 TH=-0.5D0*SH*BE2*(1D0-CTH)
22970 UH=-0.5D0*SH*BE2*(1D0+CTH)
22971 IF(MAX(TH,UH).GT.-1D0) GOTO 1150
22973 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
22974 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
22976 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
22977 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
22979 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
22980 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
22981 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
22984 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
22986 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
22987 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
22988 ATGRE=0.5D0*XW*SH/TH*TGZANG
22990 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
22992 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
22993 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
22994 AUGRE=0.5D0*XW*SH/UH*UGZANG
22996 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
22998 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
23000 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
23002 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
23004 IF(MSTP(46).LE.0) THEN
23009 ELSEIF(MSTP(46).EQ.1) THEN
23010 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23011 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23012 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23013 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23015 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23016 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23017 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23018 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23020 AWWA2=AWWARE**2+AWWAIM**2
23021 AWWS2=AWWSRE**2+AWWSIM**2
23024 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23025 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
23026 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
23027 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
23030 DO 1140 I=MMIN1,MMAX1
23031 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1140
23032 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23033 DO 1130 J=MMIN2,MMAX2
23034 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1130
23035 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23036 IF(EI*EJ.LT.0D0) THEN
23038 IF(MSTP(45).EQ.1) GOTO 1130
23039 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
23040 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
23043 IF(MSTP(45).EQ.2) GOTO 1130
23044 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
23045 IF(MSTP(46).GE.3) FACWW=FWWS
23046 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
23047 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
23053 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
23054 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
23059 ELSEIF(ISUB.EQ.78) THEN
23060 C...W+/- + h0 -> W+/- + h0
23062 ELSEIF(ISUB.EQ.79) THEN
23063 C...h0 + h0 -> h0 + h0
23065 ELSEIF(ISUB.EQ.80) THEN
23066 C...q + gamma -> q' + pi+/-
23067 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
23068 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
23069 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
23070 DELSH=UH*SQRT(ASSH*Q2FPSH)
23071 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
23072 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
23073 DELUH=SH*SQRT(ASUH*Q2FPUH)
23074 DO 1170 I=MAX(-2,MMINA),MIN(2,MMAXA)
23075 IF(I.EQ.0) GOTO 1170
23076 EI=KCHG(IABS(I),1)/3D0
23077 EJ=SIGN(1D0-ABS(EI),EI)
23079 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1160
23080 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1160
23083 ISIG(NCHN,3-ISDE)=22
23085 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
23091 C...C: 2 -> 2, tree diagrams with masses
23093 ELSEIF(ISUB.LE.90) THEN
23094 IF(ISUB.EQ.81) THEN
23095 C...q + qbar -> Q + Qbar
23096 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
23097 THQ=-0.5D0*SH*(1D0-BE34*CTH)
23098 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
23099 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
23101 IF(MSTP(5).GE.5) FACQQB=FACQQB*SH2*SQDQTS
23102 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
23104 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
23105 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
23107 DO 1180 I=MMINA,MMAXA
23108 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
23109 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1180
23117 ELSEIF(ISUB.EQ.82) THEN
23118 C...g + g -> Q + Qbar
23119 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
23120 THQ=-0.5D0*SH*(1D0-BE34*CTH)
23121 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
23122 THUHQ=THQ*UHQ-SQMAVG*SH
23123 IF(MSTP(34).EQ.0) THEN
23124 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
23125 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
23127 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
23128 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
23129 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
23130 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
23132 IF(MSTP(5).GE.5) THEN
23133 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDGGS+
23134 & 2.25D0*THQ*UHQ/SH2*SQDLGS
23135 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDGGS+
23136 & 2.25D0*THQ*UHQ/SH2*SQDLGS
23138 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
23139 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
23140 IF(MSTP(35).GE.1) THEN
23141 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
23142 FACQQ1=FACQQ1*FATRE
23143 FACQQ2=FACQQ2*FATRE
23146 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
23147 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
23150 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1190
23163 ELSEIF(ISUB.EQ.83) THEN
23164 C...f + q -> f' + Q
23165 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
23166 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
23167 DO 1210 I=MMIN1,MMAX1
23168 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1210
23169 DO 1200 J=MMIN2,MMAX2
23170 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1200
23171 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 1200
23172 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 1200
23173 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
23179 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
23180 & (IABS(I)+1)/2)*VINT(180+J)
23181 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
23182 & (MINT(55)+1)/2)*VINT(180+J)
23185 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
23186 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
23189 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
23190 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
23193 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
23194 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
23196 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
23202 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
23203 & (IABS(J)+1)/2)*VINT(180+I)
23204 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
23205 & (MINT(55)+1)/2)*VINT(180+I)
23207 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
23208 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
23211 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
23212 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
23215 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
23216 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
23221 ELSEIF(ISUB.EQ.84) THEN
23222 C...g + gamma -> Q + Qbar
23223 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
23224 THQ=-0.5D0*SH*(1D0-BE34*CTH)
23225 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
23226 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
23227 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
23229 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
23231 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
23232 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
23234 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
23241 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
23249 ELSEIF(ISUB.EQ.85) THEN
23250 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
23251 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
23252 THQ=-0.5D0*SH*(1D0-BE34*CTH)
23253 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
23254 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
23255 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
23256 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
23257 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
23258 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
23259 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
23260 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
23262 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
23263 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
23264 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
23266 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
23274 ELSEIF(ISUB.EQ.86) THEN
23275 C...g + g -> J/Psi + g
23276 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
23277 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
23278 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
23279 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23287 ELSEIF(ISUB.EQ.87) THEN
23288 C...g + g -> chi_0c + g
23289 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
23290 QGTW=(SH*TH*UH)/SH**3
23292 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
23293 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
23294 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
23295 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
23296 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
23297 & (QGTW*(QGTW-RGTW*PGTW)**4)
23298 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23306 ELSEIF(ISUB.EQ.88) THEN
23307 C...g + g -> chi_1c + g
23308 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
23309 QGTW=(SH*TH*UH)/SH**3
23311 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
23312 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
23313 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
23314 & (QGTW-RGTW*PGTW)**4
23315 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23323 ELSEIF(ISUB.EQ.89) THEN
23324 C...g + g -> chi_2c + g
23325 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
23326 QGTW=(SH*TH*UH)/SH**3
23328 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
23329 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
23330 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
23331 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
23332 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
23333 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
23334 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23343 C...D: Mimimum bias processes
23345 ELSEIF(ISUB.LE.100) THEN
23346 IF(ISUB.EQ.91) THEN
23347 C...Elastic scattering
23348 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
23350 ELSEIF(ISUB.EQ.92) THEN
23351 C...Single diffractive scattering (first side, i.e. XB)
23352 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
23354 ELSEIF(ISUB.EQ.93) THEN
23355 C...Single diffractive scattering (second side, i.e. AX)
23356 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
23358 ELSEIF(ISUB.EQ.94) THEN
23359 C...Double diffractive scattering
23360 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
23362 ELSEIF(ISUB.EQ.95) THEN
23363 C...Low-pT scattering
23364 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
23366 ELSEIF(ISUB.EQ.96) THEN
23367 C...Multiple interactions: sum of QCD processes
23368 CALL PYWIDT(21,SH,WDTP,WDTE)
23370 C...q + q' -> q + q'
23371 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
23372 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
23373 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
23374 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
23375 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
23376 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
23378 IF(I.EQ.0) GOTO 1230
23380 IF(J.EQ.0) GOTO 1220
23386 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
23388 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
23393 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
23398 C...q + qbar -> q' + qbar' or g + g
23399 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
23400 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
23401 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
23403 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
23406 IF(I.EQ.0) GOTO 1240
23416 SIGH(NCHN)=0.5D0*FACGG1
23421 SIGH(NCHN)=0.5D0*FACGG2
23425 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
23427 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
23430 IF(I.EQ.0) GOTO 1260
23434 ISIG(NCHN,3-ISDE)=21
23439 ISIG(NCHN,3-ISDE)=21
23445 C...g + g -> q + qbar (only d, u, s)
23448 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
23449 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
23450 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
23451 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
23452 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
23453 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
23454 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
23455 & UH2/SH2)*FLAVWT*FACA
23456 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
23457 & TH2/SH2)*FLAVWT*FACA
23469 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
23472 SQMAVG=PMAS(IFL,1)**2
23473 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
23474 BE34=SQRT(1D0-4D0*SQMAVG/SH)
23475 THQ=-0.5D0*SH*(1D0-BE34*CTH)
23476 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
23477 THUHQ=THQ*UHQ-SQMAVG*SH
23478 IF(MSTP(34).EQ.0) THEN
23479 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
23480 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
23482 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
23483 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
23484 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
23485 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
23487 IF(MSTP(5).GE.5) THEN
23488 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDGGS+
23489 & 2.25D0*THQ*UHQ/SH2*SQDLGS
23490 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDGGS+
23491 & 2.25D0*THQ*UHQ/SH2*SQDLGS
23493 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
23494 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
23498 ISIG(NCHN,3)=531+2*(IFL-3)
23503 ISIG(NCHN,3)=532+2*(IFL-3)
23509 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
23510 & 2D0*TH/SH+TH2/SH2)*FACA
23511 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
23512 & 2D0*SH/UH+SH2/UH2)*FACA
23513 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
23514 & 2D0*UH/TH+UH2/TH2)
23519 SIGH(NCHN)=0.5D0*FACGG1
23524 SIGH(NCHN)=0.5D0*FACGG2
23529 SIGH(NCHN)=0.5D0*FACGG3
23531 ELSEIF(ISUB.EQ.99) THEN
23532 C...f + gamma* -> f.
23533 IF(MINT(107).EQ.4) THEN
23542 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
23543 PM2RHO=PMAS(PYCOMP(113),1)**2
23544 IF(MSTP(19).EQ.0) THEN
23546 ELSEIF(MSTP(19).EQ.1) THEN
23547 COMFAC=COMFAC/(Q2GA+PM2RHO)
23548 ELSEIF(MSTP(19).EQ.2) THEN
23549 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
23551 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
23553 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
23554 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
23555 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
23556 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
23558 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
23560 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
23562 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
23563 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
23565 DO 1280 I=MMINA,MMAXA
23566 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 1280
23567 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 1280
23568 EI=KCHG(IABS(I),1)/3D0
23571 ISIG(NCHN,3-ISDE)=22
23573 SIGH(NCHN)=COMFAC*EI**2
23577 C...E: 2 -> 1, loop diagrams
23579 ELSEIF(ISUB.LE.110) THEN
23580 IF(ISUB.EQ.101) THEN
23581 C...g + g -> gamma*/Z0
23583 ELSEIF(ISUB.EQ.102) THEN
23584 C...g + g -> h0 (or H0, or A0)
23585 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23587 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23588 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23589 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23591 HI=SHR*WDTP(13)/32D0
23592 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1290
23597 SIGH(NCHN)=HI*FACBW*HF
23600 ELSEIF(ISUB.EQ.103) THEN
23601 C...gamma + gamma -> h0 (or H0, or A0)
23602 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23604 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23605 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23606 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23608 HI=SHR*WDTP(14)*2D0
23609 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 1300
23614 SIGH(NCHN)=HI*FACBW*HF
23617 ELSEIF(ISUB.EQ.104) THEN
23618 C...g + g -> chi_c0.
23620 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
23621 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
23622 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
23623 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23631 ELSEIF(ISUB.EQ.105) THEN
23632 C...g + g -> chi_c2.
23634 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
23635 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
23636 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
23637 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23645 C...Continuation C: 2 -> 2, tree diagrams with masses.
23647 ELSEIF(ISUB.EQ.106) THEN
23648 C...g + g -> J/Psi + gamma.
23650 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
23651 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
23652 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
23653 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
23661 ELSEIF(ISUB.EQ.107) THEN
23662 C...g + gamma -> J/Psi + g.
23664 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
23665 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
23666 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
23667 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
23674 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
23682 ELSEIF(ISUB.EQ.108) THEN
23683 C...gamma + gamma -> J/Psi + gamma.
23685 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
23686 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
23687 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
23688 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
23696 C...F: 2 -> 2, box diagrams
23698 ELSEIF(ISUB.EQ.110) THEN
23699 C...f + fbar -> gamma + h0
23700 THUH=MAX(TH*UH,SH*CKIN(3)**2)
23701 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
23702 FACHG=FACHG*WIDS(KFHIGG,2)
23703 C...Calculate loop contributions for intermediate gamma* and Z0
23704 CIGTOT=DCMPLX(0D0,0D0)
23705 CIZTOT=DCMPLX(0D0,0D0)
23708 IF(J.LE.2*MSTP(1)) THEN
23711 AJ=SIGN(1D0,EJ+0.1D0)
23713 BALP=SQM4/(2D0*PMAS(J,1))**2
23714 BBET=SH/(2D0*PMAS(J,1))**2
23715 ELSEIF(J.LE.3*MSTP(1)) THEN
23717 JL=2*(J-2*MSTP(1))-1
23718 EJ=KCHG(10+JL,1)/3D0
23719 AJ=SIGN(1D0,EJ+0.1D0)
23721 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
23722 BBET=SH/(2D0*PMAS(10+JL,1))**2
23724 BALP=SQM4/(2D0*PMAS(24,1))**2
23725 BBET=SH/(2D0*PMAS(24,1))**2
23727 BABI=1D0/(BALP-BBET)
23728 IF(BALP.LT.1D0) THEN
23729 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
23732 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
23733 & -DBLE(0.5D0*PARU(1)))
23736 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
23737 IF(BBET.LT.1D0) THEN
23738 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
23741 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
23742 & -DBLE(0.5D0*PARU(1)))
23745 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
23746 IF(J.LE.3*MSTP(1)) THEN
23747 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
23748 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
23749 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
23750 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
23753 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
23754 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
23755 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
23756 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
23757 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
23758 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
23762 CIGTOT=CIGTOT/DBLE(SH)
23763 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
23764 C...Loop over initial flavours
23765 DO 1320 I=MMINA,MMAXA
23766 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1320
23767 EI=KCHG(IABS(I),1)/3D0
23771 IF(IABS(I).LE.10) FCOI=FACA/3D0
23776 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
23777 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
23782 ELSEIF(ISUB.LE.120) THEN
23783 IF(ISUB.EQ.111) THEN
23784 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
23785 IF(MSTP(38).NE.0) THEN
23786 C...Simple case: only do gg <-> h exactly.
23787 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23788 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
23789 & (TH**2+UH**2)/(SH*SQM4)
23790 C...Propagators: as simulated in PYOFSH and as desired
23791 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23792 GMMHC=SQRT(SQM4)*WDTP(0)
23793 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23794 & ((SQM4-SQMH)**2+GMMHC**2)
23795 FACGH=FACGH*HBW4C/HBW4
23797 C...Messy case: do full loop integrals
23800 DO 1330 I=1,2*MSTP(1)
23804 CALL PYWAUX(1,EPSS,W1SR,W1SI)
23805 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23806 CALL PYWAUX(2,EPSS,W2SR,W2SI)
23807 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23808 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
23809 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
23810 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
23811 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
23813 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23814 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
23815 FACGH=FACGH*WIDS(25,2)
23817 DO 1340 I=MMINA,MMAXA
23818 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
23819 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1340
23827 ELSEIF(ISUB.EQ.112) THEN
23828 C...f + g -> f + h0 (q + g -> q + h0 only)
23829 IF(MSTP(38).NE.0) THEN
23830 C...Simple case: only do gg <-> h exactly.
23831 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23832 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
23833 & (SH**2+UH**2)/(-TH*SQM4)
23834 C...Propagators: as simulated in PYOFSH and as desired
23835 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23836 GMMHC=SQRT(SQM4)*WDTP(0)
23837 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23838 & ((SQM4-SQMH)**2+GMMHC**2)
23839 FACQH=FACQH*HBW4C/HBW4
23841 C...Messy case: do full loop integrals
23844 DO 1350 I=1,2*MSTP(1)
23848 CALL PYWAUX(1,EPST,W1TR,W1TI)
23849 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23850 CALL PYWAUX(2,EPST,W2TR,W2TI)
23851 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23852 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
23853 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
23854 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
23855 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
23857 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23858 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
23859 FACQH=FACQH*WIDS(25,2)
23861 DO 1370 I=MMINA,MMAXA
23862 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1370
23864 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1360
23865 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1360
23868 ISIG(NCHN,3-ISDE)=21
23874 ELSEIF(ISUB.EQ.113) THEN
23875 C...g + g -> g + h0
23876 IF(MSTP(38).NE.0) THEN
23877 C...Simple case: only do gg <-> h exactly.
23878 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23879 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
23880 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
23881 C...Propagators: as simulated in PYOFSH and as desired
23882 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23883 GMMHC=SQRT(SQM4)*WDTP(0)
23884 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23885 & ((SQM4-SQMH)**2+GMMHC**2)
23886 FACGH=FACGH*HBW4C/HBW4
23888 C...Messy case: do full loop integrals
23897 DO 1380 I=1,2*MSTP(1)
23903 IF(EPSH.LT.1D-6) GOTO 1380
23904 CALL PYWAUX(1,EPSS,W1SR,W1SI)
23905 CALL PYWAUX(1,EPST,W1TR,W1TI)
23906 CALL PYWAUX(1,EPSU,W1UR,W1UI)
23907 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23908 CALL PYWAUX(2,EPSS,W2SR,W2SI)
23909 CALL PYWAUX(2,EPST,W2TR,W2TI)
23910 CALL PYWAUX(2,EPSU,W2UR,W2UI)
23911 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23912 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
23913 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
23914 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
23915 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
23916 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
23917 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
23918 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
23919 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
23920 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
23921 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
23922 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
23923 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
23924 W3STUR=YHSTUR-Y3STUR-Y3UTSR
23925 W3STUI=YHSTUI-Y3STUI-Y3UTSI
23926 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
23927 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
23928 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
23929 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
23930 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
23931 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
23932 W3USTR=YHUSTR-Y3USTR-Y3TSUR
23933 W3USTI=YHUSTI-Y3USTI-Y3TSUI
23934 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
23935 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
23936 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
23937 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
23938 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
23939 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
23940 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
23941 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
23942 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
23943 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
23944 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
23945 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
23946 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
23947 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
23948 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
23949 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
23950 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
23951 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
23952 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
23953 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
23954 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
23955 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
23956 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
23957 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
23958 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
23959 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
23960 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
23961 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
23962 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
23963 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
23964 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
23965 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
23966 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
23967 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
23968 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
23969 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
23970 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
23971 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
23972 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
23973 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
23974 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
23975 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
23976 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
23977 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
23978 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
23979 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
23980 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
23981 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
23982 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
23983 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
23984 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
23985 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
23986 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
23987 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
23988 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
23989 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
23990 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
23991 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
23992 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
23993 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
23994 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
23995 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
23996 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
23997 & (W2SR-W2HR+W3STUR))
23998 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
23999 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24000 & (W2TR-W2HR+W3TUSR))
24001 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
24002 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24003 & (W2UR-W2HR+W3USTR))
24004 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
24005 A2STUR=A2STUR+B2STUR+B2SUTR
24006 A2STUI=A2STUI+B2STUI+B2SUTI
24007 A2USTR=A2USTR+B2USTR+B2UTSR
24008 A2USTI=A2USTI+B2USTI+B2UTSI
24009 A2TUSR=A2TUSR+B2TUSR+B2TSUR
24010 A2TUSI=A2TUSI+B2TUSI+B2TSUI
24011 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
24012 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
24014 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
24015 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
24016 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
24017 FACGH=FACGH*WIDS(25,2)
24019 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1390
24027 ELSEIF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
24028 C...g + g -> gamma + gamma or g + g -> g + gamma
24043 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
24045 EI=KCHG(IABS(I),1)/3D0
24047 IF(ISUB.EQ.115) EIWT=EI
24052 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
24053 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
24056 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
24057 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
24058 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
24059 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
24065 CALL PYWAUX(1,EPSS,W1SR,W1SI)
24066 CALL PYWAUX(1,EPST,W1TR,W1TI)
24067 CALL PYWAUX(1,EPSU,W1UR,W1UI)
24068 CALL PYWAUX(2,EPSS,W2SR,W2SI)
24069 CALL PYWAUX(2,EPST,W2TR,W2TI)
24070 CALL PYWAUX(2,EPSU,W2UR,W2UI)
24071 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
24072 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
24073 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
24074 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
24075 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
24076 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
24077 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
24078 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
24079 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
24080 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
24081 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
24082 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
24083 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
24084 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
24085 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
24086 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
24087 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
24088 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
24089 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
24090 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
24091 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
24092 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
24093 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
24094 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
24095 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
24096 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
24097 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
24098 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
24099 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
24100 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
24101 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
24102 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
24103 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
24104 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
24105 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
24106 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
24107 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
24108 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
24109 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
24110 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
24111 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
24112 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
24113 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
24114 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
24115 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
24116 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
24117 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
24118 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
24119 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
24120 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
24121 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
24122 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
24123 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
24124 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
24125 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
24126 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
24128 A0STUR=A0STUR+EIWT*B0STUR
24129 A0STUI=A0STUI+EIWT*B0STUI
24130 A0TSUR=A0TSUR+EIWT*B0TSUR
24131 A0TSUI=A0TSUI+EIWT*B0TSUI
24132 A0UTSR=A0UTSR+EIWT*B0UTSR
24133 A0UTSI=A0UTSI+EIWT*B0UTSI
24134 A1STUR=A1STUR+EIWT*B1STUR
24135 A1STUI=A1STUI+EIWT*B1STUI
24136 A2STUR=A2STUR+EIWT*B2STUR
24137 A2STUI=A2STUI+EIWT*B2STUI
24139 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
24140 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
24141 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
24142 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
24143 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1410
24148 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
24149 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
24152 ELSEIF(ISUB.EQ.116) THEN
24153 C...g + g -> gamma + Z0
24155 ELSEIF(ISUB.EQ.117) THEN
24156 C...g + g -> Z0 + Z0
24158 ELSEIF(ISUB.EQ.118) THEN
24159 C...g + g -> W+ + W-
24163 C...G: 2 -> 3, tree diagrams
24165 ELSEIF(ISUB.LE.140) THEN
24166 IF(ISUB.EQ.121) THEN
24167 C...g + g -> Q + Qbar + h0
24168 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1420
24171 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24172 & (0.5D0*PMF/PMAS(24,1))**2
24174 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24176 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24178 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24179 IF(IA.GT.10) IKFI=3
24180 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24181 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24182 FACQQH=FACQQH/(1D0+RMSS(41))**2
24183 IF(IHIGG.NE.3) THEN
24184 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24185 & PARU(151+10*IHIGG))**2
24189 CALL PYQQBH(WTQQBH)
24190 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24192 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24193 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24194 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24200 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24203 ELSEIF(ISUB.EQ.122) THEN
24204 C...q + qbar -> Q + Qbar + h0
24207 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24208 & (0.5D0*PMF/PMAS(24,1))**2
24210 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24212 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24214 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24215 IF(IA.GT.10) IKFI=3
24216 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24217 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24218 FACQQH=FACQQH/(1D0+RMSS(41))**2
24219 IF(IHIGG.NE.3) THEN
24220 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24221 & PARU(151+10*IHIGG))**2
24225 CALL PYQQBH(WTQQBH)
24226 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24228 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24229 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24230 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24232 DO 1430 I=MMINA,MMAXA
24233 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
24234 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1430
24239 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24242 ELSEIF(ISUB.EQ.123) THEN
24243 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
24245 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
24246 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24247 & PARU(154+10*IHIGG)**2
24248 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24249 & (VINT(216)-VINT(209)**2))**2
24250 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24251 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
24252 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24254 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24255 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24256 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24258 DO 1450 I=MMIN1,MMAX1
24259 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1450
24261 DO 1440 J=MMIN2,MMAX2
24262 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1440
24264 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
24265 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
24267 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
24268 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
24270 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
24271 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
24276 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
24280 ELSEIF(ISUB.EQ.124) THEN
24281 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
24283 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
24284 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24285 & PARU(155+10*IHIGG)**2
24286 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24287 & (VINT(216)-VINT(209)**2))**2
24288 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24289 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24291 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24292 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24293 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24295 DO 1470 I=MMIN1,MMAX1
24296 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1470
24297 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
24298 DO 1460 J=MMIN2,MMAX2
24299 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1460
24300 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
24301 IF(EI*EJ.GT.0D0) GOTO 1460
24302 FACLR=VINT(180+I)*VINT(180+J)
24307 SIGH(NCHN)=FACLR*FACWW*FACBW
24311 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
24312 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
24314 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
24316 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
24318 IF(ISUB.EQ.131) THEN
24319 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
24320 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
24322 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
24324 DO 1490 I=MMINA,MMAXA
24325 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1490
24326 EI=KCHG(IABS(I),1)/3D0
24329 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1480
24330 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1480
24333 ISIG(NCHN,3-ISDE)=22
24339 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
24340 C...f + gamma*_(T,L) -> f + gamma
24342 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
24344 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
24346 IF(ISUB.EQ.133) THEN
24347 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
24348 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
24350 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
24352 DO 1510 I=MMINA,MMAXA
24353 IF(I.EQ.0) GOTO 1510
24354 EI=KCHG(IABS(I),1)/3D0
24357 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1500
24358 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1500
24361 ISIG(NCHN,3-ISDE)=22
24367 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
24368 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
24370 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
24372 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
24374 CALL PYWIDT(21,SH,WDTP,WDTE)
24376 DO 1520 I=1,MIN(8,MDCY(21,3))
24378 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
24381 IF(ISUB.EQ.135) THEN
24382 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
24383 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
24385 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
24387 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
24394 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
24402 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
24403 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
24405 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
24407 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
24408 CALL PYWIDT(22,SH,WDTP,WDTE)
24410 DO 1530 I=1,MIN(12,MDCY(22,3))
24411 IF(I.LE.8) EF= KCHG(I,1)/3D0
24412 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
24413 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
24416 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
24417 IF(ISUB.EQ.137) THEN
24418 FPARAM=-SH*(TH+UH)/DLAMB2
24419 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
24420 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
24421 & 2D0*PH1*PH2*FPARAM**2)
24422 ELSEIF(ISUB.EQ.138) THEN
24423 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
24424 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
24425 & 2D0*PH1**2*(TH-UH)**2)
24426 ELSEIF(ISUB.EQ.139) THEN
24427 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
24428 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
24429 & 2D0*PH2**2*(TH-UH)**2)
24431 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
24432 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
24434 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
24444 C...H: 2 -> 1, tree diagrams, non-standard model processes
24446 ELSEIF(ISUB.LE.160) THEN
24447 IF(ISUB.EQ.141) THEN
24448 C...f + fbar -> gamma*/Z0/Z'0
24449 SQMZP=PMAS(32,1)**2
24451 CALL PYWIDT(32,SH,WDTP,WDTE)
24457 FACZP=4D0*COMFAC*3D0
24458 DO 1540 I=MMINA,MMAXA
24459 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1540
24460 EI=KCHG(IABS(I),1)/3D0
24466 VPI=PARU(123-2*MOD(IABS(I),2))
24467 API=PARU(124-2*MOD(IABS(I),2))
24468 ELSEIF(IA.LE.4) THEN
24469 VPI=PARJ(182-2*MOD(IABS(I),2))
24470 API=PARJ(183-2*MOD(IABS(I),2))
24472 VPI=PARJ(190-2*MOD(IABS(I),2))
24473 API=PARJ(191-2*MOD(IABS(I),2))
24477 VPI=PARU(127-2*MOD(IABS(I),2))
24478 API=PARU(128-2*MOD(IABS(I),2))
24479 ELSEIF(IA.LE.14) THEN
24480 VPI=PARJ(186-2*MOD(IABS(I),2))
24481 API=PARJ(187-2*MOD(IABS(I),2))
24483 VPI=PARJ(194-2*MOD(IABS(I),2))
24484 API=PARJ(195-2*MOD(IABS(I),2))
24488 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
24490 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
24492 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
24497 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
24498 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
24499 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
24500 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
24501 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
24502 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
24503 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
24504 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
24507 ELSEIF(ISUB.EQ.142) THEN
24508 C...f + fbar' -> W'+/-
24509 SQMWP=PMAS(34,1)**2
24510 CALL PYWIDT(34,SH,WDTP,WDTE)
24512 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
24513 HP=AEM/(24D0*XW)*SH
24514 DO 1560 I=MMIN1,MMAX1
24515 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1560
24517 DO 1550 J=MMIN2,MMAX2
24518 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1550
24520 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1550
24521 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24523 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24524 HI=HP*(PARU(133)**2+PARU(134)**2)
24525 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
24526 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
24531 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
24532 SIGH(NCHN)=HI*FACBW*HF
24536 ELSEIF(ISUB.EQ.143) THEN
24537 C...f + fbar' -> H+/-
24538 SQMHC=PMAS(37,1)**2
24539 CALL PYWIDT(37,SH,WDTP,WDTE)
24541 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
24542 HP=AEM/(8D0*XW)*SH/SQMW*SH
24543 DO 1580 I=MMIN1,MMAX1
24544 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1580
24546 IM=(MOD(IA,10)+1)/2
24547 DO 1570 J=MMIN2,MMAX2
24548 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1570
24550 JM=(MOD(JA,10)+1)/2
24551 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 1570
24552 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24554 IF(MOD(IA,2).EQ.0) THEN
24561 RML=PYMRUN(IL,SH)**2/SH
24562 RMU=PYMRUN(IU,SH)**2/SH
24563 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
24564 IF(IA.LE.10) HI=HI*FACA/3D0
24565 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24566 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
24571 SIGH(NCHN)=HI*FACBW*HF
24575 ELSEIF(ISUB.EQ.144) THEN
24578 CALL PYWIDT(41,SH,WDTP,WDTE)
24580 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
24581 HP=AEM/(12D0*XW)*SH
24582 DO 1600 I=MMIN1,MMAX1
24583 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1600
24585 DO 1590 J=MMIN2,MMAX2
24586 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1590
24588 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 1590
24590 IF(IA.LE.10) HI=HI*FACA/3D0
24591 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
24596 SIGH(NCHN)=HI*FACBW*HF
24600 ELSEIF(ISUB.EQ.145) THEN
24601 C...q + l -> LQ (leptoquark)
24602 SQMLQ=PMAS(42,1)**2
24603 CALL PYWIDT(42,SH,WDTP,WDTE)
24605 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
24606 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
24608 KFLQQ=KFDP(MDCY(42,2),1)
24609 KFLQL=KFDP(MDCY(42,2),2)
24610 DO 1620 I=MMIN1,MMAX1
24611 IF(KFAC(1,I).EQ.0) GOTO 1620
24613 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 1620
24614 DO 1610 J=MMIN2,MMAX2
24615 IF(KFAC(2,J).EQ.0) GOTO 1610
24617 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 1610
24618 IF(I*J.NE.KFLQQ*KFLQL) GOTO 1610
24619 IF(JA.EQ.IA) GOTO 1610
24620 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
24621 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
24623 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
24628 SIGH(NCHN)=HI*FACBW*HF
24632 ELSEIF(ISUB.EQ.146) THEN
24633 C...e + gamma* -> e* (excited lepton)
24634 KFQSTR=KFPR(ISUB,1)
24635 KCQSTR=PYCOMP(KFQSTR)
24636 KFQEXC=MOD(KFQSTR,KEXCIT)
24637 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
24639 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
24640 QF=-PARU(157)/2D0-PARU(158)/2D0
24641 FACBW=FACBW*AEM*QF**2*SH/PARU(155)**2
24642 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
24645 DO 1640 I=-KFQEXC,KFQEXC,2*KFQEXC
24647 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1630
24648 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1630
24650 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24651 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
24654 ISIG(NCHN,3-ISDE)=22
24656 SIGH(NCHN)=HI*FACBW*HF
24660 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
24661 C...d + g -> d* and u + g -> u* (excited quarks)
24662 KFQSTR=KFPR(ISUB,1)
24663 KCQSTR=PYCOMP(KFQSTR)
24664 KFQEXC=MOD(KFQSTR,KEXCIT)
24665 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
24667 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
24668 FACBW=FACBW*AS*PARU(159)**2*SH/(3D0*PARU(155)**2)
24669 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
24672 DO 1660 I=-KFQEXC,KFQEXC,2*KFQEXC
24674 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1650
24675 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1650
24677 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24678 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
24681 ISIG(NCHN,3-ISDE)=21
24683 SIGH(NCHN)=HI*FACBW*HF
24687 ELSEIF(ISUB.EQ.149) THEN
24688 C...g + g -> eta_tc
24689 KCTC=PYCOMP(KTECHN+331)
24690 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
24692 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
24693 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
24695 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1670
24697 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24702 SIGH(NCHN)=HI*FACBW*HF
24707 C...I: 2 -> 2, tree diagrams, non-standard model processes
24709 ELSEIF(ISUB.LE.200) THEN
24710 IF(ISUB.EQ.161) THEN
24711 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
24712 C...(choice of only b and t to avoid kinematics problems)
24713 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
24714 C...H propagator: as simulated in PYOFSH and as desired
24715 SQMHC=PMAS(37,1)**2
24716 GMMHC=PMAS(37,1)*PMAS(37,2)
24717 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
24718 CALL PYWIDT(37,SQM4,WDTP,WDTE)
24719 GMMHCC=SQRT(SQM4)*WDTP(0)
24720 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
24721 FHCQ=FHCQ*HBW4C/HBW4
24722 DO 1690 I=MMINA,MMAXA
24724 IF(IA.NE.5) GOTO 1690
24725 SQML=PYMRUN(IA,SH)**2
24727 SQMQ=PYMRUN(IUA,SH)**2
24728 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
24729 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
24730 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
24731 & (SQMHC-SQMQ-SH)/SH)
24732 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
24734 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1680
24735 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 1680
24738 ISIG(NCHN,3-ISDE)=21
24740 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
24744 ELSEIF(ISUB.EQ.162) THEN
24745 C...q + g -> LQ + lbar; LQ=leptoquark
24746 SQMLQ=PMAS(42,1)**2
24747 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
24748 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
24749 KFLQQ=KFDP(MDCY(42,2),1)
24750 DO 1710 I=MMINA,MMAXA
24751 IF(IABS(I).NE.KFLQQ) GOTO 1710
24754 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1700
24755 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1700
24758 ISIG(NCHN,3-ISDE)=21
24760 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
24764 ELSEIF(ISUB.EQ.163) THEN
24765 C...g + g -> LQ + LQbar; LQ=leptoquark
24766 SQMLQ=PMAS(42,1)**2
24767 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
24768 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
24769 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
24770 & ((TH-SQMLQ)*(UH-SQMLQ)))
24771 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1720
24775 C...Since don't know proper colour flow, randomize between alternatives
24776 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
24780 ELSEIF(ISUB.EQ.164) THEN
24781 C...q + qbar -> LQ + LQbar; LQ=leptoquark
24782 DELTA=0.25D0*(SQM3-SQM4)**2/SH
24783 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
24786 C SQMLQ=PMAS(42,1)**2
24787 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
24788 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
24789 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
24790 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
24791 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
24792 KFLQQ=KFDP(MDCY(42,2),1)
24793 DO 1730 I=MMINA,MMAXA
24794 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
24795 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1730
24801 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
24804 ELSEIF(ISUB.EQ.165) THEN
24805 C...q + qbar -> l+ + l- (including contact term for compositeness)
24806 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
24807 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
24808 KFF=IABS(KFPR(ISUB,1))
24810 AF=SIGN(1D0,EF+0.1D0)
24815 IF(KFF.LE.10) FCOF=3D0
24817 IF(KFF.EQ.6) WID2=WIDS(6,1)
24818 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
24819 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
24820 DO 1740 I=MMINA,MMAXA
24821 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1740
24822 EI=KCHG(IABS(I),1)/3D0
24823 AI=SIGN(1D0,EI+0.1D0)
24828 IF(IABS(I).LE.10) FCOI=FACA/3D0
24829 IF((MSTP(5).EQ.1.AND.IABS(I).LE.2).OR.MSTP(5).EQ.2) THEN
24830 FGZA=(EI*EF+VALI*VALF*ZRATR+PARU(156)*SH/
24831 & (AEM*PARU(155)**2))**2+(VALI*VALF*ZRATI)**2+
24832 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
24834 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
24835 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
24837 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
24838 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
24839 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
24840 IF((MSTP(5).EQ.3.AND.IABS(I).EQ.2).OR.(MSTP(5).EQ.4.AND.
24841 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*PARU(155)**4)
24846 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
24849 ELSEIF(ISUB.EQ.166) THEN
24850 C...q + q'bar -> l + nu_l (including contact term for compositeness)
24851 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
24852 WCIFAC=WFAC+SH2/(4D0*PARU(155)**4)
24853 KFF=IABS(KFPR(ISUB,1))
24855 IF(KFF.LE.10) FCOF=3D0
24856 DO 1760 I=MMIN1,MMAX1
24857 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1760
24859 DO 1750 J=MMIN2,MMAX2
24860 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1750
24862 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1750
24863 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24866 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
24868 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
24869 & MOD(J,2).EQ.0)) THEN
24870 IF(KFF.EQ.5) WID2=WIDS(6,2)
24871 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
24872 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
24874 IF(KFF.EQ.5) WID2=WIDS(6,3)
24875 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
24876 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
24882 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
24883 IF((MSTP(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.MSTP(5).EQ.4)
24884 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
24888 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
24889 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
24890 KFQSTR=KFPR(ISUB,2)
24891 KCQSTR=PYCOMP(KFQSTR)
24892 KFQEXC=MOD(KFQSTR,KEXCIT)
24893 FACQSA=COMFAC*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)
24894 FACQSB=COMFAC*0.25D0*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
24895 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
24896 C...Propagators: as simulated in PYOFSH and as desired
24897 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
24898 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
24899 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
24900 GMMQC=SQRT(SQM4)*WDTP(0)
24901 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
24902 FACQSA=FACQSA*HBW4C/HBW4
24903 FACQSB=FACQSB*HBW4C/HBW4
24904 C...Branching ratios.
24905 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
24906 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
24907 DO 1780 I=MMIN1,MMAX1
24909 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1780
24910 DO 1770 J=MMIN2,MMAX2
24912 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1770
24913 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
24918 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
24919 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
24924 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
24925 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
24926 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
24931 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
24932 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
24933 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
24934 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
24939 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
24940 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
24945 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
24946 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
24947 ELSEIF(I.EQ.-J) THEN
24952 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
24953 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
24958 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
24959 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
24960 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
24965 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
24966 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
24967 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
24972 ELSEIF(ISUB.EQ.169) THEN
24973 C...q + qbar -> e + e* (excited lepton)
24974 KFQSTR=KFPR(ISUB,2)
24975 KCQSTR=PYCOMP(KFQSTR)
24976 KFQEXC=MOD(KFQSTR,KEXCIT)
24977 FACQSB=(COMFAC/6D0)*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
24978 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
24979 C...Propagators: as simulated in PYOFSH and as desired
24980 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
24981 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
24982 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
24983 GMMQC=SQRT(SQM4)*WDTP(0)
24984 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
24985 FACQSB=FACQSB*HBW4C/HBW4
24986 C...Branching ratios.
24987 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
24988 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
24989 DO 1790 I=MMIN1,MMAX1
24991 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1790
24994 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1790
24999 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
25000 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
25005 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
25006 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
25009 ELSEIF(ISUB.EQ.191) THEN
25010 C...q + qbar -> rho_tc0.
25011 KCTC=PYCOMP(KTECHN+113)
25012 SQMRHT=PMAS(KCTC,1)**2
25013 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
25015 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
25016 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
25017 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
25018 ALPRHT=2.91D0*(3D0/PARP(144))
25019 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
25020 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
25021 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25022 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25023 DO 1800 I=MMINA,MMAXA
25024 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1800
25026 EI=KCHG(IABS(I),1)/3D0
25027 AI=SIGN(1D0,EI+0.1D0)
25031 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
25032 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
25033 IF(IA.LE.10) HI=HI*FACA/3D0
25038 SIGH(NCHN)=HI*FACBW*HF
25041 ELSEIF(ISUB.EQ.192) THEN
25042 C...q + qbar' -> rho_tc+/-.
25043 KCTC=PYCOMP(KTECHN+213)
25044 SQMRHT=PMAS(KCTC,1)**2
25045 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
25047 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
25048 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
25049 ALPRHT=2.91D0*(3D0/PARP(144))
25050 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
25051 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
25052 DO 1820 I=MMIN1,MMAX1
25053 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1820
25055 DO 1810 J=MMIN2,MMAX2
25056 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1810
25058 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1810
25059 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
25061 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
25062 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
25064 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
25069 SIGH(NCHN)=HI*FACBW*HF
25073 ELSEIF(ISUB.EQ.193) THEN
25074 C...q + qbar -> omega_tc0.
25075 KCTC=PYCOMP(KTECHN+223)
25076 SQMOMT=PMAS(KCTC,1)**2
25077 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
25079 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
25080 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
25081 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
25082 ALPRHT=2.91D0*(3D0/PARP(144))
25083 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
25084 & (2D0*PARP(143)-1D0)**2
25085 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25086 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25087 DO 1830 I=MMINA,MMAXA
25088 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1830
25090 EI=KCHG(IABS(I),1)/3D0
25091 AI=SIGN(1D0,EI+0.1D0)
25095 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
25096 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
25097 IF(IA.LE.10) HI=HI*FACA/3D0
25102 SIGH(NCHN)=HI*FACBW*HF
25105 ELSEIF(ISUB.EQ.194) THEN
25106 C...f + fbar -> f' + fbar' via s-channel rho_tc and omega_tc.
25108 ALPRHT=2.91D0*(3D0/PARP(144))
25110 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
25111 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
25113 QUPD=2D0*PARP(143)-1D0
25114 FAR=SQRT(AEM/ALPRHT)
25122 CALL PYWIDT(23,SH,WDTP,WDTE)
25123 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
25124 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
25125 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
25126 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
25127 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
25128 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
25129 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
25130 DAA=(-Sfzr*SSMO - Sfzo*SSMR + SSMO*SSMR*SSMZ)/DETD/SH
25131 DZZ=(-Sfar*SSMO - Sfao*SSMR + SSMO*SSMR)/DETD/SH
25132 DAZ=(far*fzr*SSMO + fao*fzo*SSMR)/DETD/SH
25134 XWRHT=1D0/(4D0*XW*(1D0-XW))
25135 KFF=IABS(KFPR(ISUB,1))
25137 AF=SIGN(1D0,EF+0.1D0)
25142 IF(KFF.LE.10) FCOF=3D0
25145 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
25146 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
25147 DZZ=DZZ*DCMPLX(XWRHT,0D0)
25148 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
25150 DO 1840 I=MMINA,MMAXA
25151 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1840
25152 EI=KCHG(IABS(I),1)/3D0
25153 AI=SIGN(1D0,EI+0.1D0)
25158 IF(IABS(I).LE.10) FCOI=FCOI/3D0
25159 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
25160 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
25161 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
25162 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
25163 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
25164 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
25169 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
25172 ELSEIF(ISUB.EQ.195) THEN
25173 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+
25176 ALPRHT=2.91D0*(3D0/PARP(144))
25177 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
25179 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
25180 CALL PYWIDT(24,SH,WDTP,WDTE)
25181 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
25182 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
25183 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
25186 IF(KFA.LE.8) FCOF=3D0
25187 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
25188 HP=FACTC*ABS(SSMR/DETD)**2/SH**2*FCOF
25190 DO 1860 I=MMIN1,MMAX1
25191 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1860
25193 DO 1850 J=MMIN2,MMAX2
25194 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1850
25196 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1850
25197 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
25199 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
25201 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
25206 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
25213 C...J: 2 -> 2, tree diagrams, SUSY processes
25215 ELSEIF(ISUB.LE.210) THEN
25216 IF(ISUB.EQ.201) THEN
25217 C...f + fbar -> e_L + e_Lbar
25218 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25219 DO 1890 I=MMIN1,MMAX1
25221 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1890
25223 TT3I=SIGN(1D0,EI+1D-6)/2D0
25227 C...Color factor for e+ e-
25228 IF(IA.GE.11) FCOL=3D0
25229 IF(ISUBSV.EQ.301) THEN
25232 ELSEIF(ILR.EQ.1) THEN
25233 A1=SFMIX(KFID,3)**2
25234 A2=SFMIX(KFID,4)**2
25235 ELSEIF(ILR.EQ.0) THEN
25236 A1=SFMIX(KFID,1)**2
25237 A2=SFMIX(KFID,2)**2
25239 XLQ=(TT3J-EJ*XW)*A1
25243 TAA=(EI*EJ)**2*(POLL+POLR)
25244 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
25245 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
25246 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
25247 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25251 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
25257 DK=1D0/(TH-SMZ(II)**2)
25258 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
25260 FREK=FAC2*TANW*EI*ZMIX(II,1)
25261 TNN1=TNN1+FLEK**2*DK
25262 TNN2=TNN2+FREK**2*DK
25264 DL=1D0/(TH-SMZ(JJ)**2)
25265 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
25267 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
25268 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
25271 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
25272 & A2**2*TNN2**2*POLR)
25273 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
25274 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
25275 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
25276 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
25277 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
25280 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
25283 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
25284 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
25285 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
25290 SIGH(NCHN)=FACQQ1+FACQQ2
25293 ELSEIF(ISUB.EQ.203) THEN
25294 C...f + fbar -> e_L + e_Rbar
25295 DO 1920 I=MMIN1,MMAX1
25297 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1920
25298 EI=KCHG(IABS(I),1)/3D0
25299 TT3I=SIGN(1D0,EI)/2D0
25303 C...Color factor for e+ e-
25304 IF(IA.GE.11) FCOL=3D0
25305 A1=SFMIX(KFID,1)**2
25306 A2=SFMIX(KFID,2)**2
25311 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
25312 & /XW**2/XW1**2*A1*A2
25313 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25318 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
25324 DK=1D0/(TH-SMZ(II)**2)
25325 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
25327 FREK=FAC2*TANW*EI*ZMIX(II,1)
25328 TNN1=TNN1+FLEK**2*DK
25329 TNN2=TNN2+FREK**2*DK
25331 DL=1D0/(TH-SMZ(JJ)**2)
25332 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
25334 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
25335 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
25338 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
25339 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
25340 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
25341 TZN=(UH*TH-SQM3*SQM4)*A1*A2
25342 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
25343 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
25346 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
25347 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
25348 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
25354 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25355 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
25360 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
25361 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25364 ELSEIF(ISUB.EQ.210) THEN
25365 C...q + qbar' -> W*- > ~l_L + ~nu_L
25366 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
25367 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
25368 DO 1940 I=MMIN1,MMAX1
25370 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1940
25371 DO 1930 J=MMIN2,MMAX2
25373 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1930
25374 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1930
25376 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25377 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25379 IF(KCHSUM.LT.0) KCHW=3
25384 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
25385 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
25386 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25388 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
25389 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25391 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
25396 ELSEIF(ISUB.LE.220) THEN
25397 IF(ISUB.EQ.213) THEN
25398 C...f + fbar -> ~nu_L + ~nu_Lbar
25399 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
25400 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25401 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25403 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25406 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
25409 DO 1950 I=MMIN1,MMAX1
25411 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1950
25414 C...Color factor for e+ e-
25415 IF(IA.GE.11) FCOL=3D0
25416 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
25420 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
25421 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
25424 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
25426 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
25432 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
25433 & *AEM**2*FCOL/3D0/XW**2
25436 ELSEIF(ISUB.EQ.216) THEN
25437 C...q + qbar -> ~chi0_1 + ~chi0_1
25438 IF(IZID1.EQ.IZID2) THEN
25439 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25441 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25442 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25444 FACXX=COMFAC*AEM**2/3D0/XW**2
25445 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
25448 WU2 = (UH-ZM12)*(UH-ZM22)
25449 WT2 = (TH-ZM12)*(TH-ZM22)
25450 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
25451 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
25452 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
25454 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
25455 IF(IZID2.NE.IZID1) THEN
25456 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
25459 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
25460 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
25462 DO 1970 I=MMINA,MMAXA
25463 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1970
25464 EI=KCHG(IABS(I),1)/3D0
25465 T3I=SIGN(1D0,EI+1D-6)/2D0
25466 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
25467 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
25468 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
25469 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
25470 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
25471 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
25472 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
25474 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
25475 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
25476 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
25478 IF(IABS(I).GE.11) FCOL=3D0
25479 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
25480 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
25481 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
25482 & QRL*DCONJG(QRR)*POLR)*WS2
25487 SIGH(NCHN)=FACXX*FACGG1*FCOL
25491 ELSEIF(ISUB.LE.230) THEN
25492 IF(ISUB.EQ.226) THEN
25493 C...f + fbar -> ~chi+_1 + ~chi-_1
25494 FACXX=COMFAC*AEM**2/3D0
25497 WU2 = (UH-ZM12)*(UH-ZM22)
25498 WT2 = (TH-ZM12)*(TH-ZM22)
25499 WS2 = SMW(IZID1)*SMW(IZID2)*SH
25500 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
25501 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
25503 IF(IZID1.EQ.IZID2) DIFF=1D0
25505 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
25506 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
25507 IF(IZID2.NE.IZID1) THEN
25508 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
25509 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
25512 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
25513 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
25514 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
25515 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
25516 DO 1990 I=MMINA,MMAXA
25517 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1990
25518 EI=KCHG(IABS(I),1)/3D0
25519 T3I=SIGN(1D0,EI+1D-6)/2D0
25520 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
25521 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
25522 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
25523 IF(MOD(I,2).EQ.0) THEN
25524 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
25525 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
25526 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
25527 & DCMPLX(T3I/XW/(TH-XML2))
25529 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
25530 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
25531 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
25532 & DCMPLX(T3I/XW/(TH-XML2))
25535 IF(IABS(I).GE.11) FCOL=3D0
25536 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
25537 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
25538 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
25539 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
25544 IF(IZID1.EQ.IZID2) THEN
25545 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25547 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
25548 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25553 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25554 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
25558 ELSEIF(ISUB.EQ.229) THEN
25559 C...q + qbar' -> ~chi0_1 + ~chi+-_1
25560 FACXX=COMFAC*AEM**2/6D0/XW**2
25563 WU2 = (UH-ZM12)*(UH-ZM22)
25564 WT2 = (TH-ZM12)*(TH-ZM22)
25565 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
25566 RT2I = 1D0/SQRT(2D0)
25567 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
25568 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
25570 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
25571 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
25574 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
25576 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
25577 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
25578 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
25579 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
25581 DO 2030 I=MMIN1,MMAX1
25583 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 2030
25585 T3I=SIGN(1D0,EI+1D-6)/2D0
25586 DO 2020 J=MMIN2,MMAX2
25588 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 2020
25589 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2020
25591 T3J=SIGN(1D0,EJ+1D-6)/2D0
25593 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25594 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25596 IF(KCHSUM.LT.0) KCHW=3
25597 IF(MOD(IA,2).EQ.0) THEN
25598 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
25599 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
25600 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
25601 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
25602 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25603 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
25606 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
25607 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
25608 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
25609 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
25610 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25611 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
25614 ZINTR=DBLE(QLR*DCONJG(QLL))
25615 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
25621 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25622 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25627 ELSEIF(ISUB.LE.240) THEN
25628 IF(ISUB.EQ.237) THEN
25629 C...q + qbar -> gluino + ~chi0_1
25630 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25631 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25632 FAC0=COMFAC*AS*AEM*4D0/9D0/XW
25635 DO 2040 I=MMINA,MMAXA
25636 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2040
25637 EI=KCHG(IABS(I),1)/3D0
25639 XLQC = -TANW*EI*ZMIX(IZID,1)
25640 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25641 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25644 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
25645 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
25646 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
25647 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
25648 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
25649 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25650 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
25651 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
25652 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
25653 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25658 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
25662 ELSEIF(ISUB.LE.250) THEN
25663 IF(ISUB.EQ.241) THEN
25664 C...q + qbar' -> ~chi+-_1 + gluino
25665 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
25668 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
25669 FAC0=UMIX(IZID,1)**2
25670 FAC1=VMIX(IZID,1)**2
25671 DO 2060 I=MMIN1,MMAX1
25673 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 2060
25674 DO 2050 J=MMIN2,MMAX2
25676 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 2050
25677 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2050
25679 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25680 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25682 IF(KCHSUM.LT.0) KCHW=3
25683 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
25684 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
25685 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
25686 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
25687 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
25688 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
25689 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
25690 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
25691 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
25692 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
25693 & SH/(TH-XMU2)/(UH-XMD2))/2D0
25698 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
25699 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25700 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25704 ELSEIF(ISUB.EQ.243) THEN
25705 C...q + qbar -> gluino + gluino
25706 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25709 DO 2070 I=MMINA,MMAXA
25710 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
25711 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2070
25713 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
25714 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
25715 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25716 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25717 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25718 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25719 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
25720 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
25721 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25722 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25723 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25724 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25728 C...1/2 for identical particles
25729 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
25732 ELSEIF(ISUB.EQ.244) THEN
25733 C...g + g -> gluino + gluino
25734 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25737 FACQQ1=COMFAC*AS**2*9D0/4D0*(
25738 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
25739 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
25740 FACQQ2=COMFAC*AS**2*9D0/4D0*(
25741 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
25742 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
25743 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
25744 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
25745 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 2080
25750 SIGH(NCHN)=FACQQ1/2D0
25755 SIGH(NCHN)=FACQQ2/2D0
25760 SIGH(NCHN)=FACQQ3/2D0
25763 ELSEIF(ISUB.EQ.246) THEN
25764 C...g + q_j -> ~chi0_1 + ~q_j
25765 FAC0=COMFAC*AS*AEM/6D0/XW
25768 FACZQ0=FAC0*( (ZM2-TH)/SH +
25769 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25770 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25771 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25772 DO 2100 I=-KFNSQ,KFNSQ,2*KFNSQ
25773 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 2100
25774 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2100
25775 EI=KCHG(IABS(I),1)/3D0
25777 XRQZ = -TANW*EI*ZMIX(IZID,1)
25778 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25779 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25781 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
25783 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
25789 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2090
25790 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2090
25793 ISIG(NCHN,3-ISDE)=21
25795 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25796 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25801 ELSEIF(ISUB.LE.260) THEN
25802 IF(ISUB.EQ.254) THEN
25803 C...g + q_j -> ~chi1_1 + ~q_i
25804 FAC0=COMFAC*AS*AEM/12D0/XW
25809 FACZQ0=FAC0*( (ZM2-TH)/SH +
25810 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25811 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25812 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
25813 IF(MOD(KFNSQ1,2).EQ.0) THEN
25820 DO 2120 I=-KFNSQ,KFNSQ,2*KFNSQ
25821 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 2120
25822 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2120
25824 IF(MOD(IA,2).EQ.0) THEN
25829 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
25833 IF(I.LT.0) KCHWQ=5-KCHW
25835 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2110
25836 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2110
25839 ISIG(NCHN,3-ISDE)=21
25841 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25842 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
25846 ELSEIF(ISUB.EQ.258) THEN
25847 C...g + q_j -> gluino + ~q_i
25854 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
25855 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
25856 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
25857 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
25858 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
25860 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
25861 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
25862 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
25863 FACQG1=COMFAC*AS**2*FACQG1/2D0
25864 FACQG2=COMFAC*AS**2*FACQG2/2D0
25865 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25866 DO 2140 I=-KFNSQ,KFNSQ,2*KFNSQ
25867 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 2140
25868 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 2140
25871 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25872 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25874 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2130
25875 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2130
25878 ISIG(NCHN,3-ISDE)=21
25880 SIGH(NCHN)=FACQG1*FACSEL
25883 ISIG(NCHN,3-ISDE)=21
25885 SIGH(NCHN)=FACQG2*FACSEL
25890 ELSEIF(ISUB.LE.270) THEN
25891 IF(ISUB.EQ.261) THEN
25892 C...q_i + q_ibar -> ~t_1 + ~t_1bar
25893 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
25894 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25895 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25897 DO 2150 I=MMIN1,MMAX1
25899 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2150
25900 IF(IA.GE.11.AND.IA.LE.18) THEN
25902 EJ=KCHG(KFNSQ,1)/3D0
25903 T3I=SIGN(1D0,EI)/2D0
25904 T3J=SIGN(1D0,EJ)/2D0
25905 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
25906 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
25907 XLF=2D0*(T3I-EI*XW)
25909 TAA=0.5D0*(EI*EJ)**2
25910 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
25911 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25912 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
25913 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25914 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
25920 SIGH(NCHN)=FACQQ1*FAC0
25923 ELSEIF(ISUB.EQ.263) THEN
25924 C...f + fbar -> ~t1 + ~t2bar
25925 DO 2160 I=MMIN1,MMAX1
25927 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2160
25928 EI=KCHG(IABS(I),1)/3D0
25929 TT3I=SIGN(1D0,EI)/2D0
25933 C...Color factor for e+ e-
25934 IF(IA.GE.11) FCOL=3D0
25935 XLQ=2D0*(TT3J-EJ*XW)
25937 XLF=2D0*(TT3I-EI*XW)
25939 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
25940 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
25941 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25942 C...Factor of 2 for t1 t2bar + t2 t1bar
25943 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
25944 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
25949 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25950 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
25955 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
25956 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25959 ELSEIF(ISUB.EQ.264) THEN
25960 C...g + g -> ~t_1 + ~t_1bar
25963 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
25964 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25965 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
25966 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
25967 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 2170
25981 ELSEIF(ISUB.LE.280) THEN
25982 IF(ISUB.EQ.271) THEN
25983 C...q + q' -> ~q + ~q' (~g exchange)
25984 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
25992 FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
25993 FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
25996 FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
25997 FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
25998 FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
26001 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
26002 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
26003 DO 2190 I=-KFNSQI,KFNSQI,2*KFNSQI
26004 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 2190
26006 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 2190
26009 DO 2180 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
26010 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 2180
26012 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 2180
26013 IF(I*J.LT.0) GOTO 2180
26018 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
26019 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
26022 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
26023 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
26025 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
26026 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
26027 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
26034 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
26035 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
26037 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
26038 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
26039 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
26045 ELSEIF(ISUB.EQ.274) THEN
26046 C...q + qbar' -> ~q + ~qbar'
26047 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
26051 C...Mrenna...Normalization.and.1/XMT
26052 FACQQ1=COMFAC*AS**2*2D0/9D0*(
26053 & (UH*TH-SQM3*SQM4)/XMT**2 )
26054 FACQQB=COMFAC*AS**2*2D0/9D0*(
26055 & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT))
26056 FACQQB=FACQQB+FACQQ1
26058 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
26061 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
26062 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
26063 DO 2210 I=-KFNSQI,KFNSQI,2*KFNSQI
26064 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 2210
26066 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 2210
26069 DO 2200 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
26070 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 2200
26072 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 2200
26073 IF(I*J.GT.0) GOTO 2200
26078 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
26079 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
26080 IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
26081 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
26085 ELSEIF(ISUB.EQ.277) THEN
26086 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
26087 C...if i .eq. j covered in 274
26088 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
26089 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
26091 DO 2220 I=MMIN1,MMAX1
26093 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
26094 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2220
26095 IF(IA.EQ.KFNSQ) GOTO 2220
26096 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
26098 EJ=KCHG(KFNSQ,1)/3D0
26100 T3I=SIGN(1D0,EI)/2D0
26102 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
26103 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
26105 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
26106 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
26108 XLF=2D0*(T3I-EI*XW)
26115 TAA=0.5D0*(EI*EJ)**2
26116 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
26117 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
26118 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
26119 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
26120 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
26121 ELSEIF(IA.LE.6) THEN
26122 FAC0=AS**2*8D0/9D0/2D0
26128 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
26131 ELSEIF(ISUB.EQ.279) THEN
26132 C...g + g -> ~q_j + ~q_jbar
26135 C...5=RKF because ~t ~tbar treated separately
26136 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
26137 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
26138 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
26139 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 2230
26144 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
26149 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
26155 ELSEIF(ISUB.LE.340) THEN
26157 ELSEIF(ISUB.LE.360) THEN
26159 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
26160 C...l + l -> H_L++/-- or H_R++/--.
26162 KFREC=PYCOMP(KFRES)
26163 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
26165 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
26166 DO 2250 I=MMIN1,MMAX1
26168 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
26170 DO 2240 J=MMIN2,MMAX2
26172 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
26174 IF(I*J.LT.0) GOTO 2240
26175 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26180 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
26181 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
26182 SIGH(NCHN)=HI*FACBW*HF
26186 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
26187 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
26189 KFREC=PYCOMP(KFRES)
26190 C...Propagators: as simulated in PYOFSH and as desired
26191 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
26192 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
26193 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
26194 GMMC=SQRT(SQM3)*WDTP(0)
26195 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
26196 FHCC=COMFAC*AEM*HBW3C/HBW3
26197 DO 2270 I=MMINA,MMAXA
26199 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 2270
26201 J=ISIGN(KFPR(ISUB,2),-I)
26202 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
26203 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
26204 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
26206 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
26207 & (TH-SQM4)*SH)/(TH-SQM4)**2
26208 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
26210 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
26211 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
26212 & ((UH-SQM3)*(TH-SQM4))
26213 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
26214 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
26215 & ((UH-SQM3)*(SH-SQML))
26216 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
26217 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
26218 & ((SH-SQML)*(TH-SQM4))
26219 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
26220 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
26222 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 2260
26223 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 2260
26226 ISIG(NCHN,3-ISDE)=22
26228 SIGH(NCHN)=FHCC*SMM*WIDSC
26232 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
26233 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
26235 KFREC=PYCOMP(KFRES)
26236 SQMH=PMAS(KFREC,1)**2
26237 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
26238 C...Propagators: H++/-- as simulated in PYOFSH and as desired
26239 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
26240 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
26241 GMMH3=SQRT(SQM3)*WDTP(0)
26242 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
26243 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
26244 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
26245 GMMH4=SQRT(SQM4)*WDTP(0)
26246 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
26247 C...Kinematical and coupling functions
26248 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
26249 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
26250 C...Loop over allowed flavours
26251 DO 2280 I=MMINA,MMAXA
26252 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2280
26253 EI=KCHG(IABS(I),1)/3D0
26254 AI=SIGN(1D0,EI+0.1D0)
26257 IF(IABS(I).LE.10) FCOI=FACA/3D0
26258 IF(ISUB.EQ.349) THEN
26259 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
26260 IF(IABS(I).LT.10) THEN
26261 DSIGHH=8D0*AEM**2*(EI**2/SH2+
26262 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
26263 & (VI**2+AI**2)*XWHH**2*HBWZ)
26265 IAOFF=181+3*((IABS(I)-11)/2)
26266 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
26268 DSIGHH=8D0*AEM**2*(EI**2/SH2+
26269 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
26270 & (VI**2+AI**2)*XWHH**2*HBWZ)+
26271 & 8D0*AEM*(EI*HSUM/(SH*TH)+
26272 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
26276 IF(IABS(I).LT.10) THEN
26277 DSIGHH=8D0*AEM**2*EI**2/SH2
26279 IAOFF=181+3*((IABS(I)-11)/2)
26280 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
26282 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
26290 SIGH(NCHN)=FACHH*FCOI*DSIGHH
26293 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
26294 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
26296 KFREC=PYCOMP(KFRES)
26297 SQMH=PMAS(KFREC,1)**2
26298 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
26299 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
26300 & PMAS(PYCOMP(9900024),1)**2
26301 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
26302 FACPRT=1D0/((VINT(204)**2-VINT(215))*
26303 & (VINT(209)**2-VINT(216)))
26304 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
26305 & (VINT(209)**2+2D0*VINT(218)))
26306 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
26308 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
26309 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
26311 DO 2300 I=MMIN1,MMAX1
26312 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2300
26313 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 2300
26314 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
26315 DO 2290 J=MMIN2,MMAX2
26316 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2290
26317 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 2290
26318 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
26320 IF(IABS(KCHH).NE.2) GOTO 2290
26321 FACLR=VINT(180+I)*VINT(180+J)
26322 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
26323 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
26324 FACPRP=0.5D0*(FACPRT+FACPRU)**2
26332 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
26336 ELSEIF(ISUB.EQ.353) THEN
26337 C...f + fbar -> Z_R0
26338 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
26339 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
26341 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
26342 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26343 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
26344 DO 2310 I=MMINA,MMAXA
26345 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2310
26346 IF(IABS(I).LE.8) THEN
26347 EI=KCHG(IABS(I),1)/3D0
26348 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
26349 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
26354 HI=HP*(VI**2+AI**2)
26355 IF(IABS(I).LE.10) HI=HI*FACA/3D0
26360 SIGH(NCHN)=HI*FACBW*HF
26363 ELSEIF(ISUB.EQ.354) THEN
26364 C...f + fbar' -> W_R+/-
26365 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
26366 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
26368 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
26369 HP=AEM/(24D0*XW)*SH
26370 DO 2330 I=MMIN1,MMAX1
26371 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2330
26373 DO 2320 J=MMIN2,MMAX2
26374 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2320
26376 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2320
26377 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26379 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26381 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
26386 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
26387 SIGH(NCHN)=HI*FACBW*HF
26392 ELSEIF(ISUB.LE.380) THEN
26394 IF(ISUB.EQ.361) THEN
26395 C...f + fbar -> W_L W_L, W_L pi_tc, pi_tc pi_tc
26396 FACA=(SH**2*BE34**2-(TH-UH)**2)
26397 ALPRHT=2.91D0*(3D0/PARP(144))
26398 HP=(1D0/12D0)*AEM*ALPRHT*CAB2*COMFAC*FACA*3D0
26399 FAR=SQRT(AEM/ALPRHT)
26407 CALL PYWIDT(23,SH,WDTP,WDTE)
26408 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26409 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26410 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26411 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26412 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26413 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26414 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26415 DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26416 DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26418 DO 2340 I=MMINA,MMAXA
26419 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2340
26421 EI=KCHG(IABS(I),1)/3D0
26422 AI=SIGN(1D0,EI+0.1D0)
26424 VALI=0.25D0*(VI+AI)
26425 VARI=0.25D0*(VI-AI)
26426 F2L=EI*DARHO+VALI*DZRHO/SQRT(XW*XW1)
26427 F2R=EI*DARHO+VARI*DZRHO/SQRT(XW*XW1)
26428 HI=ABS(F2L)**2+ABS(F2R)**2
26429 IF(IA.LE.10) HI=HI/3D0
26434 IF(KFA.EQ.KFB) THEN
26435 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
26437 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26442 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26446 ELSEIF(ISUB.EQ.364) THEN
26447 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
26449 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)/SQTV*SH
26450 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*SH
26452 ALPRHT=2.91D0*(3D0/PARP(144))
26453 HP=(1D0/24D0)*AEM**2*COMFAC*3D0
26454 FAR=SQRT(AEM/ALPRHT)
26462 CALL PYWIDT(23,SH,WDTP,WDTE)
26463 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26464 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26465 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26466 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26467 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26468 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26469 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26470 DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26471 DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26472 DAOME=(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)/DETD/SH
26473 DZOME=(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH
26475 DO 2350 I=MMINA,MMAXA
26476 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2350
26478 EI=KCHG(IABS(I),1)/3D0
26479 AI=SIGN(1D0,EI+0.1D0)
26481 VALI=0.25D0*(VI+AI)
26482 VARI=0.25D0*(VI-AI)
26483 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
26484 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
26485 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
26486 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
26487 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
26488 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
26489 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
26490 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
26491 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
26492 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
26494 IF(IA.LE.10) HI=HI/3D0
26499 IF(ISUBSV.NE.368) THEN
26500 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
26502 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26507 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26511 ELSEIF(ISUB.EQ.370) THEN
26512 C...f + fbar' -> W_L Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
26514 FACA=(SH**2*BE34**2-(TH-UH)**2)
26515 ALPRHT=2.91D0*(3D0/PARP(144))
26516 HP=(1D0/24D0)*AEM*ALPRHT*CAB2*COMFAC*FACA*3D0/XW
26518 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26519 CALL PYWIDT(24,SH,WDTP,WDTE)
26520 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26521 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26522 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26524 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26525 HP=HP*FWR**2/ABS(DETD)**2/SH**2
26527 DO 2370 I=MMIN1,MMAX1
26528 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2370
26530 DO 2360 J=MMIN2,MMAX2
26531 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2360
26533 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2360
26534 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26536 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26538 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26543 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26544 & WIDS(PYCOMP(KFB),2)
26548 ELSEIF(ISUB.EQ.374) THEN
26549 C...f + fbar' -> gamma pi_tc
26550 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)/SQTV*VRGP**2
26551 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*ARGP**2
26553 ALPRHT=2.91D0*(3D0/PARP(144))
26554 HP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*(VFAC+AFAC)*SH
26556 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26557 CALL PYWIDT(24,SH,WDTP,WDTE)
26558 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26559 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26560 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26562 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26563 HP=HP*FWR**2/ABS(DETD)**2/SH**2
26565 DO 2390 I=MMIN1,MMAX1
26566 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2390
26568 DO 2380 J=MMIN2,MMAX2
26569 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2380
26571 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2380
26572 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26574 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26576 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26581 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26582 & WIDS(PYCOMP(KFB),2)
26588 ELSEIF(ISUB.LE.400) THEN
26590 IF(ISUB.EQ.391) THEN
26591 C...f + fbar -> G*.
26592 KFGSTR=KFPR(ISUB,1)
26593 KCGSTR=PYCOMP(KFGSTR)
26594 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
26596 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26597 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
26598 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
26599 DO 2400 I=MMINA,MMAXA
26600 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2400
26602 IF(IABS(I).LE.10) HI=HI*FACA/3D0
26610 ELSEIF(ISUB.EQ.392) THEN
26612 KFGSTR=KFPR(ISUB,1)
26613 KCGSTR=PYCOMP(KFGSTR)
26614 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
26616 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26617 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
26618 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
26619 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 2410
26627 ELSEIF(ISUB.EQ.393) THEN
26628 C...q + qbar -> g + G*.
26629 KFGSTR=KFPR(ISUB,2)
26630 KCGSTR=PYCOMP(KFGSTR)
26631 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
26632 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
26633 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
26635 C...Propagators: as simulated in PYOFSH and as desired
26636 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
26637 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
26638 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
26639 HS=SQRT(SQM4)*WDTP(0)
26640 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26641 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
26642 FACG=FACG*HBW4C/HBW4
26643 DO 2420 I=MMINA,MMAXA
26644 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26645 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2420
26653 ELSEIF(ISUB.EQ.394) THEN
26654 C...q + g -> q + G*.
26655 KFGSTR=KFPR(ISUB,2)
26656 KCGSTR=PYCOMP(KFGSTR)
26657 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
26658 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
26659 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
26660 & 2D0*TH2*TH/(UH*SH2))
26661 C...Propagators: as simulated in PYOFSH and as desired
26662 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
26663 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
26664 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
26665 HS=SQRT(SQM4)*WDTP(0)
26666 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26667 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
26668 FACG=FACG*HBW4C/HBW4
26669 DO 2440 I=MMINA,MMAXA
26670 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2440
26672 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2430
26673 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2430
26676 ISIG(NCHN,3-ISDE)=21
26682 ELSEIF(ISUB.EQ.395) THEN
26683 C...g + g -> g + G*.
26684 KFGSTR=KFPR(ISUB,2)
26685 KCGSTR=PYCOMP(KFGSTR)
26686 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
26687 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
26688 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
26689 C...Propagators: as simulated in PYOFSH and as desired
26690 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
26691 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
26692 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
26693 HS=SQRT(SQM4)*WDTP(0)
26694 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26695 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
26696 FACG=FACG*HBW4C/HBW4
26697 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
26708 C...Multiply with parton distributions
26709 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
26710 DO 2450 ICHN=1,NCHN
26711 IF(MINT(45).GE.2) THEN
26713 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
26715 IF(MINT(46).GE.2) THEN
26717 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
26719 SIGS=SIGS+SIGH(ICHN)
26726 C*********************************************************************
26729 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
26730 C...parton distributions according to a few different parametrizations.
26731 C...Note that what is coded is x times the probability distribution,
26732 C...i.e. xq(x,Q2) etc.
26734 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
26736 C...Double precision and integer declarations.
26737 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26738 IMPLICIT INTEGER(I-N)
26739 INTEGER PYK,PYCHGE,PYCOMP
26741 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26742 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26743 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26744 COMMON/PYINT1/MINT(400),VINT(400)
26745 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
26747 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
26749 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
26750 &XPPI(-6:6),XPPR(-6:6)
26752 C...Interface to PDFLIB.
26753 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
26755 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
26756 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
26757 CHARACTER*20 PARM(20)
26758 DATA VALUE/20*0D0/,PARM/20*' '/
26760 C...Data related to Schuler-Sjostrand photon distributions.
26761 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
26763 C...Reset parton distributions.
26769 C...Check x and particle species.
26770 IF(X.LE.0D0.OR.X.GE.1D0) THEN
26771 WRITE(MSTU(11),5000) X
26775 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
26776 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
26777 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
26778 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
26779 &KFA.NE.310.AND.KFA.NE.130) THEN
26780 WRITE(MSTU(11),5100) KF
26784 C...Electron (or muon or tau) parton distribution call.
26785 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
26786 CALL PYPDEL(KFA,X,Q2,XPEL)
26791 C...Photon parton distribution call (VDM+anomalous).
26792 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
26793 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
26794 CALL PYPDGA(X,Q2,XPGA)
26798 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
26801 IF(MSTP(55).GE.7) P2MX=4.0D0
26802 IF(MSTP(57).EQ.0) Q2MX=P2MX
26804 IF(VINT(120).LT.0D0) P2=VINT(120)**2
26805 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
26810 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
26813 IF(MSTP(55).GE.11) P2MX=4.0D0
26814 IF(MSTP(57).EQ.0) Q2MX=P2MX
26816 IF(VINT(120).LT.0D0) P2=VINT(120)**2
26817 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
26819 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
26822 ELSEIF(MSTP(56).EQ.2) THEN
26823 C...Call PDFLIB parton distributions.
26827 VALUE(2)=MSTP(55)/1000
26829 VALUE(3)=MOD(MSTP(55),1000)
26830 IF(MINT(93).NE.3000000+MSTP(55)) THEN
26831 CALL PDFSET(PARM,VALUE)
26832 MINT(93)=3000000+MSTP(55)
26835 QQ2=MAX(0D0,Q2MIN,Q2)
26836 IF(MSTP(57).EQ.0) QQ2=Q2MIN
26838 IF(VINT(120).LT.0D0) P2=VINT(120)**2
26840 IF(MSTP(55).EQ.5004) THEN
26841 IF(5D0*P2.LT.QQ2.AND.
26842 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
26843 & P2.GE.0D0.AND.P2.LT.10D0.AND.
26844 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
26845 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
26860 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
26889 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
26892 C...Pion/gammaVDM parton distribution call.
26893 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
26894 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
26895 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
26896 & MSTP(55).LE.12) THEN
26897 ISET=1+MOD(MSTP(55)-1,4)
26900 IF(ISET.GE.3) P2MX=4.0D0
26901 IF(MSTP(57).EQ.0) Q2MX=P2MX
26903 IF(VINT(120).LT.0D0) P2=VINT(120)**2
26904 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
26906 XPQ(KFL)=XPVMD(KFL)
26909 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
26910 CALL PYPDPI(X,Q2,XPPI)
26914 ELSEIF(MSTP(54).EQ.2) THEN
26915 C...Call PDFLIB parton distributions.
26919 VALUE(2)=MSTP(53)/1000
26921 VALUE(3)=MOD(MSTP(53),1000)
26922 IF(MINT(93).NE.2000000+MSTP(53)) THEN
26923 CALL PDFSET(PARM,VALUE)
26924 MINT(93)=2000000+MSTP(53)
26927 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
26928 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
26929 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
26945 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
26948 C...Anomalous photon parton distribution call.
26949 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
26952 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
26953 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
26954 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
26955 IF(MSTP(57).EQ.0) Q2MX=P2MX
26957 IF(VINT(120).LT.0D0) P2=VINT(120)**2
26958 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
26960 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
26963 ELSEIF(MSTP(56).EQ.1) THEN
26964 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
26965 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
26966 IF(MSTP(57).EQ.0) Q2MX=P2MX
26968 IF(VINT(120).LT.0D0) P2=VINT(120)**2
26969 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
26971 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
26974 ELSEIF(MSTP(56).EQ.2) THEN
26975 IF(MSTP(57).EQ.0) Q2MX=P2MX
26976 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
26981 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
26982 IF(MSTP(57).EQ.0) Q2MX=P2MX
26983 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
26989 210 RKF=11D0*PYR(0)
26991 IF(RKF.GT.1D0) KFR=2
26992 IF(RKF.GT.5D0) KFR=3
26993 IF(RKF.GT.6D0) KFR=4
26994 IF(RKF.GT.10D0) KFR=5
26995 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
26996 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
26997 IF(MSTP(57).EQ.0) Q2MX=P2MX
26998 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
27005 C...Proton parton distribution call.
27007 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
27008 CALL PYPDPR(X,Q2,XPPR)
27012 ELSEIF(MSTP(52).EQ.2) THEN
27013 C...Call PDFLIB parton distributions.
27017 VALUE(2)=MSTP(51)/1000
27019 VALUE(3)=MOD(MSTP(51),1000)
27020 IF(MINT(93).NE.1000000+MSTP(51)) THEN
27022 CALL PDFSET_ALICE(PARM,VALUE)
27023 MINT(93)=1000000+MSTP(51)
27026 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27027 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27030 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27046 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
27050 C...Isospin average for pi0/gammaVDM.
27051 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
27052 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
27057 XPS=0.5D0*(XPQ(1)+XPQ(-2))
27058 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
27062 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
27063 XPQ(1)=XPQ(1)+0.2D0*XPV
27064 XPQ(-1)=XPQ(-1)+0.2D0*XPV
27065 XPQ(2)=XPQ(2)+0.8D0*XPV
27066 XPQ(-2)=XPQ(-2)+0.8D0*XPV
27067 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
27069 XPQ(-3)=XPQ(-3)+XPV
27070 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
27072 XPQ(-4)=XPQ(-4)+XPV
27073 IF(MSTP(55).GE.9) THEN
27079 XPQ(1)=XPQ(1)+0.5D0*XPV
27080 XPQ(-1)=XPQ(-1)+0.5D0*XPV
27081 XPQ(2)=XPQ(2)+0.5D0*XPV
27082 XPQ(-2)=XPQ(-2)+0.5D0*XPV
27085 C...Rescale for gammaVDM by effective gamma -> rho coupling.
27086 C+++Do not rescale?
27087 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
27088 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
27090 XPQ(KFL)=VINT(281)*XPQ(KFL)
27092 VINT(232)=VINT(281)*XPV
27095 C...Simple recipes for kaons.
27096 ELSEIF(KFA.EQ.321) THEN
27097 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
27099 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
27100 XPS=0.5D0*(XPQ(1)+XPQ(-2))
27101 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
27104 XPQ(1)=XPQ(1)+0.5D0*XPV
27105 XPQ(-1)=XPQ(-1)+0.5D0*XPV
27106 XPQ(3)=XPQ(3)+0.5D0*XPV
27107 XPQ(-3)=XPQ(-3)+0.5D0*XPV
27109 C...Isospin conjugation for neutron.
27110 ELSEIF(KFA.EQ.2112) THEN
27118 C...Simple recipes for hyperon (average valence parton distribution).
27119 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
27120 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
27121 XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
27122 XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
27127 XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
27128 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
27129 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
27132 C...Charge conjugation for antiparticle.
27135 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
27142 C...Allow gluon also in position 21.
27145 C...Check positivity and reset above maximum allowed flavour.
27147 XPQ(KFL)=MAX(0D0,XPQ(KFL))
27148 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
27151 C...Formats for error printouts.
27152 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
27153 5100 FORMAT(' Error: illegal particle code for parton distribution;',
27155 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
27161 C*********************************************************************
27164 C...Gives proton parton distribution at small x and/or Q^2 according to
27165 C...correct limiting behaviour.
27167 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
27169 C...Double precision and integer declarations.
27170 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27171 IMPLICIT INTEGER(I-N)
27172 INTEGER PYK,PYCHGE,PYCOMP
27174 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27175 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27176 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27177 COMMON/PYINT1/MINT(400),VINT(400)
27178 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27180 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
27181 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
27183 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
27187 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
27188 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
27189 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
27191 CALL PYPDFU(KF,X,Q2,XPQ)
27195 C...Reset. Check x.
27199 IF(X.LE.0D0.OR.X.GE.1D0) THEN
27200 WRITE(MSTU(11),5000) X
27204 C...Define valence content.
27208 IF(KF.EQ.2212) THEN
27211 ELSEIF(KF.EQ.-2212) THEN
27214 ELSEIF(KF.EQ.2112) THEN
27217 ELSEIF(KF.EQ.-2112) THEN
27220 ELSEIF(KF.EQ.211) THEN
27224 ELSEIF(KF.EQ.-211) THEN
27228 ELSEIF(MINT(105).LE.223) THEN
27233 ELSEIF(MINT(105).EQ.333) THEN
27238 ELSEIF(MINT(105).EQ.443) THEN
27245 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
27246 CALL PYPDFU(KFC,X,Q2,XPA)
27247 Q2MN=MAX(3D0,VINT(231))
27248 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
27249 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
27251 C...Large Q2 and large x: naive call is enough.
27252 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
27258 C...Small Q2 and large x: dampen boundary value.
27259 ELSEIF(X.GT.XMN) THEN
27261 C...Evaluate at boundary and define dampening factors.
27262 CALL PYPDFU(KFC,X,Q2MN,XPA)
27263 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
27264 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
27266 C...Separate valence and sea parts of parton distribution.
27268 XFV1=XPA(KFV1)-XPA(-KFV1)
27269 XPA(KFV1)=XPA(-KFV1)
27270 XFV2=XPA(KFV2)-XPA(-KFV2)
27271 XPA(KFV2)=XPA(-KFV2)
27273 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
27274 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
27275 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
27276 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
27279 C...Dampen valence and sea separately. Put back together.
27281 XPQ(KFL)=FS*XPA(KFL)
27284 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
27285 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
27287 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
27288 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
27289 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
27290 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
27294 C...Large Q2 and small x: interpolate behaviour.
27295 ELSEIF(Q2.GT.Q2MN) THEN
27297 C...Evaluate at extremes and define coefficients for interpolation.
27298 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
27300 CALL PYPDFU(KFC,X,Q2B,XPB)
27302 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
27303 FVA=(X/XMN)**0.45D0*FLA
27304 FSA=(X/XMN)**(-0.08D0)*FLA
27307 C...Separate valence and sea parts of parton distribution.
27309 XFVA1=XPA(KFV1)-XPA(-KFV1)
27310 XPA(KFV1)=XPA(-KFV1)
27311 XFVA2=XPA(KFV2)-XPA(-KFV2)
27312 XPA(KFV2)=XPA(-KFV2)
27313 XFVB1=XPB(KFV1)-XPB(-KFV1)
27314 XPB(KFV1)=XPB(-KFV1)
27315 XFVB2=XPB(KFV2)-XPB(-KFV2)
27316 XPB(KFV2)=XPB(-KFV2)
27318 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
27319 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
27320 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
27321 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
27322 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
27323 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
27324 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
27325 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
27328 C...Interpolate for valence and sea. Put back together.
27330 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
27333 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
27334 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
27336 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
27337 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
27338 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
27339 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
27343 C...Small Q2 and small x: dampen boundary value and add term.
27346 C...Evaluate at boundary and define dampening factors.
27347 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
27348 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
27350 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
27351 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
27352 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
27353 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
27354 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
27355 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
27357 C...Separate valence and sea parts of parton distribution.
27359 XFV1=XPA(KFV1)-XPA(-KFV1)
27360 XPA(KFV1)=XPA(-KFV1)
27361 XFV2=XPA(KFV2)-XPA(-KFV2)
27362 XPA(KFV2)=XPA(-KFV2)
27364 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
27365 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
27366 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
27367 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
27370 C...Dampen valence and sea separately. Add constant terms.
27371 C...Put back together.
27373 XPQ(KFL)=FSA*XPA(KFL)
27377 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
27379 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
27380 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
27383 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
27385 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
27386 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
27387 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
27388 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
27394 C...Format for error printout.
27395 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
27400 C*********************************************************************
27403 C...Gives electron (or muon, or tau) parton distribution.
27405 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
27407 C...Double precision and integer declarations.
27408 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27409 IMPLICIT INTEGER(I-N)
27410 INTEGER PYK,PYCHGE,PYCOMP
27412 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27413 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27414 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27415 COMMON/PYINT1/MINT(400),VINT(400)
27416 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27418 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
27420 C...Interface to PDFLIB.
27421 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
27423 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
27424 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
27425 CHARACTER*20 PARM(20)
27426 DATA VALUE/20*0D0/,PARM/20*' '/
27428 C...Some common constants.
27434 IF(KFA.EQ.13) PME=PMAS(13,1)
27435 IF(KFA.EQ.15) PME=PMAS(15,1)
27436 XL=LOG(MAX(1D-10,X))
27437 X1L=LOG(MAX(1D-10,1D0-X))
27438 HLE=LOG(MAX(3D0,Q2/PME**2))
27439 HBE2=(AEM/PARU(1))*(HLE-1D0)
27441 C...Electron inside electron, see R. Kleiss et al., in Z physics at
27442 C...LEP 1, CERN 89-08, p. 34
27443 IF(MSTP(59).LE.1) THEN
27444 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
27445 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
27446 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
27447 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
27448 & 4D0*XL/(1D0-X)-5D0-X)
27450 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
27451 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
27452 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
27454 C...Zero distribution for very large x and rescale it for intermediate.
27455 IF(X.GT.1D0-1D-10) THEN
27457 ELSEIF(X.GT.1D0-1D-7) THEN
27458 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
27462 C...Photon and (transverse) W- inside electron.
27463 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
27464 IF(MSTP(13).LE.1) THEN
27467 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
27469 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
27470 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
27471 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
27473 C...Electron or positron inside photon inside electron.
27474 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
27475 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
27476 & 2D0*X*(1D0+X)*XL)
27477 XPEL(11)=XPEL(11)+XFSEA
27480 C...Initialize PDFLIB photon parton distributions.
27481 IF(MSTP(56).EQ.2) THEN
27485 VALUE(2)=MSTP(55)/1000
27487 VALUE(3)=MOD(MSTP(55),1000)
27488 IF(MINT(93).NE.3000000+MSTP(55)) THEN
27489 CALL PDFSET(PARM,VALUE)
27490 MINT(93)=3000000+MSTP(55)
27494 C...Quarks and gluons inside photon inside electron:
27495 C...numerical convolution required.
27504 IF(ITER.EQ.0) NSTP=2
27506 SXP(KFL)=0.5D0*SXP(KFL)
27509 IF(ITER.EQ.0) WTSTP=0.5D0
27510 C...Pick grid of x_{gamma} values logarithmically even.
27515 XLE=XL*(ISTP-0.5D0)/NSTP
27517 XE=MIN(1D0-1D-10,EXP(XLE))
27518 XG=MIN(1D0-1D-10,X/XE)
27519 C...Evaluate photon inside electron parton distribution for convolution.
27520 XPGP=1D0+(1D0-XE)**2
27521 IF(MSTP(13).LE.1) THEN
27524 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
27526 C...Evaluate photon parton distributions for convolution.
27527 IF(MSTP(56).EQ.1) THEN
27528 CALL PYPDGA(XG,Q2,XPGA)
27530 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
27532 ELSEIF(MSTP(56).EQ.2) THEN
27533 C...Call PDFLIB parton distributions.
27535 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27536 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27537 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27538 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
27539 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
27540 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
27541 SXP(3)=SXP(3)+WTSTP*XPGP*STR
27542 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
27543 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
27544 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
27547 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
27548 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
27549 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
27551 C...Put convolution into output arrays.
27553 XPEL(0)=FCONV*SXP(0)
27555 XPEL(KFL)=FCONV*SXP(KFL)
27556 XPEL(-KFL)=XPEL(KFL)
27563 C*********************************************************************
27566 C...Gives photon parton distribution.
27568 SUBROUTINE PYPDGA(X,Q2,XPGA)
27570 C...Double precision and integer declarations.
27571 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27572 IMPLICIT INTEGER(I-N)
27573 INTEGER PYK,PYCHGE,PYCOMP
27575 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27576 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27577 COMMON/PYINT1/MINT(400),VINT(400)
27578 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
27580 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
27581 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
27582 &DGCS(4,3),DGDS(4,3),DGES(4,3)
27584 C...The following data lines are coefficients needed in the
27585 C...Drees and Grassie photon parton distribution parametrization.
27586 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
27587 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
27588 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
27589 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
27590 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
27591 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
27592 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
27593 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
27594 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
27595 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
27596 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
27597 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
27598 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
27599 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
27600 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
27601 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
27602 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
27603 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
27604 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
27605 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
27606 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
27607 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
27608 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
27609 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
27610 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
27611 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
27613 C...Photon parton distribution from Drees and Grassie.
27614 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
27619 IF(MSTP(57).LE.0) THEN
27622 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
27626 IF(Q2.GT.25D0) NF=4
27627 IF(Q2.GT.300D0) NF=5
27631 C...Evaluate gluon content.
27632 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
27633 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
27634 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
27635 XPGL=DGA*X**DGB*X1**DGC
27637 C...Evaluate up- and down-type quark content.
27638 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
27639 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
27640 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
27641 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
27642 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
27643 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
27644 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
27645 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
27646 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
27647 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
27648 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
27650 IF(NF.EQ.4) DGF=10D0
27651 IF(NF.EQ.5) DGF=55D0/6D0
27652 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
27654 XPQU=(XPQS+9D0*XPQN)/6D0
27655 XPQD=(XPQS-4.5D0*XPQN)/6D0
27656 ELSEIF(NF.EQ.4) THEN
27657 XPQU=(XPQS+6D0*XPQN)/8D0
27658 XPQD=(XPQS-6D0*XPQN)/8D0
27660 XPQU=(XPQS+7.5D0*XPQN)/10D0
27661 XPQD=(XPQS-5D0*XPQN)/10D0
27664 C...Put into output arrays.
27669 IF(NF.GE.4) XPGA(4)=AEM*XPQU
27670 IF(NF.GE.5) XPGA(5)=AEM*XPQD
27672 XPGA(-KFL)=XPGA(KFL)
27678 C*********************************************************************
27681 C...Constructs the F2 and parton distributions of the photon
27682 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
27683 C...For F2, c and b are included by the Bethe-Heitler formula;
27684 C...in the 'MSbar' scheme additionally a Cgamma term is added.
27685 C...Contains the SaS sets 1D, 1M, 2D and 2M.
27686 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
27688 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
27690 C...Double precision and integer declarations.
27691 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27692 IMPLICIT INTEGER(I-N)
27693 INTEGER PYK,PYCHGE,PYCOMP
27695 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
27697 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
27698 SAVE /PYINT8/,/PYINT9/
27700 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
27701 C...Charm and bottom masses (low to compensate for J/psi etc.).
27702 DATA PMC/1.3D0/, PMB/4.6D0/
27703 C...alpha_em and alpha_em/(2*pi).
27704 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
27705 C...Lambda value for 4 flavours.
27707 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
27709 C...VMD couplings f_V**2/(4*pi).
27710 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
27711 C...Masses for rho (=omega) and phi.
27712 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
27713 C...Number of points in integration for IP2=1.
27731 C...Set Q0 cut-off parameter as function of set used.
27739 C...Scale choice for off-shell photon; common factors.
27744 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
27745 FACNOR=LOG(Q2/Q02)/NSTEP
27746 ELSEIF(IP2.EQ.2) THEN
27748 ELSEIF(IP2.EQ.3) THEN
27750 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
27751 ELSEIF(IP2.EQ.4) THEN
27752 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
27753 & ((Q2+P2)*(Q02+P2)))
27754 ELSEIF(IP2.EQ.5) THEN
27755 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
27756 & ((Q2+P2)*(Q02+P2)))
27757 P2MX=Q0*SQRT(P2MXA)
27758 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
27759 ELSEIF(IP2.EQ.6) THEN
27760 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
27761 & ((Q2+P2)*(Q02+P2)))
27762 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
27764 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
27765 & ((Q2+P2)*(Q02+P2)))
27766 P2MX=Q0*SQRT(P2MXA)
27768 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
27769 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
27770 IF(ABS(Q2-Q02).GT.1D-6) THEN
27771 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
27772 ELSEIF(P2.LT.Q02) THEN
27773 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
27779 C...Call VMD parametrization for d quark and use to give rho, omega,
27780 C...phi. Note dipole dampening for off-shell photon.
27781 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
27785 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
27786 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
27788 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
27790 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
27791 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
27792 XPVMD(3)=XPVMD(3)+FACS*XFVAL
27793 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
27794 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
27795 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
27796 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
27797 VXPVMD(2)=FRACU*FACUD*XFVAL
27798 VXPVMD(3)=FACS*XFVAL
27799 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
27800 VXPVMD(-2)=FRACU*FACUD*XFVAL
27801 VXPVMD(-3)=FACS*XFVAL
27804 C...Anomalous parametrizations for different strategies
27805 C...for off-shell photons; except full integration.
27807 C...Call anomalous parametrization for d + u + s.
27808 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
27810 XPANL(KFL)=FACNOR*XPGA(KFL)
27811 VXPANL(KFL)=FACNOR*VXPGA(KFL)
27814 C...Call anomalous parametrization for c and b.
27815 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
27817 XPANH(KFL)=FACNOR*XPGA(KFL)
27818 VXPANH(KFL)=FACNOR*VXPGA(KFL)
27820 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
27822 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
27823 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
27827 C...Special option: loop over flavours and integrate over k2.
27829 DO 160 ISTEP=1,NSTEP
27830 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
27831 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
27832 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
27833 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
27834 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
27835 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
27836 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
27838 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
27839 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
27840 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
27841 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
27847 C...Call Bethe-Heitler term expression for charm and bottom.
27848 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
27851 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
27855 C...For MSbar subtraction call C^gamma term expression for d, u, s.
27856 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
27857 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
27859 XPDIR(KFL)=XPGA(KFL)
27863 C...Store result in output array.
27866 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
27867 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
27868 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
27869 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
27870 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
27876 C*********************************************************************
27879 C...Evaluates the VMD parton distributions of a photon,
27880 C...evolved homogeneously from an initial scale P2 to Q2.
27881 C...Does not include dipole suppression factor.
27882 C...ISET is parton distribution set, see above;
27883 C...additionally ISET=0 is used for the evolution of an anomalous photon
27884 C...which branched at a scale P2 and then evolved homogeneously to Q2.
27885 C...ALAM is the 4-flavour Lambda, which is automatically converted
27886 C...to 3- and 5-flavour equivalents as needed.
27887 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
27889 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
27891 C...Double precision and integer declarations.
27892 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27893 IMPLICIT INTEGER(I-N)
27894 INTEGER PYK,PYCHGE,PYCOMP
27895 C...Local arrays and data.
27896 DIMENSION XPGA(-6:6), VXPGA(-6:6)
27897 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
27906 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
27907 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
27908 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
27909 P2EFF=MAX(P2,1.2D0*ALAM3**2)
27910 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
27911 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
27912 Q2EFF=MAX(Q2,P2EFF)
27914 C...Find number of flavours at lower and upper scale.
27916 IF(P2EFF.LT.PMC**2) NFP=3
27917 IF(P2EFF.GT.PMB**2) NFP=5
27919 IF(Q2EFF.LT.PMC**2) NFQ=3
27920 IF(Q2EFF.GT.PMB**2) NFQ=5
27922 C...Find s as sum of 3-, 4- and 5-flavour parts.
27926 IF(NFQ.EQ.3) Q2DIV=Q2EFF
27927 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
27929 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
27931 IF(NFP.EQ.3) P2DIV=PMC**2
27933 IF(NFQ.EQ.5) Q2DIV=PMB**2
27934 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
27938 IF(NFP.EQ.5) P2DIV=P2EFF
27939 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
27942 C...Calculate frequent combinations of x and s.
27949 C...Evaluate homogeneous anomalous parton distributions below or
27950 C...above threshold.
27952 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
27953 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
27954 XVAL = X * 1.5D0 * (X**2+X1**2)
27958 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
27959 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
27960 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
27961 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
27962 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
27963 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
27964 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
27965 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
27966 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
27967 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
27968 & (2D0*X-1D0)*X*XL**2)
27971 C...Evaluate set 1D parton distributions below or above threshold.
27972 ELSEIF(ISET.EQ.1) THEN
27973 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
27974 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
27975 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
27976 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
27977 XSEA = 0.100D0 * X1**3.76D0
27979 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
27980 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
27981 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
27982 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
27983 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
27984 & X**0.40D0 * X1**(1.76D0+3D0*S)
27985 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
27986 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
27987 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
27988 XSEA0 = 0.100D0 * X1**3.76D0
27991 C...Evaluate set 1M parton distributions below or above threshold.
27992 ELSEIF(ISET.EQ.2) THEN
27993 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
27994 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
27995 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
27996 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
27999 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
28000 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
28001 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
28002 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
28003 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
28004 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
28005 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
28006 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
28011 C...Evaluate set 2D parton distributions below or above threshold.
28012 ELSEIF(ISET.EQ.3) THEN
28013 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28014 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28015 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
28016 XGLU = 1.925D0 * X1**2
28017 XSEA = 0.242D0 * X1**4
28019 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
28020 & X**(0.46D0+0.25D0*S) *
28021 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
28022 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
28023 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
28024 & EXP(-18.67D0*S) *
28025 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
28026 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
28027 & XL**(9.3D0*S/(1D0+1.7D0*S))
28028 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
28029 & (1D0-0.607D0*S+21.95D0*S2) *
28030 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
28031 XSEA0 = 0.242D0 * X1**4
28034 C...Evaluate set 2M parton distributions below or above threshold.
28035 ELSEIF(ISET.EQ.4) THEN
28036 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28037 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28038 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
28039 XGLU = 1.808D0 * X1**2
28040 XSEA = 0.209D0 * X1**4
28042 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
28043 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
28044 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
28045 & XL**(5.15D0*S/(1D0+2D0*S)) +
28046 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
28047 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
28048 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
28049 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
28050 & XL**(10.9D0*S/(1D0+2.5D0*S))
28051 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
28052 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
28053 & X1**(4D0+S) * XL**(0.45D0*S)
28054 XSEA0 = 0.209D0 * X1**4
28058 C...Threshold factors for c and b sea.
28059 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
28061 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
28062 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
28064 XCHM=XSEA*(1D0-(SCH/SLL)**2)
28066 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
28070 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
28071 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
28073 XBOT=XSEA*(1D0-(SBT/SLL)**2)
28075 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
28079 C...Fill parton distributions.
28086 XPGA(KFA)=XPGA(KFA)+XVAL
28088 XPGA(-KFL)=XPGA(KFL)
28096 C*********************************************************************
28099 C...Evaluates the parton distributions of the anomalous photon,
28100 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
28101 C...KF=0 gives the sum over (up to) 5 flavours,
28102 C...KF<0 limits to flavours up to abs(KF),
28103 C...KF>0 is for flavour KF only.
28104 C...ALAM is the 4-flavour Lambda, which is automatically converted
28105 C...to 3- and 5-flavour equivalents as needed.
28106 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28108 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
28110 C...Double precision and integer declarations.
28111 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28112 IMPLICIT INTEGER(I-N)
28113 INTEGER PYK,PYCHGE,PYCOMP
28114 C...Local arrays and data.
28115 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
28116 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
28123 IF(Q2.LE.P2) RETURN
28126 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
28127 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
28129 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
28130 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
28131 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
28132 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
28133 Q2EFF=MAX(Q2,P2EFF)
28136 C...Find number of flavours at lower and upper scale.
28138 IF(P2EFF.LT.PMC**2) NFP=3
28139 IF(P2EFF.GT.PMB**2) NFP=5
28141 IF(Q2EFF.LT.PMC**2) NFQ=3
28142 IF(Q2EFF.GT.PMB**2) NFQ=5
28144 C...Define range of flavour loop.
28148 ELSEIF(KF.LT.0) THEN
28156 C...Loop over flavours the photon can branch into.
28157 DO 110 KFL=KFLMN,KFLMX
28159 C...Light flavours: calculate t range and (approximate) s range.
28160 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
28161 TDIFF=LOG(Q2EFF/P2EFF)
28162 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
28163 & LOG(P2EFF/ALAMSQ(NFQ)))
28164 IF(NFQ.GT.NFP) THEN
28166 IF(NFQ.EQ.4) Q2DIV=PMC**2
28167 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
28168 & LOG(P2EFF/ALAMSQ(NFQ)))
28169 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
28170 & LOG(P2EFF/ALAMSQ(NFQ-1)))
28171 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
28173 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
28175 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
28176 & LOG(P2EFF/ALAMSQ(4)))
28177 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
28178 & LOG(P2EFF/ALAMSQ(3)))
28179 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
28182 C...u and s quark do not need a separate treatment when d has been done.
28183 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
28185 C...Charm: as above, but only include range above c threshold.
28186 ELSEIF(KFL.EQ.4) THEN
28187 IF(Q2.LE.PMC**2) GOTO 110
28188 P2EFF=MAX(P2EFF,PMC**2)
28189 Q2EFF=MAX(Q2EFF,P2EFF)
28190 TDIFF=LOG(Q2EFF/P2EFF)
28191 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
28192 & LOG(P2EFF/ALAMSQ(NFQ)))
28193 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
28195 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
28196 & LOG(P2EFF/ALAMSQ(NFQ)))
28197 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
28198 & LOG(P2EFF/ALAMSQ(NFQ-1)))
28199 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
28202 C...Bottom: as above, but only include range above b threshold.
28203 ELSEIF(KFL.EQ.5) THEN
28204 IF(Q2.LE.PMB**2) GOTO 110
28205 P2EFF=MAX(P2EFF,PMB**2)
28206 Q2EFF=MAX(Q2,P2EFF)
28207 TDIFF=LOG(Q2EFF/P2EFF)
28208 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
28209 & LOG(P2EFF/ALAMSQ(NFQ)))
28212 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
28214 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
28215 FAC=AEM2PI*2D0*CHSQ*TDIFF
28217 C...Evaluate parton distributions (normalized to unit momentum sum).
28218 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
28219 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
28220 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
28221 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
28222 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
28223 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
28224 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
28225 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
28226 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
28227 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
28228 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
28229 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
28231 C...Threshold factors for c and b sea.
28232 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
28234 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
28235 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
28236 XCHM=XSEA*(1D0-(SCH/SLL)**3)
28239 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
28240 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
28241 XBOT=XSEA*(1D0-(SBT/SLL)**3)
28245 C...Add contribution of each valence flavour.
28246 XPGA(0)=XPGA(0)+FAC*XGLU
28247 XPGA(1)=XPGA(1)+FAC*XSEA
28248 XPGA(2)=XPGA(2)+FAC*XSEA
28249 XPGA(3)=XPGA(3)+FAC*XSEA
28250 XPGA(4)=XPGA(4)+FAC*XCHM
28251 XPGA(5)=XPGA(5)+FAC*XBOT
28252 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
28253 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
28256 XPGA(-KFL)=XPGA(KFL)
28257 VXPGA(-KFL)=VXPGA(KFL)
28263 C*********************************************************************
28266 C...Evaluates the Bethe-Heitler cross section for heavy flavour
28268 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28270 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
28272 C...Double precision and integer declarations.
28273 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28274 IMPLICIT INTEGER(I-N)
28275 INTEGER PYK,PYCHGE,PYCOMP
28278 DATA AEM2PI/0.0011614D0/
28284 C...Check kinematics limits.
28285 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
28287 BETA2=1D0-4D0*PM2/W2
28288 IF(BETA2.LT.1D-10) RETURN
28292 C...Simple case: P2 = 0.
28293 IF(P2.LT.1D-4) THEN
28294 IF(BETA.LT.0.99D0) THEN
28295 XBL=LOG((1D0+BETA)/(1D0-BETA))
28297 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
28299 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
28300 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
28302 C...Complicated case: P2 > 0, based on approximation of
28303 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
28305 RPQ=1D0-4D0*X**2*P2/Q2
28306 IF(RPQ.GT.1D-10) THEN
28307 RPBE=SQRT(RPQ*BETA2)
28308 IF(RPBE.LT.0.99D0) THEN
28309 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
28310 XBI=2D0*RPBE/(1D0-RPBE**2)
28312 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
28313 XBL=LOG((1D0+RPBE)**2/RPBESN)
28314 XBI=2D0*RPBE/RPBESN
28316 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
28317 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
28318 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
28322 C...Multiply by charge-squared etc. to get parton distribution.
28324 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
28325 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
28330 C*********************************************************************
28333 C...Evaluates the direct contribution, i.e. the C^gamma term,
28334 C...as needed in MSbar parametrizations.
28335 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28337 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
28339 C...Double precision and integer declarations.
28340 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28341 IMPLICIT INTEGER(I-N)
28342 INTEGER PYK,PYCHGE,PYCOMP
28343 C...Local array and data.
28344 DIMENSION XPGA(-6:6)
28345 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
28352 C...Evaluate common x-dependent expression.
28353 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
28354 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
28356 C...d, u, s part by simple charge factor.
28357 XPGA(1)=(1D0/9D0)*CGAM
28358 XPGA(2)=(4D0/9D0)*CGAM
28359 XPGA(3)=(1D0/9D0)*CGAM
28361 C...Also fill for antiquarks.
28369 C*********************************************************************
28372 C...Gives pi+ parton distribution according to two different
28373 C...parametrizations.
28375 SUBROUTINE PYPDPI(X,Q2,XPPI)
28377 C...Double precision and integer declarations.
28378 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28379 IMPLICIT INTEGER(I-N)
28380 INTEGER PYK,PYCHGE,PYCOMP
28382 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28383 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28384 COMMON/PYINT1/MINT(400),VINT(400)
28385 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
28387 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
28389 C...The following data lines are coefficients needed in the
28390 C...Owens pion parton distribution parametrizations, see below.
28391 C...Expansion coefficients for up and down valence quark distributions.
28392 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
28393 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
28394 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
28395 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
28396 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
28397 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
28398 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
28399 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
28400 C...Expansion coefficients for gluon distribution.
28401 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
28402 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
28403 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
28404 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
28405 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
28406 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
28407 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
28408 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
28409 C...Expansion coefficients for (up+down+strange) quark sea distribution.
28410 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
28411 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
28412 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
28413 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
28414 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
28415 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
28416 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
28417 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
28418 C...Expansion coefficients for charm quark sea distribution.
28419 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
28420 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
28421 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
28422 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
28423 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
28424 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
28425 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
28426 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
28428 C...Euler's beta function, requires ordinary Gamma function
28429 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
28431 C...Reset output array.
28436 IF(MSTP(53).LE.2) THEN
28437 C...Pion parton distributions from Owens.
28438 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
28440 C...Determine set, Lambda and s expansion variable.
28442 IF(NSET.EQ.1) ALAM=0.2D0
28443 IF(NSET.EQ.2) ALAM=0.4D0
28445 IF(MSTP(57).LE.0) THEN
28448 Q2IN=MIN(2D3,MAX(4D0,Q2))
28449 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
28452 C...Calculate parton distributions.
28455 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
28456 & COW(3,IS,KFL,NSET)*SD**2
28459 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
28461 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
28466 C...Put into output array.
28469 XPPI(2)=XQ(1)+XQ(3)/6D0
28472 XPPI(-1)=XQ(1)+XQ(3)/6D0
28477 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
28478 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
28482 C...Determine s expansion variable and some x expressions.
28484 IF(MSTP(57).LE.0) THEN
28487 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
28488 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
28494 C...Evaluate valence, gluon and sea distributions.
28495 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
28496 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
28497 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
28499 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
28500 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
28502 & (1D0-X)**(0.390D0+1.053D0*SD)
28503 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
28505 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
28507 & XL**(2.538D0-0.763D0*SD)
28508 IF(SD.LE.0.888D0) THEN
28511 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
28513 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
28516 IF(SD.LE.1.351D0) THEN
28519 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
28520 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
28524 C...Put into output array.
28532 XPPI(-KFL)=XPPI(KFL)
28534 XPPI(2)=XPPI(2)+XFVAL
28535 XPPI(-1)=XPPI(-1)+XFVAL
28541 C*********************************************************************
28544 C...Gives proton parton distributions according to a few different
28545 C...parametrizations.
28547 SUBROUTINE PYPDPR(X,Q2,XPPR)
28549 C...Double precision and integer declarations.
28550 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28551 IMPLICIT INTEGER(I-N)
28552 INTEGER PYK,PYCHGE,PYCOMP
28554 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28555 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28556 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28557 COMMON/PYINT1/MINT(400),VINT(400)
28558 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28559 C...Arrays and data.
28560 DIMENSION XPPR(-6:6),Q2MIN(16)
28561 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
28562 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
28564 C...Reset output array.
28569 C...Common preliminaries.
28570 NSET=MAX(1,MIN(16,MSTP(51)))
28571 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
28572 VINT(231)=Q2MIN(NSET)
28573 IF(MSTP(57).EQ.0) THEN
28576 Q2L=MAX(Q2MIN(NSET),Q2)
28579 IF(NSET.GE.1.AND.NSET.LE.3) THEN
28580 C...Interface to the CTEQ 3 parton distributions.
28581 QRT=SQRT(MAX(1D0,Q2L))
28583 C...Loop over flavours.
28586 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
28587 ELSEIF(I.LE.2) THEN
28588 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
28594 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
28595 C...Interface to the GRV 94 distributions.
28597 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
28598 ELSEIF(NSET.EQ.5) THEN
28599 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
28601 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
28604 C...Put into output array.
28606 XPPR(-1)=0.5D0*(UDB+DEL)
28607 XPPR(-2)=0.5D0*(UDB-DEL)
28611 XPPR(1)=DV+XPPR(-1)
28612 XPPR(2)=UV+XPPR(-2)
28617 ELSEIF(NSET.EQ.7) THEN
28618 C...Interface to the CTEQ 5L parton distributions.
28619 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
28620 C...freezing x*f(x,Q2) at borders.
28621 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
28622 XIN=MAX(1D-6,MIN(1D0,X))
28624 C...Loop over flavours (with u <-> d notation mismatch).
28625 SUMUDB=PYCT5L(-1,XIN,QRT)
28626 RATUDB=PYCT5L(-2,XIN,QRT)
28629 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
28630 ELSEIF(I.EQ.2) THEN
28631 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
28632 ELSEIF(I.EQ.-1) THEN
28633 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
28634 ELSEIF(I.EQ.-2) THEN
28635 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
28637 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
28638 IF(I.LT.0) XPPR(-I)=XPPR(I)
28642 ELSEIF(NSET.EQ.8) THEN
28643 C...Interface to the CTEQ 5M1 parton distributions.
28644 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
28645 XIN=MAX(1D-6,MIN(1D0,X))
28647 C...Loop over flavours (with u <-> d notation mismatch).
28648 SUMUDB=PYCT5M(-1,XIN,QRT)
28649 RATUDB=PYCT5M(-2,XIN,QRT)
28652 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
28653 ELSEIF(I.EQ.2) THEN
28654 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
28655 ELSEIF(I.EQ.-1) THEN
28656 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
28657 ELSEIF(I.EQ.-2) THEN
28658 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
28660 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
28661 IF(I.LT.0) XPPR(-I)=XPPR(I)
28665 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
28666 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
28667 C...obsolete but offers backwards compatibility.
28668 CALL PYPDPO(X,Q2L,XPPR)
28670 C...Symmetric choice for debugging only
28671 ELSEIF(NSET.EQ.16) THEN
28689 C*********************************************************************
28692 C...Gives the CTEQ 3 parton distribution function sets in
28693 C...parametrized form, of October 24, 1994.
28694 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
28695 C...J. Qiu, W.K. Tung and H. Weerts.
28697 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
28699 C...Double precision declaration.
28700 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28701 IMPLICIT INTEGER(I-N)
28703 C...Data on Lambda values of fits, minimum Q and quark masses.
28704 DIMENSION ALM(3), QMS(4:6)
28705 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
28706 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
28708 C....Check flavour thresholds. Set up QI for SB.
28711 IF(Q .LE. QMS(IP)) THEN
28720 C...Use "standard lambda" of parametrization program for expansion.
28722 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
28727 C...Expansion for CTEQ3L.
28728 IF(ISET .EQ. 1) THEN
28729 IF(IPRT .EQ. 2) THEN
28730 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
28732 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
28733 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
28734 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
28735 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
28736 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
28737 ELSEIF(IPRT .EQ. 1) THEN
28738 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
28740 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
28741 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
28742 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
28743 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
28744 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
28745 ELSEIF(IPRT .EQ. 0) THEN
28746 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
28748 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
28749 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
28750 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
28751 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
28752 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
28753 ELSEIF(IPRT .EQ. -1) THEN
28754 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
28756 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
28757 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
28758 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
28759 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
28760 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
28761 ELSEIF(IPRT .EQ. -2) THEN
28762 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
28764 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
28765 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
28766 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
28767 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
28768 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
28769 ELSEIF(IPRT .EQ. -3) THEN
28770 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
28772 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
28773 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
28774 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
28775 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
28776 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
28777 ELSEIF(IPRT .EQ. -4) THEN
28778 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
28780 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
28781 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
28782 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
28783 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
28784 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
28785 ELSEIF(IPRT .EQ. -5) THEN
28786 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
28788 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
28789 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
28790 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
28791 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
28792 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
28793 ELSEIF(IPRT .EQ. -6) THEN
28794 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
28796 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
28797 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
28798 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
28799 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
28800 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
28803 C...Expansion for CTEQ3M.
28804 ELSEIF(ISET .EQ. 2) THEN
28805 IF(IPRT .EQ. 2) THEN
28806 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
28808 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
28809 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
28810 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
28811 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
28812 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
28813 ELSEIF(IPRT .EQ. 1) THEN
28814 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
28816 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
28817 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
28818 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
28819 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
28820 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
28821 ELSEIF(IPRT .EQ. 0) THEN
28822 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
28824 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
28825 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
28826 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
28827 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
28828 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
28829 ELSEIF(IPRT .EQ. -1) THEN
28830 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
28832 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
28833 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
28834 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
28835 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
28836 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
28837 ELSEIF(IPRT .EQ. -2) THEN
28838 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
28840 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
28841 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
28842 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
28843 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
28844 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
28845 ELSEIF(IPRT .EQ. -3) THEN
28846 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
28848 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
28849 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
28850 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
28851 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
28852 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
28853 ELSEIF(IPRT .EQ. -4) THEN
28854 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
28856 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
28857 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
28858 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
28859 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
28860 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
28861 ELSEIF(IPRT .EQ. -5) THEN
28862 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
28864 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
28865 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
28866 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
28867 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
28868 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
28869 ELSEIF(IPRT .EQ. -6) THEN
28870 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
28872 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
28873 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
28874 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
28875 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
28876 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
28879 C...Expansion for CTEQ3D.
28880 ELSEIF(ISET .EQ. 3) THEN
28881 IF(IPRT .EQ. 2) THEN
28882 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
28884 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
28885 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
28886 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
28887 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
28888 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
28889 ELSEIF(IPRT .EQ. 1) THEN
28890 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
28892 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
28893 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
28894 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
28895 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
28896 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
28897 ELSEIF(IPRT .EQ. 0) THEN
28898 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
28900 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
28901 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
28902 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
28903 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
28904 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
28905 ELSEIF(IPRT .EQ. -1) THEN
28906 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
28908 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
28909 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
28910 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
28911 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
28912 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
28913 ELSEIF(IPRT .EQ. -2) THEN
28914 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
28916 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
28917 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
28918 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
28919 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
28920 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
28921 ELSEIF(IPRT .EQ. -3) THEN
28922 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
28924 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
28925 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
28926 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
28927 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
28928 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
28929 ELSEIF(IPRT .EQ. -4) THEN
28930 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
28932 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
28933 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
28934 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
28935 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
28936 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
28937 ELSEIF(IPRT .EQ. -5) THEN
28938 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
28940 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
28941 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
28942 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
28943 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
28944 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
28945 ELSEIF(IPRT .EQ. -6) THEN
28946 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
28948 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
28949 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
28950 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
28951 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
28952 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
28956 C...Calculation of x * f(x, Q).
28957 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
28958 & *(LOG(1D0+1D0/X))**A5 )
28963 C*********************************************************************
28966 C...Gives the GRV 94 L (leading order) parton distribution function set
28967 C...in parametrized form.
28968 C...Authors: M. Glueck, E. Reya and A. Vogt.
28970 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
28972 C...Double precision declaration.
28973 IMPLICIT DOUBLE PRECISION (A - Z)
28975 C...Common expressions.
28977 LAM2 = 0.2322D0 * 0.2322D0
28978 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
28984 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
28985 AKU = 0.590D0 - 0.024D0 * S
28986 BKU = 0.131D0 + 0.063D0 * S
28987 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
28988 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
28989 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
28990 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
28991 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
28994 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
28996 BKD = 0.486D0 + 0.062D0 * S
28997 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
28998 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
28999 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
29000 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
29001 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
29004 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
29005 AKE = 0.409D0 - 0.005D0 * S
29006 BKE = 0.799D0 + 0.071D0 * S
29007 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
29008 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
29010 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
29011 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
29016 AKX = 0.410D0 - 0.232D0 * S
29017 BKX = 0.534D0 - 0.457D0 * S
29018 AGX = 0.890D0 - 0.140D0 * S
29020 CX = 0.320D0 + 0.683D0 * S
29021 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
29022 EX = 4.119D0 + 1.713D0 * S
29023 ESX = 0.682D0 + 2.978D0 * S
29024 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
29031 AKS = 1.798D0 - 0.596D0 * S
29032 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
29033 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
29034 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
29035 EST = 3.981D0 + 1.638D0 * S
29037 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
29045 BC = 4.24D0 - 0.804D0 * S
29046 DCT = 3.46D0 - 1.076D0 * S
29047 ECT = 4.61D0 + 1.49D0 * S
29048 ESC = 2.555D0 + 1.961D0 * S
29049 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
29058 DBT = 2.929D0 + 1.396D0 * S
29059 EBT = 4.71D0 + 1.514D0 * S
29060 ESB = 4.02D0 + 1.239D0 * S
29061 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
29066 AKG = 1.742D0 - 0.930D0 * S
29067 BKG = - 0.399D0 * S2
29068 AG = 7.486D0 - 2.185D0 * S
29069 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
29070 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
29071 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
29072 EG = 0.807D0 + 2.005D0 * S
29073 ESG = 3.841D0 + 0.316D0 * S
29074 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
29080 C*********************************************************************
29083 C...Gives the GRV 94 M (MSbar) parton distribution function set
29084 C...in parametrized form.
29085 C...Authors: M. Glueck, E. Reya and A. Vogt.
29087 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29089 C...Double precision declaration.
29090 IMPLICIT DOUBLE PRECISION (A - Z)
29092 C...Common expressions.
29094 LAM2 = 0.248D0 * 0.248D0
29095 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
29101 NU = 1.304D0 + 0.863D0 * S
29102 AKU = 0.558D0 - 0.020D0 * S
29104 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
29105 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
29106 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
29107 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
29108 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
29111 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
29112 AKD = 0.270D0 - 0.019D0 * S
29114 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
29115 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
29116 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
29117 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
29118 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
29121 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
29122 AKE = 0.409D0 - 0.007D0 * S
29123 BKE = 0.782D0 + 0.082D0 * S
29124 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
29125 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
29127 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
29128 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
29136 BGX = 3.210D0 - 1.866D0 * S
29138 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
29139 EX = 3.077D0 + 1.446D0 * S
29140 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
29141 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
29148 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
29149 AS = -4.329D0 + 1.131D0 * S
29150 BS = 9.568D0 - 1.744D0 * S
29151 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
29152 EST = 3.031D0 + 1.639D0 * S
29153 ESS = 5.837D0 + 0.815D0 * S
29154 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
29160 AKC = -0.625D0 - 0.523D0 * S
29162 BC = 1.896D0 + 1.616D0 * S
29163 DCT = 4.12D0 + 0.683D0 * S
29164 ECT = 4.36D0 + 1.328D0 * S
29165 ESC = 0.677D0 + 0.679D0 * S
29166 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
29172 AKB = - 0.193D0 * S
29175 DBT = 3.447D0 + 0.927D0 * S
29176 EBT = 4.68D0 + 1.259D0 * S
29177 ESB = 1.892D0 + 2.199D0 * S
29178 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
29183 AKG = 1.724D0 + 0.157D0 * S
29184 BKG = 0.800D0 + 1.016D0 * S
29185 AG = 7.517D0 - 2.547D0 * S
29186 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
29187 CG = 4.039D0 + 1.491D0 * S
29188 DG = 3.404D0 + 0.830D0 * S
29189 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
29190 ESG = 3.256D0 - 0.436D0 * S
29191 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
29196 C*********************************************************************
29199 C...Gives the GRV 94 D (DIS) parton distribution function set
29200 C...in parametrized form.
29201 C...Authors: M. Glueck, E. Reya and A. Vogt.
29203 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29205 C...Double precision declaration.
29206 IMPLICIT DOUBLE PRECISION (A - Z)
29208 C...Common expressions.
29210 LAM2 = 0.248D0 * 0.248D0
29211 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
29217 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
29218 AKU = 0.563D0 - 0.025D0 * S
29219 BKU = 0.054D0 + 0.154D0 * S
29220 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
29221 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
29222 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
29223 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
29224 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
29227 ND = 0.156D0 - 0.017D0 * S
29228 AKD = 0.299D0 - 0.022D0 * S
29229 BKD = 0.259D0 - 0.015D0 * S
29230 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
29231 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
29232 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
29233 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
29234 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
29237 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
29238 AKE = 0.419D0 - 0.013D0 * S
29239 BKE = 1.064D0 - 0.038D0 * S
29240 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
29241 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
29242 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
29243 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
29244 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
29249 AKX = 0.326D0 + 0.150D0 * S
29250 BKX = 0.956D0 + 0.405D0 * S
29252 BGX = 3.794D0 - 2.359D0 * DS
29254 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
29255 EX = 3.049D0 + 1.597D0 * S
29256 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
29257 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
29264 AKS = 1.415D0 - 0.641D0 * DS
29265 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
29266 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
29267 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
29268 EST = 4.546D0 + 0.372D0 * S2
29269 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
29270 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
29276 AKC = -0.625D0 - 0.523D0 * S
29278 BC = 1.896D0 + 1.616D0 * S
29279 DCT = 4.12D0 + 0.683D0 * S
29280 ECT = 4.36D0 + 1.328D0 * S
29281 ESC = 0.677D0 + 0.679D0 * S
29282 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
29288 AKB = - 0.193D0 * S
29291 DBT = 3.447D0 + 0.927D0 * S
29292 EBT = 4.68D0 + 1.259D0 * S
29293 ESB = 1.892D0 + 2.199D0 * S
29294 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
29300 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
29301 AG = 25.09D0 - 7.935D0 * S
29302 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
29303 CG = 590.3D0 - 173.8D0 * S
29304 DG = 5.196D0 + 1.857D0 * S
29305 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
29306 ESG = 3.232D0 - 0.542D0 * S
29307 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
29312 C*********************************************************************
29315 C...Auxiliary for the GRV 94 parton distribution functions
29316 C...for u and d valence and d-u sea.
29317 C...Authors: M. Glueck, E. Reya and A. Vogt.
29319 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
29321 C...Double precision declaration.
29322 IMPLICIT DOUBLE PRECISION (A - Z)
29326 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
29332 C*********************************************************************
29335 C...Auxiliary for the GRV 94 parton distribution functions
29336 C...for d+u sea and gluon.
29337 C...Authors: M. Glueck, E. Reya and A. Vogt.
29339 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
29341 C...Double precision declaration.
29342 IMPLICIT DOUBLE PRECISION (A - Z)
29346 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
29347 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
29352 C*********************************************************************
29355 C...Auxiliary for the GRV 94 parton distribution functions
29356 C...for s, c and b sea.
29357 C...Authors: M. Glueck, E. Reya and A. Vogt.
29359 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
29361 C...Double precision declaration.
29362 IMPLICIT DOUBLE PRECISION (A - Z)
29370 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
29371 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
29377 C*********************************************************************
29380 C...Auxiliary function for parametrization of CTEQ5L.
29381 C...Author: J. Pumplin 9/99.
29383 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
29384 C...in Parametrized Form
29385 C... September 15, 1999
29387 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
29388 C... CTEQ5 PPARTON DISTRIBUTIONS"
29391 C...The CTEQ5M1 set given here is an updated version of the original
29392 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
29393 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
29394 C...almost all applications.
29395 C...The improvement is in the QCD evolution which is now more
29396 C...accurate, and which agrees completely with the benchmark work
29397 C...of the HERA 96/97 Workshop.
29398 C...The differences between the parametrized and the corresponding
29399 C...table versions (on which it is based) are of similar order as
29400 C...between the two version.
29402 C...!! Because accurate parametrizations over a wide range of (x,Q)
29403 C...is hard to obtain, only the most widely used sets CTEQ5M and
29404 C...CTEQ5L are available in parametrized form for now.
29406 C...These parametrizations were obtained by Jon Pumplin.
29408 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
29409 C -------------------------------------------------------------------
29410 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
29411 C 3 CTEQ5L Leading Order 0.127 192 146
29412 C -------------------------------------------------------------------
29413 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
29414 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
29417 C...The two Iset value are adopted to agree with the standard table
29420 C...Range of validity:
29421 C...The range of (x, Q) covered by this parametrization of the QCD
29422 C...evolved parton distributions is 1E-6 < x < 1 ;
29423 C...1.1 GeV < Q < 10 TeV. Of course, the PDF's are constrained by
29424 C...data only in a subset of that region; and the assumed DGLAP
29425 C...evolution is unlikely to be valid for all of it either.
29427 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
29428 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
29429 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
29430 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
29432 FUNCTION PYCT5L(IFL,X,Q)
29434 C...Double precision declaration.
29435 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29436 IMPLICIT INTEGER(I-N)
29438 PARAMETER (NEX=8, NLF=2)
29439 DIMENSION AM(0:NEX,0:NLF,-5:2)
29440 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
29441 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
29442 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
29443 DIMENSION AF(0:NEX)
29445 DATA MEXVEC( 2) / 8 /
29446 DATA MLFVEC( 2) / 2 /
29447 DATA UT1VEC( 2) / 0.4971265E+01 /
29448 DATA UT2VEC( 2) / -0.1105128E+01 /
29449 DATA ALFVEC( 2) / 0.2987216E+00 /
29450 DATA QMAVEC( 2) / 0.0000000E+00 /
29451 DATA (AM( 0,K, 2),K=0, 2)
29452 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
29453 DATA (AM( 1,K, 2),K=0, 2)
29454 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
29455 DATA (AM( 2,K, 2),K=0, 2)
29456 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
29457 DATA (AM( 3,K, 2),K=0, 2)
29458 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
29459 DATA (AM( 4,K, 2),K=0, 2)
29460 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
29461 DATA (AM( 5,K, 2),K=0, 2)
29462 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
29463 DATA (AM( 6,K, 2),K=0, 2)
29464 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
29465 DATA (AM( 7,K, 2),K=0, 2)
29466 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
29467 DATA (AM( 8,K, 2),K=0, 2)
29468 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
29470 DATA MEXVEC( 1) / 8 /
29471 DATA MLFVEC( 1) / 2 /
29472 DATA UT1VEC( 1) / 0.2612618E+01 /
29473 DATA UT2VEC( 1) / -0.1258304E+06 /
29474 DATA ALFVEC( 1) / 0.3407552E+00 /
29475 DATA QMAVEC( 1) / 0.0000000E+00 /
29476 DATA (AM( 0,K, 1),K=0, 2)
29477 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
29478 DATA (AM( 1,K, 1),K=0, 2)
29479 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
29480 DATA (AM( 2,K, 1),K=0, 2)
29481 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
29482 DATA (AM( 3,K, 1),K=0, 2)
29483 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
29484 DATA (AM( 4,K, 1),K=0, 2)
29485 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
29486 DATA (AM( 5,K, 1),K=0, 2)
29487 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
29488 DATA (AM( 6,K, 1),K=0, 2)
29489 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
29490 DATA (AM( 7,K, 1),K=0, 2)
29491 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
29492 DATA (AM( 8,K, 1),K=0, 2)
29493 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
29495 DATA MEXVEC( 0) / 8 /
29496 DATA MLFVEC( 0) / 2 /
29497 DATA UT1VEC( 0) / -0.4656819E+00 /
29498 DATA UT2VEC( 0) / -0.2742390E+03 /
29499 DATA ALFVEC( 0) / 0.4491863E+00 /
29500 DATA QMAVEC( 0) / 0.0000000E+00 /
29501 DATA (AM( 0,K, 0),K=0, 2)
29502 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
29503 DATA (AM( 1,K, 0),K=0, 2)
29504 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
29505 DATA (AM( 2,K, 0),K=0, 2)
29506 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
29507 DATA (AM( 3,K, 0),K=0, 2)
29508 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
29509 DATA (AM( 4,K, 0),K=0, 2)
29510 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
29511 DATA (AM( 5,K, 0),K=0, 2)
29512 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
29513 DATA (AM( 6,K, 0),K=0, 2)
29514 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
29515 DATA (AM( 7,K, 0),K=0, 2)
29516 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
29517 DATA (AM( 8,K, 0),K=0, 2)
29518 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
29520 DATA MEXVEC(-1) / 8 /
29521 DATA MLFVEC(-1) / 2 /
29522 DATA UT1VEC(-1) / 0.3862583E+01 /
29523 DATA UT2VEC(-1) / -0.1265969E+01 /
29524 DATA ALFVEC(-1) / 0.2457668E+00 /
29525 DATA QMAVEC(-1) / 0.0000000E+00 /
29526 DATA (AM( 0,K,-1),K=0, 2)
29527 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
29528 DATA (AM( 1,K,-1),K=0, 2)
29529 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
29530 DATA (AM( 2,K,-1),K=0, 2)
29531 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
29532 DATA (AM( 3,K,-1),K=0, 2)
29533 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
29534 DATA (AM( 4,K,-1),K=0, 2)
29535 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
29536 DATA (AM( 5,K,-1),K=0, 2)
29537 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
29538 DATA (AM( 6,K,-1),K=0, 2)
29539 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
29540 DATA (AM( 7,K,-1),K=0, 2)
29541 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
29542 DATA (AM( 8,K,-1),K=0, 2)
29543 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
29545 DATA MEXVEC(-2) / 7 /
29546 DATA MLFVEC(-2) / 2 /
29547 DATA UT1VEC(-2) / 0.1895615E+00 /
29548 DATA UT2VEC(-2) / -0.3069097E+01 /
29549 DATA ALFVEC(-2) / 0.5293999E+00 /
29550 DATA QMAVEC(-2) / 0.0000000E+00 /
29551 DATA (AM( 0,K,-2),K=0, 2)
29552 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
29553 DATA (AM( 1,K,-2),K=0, 2)
29554 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
29555 DATA (AM( 2,K,-2),K=0, 2)
29556 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
29557 DATA (AM( 3,K,-2),K=0, 2)
29558 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
29559 DATA (AM( 4,K,-2),K=0, 2)
29560 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
29561 DATA (AM( 5,K,-2),K=0, 2)
29562 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
29563 DATA (AM( 6,K,-2),K=0, 2)
29564 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
29565 DATA (AM( 7,K,-2),K=0, 2)
29566 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
29568 DATA MEXVEC(-3) / 7 /
29569 DATA MLFVEC(-3) / 2 /
29570 DATA UT1VEC(-3) / 0.3753257E+01 /
29571 DATA UT2VEC(-3) / -0.1113085E+01 /
29572 DATA ALFVEC(-3) / 0.3713141E+00 /
29573 DATA QMAVEC(-3) / 0.0000000E+00 /
29574 DATA (AM( 0,K,-3),K=0, 2)
29575 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
29576 DATA (AM( 1,K,-3),K=0, 2)
29577 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
29578 DATA (AM( 2,K,-3),K=0, 2)
29579 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
29580 DATA (AM( 3,K,-3),K=0, 2)
29581 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
29582 DATA (AM( 4,K,-3),K=0, 2)
29583 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
29584 DATA (AM( 5,K,-3),K=0, 2)
29585 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
29586 DATA (AM( 6,K,-3),K=0, 2)
29587 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
29588 DATA (AM( 7,K,-3),K=0, 2)
29589 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
29591 DATA MEXVEC(-4) / 7 /
29592 DATA MLFVEC(-4) / 2 /
29593 DATA UT1VEC(-4) / 0.4400772E+01 /
29594 DATA UT2VEC(-4) / -0.1356116E+01 /
29595 DATA ALFVEC(-4) / 0.3712017E-01 /
29596 DATA QMAVEC(-4) / 0.1300000E+01 /
29597 DATA (AM( 0,K,-4),K=0, 2)
29598 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
29599 DATA (AM( 1,K,-4),K=0, 2)
29600 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
29601 DATA (AM( 2,K,-4),K=0, 2)
29602 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
29603 DATA (AM( 3,K,-4),K=0, 2)
29604 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
29605 DATA (AM( 4,K,-4),K=0, 2)
29606 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
29607 DATA (AM( 5,K,-4),K=0, 2)
29608 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
29609 DATA (AM( 6,K,-4),K=0, 2)
29610 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
29611 DATA (AM( 7,K,-4),K=0, 2)
29612 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
29614 DATA MEXVEC(-5) / 6 /
29615 DATA MLFVEC(-5) / 2 /
29616 DATA UT1VEC(-5) / 0.5562568E+01 /
29617 DATA UT2VEC(-5) / -0.1801317E+01 /
29618 DATA ALFVEC(-5) / 0.4952010E-02 /
29619 DATA QMAVEC(-5) / 0.4500000E+01 /
29620 DATA (AM( 0,K,-5),K=0, 2)
29621 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
29622 DATA (AM( 1,K,-5),K=0, 2)
29623 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
29624 DATA (AM( 2,K,-5),K=0, 2)
29625 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
29626 DATA (AM( 3,K,-5),K=0, 2)
29627 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
29628 DATA (AM( 4,K,-5),K=0, 2)
29629 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
29630 DATA (AM( 5,K,-5),K=0, 2)
29631 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
29632 DATA (AM( 6,K,-5),K=0, 2)
29633 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
29635 IF(Q .LE. QMAVEC(IFL)) THEN
29640 IF(X .GE. 1.D0) THEN
29645 TMP = LOG(Q/ALFVEC(IFL))
29646 IF(TMP .LE. 0.D0) THEN
29658 DO 100 K = 0, MLFVEC(IFL)
29659 AF(I) = AF(I) + SBX*AM(I,K,IFL)
29665 U = LOG(X/0.00001D0)
29667 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
29668 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
29669 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
29670 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
29671 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
29673 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
29675 C...Include threshold factor.
29676 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
29681 C*********************************************************************
29684 C...Auxiliary function for parametrization of CTEQ5M1.
29685 C...Author: J. Pumplin 9/99.
29687 FUNCTION PYCT5M(IFL,X,Q)
29689 C...Double precision declaration.
29690 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29691 IMPLICIT INTEGER(I-N)
29693 PARAMETER (NEX=8, NLF=2)
29694 DIMENSION AM(0:NEX,0:NLF,-5:2)
29695 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
29696 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
29697 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
29698 DIMENSION AF(0:NEX)
29700 DATA MEXVEC( 2) / 8 /
29701 DATA MLFVEC( 2) / 2 /
29702 DATA UT1VEC( 2) / 0.5141718E+01 /
29703 DATA UT2VEC( 2) / -0.1346944E+01 /
29704 DATA ALFVEC( 2) / 0.5260555E+00 /
29705 DATA QMAVEC( 2) / 0.0000000E+00 /
29706 DATA (AM( 0,K, 2),K=0, 2)
29707 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
29708 DATA (AM( 1,K, 2),K=0, 2)
29709 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
29710 DATA (AM( 2,K, 2),K=0, 2)
29711 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
29712 DATA (AM( 3,K, 2),K=0, 2)
29713 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
29714 DATA (AM( 4,K, 2),K=0, 2)
29715 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
29716 DATA (AM( 5,K, 2),K=0, 2)
29717 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
29718 DATA (AM( 6,K, 2),K=0, 2)
29719 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
29720 DATA (AM( 7,K, 2),K=0, 2)
29721 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
29722 DATA (AM( 8,K, 2),K=0, 2)
29723 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
29725 DATA MEXVEC( 1) / 8 /
29726 DATA MLFVEC( 1) / 2 /
29727 DATA UT1VEC( 1) / 0.4138426E+01 /
29728 DATA UT2VEC( 1) / -0.3221374E+01 /
29729 DATA ALFVEC( 1) / 0.4960962E+00 /
29730 DATA QMAVEC( 1) / 0.0000000E+00 /
29731 DATA (AM( 0,K, 1),K=0, 2)
29732 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
29733 DATA (AM( 1,K, 1),K=0, 2)
29734 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
29735 DATA (AM( 2,K, 1),K=0, 2)
29736 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
29737 DATA (AM( 3,K, 1),K=0, 2)
29738 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
29739 DATA (AM( 4,K, 1),K=0, 2)
29740 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
29741 DATA (AM( 5,K, 1),K=0, 2)
29742 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
29743 DATA (AM( 6,K, 1),K=0, 2)
29744 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
29745 DATA (AM( 7,K, 1),K=0, 2)
29746 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
29747 DATA (AM( 8,K, 1),K=0, 2)
29748 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
29750 DATA MEXVEC( 0) / 8 /
29751 DATA MLFVEC( 0) / 2 /
29752 DATA UT1VEC( 0) / -0.1026789E+01 /
29753 DATA UT2VEC( 0) / -0.9051707E+01 /
29754 DATA ALFVEC( 0) / 0.9462977E+00 /
29755 DATA QMAVEC( 0) / 0.0000000E+00 /
29756 DATA (AM( 0,K, 0),K=0, 2)
29757 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
29758 DATA (AM( 1,K, 0),K=0, 2)
29759 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
29760 DATA (AM( 2,K, 0),K=0, 2)
29761 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
29762 DATA (AM( 3,K, 0),K=0, 2)
29763 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
29764 DATA (AM( 4,K, 0),K=0, 2)
29765 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
29766 DATA (AM( 5,K, 0),K=0, 2)
29767 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
29768 DATA (AM( 6,K, 0),K=0, 2)
29769 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
29770 DATA (AM( 7,K, 0),K=0, 2)
29771 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
29772 DATA (AM( 8,K, 0),K=0, 2)
29773 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
29775 DATA MEXVEC(-1) / 8 /
29776 DATA MLFVEC(-1) / 2 /
29777 DATA UT1VEC(-1) / 0.5243571E+01 /
29778 DATA UT2VEC(-1) / -0.2870513E+01 /
29779 DATA ALFVEC(-1) / 0.6701448E+00 /
29780 DATA QMAVEC(-1) / 0.0000000E+00 /
29781 DATA (AM( 0,K,-1),K=0, 2)
29782 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
29783 DATA (AM( 1,K,-1),K=0, 2)
29784 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
29785 DATA (AM( 2,K,-1),K=0, 2)
29786 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
29787 DATA (AM( 3,K,-1),K=0, 2)
29788 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
29789 DATA (AM( 4,K,-1),K=0, 2)
29790 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
29791 DATA (AM( 5,K,-1),K=0, 2)
29792 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
29793 DATA (AM( 6,K,-1),K=0, 2)
29794 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
29795 DATA (AM( 7,K,-1),K=0, 2)
29796 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
29797 DATA (AM( 8,K,-1),K=0, 2)
29798 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
29800 DATA MEXVEC(-2) / 7 /
29801 DATA MLFVEC(-2) / 2 /
29802 DATA UT1VEC(-2) / 0.4782210E+01 /
29803 DATA UT2VEC(-2) / -0.1976856E+02 /
29804 DATA ALFVEC(-2) / 0.7558374E+00 /
29805 DATA QMAVEC(-2) / 0.0000000E+00 /
29806 DATA (AM( 0,K,-2),K=0, 2)
29807 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
29808 DATA (AM( 1,K,-2),K=0, 2)
29809 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
29810 DATA (AM( 2,K,-2),K=0, 2)
29811 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
29812 DATA (AM( 3,K,-2),K=0, 2)
29813 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
29814 DATA (AM( 4,K,-2),K=0, 2)
29815 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
29816 DATA (AM( 5,K,-2),K=0, 2)
29817 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
29818 DATA (AM( 6,K,-2),K=0, 2)
29819 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
29820 DATA (AM( 7,K,-2),K=0, 2)
29821 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
29823 DATA MEXVEC(-3) / 7 /
29824 DATA MLFVEC(-3) / 2 /
29825 DATA UT1VEC(-3) / 0.4518239E+01 /
29826 DATA UT2VEC(-3) / -0.2690590E+01 /
29827 DATA ALFVEC(-3) / 0.6124079E+00 /
29828 DATA QMAVEC(-3) / 0.0000000E+00 /
29829 DATA (AM( 0,K,-3),K=0, 2)
29830 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
29831 DATA (AM( 1,K,-3),K=0, 2)
29832 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
29833 DATA (AM( 2,K,-3),K=0, 2)
29834 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
29835 DATA (AM( 3,K,-3),K=0, 2)
29836 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
29837 DATA (AM( 4,K,-3),K=0, 2)
29838 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
29839 DATA (AM( 5,K,-3),K=0, 2)
29840 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
29841 DATA (AM( 6,K,-3),K=0, 2)
29842 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
29843 DATA (AM( 7,K,-3),K=0, 2)
29844 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
29846 DATA MEXVEC(-4) / 7 /
29847 DATA MLFVEC(-4) / 2 /
29848 DATA UT1VEC(-4) / 0.2783230E+01 /
29849 DATA UT2VEC(-4) / -0.1746328E+01 /
29850 DATA ALFVEC(-4) / 0.1115653E+01 /
29851 DATA QMAVEC(-4) / 0.1300000E+01 /
29852 DATA (AM( 0,K,-4),K=0, 2)
29853 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
29854 DATA (AM( 1,K,-4),K=0, 2)
29855 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
29856 DATA (AM( 2,K,-4),K=0, 2)
29857 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
29858 DATA (AM( 3,K,-4),K=0, 2)
29859 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
29860 DATA (AM( 4,K,-4),K=0, 2)
29861 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
29862 DATA (AM( 5,K,-4),K=0, 2)
29863 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
29864 DATA (AM( 6,K,-4),K=0, 2)
29865 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
29866 DATA (AM( 7,K,-4),K=0, 2)
29867 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
29869 DATA MEXVEC(-5) / 6 /
29870 DATA MLFVEC(-5) / 2 /
29871 DATA UT1VEC(-5) / 0.1619654E+02 /
29872 DATA UT2VEC(-5) / -0.3367346E+01 /
29873 DATA ALFVEC(-5) / 0.5109891E-02 /
29874 DATA QMAVEC(-5) / 0.4500000E+01 /
29875 DATA (AM( 0,K,-5),K=0, 2)
29876 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
29877 DATA (AM( 1,K,-5),K=0, 2)
29878 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
29879 DATA (AM( 2,K,-5),K=0, 2)
29880 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
29881 DATA (AM( 3,K,-5),K=0, 2)
29882 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
29883 DATA (AM( 4,K,-5),K=0, 2)
29884 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
29885 DATA (AM( 5,K,-5),K=0, 2)
29886 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
29887 DATA (AM( 6,K,-5),K=0, 2)
29888 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
29890 IF(Q .LE. QMAVEC(IFL)) THEN
29895 IF(X .GE. 1.D0) THEN
29900 TMP = LOG(Q/ALFVEC(IFL))
29901 IF(TMP .LE. 0.D0) THEN
29913 DO 100 K = 0, MLFVEC(IFL)
29914 AF(I) = AF(I) + SBX*AM(I,K,IFL)
29920 U = LOG(X/0.00001D0)
29922 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
29923 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
29924 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
29925 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
29926 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
29928 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
29930 C...Include threshold factor.
29931 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
29936 C*********************************************************************
29939 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
29940 C...a few older parametrizations, now obsolete but convenient for
29941 C...backwards checks.
29943 SUBROUTINE PYPDPO(X,Q2,XPPR)
29945 C...Double precision and integer declarations.
29946 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29947 IMPLICIT INTEGER(I-N)
29948 INTEGER PYK,PYCHGE,PYCOMP
29950 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29951 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29952 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29953 COMMON/PYINT1/MINT(400),VINT(400)
29954 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
29955 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
29956 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
29959 C...The following data lines are coefficients needed in the
29960 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
29961 C...parametrizations, see below.
29962 C...Powers of 1-x in different cases.
29963 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
29964 C...Expansion coefficients for up valence quark distribution.
29965 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
29966 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
29967 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
29968 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
29969 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
29970 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
29971 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
29972 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
29973 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
29974 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
29975 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
29976 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
29977 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
29978 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
29979 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
29980 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
29981 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
29982 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
29983 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
29984 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
29985 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
29986 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
29987 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
29988 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
29989 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
29990 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
29991 C...Expansion coefficients for down valence quark distribution.
29992 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
29993 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
29994 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
29995 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
29996 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
29997 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
29998 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
29999 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
30000 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
30001 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
30002 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
30003 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
30004 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
30005 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
30006 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
30007 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
30008 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
30009 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
30010 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
30011 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
30012 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
30013 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
30014 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
30015 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
30016 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
30017 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
30018 C...Expansion coefficients for up and down sea quark distributions.
30019 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
30020 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
30021 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
30022 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
30023 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
30024 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
30025 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
30026 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
30027 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
30028 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
30029 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
30030 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
30031 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
30032 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
30033 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
30034 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
30035 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
30036 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
30037 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
30038 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
30039 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
30040 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
30041 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
30042 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
30043 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
30044 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
30045 C...Expansion coefficients for gluon distribution.
30046 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
30047 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
30048 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
30049 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
30050 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
30051 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
30052 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
30053 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
30054 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
30055 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
30056 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
30057 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
30058 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
30059 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
30060 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
30061 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
30062 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
30063 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
30064 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
30065 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
30066 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
30067 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
30068 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
30069 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
30070 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
30071 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
30072 C...Expansion coefficients for strange sea quark distribution.
30073 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
30074 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
30075 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
30076 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
30077 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
30078 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
30079 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
30080 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
30081 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
30082 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
30083 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
30084 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
30085 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
30086 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
30087 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
30088 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
30089 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
30090 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
30091 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
30092 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
30093 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
30094 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
30095 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
30096 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
30097 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
30098 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
30099 C...Expansion coefficients for charm sea quark distribution.
30100 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
30101 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
30102 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
30103 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
30104 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
30105 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
30106 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
30107 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
30108 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
30109 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
30110 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
30111 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
30112 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
30113 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
30114 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
30115 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
30116 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
30117 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
30118 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
30119 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
30120 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
30121 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
30122 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
30123 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
30124 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
30125 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
30126 C...Expansion coefficients for bottom sea quark distribution.
30127 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
30128 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
30129 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
30130 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
30131 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
30132 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
30133 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
30134 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
30135 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
30136 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
30137 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
30138 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
30139 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
30140 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
30141 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
30142 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
30143 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
30144 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
30145 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
30146 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
30147 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
30148 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
30149 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
30150 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
30151 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
30152 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
30153 C...Expansion coefficients for top sea quark distribution.
30154 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
30155 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
30156 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
30157 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
30158 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
30159 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
30160 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
30161 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
30162 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
30163 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
30164 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
30165 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
30166 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
30167 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
30168 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
30169 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
30170 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
30171 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
30172 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
30173 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
30174 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
30175 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
30176 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
30177 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
30178 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
30179 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
30181 C...The following data lines are coefficients needed in the
30182 C...Duke, Owens proton structure function parametrizations, see below.
30183 C...Expansion coefficients for (up+down) valence quark distribution.
30184 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
30185 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30186 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30187 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
30188 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
30189 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30190 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30191 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
30192 C...Expansion coefficients for down valence quark distribution.
30193 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
30194 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30195 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
30196 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
30197 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
30198 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30199 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
30200 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
30201 C...Expansion coefficients for (up+down+strange) sea quark distribution.
30202 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
30203 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30204 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
30205 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
30206 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
30207 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30208 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
30209 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
30210 C...Expansion coefficients for charm sea quark distribution.
30211 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
30212 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30213 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
30214 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
30215 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
30216 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
30217 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
30218 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
30219 C...Expansion coefficients for gluon distribution.
30220 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
30221 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
30222 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
30223 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
30224 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
30225 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
30226 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
30227 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
30229 C...Euler's beta function, requires ordinary Gamma function
30230 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
30232 C...Leading order proton parton distributions from Glueck, Reya and
30233 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
30235 IF(MSTP(51).EQ.11) THEN
30237 C...Determine s expansion variable and some x expressions.
30238 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
30239 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
30244 C...Evaluate valence, gluon and sea distributions.
30245 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
30246 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
30247 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
30248 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
30249 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
30250 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
30251 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
30252 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
30253 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
30254 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
30255 & SQRT(4.066D0*SD**1.218D0*XL)))*
30256 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
30257 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
30258 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
30259 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
30260 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
30261 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
30262 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
30263 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
30264 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
30265 IF(SD.LE.0.888D0) THEN
30268 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
30269 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
30270 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
30272 IF(SD.LE.1.351D0) THEN
30275 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
30276 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
30277 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
30280 C...Put into output array.
30282 XPPR(1)=XFVDD+XFSEA
30283 XPPR(2)=XFVUD-XFVDD+XFSEA
30293 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
30294 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
30295 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
30297 C...Determine set, Lambda and x and t expansion variables.
30299 IF(NSET.EQ.1) ALAM=0.2D0
30300 IF(NSET.EQ.2) ALAM=0.29D0
30301 TMIN=LOG(5D0/ALAM**2)
30302 TMAX=LOG(1D8/ALAM**2)
30303 T=LOG(MAX(1D0,Q2/ALAM**2))
30304 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
30306 IF(X.LE.0.1D0) NX=2
30307 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
30308 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
30310 C...Chebyshev polynomials for x and t expansion.
30313 TX(3)=2D0*VX**2-1D0
30314 TX(4)=4D0*VX**3-3D0*VX
30315 TX(5)=8D0*VX**4-8D0*VX**2+1D0
30316 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
30319 TT(3)=2D0*VT**2-1D0
30320 TT(4)=4D0*VT**3-3D0*VT
30321 TT(5)=8D0*VT**4-8D0*VT**2+1D0
30322 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
30324 C...Calculate structure functions.
30329 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
30332 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
30335 C...Put into output array.
30337 XPPR(1)=XQ(2)+XQ(3)
30338 XPPR(2)=XQ(1)+XQ(3)
30346 C...Special expansion for bottom (threshold effects).
30347 IF(MSTP(58).GE.5) THEN
30348 IF(NSET.EQ.1) TMIN=8.1905D0
30349 IF(NSET.EQ.2) TMIN=7.4474D0
30351 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
30354 TT(3)=2D0*VT**2-1D0
30355 TT(4)=4D0*VT**3-3D0*VT
30356 TT(5)=8D0*VT**4-8D0*VT**2+1D0
30357 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
30361 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
30364 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
30369 C...Special expansion for top (threshold effects).
30370 IF(MSTP(58).GE.6) THEN
30371 IF(NSET.EQ.1) TMIN=11.5528D0
30372 IF(NSET.EQ.2) TMIN=10.8097D0
30373 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
30374 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
30376 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
30379 TT(3)=2D0*VT**2-1D0
30380 TT(4)=4D0*VT**3-3D0*VT
30381 TT(5)=8D0*VT**4-8D0*VT**2+1D0
30382 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
30386 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
30389 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
30394 C...Proton parton distributions from Duke, Owens.
30395 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
30396 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
30398 C...Determine set, Lambda and s expansion parameter.
30400 IF(NSET.EQ.1) ALAM=0.2D0
30401 IF(NSET.EQ.2) ALAM=0.4D0
30402 Q2IN=MIN(1D6,MAX(4D0,Q2))
30403 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
30405 C...Calculate structure functions.
30408 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
30409 & CDO(3,IS,KFL,NSET)*SD**2
30412 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
30413 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
30415 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
30416 & TS(5)*X**2+TS(6)*X**3)
30420 C...Put into output arrays.
30422 XPPR(1)=XQ(2)+XQ(3)/6D0
30423 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
30436 C*********************************************************************
30439 C...Gives threshold attractive/repulsive factor for heavy flavour
30442 FUNCTION PYHFTH(SH,SQM,FRATT)
30444 C...Double precision and integer declarations.
30445 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30446 IMPLICIT INTEGER(I-N)
30447 INTEGER PYK,PYCHGE,PYCOMP
30449 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30450 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30451 COMMON/PYINT1/MINT(400),VINT(400)
30452 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
30454 C...Value for alpha_strong.
30455 IF(MSTP(35).LE.1) THEN
30460 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
30466 C...Evaluate attractive and repulsive factors.
30467 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
30468 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
30469 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
30470 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
30471 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
30477 C*********************************************************************
30480 C...Splits a hadron remnant into two (partons or hadron + parton)
30481 C...in case it is more complicated than just a quark or a diquark.
30483 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
30485 C...Double precision and integer declarations.
30486 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30487 IMPLICIT INTEGER(I-N)
30488 INTEGER PYK,PYCHGE,PYCOMP
30489 C...Commonblocks. PYDAT1 temporary
30490 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30491 COMMON/PYINT1/MINT(400),VINT(400)
30492 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30493 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
30497 C...Preliminaries. Parton composition.
30500 KFL(1)=MOD(KFA/1000,10)
30501 KFL(2)=MOD(KFA/100,10)
30502 KFL(3)=MOD(KFA/10,10)
30503 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
30504 KFL(2)=INT(1.5D0+PYR(0))
30505 IF(MINT(105).EQ.333) KFL(2)=3
30506 IF(MINT(105).EQ.443) KFL(2)=4
30508 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
30511 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
30514 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
30515 KFL(2)=MOD(KFA/10,10)
30516 KFL(3)=MOD(KFA/100,10)
30518 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
30525 C...Subdivide lepton.
30526 IF(KFA.GE.11.AND.KFA.LE.18) THEN
30527 IF(KFLR.EQ.KFA) THEN
30529 ELSEIF(KFLR.EQ.22) THEN
30531 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
30533 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
30535 ELSEIF(KFLR.EQ.21) THEN
30543 C...Subdivide photon.
30544 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
30545 IF(KFLR.NE.21) THEN
30550 IF(RAGR.GT.0.125D0) KFLSP=2
30551 IF(RAGR.GT.0.625D0) KFLSP=3
30552 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
30556 C...Subdivide Reggeon or Pomeron.
30557 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
30558 IF(KFLIN.EQ.21) THEN
30564 C...Subdivide meson.
30565 ELSEIF(KFL(1).EQ.0) THEN
30566 KFL(2)=KFL(2)*(-1)**KFL(2)
30567 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
30568 IF(KFLR.EQ.KFL(2)) THEN
30570 ELSEIF(KFLR.EQ.KFL(3)) THEN
30572 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
30575 ELSEIF(KFLR.EQ.21) THEN
30578 ELSEIF(KFLR*KFL(2).GT.0) THEN
30581 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
30582 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
30584 ELSEIF(KFLCH.EQ.0) THEN
30585 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
30593 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
30594 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
30596 ELSEIF(KFLCH.EQ.0) THEN
30597 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
30604 C...Subdivide baryon.
30608 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
30611 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
30614 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
30615 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
30618 IAGR=1.00001D0+2.99998D0*PYR(0)
30621 IF(IAGR.EQ.1) ID1=2
30622 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
30625 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
30626 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
30627 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
30628 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
30629 ELSEIF(MOD(KFA,10).EQ.2) THEN
30630 IF(IAGR.EQ.1) KSP=1
30631 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
30633 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
30634 IF(KFLR.EQ.21) THEN
30636 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
30639 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
30640 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
30642 ELSEIF(KFLCH.EQ.0) THEN
30643 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
30647 ELSEIF(NAGR.EQ.0) THEN
30650 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
30651 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
30653 ELSEIF(KFLCH.EQ.0) THEN
30654 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
30662 C...Add on correct sign for result.
30669 C*********************************************************************
30672 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
30673 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
30674 C...(Dover, 1965) 6.1.36.
30678 C...Double precision and integer declarations.
30679 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30680 IMPLICIT INTEGER(I-N)
30681 INTEGER PYK,PYCHGE,PYCOMP
30682 C...Local array and data.
30684 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
30685 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
30694 PYGAMM=PYGAMM+B(I)*DXP
30700 PYGAMM=(X-IX)*PYGAMM
30707 C***********************************************************************
30710 C...Calculates real and imaginary parts of the auxiliary functions W1
30711 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
30712 C...der Bij, Nucl. Phys. B297 (1988) 221.
30714 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
30716 C...Double precision and integer declarations.
30717 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30718 IMPLICIT INTEGER(I-N)
30719 INTEGER PYK,PYCHGE,PYCOMP
30721 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30724 ASINH(X)=LOG(X+SQRT(X**2+1D0))
30725 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
30727 IF(EPS.LT.0D0) THEN
30728 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
30729 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
30731 ELSEIF(EPS.LT.1D0) THEN
30732 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
30733 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
30734 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
30735 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
30737 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
30738 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
30745 C***********************************************************************
30748 C...Calculates real and imaginary parts of the auxiliary function I3;
30749 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
30750 C...Nucl. Phys. B297 (1988) 221.
30752 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
30754 C...Double precision and integer declarations.
30755 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30756 IMPLICIT INTEGER(I-N)
30757 INTEGER PYK,PYCHGE,PYCOMP
30759 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30762 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
30763 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
30765 IF(EPS.LT.0D0) THEN
30766 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
30767 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
30768 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
30769 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
30770 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
30771 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
30772 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
30773 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
30775 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
30776 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
30777 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
30778 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
30779 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
30780 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
30781 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
30782 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
30783 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
30784 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
30785 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
30786 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
30787 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
30788 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
30789 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
30790 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
30792 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
30793 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
30794 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
30795 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
30796 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
30799 ELSEIF(EPS.LT.1D0) THEN
30800 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
30801 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
30802 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
30803 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
30804 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
30805 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
30806 & (0.25D0*(RAT+1D0)*EPS))
30807 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
30808 & (0.25D0*(RAT+1D0)*EPS))
30809 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
30810 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
30811 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
30812 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
30813 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
30814 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
30815 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
30816 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
30817 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
30818 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
30819 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
30820 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
30821 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
30822 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
30823 & (1D0+0.25D0*RAT*EPS-GA))
30824 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
30825 & (1D0+0.25D0*RAT*EPS-GA))
30827 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
30828 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
30829 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
30830 & LOG((GA+BE-1D0)/(BE-GA))
30831 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
30834 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
30835 RCTHE=RSQ*(1D0-2D0*BE/EPS)
30836 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
30837 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
30838 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
30840 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
30841 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
30842 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
30843 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
30844 & (PHI-THE)*(PHI+THE-PARU(1))
30845 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
30846 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
30849 Y3RE=2D0/(2D0*BE-1D0)*F3RE
30850 Y3IM=2D0/(2D0*BE-1D0)*F3IM
30855 C***********************************************************************
30858 C...Calculates real and imaginary part of Spence function; see
30859 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
30861 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
30863 C...Double precision and integer declarations.
30864 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30865 IMPLICIT INTEGER(I-N)
30866 INTEGER PYK,PYCHGE,PYCOMP
30868 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30870 C...Local array and data.
30873 &1.000000D+00, -5.000000D-01, 1.666667D-01,
30874 &0.000000D+00, -3.333333D-02, 0.000000D+00,
30875 &2.380952D-02, 0.000000D+00, -3.333333D-02,
30876 &0.000000D+00, 7.575757D-02, 0.000000D+00,
30877 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
30881 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
30882 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
30883 IF(IREIM.EQ.2) PYSPEN=0D0
30887 XMOD=SQRT(XRE**2+XIM**2)
30888 IF(XMOD.LT.1D-6) THEN
30889 IF(IREIM.EQ.1) PYSPEN=0D0
30890 IF(IREIM.EQ.2) PYSPEN=0D0
30894 XARG=SIGN(ACOS(XRE/XMOD),XIM)
30898 IF(XMOD.GT.1D0) THEN
30900 ALGXIM=XARG-SIGN(PARU(1),XARG)
30901 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
30902 SP0IM=-ALGXRE*ALGXIM
30909 IF(XRE.GT.0.5D0) THEN
30914 XMOD=SQRT(XRE**2+XIM**2)
30915 XARG=SIGN(ACOS(XRE/XMOD),XIM)
30918 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
30919 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
30925 XMOD=SQRT(XRE**2+XIM**2)
30926 XARG=SIGN(ACOS(XRE/XMOD),XIM)
30935 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
30936 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
30937 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
30940 SPRE=SPRE+B(I)*TERMRE
30941 SPIM=SPIM+B(I)*TERMIM
30944 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
30945 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
30950 C***********************************************************************
30953 C...Calculates the matrix element for the processes
30954 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
30955 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
30956 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
30958 SUBROUTINE PYQQBH(WTQQBH)
30960 C...Double precision and integer declarations.
30961 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30962 IMPLICIT INTEGER(I-N)
30963 INTEGER PYK,PYCHGE,PYCOMP
30965 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30966 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30967 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30968 COMMON/PYINT1/MINT(400),VINT(400)
30969 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30970 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
30971 C...Local arrays and function.
30972 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
30973 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
30976 C...Mass parameters.
30979 SHPR=SQRT(VINT(26))*VINT(1)
30980 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
30981 PH=SQRT(VINT(21))*VINT(1)
30985 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
30987 PT=SQRT(MAX(0D0,VINT(197+5*I)))
30988 PP(I,1)=PT*COS(VINT(198+5*I))
30989 PP(I,2)=PT*SIN(VINT(198+5*I))
30991 PP(3,1)=-PP(1,1)-PP(2,1)
30992 PP(3,2)=-PP(1,2)-PP(2,2)
30993 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
30994 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
30995 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
30997 PP(3,3)=PMT3*SINH(VINT(211))
30998 PP(3,4)=PMT3*COSH(VINT(211))
30999 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
31000 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
31001 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
31002 PP(2,3)=-PP(1,3)-PP(3,3)
31003 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
31004 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
31006 C...Set up incoming kinematics and derived momentum combinations.
31010 PP(I,3)=-0.5D0*SHPR*(-1)**I
31011 PP(I,4)=-0.5D0*SHPR
31014 PP(6,J)=PP(1,J)+PP(2,J)
31015 PP(7,J)=PP(1,J)+PP(3,J)
31016 PP(8,J)=PP(1,J)+PP(4,J)
31017 PP(9,J)=PP(1,J)+PP(5,J)
31018 PP(10,J)=-PP(2,J)-PP(3,J)
31019 PP(11,J)=-PP(2,J)-PP(4,J)
31020 PP(12,J)=-PP(2,J)-PP(5,J)
31021 PP(13,J)=-PP(4,J)-PP(5,J)
31024 C...Derived kinematics invariants.
31053 C...Define colour coefficients for g + g -> Q + Qbar + H.
31054 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
31058 CLR(I+3,J+3)=16D0/3D0
31059 CLR(I,J+3)=-2D0/3D0
31060 CLR(I+3,J)=-2D0/3D0
31073 CLR(6+K1,6+K2)=12D0
31077 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
31078 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
31079 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
31080 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
31081 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
31082 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
31083 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
31085 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
31086 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
31087 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
31088 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
31089 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
31090 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
31091 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
31092 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
31093 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
31094 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
31095 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
31096 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
31097 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
31098 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
31099 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
31100 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
31101 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
31102 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
31104 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
31105 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
31106 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
31107 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
31108 & +X4*X9*X5+X4*X5**2)
31109 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
31110 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
31111 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
31112 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
31113 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
31114 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
31115 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
31116 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
31117 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
31118 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
31119 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
31120 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
31121 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
31122 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
31123 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
31124 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
31125 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
31126 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
31127 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
31128 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
31130 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
31131 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
31132 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
31133 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
31134 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
31135 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
31136 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
31138 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
31139 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
31140 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
31141 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
31142 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
31143 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
31145 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
31146 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
31147 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
31148 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
31149 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
31150 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
31151 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
31153 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
31154 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
31155 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
31156 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
31157 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
31158 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
31159 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
31160 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
31161 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
31162 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
31163 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
31164 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
31165 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
31166 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
31167 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
31168 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
31169 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
31170 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
31171 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
31172 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
31173 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
31174 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
31175 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
31176 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
31177 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
31178 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
31179 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
31180 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
31181 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
31182 & +X3*X8*X5+X3*X5**2)
31183 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
31184 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
31185 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
31186 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
31187 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
31188 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
31189 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
31191 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
31192 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
31193 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
31194 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
31195 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
31196 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
31197 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
31198 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
31199 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
31200 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
31201 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
31202 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
31203 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
31204 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
31205 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
31206 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
31207 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
31208 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
31209 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
31210 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
31211 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
31212 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
31213 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
31214 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
31215 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
31216 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
31218 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
31219 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
31220 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
31221 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
31222 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
31223 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
31224 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
31225 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
31226 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
31227 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
31228 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
31229 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
31230 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
31231 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
31232 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
31233 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
31234 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
31235 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
31236 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
31237 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
31238 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
31239 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
31240 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
31241 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
31242 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
31243 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
31245 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
31246 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
31247 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
31248 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
31249 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
31250 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
31251 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
31252 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
31253 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
31254 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
31255 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
31256 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
31257 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
31258 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
31259 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
31260 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
31261 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
31262 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
31263 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
31264 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
31265 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
31266 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
31267 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
31268 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
31269 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
31270 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
31271 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
31272 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
31273 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
31274 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
31275 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
31276 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
31277 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
31278 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
31279 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
31280 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
31281 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
31282 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
31283 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
31284 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
31285 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
31286 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
31287 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
31288 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
31290 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
31291 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
31292 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
31293 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
31294 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
31295 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
31296 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
31297 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
31298 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
31299 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
31300 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
31302 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
31303 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
31304 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
31305 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
31306 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
31307 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
31309 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
31310 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
31311 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
31313 FM(9,10)=0.5D0*(FMXX+FM(9,10))
31314 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
31315 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
31316 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
31318 C...Repackage matrix elements.
31324 RM(7,7)=FM(7,7)-2D0*FM(9,9)
31325 RM(7,8)=FM(7,8)-2D0*FM(9,10)
31326 RM(8,8)=FM(8,8)-2D0*FM(10,10)
31328 C...Produce final result: matrix elements * colours * propagators.
31333 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
31336 WTQQBH=-WTQQBH/256D0
31339 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
31340 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
31341 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
31343 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
31344 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
31345 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
31347 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
31348 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
31351 C...Produce final result: matrix elements * propagators.
31353 A12=A12/(DX(7)*DX(8))
31355 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
31361 C*********************************************************************
31364 C...Initializes supersymmetry: finds sparticle masses and
31365 C...branching ratios and stores this information.
31366 C...AUTHOR: STEPHEN MRENNA
31370 C...Double precision and integer declarations.
31371 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31372 IMPLICIT INTEGER(I-N)
31373 INTEGER PYK,PYCHGE,PYCOMP
31374 C...Parameter statement to help give large particle numbers.
31375 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31376 &KEXCIT=4000000,KDIMEN=5000000)
31378 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31379 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31380 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
31381 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31382 COMMON/PYINT4/MWID(500),WIDS(500,5)
31383 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
31384 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
31385 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
31386 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
31387 COMMON/PYHTRI/HHH(7)
31388 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
31391 C...Local variables.
31392 DOUBLE PRECISION ALFA,BETA
31393 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
31394 INTEGER I,J,J1,I1,K1
31395 INTEGER KC,LKNT,IDLAM(300,3)
31396 DOUBLE PRECISION XLAM(0:300)
31397 DOUBLE PRECISION WDTP(0:300),WDTE(0:300,0:5)
31398 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
31399 DOUBLE PRECISION DELM,XMDIF
31400 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
31401 DOUBLE PRECISION ARG,SGNMU,R
31404 INTEGER KFSUSY(36),MWIDSU(36),MDCYSU(36)
31407 &1000001,2000001,1000002,2000002,1000003,2000003,
31408 &1000004,2000004,1000005,2000005,1000006,2000006,
31409 &1000011,2000011,1000012,2000012,1000013,2000013,
31410 &1000014,2000014,1000015,2000015,1000016,2000016,
31411 &1000021,1000022,1000023,1000025,1000035,1000024,
31412 &1000037,1000039, 25, 35, 36, 37/
31415 C...Do nothing if SUSY not requested.
31417 IF(IMSSM.EQ.0) RETURN
31419 C...Save copy of MWID(KC) and MDCY(KC,1) values before
31420 C...they are set to zero for the LSP.
31427 MDCYSU(I)=MDCY(KC,1)
31431 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
31435 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
31437 MDCY(KC,1)=MDCYSU(I)
31441 C...First part of routine: set masses and couplings.
31443 C...Reset mixing values in sfermion sector to pure left/right.
31451 C...Common couplings.
31456 COS2B=COS(2D0*BETA)
31462 C...Define sparticle masses for a general MSSM simulation.
31463 IF(IMSSM.EQ.1) THEN
31464 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
31466 KC=PYCOMP(KSUSY1+I)
31467 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
31468 KC=PYCOMP(KSUSY2+I)
31469 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
31470 KC=PYCOMP(KSUSY1+I+1)
31471 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
31472 KC=PYCOMP(KSUSY2+I+1)
31473 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
31475 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
31476 IF(XARG.LT.0D0) THEN
31477 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
31478 & ' FROM THE SUM RULE. '
31479 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
31485 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
31486 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
31487 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
31488 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
31490 IF(IMSS(8).EQ.1) THEN
31495 C...Alternatively derive masses from SUGRA relations.
31496 ELSEIF(IMSSM.EQ.2) THEN
31500 C...Add in extra D-term contributions.
31501 IF(IMSS(7).EQ.1) THEN
31506 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31507 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
31508 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
31509 WRITE(MSTU(11),*) 'C DX = ',DX
31510 WRITE(MSTU(11),*) 'C DY = ',DY
31511 WRITE(MSTU(11),*) 'C DS = ',DS
31512 WRITE(MSTU(11),*) 'C '
31513 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
31514 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
31515 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31516 DQ2=DY/6D0-DX/3D0-DS/3D0
31517 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
31518 DD2=DY/3D0+DX-2D0*DS/3D0
31519 DL2=-DY/2D0+DX-2D0*DS/3D0
31520 DE2=DY-DX/3D0-DS/3D0
31521 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
31522 DHD2=-DY/2D0-2D0*DX/3D0+DS
31523 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
31525 DMA2 = 2D0*DMU2+DHU2+DHD2
31527 KC=PYCOMP(KSUSY1+I)
31528 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
31529 KC=PYCOMP(KSUSY2+I)
31530 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
31531 KC=PYCOMP(KSUSY1+I+1)
31532 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
31533 KC=PYCOMP(KSUSY2+I+1)
31534 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
31537 KC=PYCOMP(KSUSY1+I)
31538 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
31539 KC=PYCOMP(KSUSY2+I)
31540 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
31541 KC=PYCOMP(KSUSY1+I+1)
31542 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
31544 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
31545 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
31548 SGNMU=SIGN(1D0,RMSS(4))
31549 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
31550 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
31551 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
31552 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
31553 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
31554 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
31555 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
31556 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
31557 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
31558 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
31559 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
31560 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
31561 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
31564 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
31565 RMSS(6)=SQRT(RMSS(6)**2+DL2)
31566 RMSS(7)=SQRT(RMSS(7)**2+DE2)
31567 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
31568 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
31569 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
31570 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
31571 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
31574 C...Fix the third generation sfermions.
31576 XARG=RMSS(13)**2-PMAS(24,1)**2*ABS(COS2B)
31577 IF(XARG.LT.0D0) THEN
31578 WRITE(MSTU(11),*) ' TAU SNEUTRINO MASS IS NEGATIVE FROM'//
31579 & ' THE SUM RULE. '
31580 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
31583 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
31586 C...Fix the neutralino--chargino--gluino sector.
31589 C...Fix the Higgs sector.
31592 C...Choose the Gunion-Haber convention.
31596 C...Print information on mass parameters.
31597 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
31598 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31599 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
31600 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
31601 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
31602 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
31603 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
31604 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
31605 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
31606 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
31607 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31609 IF(IMSS(20).EQ.1) THEN
31610 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31611 WRITE(MSTU(11),*) ' DEBUG MODE '
31612 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
31613 & UMIX(2,1),UMIX(2,2)
31614 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
31615 & UMIXI(2,1),UMIXI(2,2)
31616 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
31617 & VMIX(2,1),VMIX(2,2)
31618 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
31619 & VMIXI(2,1),VMIXI(2,2)
31620 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
31621 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
31622 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
31623 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
31624 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
31625 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
31626 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
31627 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
31628 WRITE(MSTU(11),*) ' ALFA = ',ALFA
31629 WRITE(MSTU(11),*) ' BETA = ',BETA
31630 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
31631 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
31632 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
31635 C...Set up the Higgs couplings - needed here since initialization
31636 C...in PYINRE did not yet occur when PYWIDT is called below.
31648 C2B=COSB**2-SINB**2
31649 C...tanb (used for H+)
31653 C...Coupling to d-type quarks
31654 PARU(161)=SINA/COSB
31655 C...Coupling to u-type quarks
31656 PARU(162)=-COSA/SINB
31657 C...Coupling to leptons
31658 PARU(163)=PARU(161)
31662 PARU(165)=PARU(164)
31665 C...Coupling to d-type quarks
31666 PARU(171)=-COSA/COSB
31667 C...Coupling to u-type quarks
31668 PARU(172)=-SINA/SINB
31669 C...Coupling to leptons
31670 PARU(173)=PARU(171)
31674 PARU(175)=PARU(174)
31676 IF(IMSS(4).EQ.2) THEN
31677 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
31679 HHH(3)=HHH(3)+HHH(4)+HHH(5)
31680 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
31681 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
31682 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
31683 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
31687 IF(IMSS(4).EQ.2) THEN
31688 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
31690 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
31691 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
31692 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
31693 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
31696 IF(IMSS(4).EQ.2) THEN
31697 PARU(177)=COS(2D0*BE)*COS(BE+AL)
31699 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
31700 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
31701 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
31702 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
31705 IF(IMSS(4).EQ.2) THEN
31706 PARU(178)=PARU(177)
31708 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
31711 C...Coupling to d-type quarks
31713 C...Coupling to u-type quarks
31714 PARU(182)=1D0/PARU(181)
31715 C...Coupling to leptons
31716 PARU(183)=PARU(181)
31719 C...Coupling to Z h
31720 PARU(186)=COS(BE-AL)
31721 C...Coupling to Z H
31722 PARU(187)=SIN(BE-AL)
31728 C...Coupling to W h
31729 PARU(195)=COS(BE-AL)
31731 C...Tell that all Higgs couplings have been set.
31734 C...Set R-Violating couplings
31735 C...Set lambda couplings to common value or "natural values".
31736 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
31737 VIR3=1D0/(126D0)**3
31741 IF (IRI.NE.IRJ) THEN
31742 RVLAM(IRI,IRJ,IRK)=RMSS(51)
31743 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)
31744 & *SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*PMAS(9+2
31747 IF (IRI.GT.IRJ) RVLAM(IRI,IRJ,IRK)=-RVLAM(IRI,IRJ,IRK)
31752 C...Set lambda' couplings to common value or "natural values".
31753 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
31754 VIR3=1D0/(126D0)**3
31758 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
31759 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)
31760 & *SQRT(PMAS(9+2*IRI,1)*0.5*(PMAS(2*IRJ,1)+PMAS(2*IRJ
31761 & -1,1))*PMAS(2*IRK-1,1)*VIR3)
31767 C...Second part of routine: set decay modes and branching ratios.
31769 C...Allow chi10 -> gravitino + gamma or not.
31770 KC=PYCOMP(KSUSY1+39)
31771 IF( IMSS(11) .NE. 0 ) THEN
31772 PMAS(KC,1)=RMSS(21)/1000000000D0
31773 PMAS(KC,2)=0.0001D0
31775 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
31776 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1) THEN
31778 WRITE(MSTU(11),*) ' ALLOWING L-VIOLATING DECAYS '
31784 C...Loop over sparticle and Higgs species.
31785 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
31786 C...Find the LSP or NLSP for a gravitino LSP
31791 IF(KF.EQ.1000039) GOTO 230
31793 IF(PMAS(KC,1).LT.PMLSP) THEN
31803 C...Sfermion decays.
31805 C...First check to see if sneutrino is lighter than chi10.
31806 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
31807 & PMAS(KC,1).LT.PMCHI1) THEN
31809 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
31813 ELSEIF(I.EQ.25) THEN
31814 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
31815 IF(I.EQ.ILSP) LKNT=0
31817 C...Neutralino decays.
31818 ELSEIF(I.GE.26.AND.I.LE.29) THEN
31819 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
31820 C...chi10 stable or chi10 -> gravitino + gamma.
31821 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
31827 C...Chargino decays.
31828 ELSEIF(I.GE.30.AND.I.LE.31) THEN
31829 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
31831 C...Gravitino is stable.
31832 ELSEIF(I.EQ.32) THEN
31837 ELSEIF(I.GE.33.AND.I.LE.36) THEN
31838 C...Calculate decays to non-SUSY particles.
31839 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
31844 DO 260 I1=1,MDCY(KC,3)
31846 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
31847 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 260
31849 XLAM(0)=XLAM(0)+XLAM(I1)
31851 IDLAM(I1,J1)=KFDP(K1,J1)
31855 C...Add the decays to SUSY particles.
31856 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
31858 C...Zero the branching ratios for use in loop mode
31859 C...thanks to K. Matchev (FNAL)
31860 DO 270 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
31864 C...Set stable particles.
31872 C...Store branching ratios in the standard tables.
31874 IDC=MDCY(KC,2)+MDCY(KC,3)-1
31880 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
31881 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
31882 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
31883 BRAT(IDC)=XLAM(IL)/XLAM(0)
31885 IF(MDME(IDC,1).GE.1) THEN
31886 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
31887 & PMAS(PYCOMP(KFDP(IDC,2)),1)
31888 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
31889 & PMAS(PYCOMP(KFDP(IDC,3)),1)
31892 IF(XMDIF.GE.0D0) THEN
31893 DELM=MIN(DELM,XMDIF)
31895 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
31896 WRITE(MSTU(11),*) ' KF = ',KF
31897 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
31901 ELSEIF(IDC.EQ.IDCSV) THEN
31902 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
31903 & 'channel not recognized:'
31904 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
31911 C...Store width, cutoff and lifetime.
31913 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
31914 PMAS(KC,3)=PMAS(KC,2)*10D0
31916 PMAS(KC,3)=0.95D0*DELM
31918 IF(PMAS(KC,2).NE.0D0) THEN
31919 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
31927 C*********************************************************************
31930 C...Uses approximate analytical formulae to determine the full set of
31931 C...MSSM parameters from SUGRA input.
31932 C...See M. Drees and S.P. Martin, hep-ph/9504124
31936 C...Double precision and integer declarations.
31937 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31938 IMPLICIT INTEGER(I-N)
31939 INTEGER PYK,PYCHGE,PYCOMP
31940 C...Parameter statement to help give large particle numbers.
31941 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31942 &KEXCIT=4000000,KDIMEN=5000000)
31944 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31945 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31946 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
31947 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
31964 SINB=TANB/SQRT(TANB**2+1D0)
31967 DTERM=XMZ2*COS(2D0*BETA)
31968 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
31969 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
31972 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
31973 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
31974 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
31975 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
31977 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
31978 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
31979 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
31980 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
31982 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
31983 IF(XARG.LT.0D0) THEN
31984 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
31985 & ' FROM THE SUM RULE. '
31986 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
31992 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
31993 PMAS(PYCOMP(KSUSY2+I),1)=XMER
31994 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
31995 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
32000 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
32001 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
32003 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
32004 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
32005 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
32006 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
32009 C XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2)
32011 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
32012 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
32013 C XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2
32015 XMA2=2D0*(XM02+.52D0*XMG2)-XTOP-XBOT-XTAU/3D0+2D0*XMU2
32016 XMU=SIGN(SQRT(XMU2),RMSS(4))
32018 RMSS(19)=SQRT(XMA2)
32019 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
32020 IF(ARG.GT.0D0) THEN
32023 WRITE(MSTU(11),*) ' RIGHT STAU MASS < 0 '
32026 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
32027 IF(ARG.GT.0D0) THEN
32030 WRITE(MSTU(11),*) ' LEFT STAU MASS < 0 '
32033 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
32034 IF(ARG.GT.0D0) THEN
32037 RMSS(10)=-SQRT(-ARG)
32039 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
32040 IF(ARG.GT.0D0) THEN
32043 RMSS(12)=-SQRT(-ARG)
32045 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
32046 IF(ARG.GT.0D0) THEN
32049 RMSS(11)=-SQRT(-ARG)
32055 C*********************************************************************
32058 C...Determines the running mass of quarks.
32060 FUNCTION PYRNMQ(ID,DTERM)
32062 C...Double precision and integer declarations.
32063 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32064 IMPLICIT INTEGER(I-N)
32065 INTEGER PYK,PYCHGE,PYCOMP
32067 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32070 C...Local variables.
32071 DOUBLE PRECISION PI,R
32072 DOUBLE PRECISION TOL
32073 DOUBLE PRECISION CI(3)
32075 DOUBLE PRECISION PYALPS
32077 DATA PI,R/3.141592654D0,.61803399D0/
32078 DATA CI/0.47D0,0.07D0,0.02D0/
32082 AG=(0.71D0)**2/4D0/PI
32089 AS=PYALPS(XM02+6D0*XMG2)
32090 CG=8D0/9D0*((AS/AG)**2-1D0)
32091 BX=XM02+(CA+CG)*XMG2+DTERM
32092 AX=MIN(50D0**2,0.5D0*BX)
32093 CX=MAX(2000D0**2,2D0*BX)
32097 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
32105 CG=8D0/9D0*((AS1/AG)**2-1D0)
32106 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
32108 CG=8D0/9D0*((AS2/AG)**2-1D0)
32109 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
32110 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
32117 CG=8D0/9D0*((AS2/AG)**2-1D0)
32118 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
32125 CG=8D0/9D0*((AS1/AG)**2-1D0)
32126 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
32141 C*********************************************************************
32144 C...Determines the running mass of the top quark.
32146 FUNCTION PYRNMT(XMT)
32148 C...Double precision and integer declarations.
32149 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32150 IMPLICIT INTEGER(I-N)
32151 INTEGER PYK,PYCHGE,PYCOMP
32153 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32156 C...Local variables.
32157 DOUBLE PRECISION XMT
32158 DOUBLE PRECISION PI,R
32159 DOUBLE PRECISION TOL
32161 DOUBLE PRECISION PYALPS
32163 DATA PI,R/3.141592654D0,0.61803399D0/
32168 AX=MIN(50D0,BX*0.5D0)
32169 CX=MAX(300D0,2D0*BX)
32173 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
32180 AS1=PYALPS(X1**2)/PI
32181 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
32182 AS2=PYALPS(X2**2)/PI
32183 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
32184 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
32190 AS2=PYALPS(X2**2)/PI
32191 F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
32197 AS1=PYALPS(X1**2)/PI
32198 F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
32213 C*********************************************************************
32216 C...Calculates the mass eigenstates of the third generation sfermions.
32217 C...Created: 5-31-96
32221 C...Double precision and integer declarations.
32222 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32223 IMPLICIT INTEGER(I-N)
32224 INTEGER PYK,PYCHGE,PYCOMP
32225 C...Parameter statement to help give large particle numbers.
32226 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32227 &KEXCIT=4000000,KDIMEN=5000000)
32229 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32230 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32231 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32232 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32233 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
32234 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
32236 C...Local variables.
32237 DOUBLE PRECISION BETA
32238 DOUBLE PRECISION PYRNMT
32239 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
32240 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
32241 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
32242 DOUBLE PRECISION ATR,AMQR,AMQL
32243 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
32244 INTEGER IF,I,J,II,JJ,IT,L
32258 COS2B=COS(2D0*BETA)
32260 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
32270 XMQL2=CTT2*XM12+STT2*XM22
32271 XMQR2=STT2*XM12+CTT2*XM22
32273 XMF2=PYRNMT(XMFR)**2
32274 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
32275 c ATMT=SQRT(XMF2)*(ATOP+XMU/TANB)
32276 c XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
32277 c IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
32279 c ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
32282 C......SUBTRACT OUT D-TERM AND FERMION MASS
32283 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
32284 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
32285 IF(XMQL2.GE.0D0) THEN
32286 RMSS(10)=SQRT(XMQL2)
32288 RMSS(10)=-SQRT(-XMQL2)
32290 IF(XMQR2.GE.0D0) THEN
32291 RMSS(12)=SQRT(XMQR2)
32293 RMSS(12)=-SQRT(-XMQR2)
32296 C SAME FOR BOTTOM SQUARK
32304 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
32306 IF(ABS(CTT).GE..9999D0) THEN
32309 ELSEIF(ABS(CTT).LE.1D-4) THEN
32313 XM22=(XMQL2-CTT2*XM12)/STT2
32314 XMQR2=STT2*XM12+CTT2*XM22
32315 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
32317 c ATMT=SQRT(XMF2)*(ABOT+XMU*TANB)
32318 c XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
32319 c IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
32321 c ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
32324 C......SUBTRACT OUT D-TERM AND FERMION MASS
32325 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
32326 IF(XMQR2.GE.0D0) THEN
32327 RMSS(11)=SQRT(XMQR2)
32329 RMSS(11)=-SQRT(-XMQR2)
32331 C SAME FOR TAU SLEPTON
32338 XMQL2=CTT2*XM12+STT2*XM22
32339 XMQR2=STT2*XM12+CTT2*XM22
32342 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
32343 c ATMT=SQRT(XMF2)*(ATAU+XMU*TANB)
32344 c XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
32345 c IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
32347 c ATAU=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
32350 C......SUBTRACT OUT D-TERM AND FERMION MASS
32351 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
32352 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
32353 IF(XMQL2.GE.0D0) THEN
32354 RMSS(13)=SQRT(XMQL2)
32356 RMSS(13)=-SQRT(-XMQL2)
32358 IF(XMQR2.GE.0D0) THEN
32359 RMSS(14)=SQRT(XMQR2)
32361 RMSS(14)=-SQRT(-XMQR2)
32366 IF(AMQL.LT.0D0) THEN
32374 IF(L.EQ.2) XMF=PYRNMT(XMF)
32378 IF(AMQR.LT.0D0) THEN
32383 AM2(1,1)=XMQL2+XMF2
32384 AM2(2,2)=XMQR2+XMF2
32385 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
32388 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
32389 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
32390 AM2(1,2)=XMF*(ATR+XMU*TANB)
32391 ELSEIF(L.EQ.2) THEN
32392 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
32393 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
32394 AM2(1,2)=XMF*(ATR+XMU/TANB)
32395 ELSEIF(L.EQ.3) THEN
32396 IF(IMSS(8).EQ.1) THEN
32397 AM2(1,1)=RMSS(6)**2
32398 AM2(2,2)=RMSS(7)**2
32403 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
32404 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
32405 AM2(1,2)=XMF*(ATR+XMU*TANB)
32410 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
32411 IF(DETM.LT.0D0) THEN
32412 WRITE(MSTU(11),*) ID2(L),DETM,AM2
32413 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
32415 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
32416 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
32420 IF(XMF22-XMF12.GT.0D0) THEN
32421 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
32423 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
32424 & AM2(1,2)/(XMF22-XMF12))
32440 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
32446 IF(DI(1,1).GT.DI(2,2)) THEN
32447 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
32448 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
32449 WRITE(MSTU(11),*) AM2
32450 WRITE(MSTU(11),*) DI
32451 WRITE(MSTU(11),*) RT
32462 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
32463 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
32464 & ' OFF DIAGONAL ELEMENTS '
32465 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
32466 WRITE(MSTU(11),*) DI
32467 WRITE(MSTU(11),*) ' ROTATION = ',RT
32469 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
32470 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
32471 & ' NEGATIVE MASSES '
32474 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
32475 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
32476 SFMIX(IF,1)=RT(1,1)
32477 SFMIX(IF,2)=RT(1,2)
32478 SFMIX(IF,3)=RT(2,1)
32479 SFMIX(IF,4)=RT(2,2)
32485 C*********************************************************************
32488 C...Finds the mass eigenstates and mixing matrices for neutralinos
32493 C...Double precision and integer declarations.
32494 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32495 IMPLICIT INTEGER(I-N)
32497 C...Parameter statement to help give large particle numbers.
32498 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32499 &KEXCIT=4000000,KDIMEN=5000000)
32501 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32502 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32503 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32504 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32505 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
32506 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
32508 C...Local variables.
32509 DOUBLE PRECISION XMW,XMZ,XM(4)
32510 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),AI(4,4)
32511 DOUBLE PRECISION WI(4),FV1(4),FV2(4),FV3(4)
32512 DOUBLE PRECISION COSW,SINW
32513 DOUBLE PRECISION XMU
32514 DOUBLE PRECISION TANB,COSB,SINB
32515 DOUBLE PRECISION XM1,XM2,XM3,BETA
32516 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
32517 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
32518 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
32519 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
32520 DOUBLE PRECISION PYALPS,PYALEM
32521 DOUBLE PRECISION PYRNM3
32522 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
32523 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
32524 DATA KFNCHI/1000022,1000023,1000025,1000035/
32527 IF(IMSS(1).EQ.2) THEN
32530 C...M1, M2, AND M3 ARE INDEPENDENT
32535 ELSEIF(IOPT.GE.1) THEN
32539 A1=AEM/(1D0-PARU(102))
32542 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
32544 XM2=XM1*A2/A1*3D0/5D0
32546 ELSEIF(IOPT.EQ.3) THEN
32547 XM1=XM2*5D0/3D0*A1/A2
32552 IF(XM3.LE.0D0) THEN
32553 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
32559 IF(IMSS(3).EQ.1) THEN
32560 PMAS(PYCOMP(KSUSY1+21),1)=XM3
32565 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
32566 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
32567 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
32573 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
32574 RM2=PMAS(I,1)**2/XM3**2
32575 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
32576 IF(ARG.GE.0D0) THEN
32577 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
32579 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
32584 ELSEIF(X0.EQ.0D0) THEN
32588 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
32589 & 0.5D0*X0**2*LOG(AX0)
32590 BT=(-1D0-2D0*X0)/4D0
32595 ELSEIF(X1.EQ.0D0) THEN
32599 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
32600 & X1**2*LOG(AX1)+AT
32601 BT=(-1D0-2D0*X1)/4D0+BT
32605 X0=0.5D0*(1D0+RM2-RM1)
32606 Y0=-0.5D0*SQRT(-ARG)
32607 AMGX0=SQRT(X0**2+Y0**2)
32608 AM1X0=SQRT((1D0-X0)**2+Y0**2)
32609 ARGX0=ATAN2(-X0,-Y0)
32610 AR1X0=ATAN2(1D0-X0,Y0)
32615 ARGX1=ATAN2(-X1,-Y1)
32616 AR1X1=ATAN2(1D0-X1,Y1)
32617 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
32618 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
32619 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
32620 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
32621 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
32622 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
32627 PMAS(PYCOMP(KSUSY1+21),1)=XM3*(1D0+PYALPS(XM3**2)/(2D0*PARU(2))*
32631 C...NEUTRALINO MASSES
32640 SINW=SQRT(PARU(102))
32641 COSW=SQRT(1D0-PARU(102))
32648 C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
32649 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
32650 AR(1,1) = XM1*COS(RMSS(30))
32651 AI(1,1) = XM1*SIN(RMSS(30))
32652 AR(2,2) = XM2*COS(RMSS(31))
32653 AI(2,2) = XM2*SIN(RMSS(31))
32658 AR(1,3) = -XMZ*SINW*COSB
32660 AR(1,4) = XMZ*SINW*SINB
32662 AR(2,3) = XMZ*COSW*COSB
32664 AR(2,4) = -XMZ*COSW*SINB
32666 AR(3,4) = -XMU*COS(RMSS(33))
32667 AI(3,4) = -XMU*SIN(RMSS(33))
32668 AR(4,3) = -XMU*COS(RMSS(33))
32669 AI(4,3) = -XMU*SIN(RMSS(33))
32670 C CALL PYEIG4(AR,WR,ZR)
32671 CALL PYEICG(4,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
32673 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
32682 IF(XM(K).LT.XM(J)) THEN
32700 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
32703 S=S+ZR(J,K)**2+ZI(J,K)**2
32706 ZMIX(I,J)=ZR(J,K)/SQRT(S)
32707 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
32708 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
32709 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
32713 C...CHARGINO MASSES
32714 C.....Find eigenvectors of X X^*
32717 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
32718 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
32719 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
32720 &XMU*COS(RMSS(33))*SINB)
32721 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
32722 &XMU*SIN(RMSS(33))*SINB)
32723 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
32724 &XMU*COS(RMSS(33))*SINB)
32725 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
32726 &XMU*SIN(RMSS(33))*SINB)
32727 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
32729 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
32733 IF(WR(2).LT.WR(1)) THEN
32743 S=S+ZR(J,K)**2+ZI(J,K)**2
32746 UMIX(I,J)=ZR(J,K)/SQRT(S)
32747 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
32748 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
32749 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
32752 IF(ABS(SMW(1)).LT.ABS(SMZ(1))) THEN
32753 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
32755 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
32756 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
32758 C.....Find eigenvectors of X^* X
32761 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
32762 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
32763 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
32764 &XMU*COS(RMSS(33))*COSB)
32765 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
32766 &XMU*SIN(RMSS(33))*COSB)
32767 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
32768 &XMU*COS(RMSS(33))*COSB)
32769 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
32770 &XMU*SIN(RMSS(33))*COSB)
32771 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
32773 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
32777 IF(WR(2).LT.WR(1)) THEN
32786 S=S+ZR(J,K)**2+ZI(J,K)**2
32789 VMIX(I,J)=ZR(J,K)/SQRT(S)
32790 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
32791 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
32792 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
32800 C*********************************************************************
32803 C...Calculates the running of M3, the SU(3) gluino mass parameter.
32805 FUNCTION PYRNM3(RGUT)
32807 C...Double precision and integer declarations.
32808 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32809 IMPLICIT INTEGER(I-N)
32810 INTEGER PYK,PYCHGE,PYCOMP
32812 C...Local variables.
32814 DOUBLE PRECISION TOL
32816 DOUBLE PRECISION PYALPS
32818 DATA R/0.61803399D0/
32822 BX=RGUT*PYALPS(RGUT**2)
32823 AX=MIN(50D0,BX*0.5D0)
32824 CX=MAX(2000D0,2D0*BX)
32828 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
32836 F1=ABS(X1-RGUT*AS1)
32838 F2=ABS(X2-RGUT*AS2)
32839 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
32846 F2=ABS(X2-RGUT*AS2)
32853 F1=ABS(X1-RGUT*AS1)
32868 C*********************************************************************
32871 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
32872 C...Specific application: mixing in neutralino sector.
32874 SUBROUTINE PYEIG4(A,W,Z)
32876 C...Double precision and integer declarations.
32877 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32878 IMPLICIT INTEGER(I-N)
32879 INTEGER PYK,PYCHGE,PYCOMP
32881 C...Arrays: in call and local.
32882 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
32884 C...Coefficients of fourth-degree equation from matrix.
32885 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
32886 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
32890 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
32899 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
32900 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
32901 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
32902 B0=B0+(-1D0)**(I+1)*A(1,I)*(
32903 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
32904 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
32905 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
32908 C...Coefficients of third-degree equation needed for
32909 C...separation into two second-degree equations.
32910 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
32913 C0=-B1**2-B0*B3**2+4D0*B0*B2
32914 CQ=C1/3D0-C2**2/9D0
32915 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
32918 C...Cases with one or three real roots.
32919 IF(CQR.GE.0D0) THEN
32920 S1=(CR+SQRT(CQR))**(1D0/3D0)
32921 S2=(CR-SQRT(CQR))**(1D0/3D0)
32925 THE=ACOS(CR/SABS**3)/3D0
32930 C...Find and solve two second-degree equations.
32931 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
32932 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
32933 Q1=U/2D0+SQRT(U**2/4D0-B0)
32934 Q2=U/2D0-SQRT(U**2/4D0-B0)
32935 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
32940 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
32941 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
32942 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
32943 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
32945 C...Order eigenvalues in asceding mass.
32948 DO 130 I2=I1-1,1,-1
32949 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
32955 C...Find equation system for eigenvectors.
32958 D(J1,J1)=A(J1,J1)-W(I)
32965 C...Find largest element in matrix.
32969 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
32972 DAMAX=ABS(D(J1,J2))
32976 C...Subtract others by multiple of row selected above.
32978 DO 210 J3=JA+1,JA+3
32980 RL=D(J1,JB)/D(JA,JB)
32982 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
32983 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
32986 DAMAX=ABS(D(J1,J2))
32990 C...Do one more subtraction of a row.
32992 DO 230 J3=JC+1,JC+3
32994 IF(J1.EQ.JA) GOTO 230
32995 RL=D(J1,JD)/D(JC,JD)
32997 IF(J2.EQ.JB) GOTO 220
32998 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
32999 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
33001 DAMAX=ABS(D(J1,J2))
33005 C...Construct unnormalized eigenvector.
33007 JF2=JD+2-4*((JD+1)/4)
33008 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
33009 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
33012 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
33013 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
33016 C...Normalize and fill in final array.
33017 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
33018 SGN=(-1D0)**INT(PYR(0)+0.5D0)
33027 C*********************************************************************
33030 C...Determines the Higgs boson mass spectrum using several inputs.
33032 SUBROUTINE PYHGGM(ALPHA)
33034 C...Double precision and integer declarations.
33035 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33036 IMPLICIT INTEGER(I-N)
33037 INTEGER PYK,PYCHGE,PYCOMP
33038 C...Parameter statement to help give large particle numbers.
33039 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33040 &KEXCIT=4000000,KDIMEN=5000000)
33042 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33043 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33044 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33045 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33046 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
33048 C...Local variables.
33049 DOUBLE PRECISION AT,AB,XMU,TANB
33050 DOUBLE PRECISION ALPHA
33052 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
33053 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
33054 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
33055 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
33058 IF(IHOPT.EQ.2) THEN
33074 DMC=PMAS(PYCOMP(KSUSY1+37),1)
33081 IF(IHOPT.EQ.0) THEN
33082 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
33083 & DMHCH,DSA,DCA,DTANBA)
33084 ELSEIF(IHOPT.EQ.1) THEN
33085 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
33086 & DMHCH,DSA,DCA,DTANBA)
33087 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
33088 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
33089 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
33095 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
33096 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
33097 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
33098 & PMAS(PYCOMP(1000006),1),DSTOP2
33100 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
33101 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
33102 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
33103 & PMAS(PYCOMP(2000006),1),DSTOP1
33105 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
33106 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
33107 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
33108 & PMAS(PYCOMP(1000005),1),DSBOT2
33110 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
33111 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
33112 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
33113 & PMAS(PYCOMP(2000005),1),DSBOT1
33128 C*********************************************************************
33131 C...This routine computes the renormalization group improved
33132 C...values of Higgs masses and couplings in the MSSM.
33134 C...Program based on the work by M. Carena, J.R. Espinosa,
33135 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
33137 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
33138 C...All masses in GeV units. MA is the CP-odd Higgs mass,
33139 C...MTOP is the physical top mass, MQ and MUR are the soft
33140 C...supersymmetry breaking mass parameters of left handed
33141 C...and right handed stops respectively, AU and AD are the
33142 C...stop and sbottom trilinear soft breaking terms,
33143 C...respectively, and MU is the supersymmetric
33144 C...Higgs mass parameter. We use the conventions from
33145 C...the physics report of Haber and Kane: left right
33146 C...stop mixing term proportional to (AU - MU/TANB)
33147 C...We use as input TANB defined at the scale MTOP
33149 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
33150 C...where MH and HM are the lightest and heaviest CP-even
33151 C...Higgs masses, MHCH is the charged Higgs mass and
33152 C...ALPHA is the Higgs mixing angle
33153 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
33155 C...Range of validity:
33156 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
33157 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
33158 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
33159 C...are the sbottom mass eigenvalues, respectively. This
33160 C...range automatically excludes the existence of tachyons.
33161 C...For the charged Higgs mass computation, the method is
33163 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
33164 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
33165 C...where M_SUSY**2 is the average of the squared stop mass
33166 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
33167 C...masses have been assumed to be of order of the stop ones
33168 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
33170 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
33171 &XMHCH,SA,CA,TANBA)
33173 C...Double precision and integer declarations.
33174 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33175 IMPLICIT INTEGER(I-N)
33176 INTEGER PYK,PYCHGE,PYCOMP
33177 C...Parameter statement to help give large particle numbers.
33178 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33179 &KEXCIT=4000000,KDIMEN=5000000)
33181 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33182 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33183 COMMON/PYHTRI/HHH(7)
33184 SAVE /PYDAT1/,/PYDAT2/
33186 C...Local variables.
33187 DOUBLE PRECISION PYALEM,PYALPS
33188 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
33189 DOUBLE PRECISION XMHCH,SA,CA
33190 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
33191 DOUBLE PRECISION Q02
33192 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
33193 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
33194 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
33195 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
33196 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
33197 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
33198 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
33199 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
33204 ALP1=AEM/(1D0-PARU(102))
33217 C...MBOTTOM(MTOP) = 3. GEV
33219 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
33220 &LOG(XMTOP**2/XMZ**2))
33222 C...RMTOP= RUNNING TOP QUARK MASS
33223 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
33224 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
33225 T = LOG(XMS**2/XMTOP**2)
33226 SINB = TANB/((1D0 + TANB**2)**0.5D0)
33228 C...IF(MA.LE.XMTOP) TANBA = TANBT
33230 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
33231 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
33232 &LOG(XMA**2/XMTOP**2))
33234 SINBT = TANBT/SQRT(1D0 + TANBT**2)
33235 COSBT = 1D0/SQRT(1D0 + TANBT**2)
33236 C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
33237 G1 = SQRT(ALP1*4D0*PI)
33238 G2 = SQRT(ALP2*4D0*PI)
33239 G3 = SQRT(ALP3*4D0*PI)
33254 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
33255 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
33256 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
33257 &+ 3D0*(AU + AD)**2/XMS2)/6D0
33258 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
33259 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
33260 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
33261 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
33262 &- 16D0*G3**2) *T/16D0/PI2)
33263 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
33264 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
33265 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
33266 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
33267 &- 16D0*G3**2) *T/16D0/PI2)
33268 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
33269 &(HU2 + HD2)*T/16D0/PI2)
33270 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
33271 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
33272 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
33273 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
33274 &- 16D0*G3**2) *T/16D0/PI2)
33275 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
33276 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
33277 &- 16D0*G3**2) *T/16D0/PI2)
33278 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
33279 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
33280 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
33281 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
33283 &(1+ (6D0*HU2 -2D0* HD2
33284 &- 16D0*G3**2) *T/16D0/PI2)
33285 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
33287 &(1+ (6D0*HD2 -2D0* HU2/2D0
33288 &- 16D0*G3**2) *T/16D0/PI2)
33289 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
33290 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
33291 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
33292 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
33293 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
33294 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
33295 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
33296 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
33297 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
33298 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
33299 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
33300 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
33308 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
33309 &2D0* XLAM6*SINBT*COSBT
33310 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
33312 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
33314 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
33315 &2D0* XLAM6* COSBT*SINBT
33316 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
33317 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
33318 &((XLAM1* COSBT**2 +2D0*
33319 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
33320 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
33322 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
33323 &+ XLAM4) + XLAM6*COSBT**2
33324 &+ XLAM7* SINBT**2))
33326 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
33327 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
33330 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
33331 XMHCH = SQRT(XMHCH2)
33333 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
33334 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
33335 &XLAM6* COSBT*SINBT
33336 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
33337 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
33338 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
33339 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
33341 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
33342 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
33343 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
33344 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
33345 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
33346 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
33347 &XLAM6* COSBT*SINBT
33348 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
33349 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
33350 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
33360 C*********************************************************************
33363 C...This subroutine computes the CP-even higgs and CP-odd pole
33364 c...Higgs masses and mixing angles.
33366 C...Program based on the work by M. Carena, M. Quiros
33367 C...and C.E.M. Wagner, "Effective potential methods and
33368 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
33370 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
33372 C...where MCHI is the largest chargino mass, MA is the running
33373 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
33374 C...expectaion values at the scale MTOP, MQ is the third generation
33375 C...left handed squark mass parameter, MUR is the third generation
33376 C...right handed stop mass parameter, MDR is the third generation
33377 C...right handed sbottom mass parameter, MTOP is the pole top quark
33378 C...mass; AT,AB are the soft supersymmetry breaking trilinear
33379 C...couplings of the stop and sbottoms, respectively, and MU is the
33380 C...supersymmetric mass parameter
33382 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
33383 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
33384 C...masses are given, what makes the running of the program
33385 c...much faster and it is quite generally a good approximation
33386 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
33387 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
33388 c...and if IHIGGS=3, then h,H,A polarizations are computed
33390 C...Output: MH and MHP which are the lightest CP-even Higgs running
33391 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
33392 C...Higgs running and pole masses, repectively; SA and CA are the
33393 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
33394 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
33395 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
33396 C...the value of TANB at the CP-odd Higgs mass scale
33398 C...This subroutine makes use of CERN library subroutine
33399 C...integration package, which makes the computation of the
33400 C...pole Higgs masses somewhat faster. We thank P. Janot for this
33401 C...improvement. Those who are not able to call the CERN
33402 C...libraries, please use the subroutine SUBHPOLE2.F, which
33403 C...although somewhat slower, gives identical results
33405 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
33406 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
33408 C...Double precision and integer declarations.
33409 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33410 IMPLICIT INTEGER(I-N)
33413 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33415 INTEGER PYK,PYCHGE,PYCOMP
33417 C...Local variables.
33418 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
33419 &SSBOT2(2),B(2,2),COUPB(2,2),
33420 &HCOUPT(2,2),HCOUPB(2,2),
33421 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
33431 C ALP3=1D0/(1D0/ALP3Z+23D0/6D0/PI*LOG(XMT/XMZ))
33433 C RXMT = XMT/(1D0+4*ALP3/3D0/PI)
33435 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
33436 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
33438 SINB = TANB/(TANB**2+1D0)**0.5D0
33439 COSB = 1D0/(TANB**2+1D0)**0.5D0
33440 COS2B = SINB**2 - COSB**2
33441 SINBPA = SINB*CA + COSB*SA
33442 COSBPA = COSB*CA - SINB*SA
33446 IF(XMUR.LT.0D0) XMUR2=-XMUR2
33448 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
33449 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
33450 IF(XMST11.LT.0D0) GOTO 500
33451 IF(XMST22.LT.0D0) GOTO 500
33452 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
33453 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
33454 IF(XMSB11.LT.0D0) GOTO 500
33455 IF(XMSB22.LT.0D0) GOTO 500
33456 C WMST11 = RXMT**2 + XMQ2
33457 C WMST22 = RXMT**2 + XMUR2
33458 XMST12 = RXMT*(AT - XMU/TANB)
33459 XMSB12 = RMBOT*(AB - XMU*TANB)
33461 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33462 C...STOP EIGENVALUES CALCULATION
33463 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33465 STOP12 = 0.5D0*(XMST11+XMST22) +
33466 &0.5D0*((XMST11+XMST22)**2 -
33467 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
33468 STOP22 = 0.5D0*(XMST11+XMST22) -
33469 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
33470 &XMST12**2))**0.5D0
33472 IF(STOP22.LT.0D0) GOTO 500
33475 STOP1 = STOP12**0.5D0
33476 STOP2 = STOP22**0.5D0
33480 IF(XMST12.EQ.0D0) XST11 = 1D0
33481 IF(XMST12.EQ.0D0) XST12 = 0D0
33482 IF(XMST12.EQ.0D0) XST21 = 0D0
33483 IF(XMST12.EQ.0D0) XST22 = 1D0
33485 IF(XMST12.EQ.0D0) GOTO 110
33487 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
33488 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
33489 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
33490 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
33497 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
33498 &0.5D0*((XMSB11+XMSB22)**2 -
33499 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
33500 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
33501 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
33502 &XMSB12**2))**0.5D0
33503 IF(SBOT22.LT.0D0) GOTO 500
33504 SBOT1 = SBOT12**0.5D0
33505 SBOT2 = SBOT22**0.5D0
33510 IF(XMSB12.EQ.0D0) XSB11 = 1D0
33511 IF(XMSB12.EQ.0D0) XSB12 = 0D0
33512 IF(XMSB12.EQ.0D0) XSB21 = 0D0
33513 IF(XMSB12.EQ.0D0) XSB22 = 1D0
33515 IF(XMSB12.EQ.0D0) GOTO 130
33517 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
33518 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
33519 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
33520 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
33532 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33533 C...STARTING OF LIGHT HIGGS
33534 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33536 IF(IHIGGS.EQ.0) GOTO 490
33541 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
33542 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
33543 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
33544 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
33553 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
33554 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
33555 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
33556 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
33564 180 ITER = ITER + 1
33567 PR(I3)=PRUN+(I3-2)*EPS/2
33572 POLT = POLT + COUPT(I,J)**2*3D0*
33573 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
33580 POLB = POLB + COUPB(I,J)**2*3D0*
33581 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
33588 & 3D0*RXMT**2/8D0/PI**2/ V **2*
33590 & (-2D0*XMT**2+0.5D0*P2)*
33591 & PYFINT(P2,XMT2,XMT2)
33593 POL = POLT + POLB + POLTT
33594 POLAR(I3) = P2 - XMH**2 - POL
33596 DERIV = (POLAR(3)-POLAR(1))/EPS
33597 DRUN = - POLAR(2)/DERIV
33600 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
33606 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33607 C...END OF LIGHT HIGGS
33608 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33610 250 IF(IHIGGS.EQ.1) GOTO 490
33612 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33613 C... STARTING OF HEAVY HIGGS
33614 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33619 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
33620 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
33621 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
33622 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
33630 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
33631 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
33632 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
33633 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
33642 300 ITER = ITER + 1
33644 PR(I3)=PRUN+(I3-2)*EPS/2
33650 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
33651 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
33658 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
33659 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
33667 & 3D0*RXMT**2/8D0/PI**2/ V **2*
33669 & (-2D0*XMT**2+0.5D0*HP2)*
33670 & PYFINT(HP2,XMT2,XMT2)
33672 HPOL = HPOLT + HPOLB + HPOLTT
33673 POLAR(I3) =HP2-HM**2-HPOL
33675 DERIV = (POLAR(3)-POLAR(1))/EPS
33676 DRUN = - POLAR(2)/DERIV
33679 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
33687 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33688 C... END OF HEAVY HIGGS
33689 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33691 IF(IHIGGS.EQ.2) GOTO 490
33693 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33694 C...BEGINNING OF PSEUDOSCALAR HIGGS
33695 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33700 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
33701 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
33707 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
33708 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
33715 420 ITER = ITER + 1
33717 PR(I3)=PRUN+(I3-2)*EPS/2
33722 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
33723 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
33729 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
33730 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
33736 & 3D0*RXMT**2/8D0/PI**2/ V **2*
33737 & COSB**2/SINB**2 *
33739 & PYFINT(AP2,XMT2,XMT2)
33740 APOL = APOLT + APOLB + APOLTT
33741 POLAR(I3) = AP2 - XMA**2 -APOL
33743 DERIV = (POLAR(3)-POLAR(1))/EPS
33744 DRUN = - POLAR(2)/DERIV
33747 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
33753 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33754 C...END OF PSEUDOSCALAR HIGGS
33755 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33757 IF(IHIGGS.EQ.3) GOTO 490
33762 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
33763 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
33764 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
33765 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
33769 C*********************************************************************
33772 C...Auxiliary to PYPOLE.
33774 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
33775 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
33776 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
33777 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
33780 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33791 C MBOTTOM(MTOP) = 3. GEV
33793 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
33794 *LOG(MTOP**2/MZ**2))
33795 C RMTOP= RUNNING TOP QUARK MASS
33796 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
33797 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
33798 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
33799 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
33800 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33802 C NEW DEFINITION, TGLU.
33804 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33805 TGLU = LOG(MGLU**2/MTOP**2)
33806 SINB = TANB/DSQRT(1D0 + TANB**2)
33809 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
33810 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
33811 *LOG(MA**2/MTOP**2))
33812 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
33813 SINB = TANBT/SQRT(1D0 + TANBT**2)
33814 COSB = 1D0/DSQRT(1D0 + TANBT**2)
33815 G1 = SQRT(ALPHA1*4D0*PI)
33816 G2 = SQRT(ALPHA2*4D0*PI)
33817 G3 = SQRT(ALPHA3*4D0*PI)
33820 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
33821 *SBOT1,SBOT2,DELTAMT,DELTAMB)
33822 IF(MQ.GT.MUR) TP = TQ - TU
33823 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
33824 IF(MQ.GT.MUR) TDP = TU
33825 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
33826 IF(MQ.GT.MD) TPD = TQ - TD
33827 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
33828 IF(MQ.GT.MD) TDPD = TD
33829 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
33831 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
33832 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
33833 * HD**2*(G1**2/3D0+G2**2)*TPD
33835 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
33836 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
33837 * HU**2*(-G1**2/3D0+G2**2)*TP
33839 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33841 C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
33842 C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
33843 C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
33847 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33849 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
33850 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
33851 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
33854 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
33855 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
33858 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
33859 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
33862 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
33863 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
33866 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
33867 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
33870 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
33871 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
33876 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
33877 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
33878 *(G2**2-G1**2/3D0)*TPD
33879 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
33880 *1D0/16D0/PI**2*G1**2*HU**2*TP
33881 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
33882 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
33883 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
33884 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
33886 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
33887 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
33888 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
33889 *+ (3D0*HD**2/2D0 + HU**2/2D0
33890 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
33891 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
33892 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
33893 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
33894 *(TP + TDP)/8D0/PI**2)
33895 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
33896 *+ (3D0*HU**2/2D0 + HD**2/2D0
33897 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
33898 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
33899 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
33900 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
33901 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
33902 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
33903 LAMBDA4 = (- G2**2/2D0)*(1D0
33904 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
33905 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
33911 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
33912 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
33914 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
33915 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
33916 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
33917 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
33920 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33921 CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
33922 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33924 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
33926 IF(MCHI.GT.MSSUSY) GOTO 100
33927 IF(MCHI.LT.MTOP) MCHI=MTOP
33929 TCHAR=LOG(MSSUSY**2/MCHI**2)
33931 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
33932 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
33933 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
33935 DELTAM112=2D0*DELTAL12*V**2*COSB**2
33936 DELTAM222=2D0*DELTAL12*V**2*SINB**2
33937 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
33939 M2(1,1)=M2(1,1)+DELTAM112
33940 M2(2,2)=M2(2,2)+DELTAM222
33941 M2(1,2)=M2(1,2)+DELTAM122
33942 M2(2,1)=M2(2,1)+DELTAM122
33946 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33947 CCC END OF CHARGINOS/NEUTRALINOS
33948 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33952 M2P(I,J) = M2(I,J) + VH(I,J)
33955 TRM2P = M2P(1,1) + M2P(2,2)
33956 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
33957 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
33958 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
33960 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
33962 IF(MH2P.LT.0.) GOTO 130
33964 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
33965 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
33966 IF(COS2ALPHA.GT.0.) ALPHA = ASIN(SIN2ALPHA)/2D0
33967 IF(COS2ALPHA.LT.0.) ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
33970 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33972 C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
33973 C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
33974 C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
33977 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
33978 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
33979 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
33984 C*********************************************************************
33987 C...Auxiliary to PYRGHM.
33989 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
33990 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
33991 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
33992 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
33994 INTEGER MSTU,MSTJ,KCHG
33995 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33996 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33997 SAVE /PYDAT1/,/PYDAT2/
33999 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
34001 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
34002 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
34004 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
34009 SINBA = TANBA/DSQRT(TANBA**2+1D0)
34010 COSBA = SINBA/TANBA
34012 SINB = TANB/DSQRT(TANB**2+1D0)
34018 SW = 1D0-MW**2/MZ**2
34021 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
34022 G2 = DSQRT(0.0336D0*4D0*PI)
34023 G1 = DSQRT(0.0101D0*4D0*PI)
34026 IF(MQ.GT.MUR) MST = MQ
34027 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
34029 MSUSYT = DSQRT(MST**2 + MTOP**2)
34031 IF(MQ.GT.MD) MSB = MQ
34032 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
34034 MSUSYB = DSQRT(MSB**2 + MB**2)
34035 TT = LOG(MSUSYT**2/MTOP**2)
34036 TB = LOG(MSUSYB**2/MTOP**2)
34038 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
34039 HT = RMTOP/(V*SINB)
34042 G32 = ALPHA3*4D0*PI
34043 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
34044 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
34045 AL2 = 3D0/8D0/PI**2*HT**2
34046 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
34047 C ALST = 3./8./PI**2*HTST**2
34048 AL1 = 3D0/8D0/PI**2*HB**2
34051 AL(1,2) = (AL2+AL1)/2D0
34052 AL(2,1) = (AL2+AL1)/2D0
34055 IF(MA.GT.MTOP) THEN
34056 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
34057 * LOG(MTOP**2/MA**2))
34060 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
34061 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
34062 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
34063 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
34068 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
34069 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
34070 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
34071 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
34075 SINBT = TANBST/DSQRT(1D0+TANBST**2)
34078 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
34079 COSBB = SINBB/TANBSB
34084 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
34085 MTOP2 = DSQRT(MTOP4)
34086 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
34087 * /(1D0+DELTAMB)**4
34088 MBOT2 = DSQRT(MBOT4)
34090 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
34091 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
34092 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
34093 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
34094 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
34095 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
34096 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
34097 * MQ2 - MUR2)**2*0.25D0
34098 * + MTOP2*(AT-XMU/TANBST)**2)
34099 IF(STOP22.LT.0.) GOTO 120
34100 SBOT12 = (MQ2 + MD2)*.5D0
34101 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
34102 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
34103 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
34104 SBOT22 = (MQ2 + MD2)*.5D0
34105 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
34106 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
34107 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
34108 IF(SBOT22.LT.0.) SBOT22 = 10000D0
34110 STOP1 = DSQRT(STOP12)
34111 STOP2 = DSQRT(STOP22)
34112 SBOT1 = DSQRT(SBOT12)
34113 SBOT2 = DSQRT(SBOT22)
34115 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34117 C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
34118 C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
34119 C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
34120 C INDUCED CORRECTIONS.
34122 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34127 IF(X.EQ.Y) X = X - 0.00001D0
34128 IF(X.EQ.Z) X = X - 0.00002D0
34129 IF(Y.EQ.Z) Y = Y - 0.00003D0
34135 IF(X.EQ.Y) X = X - 0.00001D0
34136 IF(X.EQ.Z) X = X - 0.00002D0
34137 IF(Y.EQ.Z) Y = Y - 0.00003D0
34139 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
34140 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
34144 IF(X.EQ.Y) X = X - 0.00001D0
34145 IF(X.EQ.Z) X = X - 0.00002D0
34146 IF(Y.EQ.Z) Y = Y - 0.00003D0
34148 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
34150 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34152 C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
34153 C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
34154 C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
34155 C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
34156 C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
34157 C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
34158 C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
34159 C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
34160 C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
34161 C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
34162 C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
34165 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34167 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
34168 MTOP2 = DSQRT(MTOP4)
34169 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
34170 * /(1D0+DELTAMB)**4
34171 MBOT2 = DSQRT(MBOT4)
34173 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
34174 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
34175 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
34176 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
34177 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
34178 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
34179 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
34180 * MQ2 - MUR2)**2*0.25D0
34181 * + MTOP2*(AT-XMU/TANBST)**2)
34183 IF(STOP22.LT.0.) GOTO 120
34184 SBOT12 = (MQ2 + MD2)*.5D0
34185 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
34186 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
34187 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
34188 SBOT22 = (MQ2 + MD2)*.5D0
34189 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
34190 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
34191 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
34192 IF(SBOT22.LT.0.) GOTO 120
34195 STOP1 = DSQRT(STOP12)
34196 STOP2 = DSQRT(STOP22)
34197 SBOT1 = DSQRT(SBOT12)
34198 SBOT2 = DSQRT(SBOT22)
34200 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34202 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34205 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
34207 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
34208 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
34210 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
34212 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
34213 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
34215 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
34216 * (-.5D0*LOG(STOP12/STOP22)
34217 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
34218 * G(STOP12,STOP22))
34220 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
34221 * (.5D0*LOG(SBOT12/SBOT22)
34222 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
34223 * G(SBOT12,SBOT22))
34225 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
34226 * (MQ2+MBOT2)/(MD2+MBOT2))
34227 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
34228 * LOG(SBOT1**2/SBOT2**2)) +
34229 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
34230 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
34233 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
34234 * -STOP2**2))**2*G(STOP12,STOP22)
34236 VH3B(1,1)=VH3B(1,1)+
34237 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
34239 VH3T(1,1) = VH3T(1,1) +
34240 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
34242 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
34243 * (MQ2+MTOP2)/(MUR2+MTOP2))
34244 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
34245 * LOG(STOP1**2/STOP2**2)) +
34246 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
34247 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
34250 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
34251 * -SBOT2**2))**2*G(SBOT12,SBOT22)
34253 VH3T(2,2)=VH3T(2,2)+
34254 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
34255 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
34257 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
34258 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
34259 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
34262 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
34263 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
34264 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
34267 VH3T(1,2)=VH3T(1,2) +
34268 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
34270 VH3B(1,2)=VH3B(1,2) +
34271 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
34273 VH3T(2,1) = VH3T(1,2)
34274 VH3B(2,1) = VH3B(1,2)
34276 C TQ = LOG((MQ2 + MTOP2)/MTOP2)
34277 C TU = LOG((MUR2+MTOP2)/MTOP2)
34278 C TQD = LOG((MQ2 + MB**2)/MB**2)
34279 C TD = LOG((MD2+MB**2)/MB**2)
34284 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
34285 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
34286 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
34287 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
34306 C*********************************************************************
34309 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
34311 FUNCTION PYFINT(A,B,C)
34313 C...Double precision and integer declarations.
34314 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34315 IMPLICIT INTEGER(I-N)
34316 INTEGER PYK,PYCHGE,PYCOMP
34318 COMMON/PYINTS/XXM(20)
34321 C...Local variables.
34323 DOUBLE PRECISION PYFISB
34330 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
34335 C*********************************************************************
34338 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
34342 C...Double precision and integer declarations.
34343 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34344 IMPLICIT INTEGER(I-N)
34345 INTEGER PYK,PYCHGE,PYCOMP
34347 COMMON/PYINTS/XXM(20)
34350 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
34351 &(X*(XXM(2)-XXM(3))+XXM(3)))
34356 C*********************************************************************
34359 C...Calculates decays of sfermions.
34361 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
34363 C...Double precision and integer declarations.
34364 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34365 IMPLICIT INTEGER(I-N)
34366 INTEGER PYK,PYCHGE,PYCOMP
34367 C...Parameter statement to help give large particle numbers.
34368 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34369 &KEXCIT=4000000,KDIMEN=5000000)
34371 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34372 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34373 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34374 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34375 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
34376 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
34378 C...Local variables.
34379 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
34380 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
34382 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
34383 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
34384 DOUBLE PRECISION PYLAMF,XL
34385 DOUBLE PRECISION TANW,XW,AEM,C1,AS
34386 DOUBLE PRECISION AL,AR,BL,BR
34387 DOUBLE PRECISION CH1,CH2,CH3,CH4
34388 DOUBLE PRECISION XMBOT,XMTOP
34389 DOUBLE PRECISION XLAM(0:300)
34390 INTEGER IDLAM(300,3)
34391 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
34392 DOUBLE PRECISION SR2
34393 DOUBLE PRECISION CBETA,SBETA
34394 DOUBLE PRECISION CW
34395 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
34396 DOUBLE PRECISION COSA,SINA,TANB
34397 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,PYRNMT
34398 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
34400 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
34401 DATA IGG/23,25,35,36/
34402 DATA PI/3.141592654D0/
34403 DATA SR2/1.4142136D0/
34404 DATA KFNCHI/1000022,1000023,1000025,1000035/
34405 DATA KFCCHI/1000024,1000037/
34407 C...COUNT THE NUMBER OF DECAY MODES
34411 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
34412 &KFIN.EQ.KSUSY2+16) RETURN
34418 TANW = SQRT(XW/(1D0-XW))
34423 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
34428 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
34429 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
34435 C...ILR is 1 for left and 2 for right.
34437 C...IFL is matching non-SUSY flavour.
34438 IFL=MOD(KFIN,KSUSY1)
34439 C...IDU is weak isospin, 1 for down and 2 for up.
34451 XMTOP=PYRNMT(PMAS(6,1))
34466 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
34468 IF(IMSS(11).EQ.1) THEN
34471 XMGR=PMAS(PYCOMP(IDG),1)
34472 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
34475 ELSEIF(IFL.EQ.6) THEN
34480 IF(XMI.GT.XMGR+XMF) THEN
34485 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
34489 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
34491 C...CHARGED DECAYS:
34493 C...DI -> U CHI1-,CHI2-
34497 C...UI -> D CHI1+,CHI2+
34504 IF(XMI.GE.AXMJ+XMFP) THEN
34511 ELSEIF(IFL.LT.6) THEN
34516 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
34517 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
34523 ELSEIF(IFL.LT.5) THEN
34528 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
34529 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
34533 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
34534 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
34535 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
34536 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
34552 XL=PYLAMF(XMI2,XMA2,XMB2)
34553 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
34554 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
34555 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
34558 IDLAM(LKNT,1)=-KFCCHI(IX)
34559 IDLAM(LKNT,2)=IFL+1
34561 IDLAM(LKNT,1)=KFCCHI(IX)
34562 IDLAM(LKNT,2)=IFL-1
34573 IF(XMI.GE.AXMJ+XMF) THEN
34579 ELSEIF(IFL.LT.5) THEN
34582 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
34583 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
34584 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
34589 ELSEIF(IFL.LT.5) THEN
34592 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
34593 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
34594 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
34598 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
34599 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
34600 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
34601 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
34617 XL=PYLAMF(XMI2,XMA2,XMB2)
34618 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
34619 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
34620 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
34621 IDLAM(LKNT,1)=KFNCHI(IX)
34627 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
34631 IF(ILR.EQ.1) GOTO 160
34633 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
34634 IF(XMI.LT.XMSF1+XMB) GOTO 160
34636 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
34639 ELSEIF(IG.EQ.25) THEN
34642 ELSEIF(IFL.EQ.6) THEN
34644 ELSEIF(IFL.LT.5) THEN
34650 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
34651 & XMF**2/XMW*COSA/SBETA
34652 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
34653 & XMF**2/XMW*COSA/SBETA
34655 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
34656 & XMF**2/XMW*(-SINA)/CBETA
34657 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
34658 & XMF**2/XMW*(-SINA)/CBETA
34662 ELSEIF(IFL.EQ.6) THEN
34664 ELSEIF(IFL.EQ.15) THEN
34669 C.........need to complexify
34671 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
34674 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
34680 ELSEIF(IG.EQ.35) THEN
34683 ELSEIF(IFL.EQ.6) THEN
34685 ELSEIF(IFL.LT.5) THEN
34691 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
34692 & XMF**2/XMW*SINA/SBETA
34693 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
34694 & XMF**2/XMW*SINA/SBETA
34696 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
34697 & XMF**2/XMW*COSA/CBETA
34698 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
34699 & XMF**2/XMW*COSA/CBETA
34703 ELSEIF(IFL.EQ.6) THEN
34705 ELSEIF(IFL.EQ.15) THEN
34710 C.........Need to complexify
34712 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
34715 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
34721 ELSEIF(IG.EQ.36) THEN
34726 ELSEIF(IFL.EQ.6) THEN
34728 ELSEIF(IFL.LT.5) THEN
34735 ELSEIF(IFL.EQ.6) THEN
34737 ELSEIF(IFL.EQ.15) THEN
34742 C.........Need to complexify
34744 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
34746 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
34752 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
34753 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
34754 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
34755 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
34758 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
34760 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
34763 IDLAM(LKNT,1)=KFIN-KSUSY1
34769 IF(MOD(IFL,2).EQ.0) THEN
34775 XMSF1=PMAS(PYCOMP(KF1),1)
34776 XMSF2=PMAS(PYCOMP(KF2),1)
34777 IF(XMI.GT.XMB+XMSF1) THEN
34778 IF(MOD(IFL,2).EQ.0) THEN
34780 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
34782 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
34786 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
34788 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
34791 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
34793 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
34796 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
34798 IF(XMI.GT.XMB+XMSF2) THEN
34799 IF(MOD(IFL,2).EQ.0) THEN
34801 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
34803 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
34807 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
34809 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
34812 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
34814 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
34817 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
34822 IF(MOD(IFL,2).EQ.0) THEN
34828 XMSF1=PMAS(PYCOMP(KF1),1)
34829 XMSF2=PMAS(PYCOMP(KF2),1)
34830 IF(XMI.GT.XMB+XMSF1) THEN
34835 IF(MOD(IFL,2).EQ.0) THEN
34838 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
34839 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
34840 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
34841 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
34844 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
34845 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
34846 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
34847 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
34858 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
34859 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
34860 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
34861 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
34864 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
34865 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
34866 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
34867 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
34876 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
34878 C.......Need to complexify
34879 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
34880 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
34881 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
34882 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
34885 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
34887 IF(XMI.GT.XMB+XMSF2) THEN
34892 IF(MOD(IFL,2).EQ.0) THEN
34895 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
34896 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
34897 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
34898 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
34901 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
34902 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
34903 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
34904 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
34915 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
34916 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
34917 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
34918 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
34921 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
34922 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
34923 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
34924 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
34933 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
34935 C.......Need to complexify
34936 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
34937 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
34938 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
34939 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
34942 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
34945 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
34950 IF(IFL.EQ.6) XMF=PMAS(6,1)
34951 IF(IFL.EQ.5) XMF=PMAS(5,1)
34952 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
34954 IF(XMI.GE.AXMJ+XMF) THEN
34971 XL=PYLAMF(XMI2,XMA2,XMB2)
34972 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
34973 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
34974 IDLAM(LKNT,1)=KSUSY1+21
34980 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
34981 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
34982 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
34983 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
34984 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
34985 C...M*M = C1**2 * G**2/(16PI**2)
34986 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
34988 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
34989 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
34990 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
34991 IDLAM(LKNT,1)=KSUSY1+22
34996 C...R-violating sfermion decays (SKANDS).
34997 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
35002 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
35003 XLAM(0)=XLAM(0)+XLAM(I)
35005 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
35010 C*********************************************************************
35013 C...Calculates gluino decay modes.
35015 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
35017 C...Double precision and integer declarations.
35018 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35019 IMPLICIT INTEGER(I-N)
35020 INTEGER PYK,PYCHGE,PYCOMP
35021 C...Parameter statement to help give large particle numbers.
35022 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35023 &KEXCIT=4000000,KDIMEN=5000000)
35025 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35026 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35027 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35028 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35029 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35031 C COMMON/PYINTS/XXM(20)
35033 COMMON/PYINTC/XXC(10),CXC(8)
35034 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
35036 C...Local variables
35037 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
35038 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
35039 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
35040 DOUBLE PRECISION PYLAMF,XL
35041 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
35042 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
35043 DOUBLE PRECISION XLAM(0:300)
35044 INTEGER IDLAM(300,3)
35045 INTEGER LKNT,IX,ILR,I,IKNT,IFL
35046 DOUBLE PRECISION SR2
35047 DOUBLE PRECISION GAM
35048 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
35049 EXTERNAL PYGAUS,PYXXZ6
35050 DOUBLE PRECISION PYGAUS,PYXXZ6
35051 DOUBLE PRECISION PREC
35052 INTEGER KFNCHI(4),KFCCHI(2)
35053 DATA PI/3.141592654D0/
35054 DATA SR2/1.4142136D0/
35056 DATA KFNCHI/1000022,1000023,1000025,1000035/
35057 DATA KFCCHI/1000024,1000037/
35059 C...COUNT THE NUMBER OF DECAY MODES
35061 IF(KFIN.NE.KSUSY1+21) RETURN
35065 TANW = SQRT(XW/(1D0-XW))
35075 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
35077 IF(IMSS(11).EQ.1) THEN
35080 XMGR=PMAS(PYCOMP(IDG),1)
35081 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
35082 IF(AXMI.GT.XMGR) THEN
35091 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
35095 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
35098 IF(XMI.GE.AXMJ+XMF) THEN
35099 C...Minus sign difference from gluino-quark-squark feynman rules
35116 XL=PYLAMF(XMI2,XMA2,XMB2)
35117 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
35118 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
35119 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
35123 XLAM(LKNT)=XLAM(LKNT-1)
35124 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35125 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35131 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
35132 C...GLUINO -> NI Q QBAR
35136 IF(XMI.GE.AXMJ) THEN
35138 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
35140 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
35147 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
35148 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
35154 T3I=SIGN(1D0,EI+1D-6)/2D0
35155 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
35156 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
35160 CXC(4)=DCONJG(GLIJ)
35164 CXC(8)=-DCONJG(GRIJ)
35166 S12MAX=(AXMI-AXMJ)**2
35167 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
35168 IF(XMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
35170 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
35171 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
35172 IDLAM(LKNT,1)=KFNCHI(IX)
35176 IF(XMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
35178 XLAM(LKNT)=XLAM(LKNT-1)
35179 IDLAM(LKNT,1)=KFNCHI(IX)
35184 IF(XMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
35185 CALL PYTBBN(IX,80,-1D0/3D0,AXMI,GAM)
35188 IDLAM(LKNT,1)=KFNCHI(IX)
35195 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
35196 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
35197 C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
35201 T3I=SIGN(1D0,EI+1D-6)/2D0
35202 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
35203 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
35205 CXC(4)=DCONJG(GLIJ)
35207 CXC(8)=-DCONJG(GRIJ)
35208 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
35209 IF(XMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
35211 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
35212 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
35213 IDLAM(LKNT,1)=KFNCHI(IX)
35217 IF(XMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
35219 XLAM(LKNT)=XLAM(LKNT-1)
35220 IDLAM(LKNT,1)=KFNCHI(IX)
35225 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
35226 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
35227 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 160
35229 IF(XMI.GE.AXMJ+2D0*XMF) THEN
35230 CALL PYTBBN(IX,80,2D0/3D0,AXMI,GAM)
35233 IDLAM(LKNT,1)=KFNCHI(IX)
35241 C...GLUINO -> CI Q QBAR'
35245 IF(XMI.GE.AXMJ) THEN
35247 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
35248 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
35251 S12MAX=(AXMI-AXMJ)**2
35256 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
35257 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
35260 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
35262 CXC(1)=DCMPLX(0D0,0D0)
35263 CXC(3)=DCMPLX(0D0,0D0)
35264 CXC(5)=DCMPLX(0D0,0D0)
35265 CXC(7)=DCMPLX(0D0,0D0)
35266 CXC(2)=UMIXC(IX,1)*OLPP/SR2
35267 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
35268 CXC(6)=DCMPLX(0D0,0D0)
35269 CXC(8)=DCMPLX(0D0,0D0)
35270 IF(XXC(5).LT.AXMI) THEN
35272 ELSEIF(XXC(6).LT.AXMI) THEN
35277 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
35278 IF(XMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
35280 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
35281 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
35282 IDLAM(LKNT,1)=KFCCHI(IX)
35286 XLAM(LKNT)=XLAM(LKNT-1)
35287 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35288 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35289 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35291 IF(XMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
35293 XLAM(LKNT)=XLAM(LKNT-1)
35294 IDLAM(LKNT,1)=KFCCHI(IX)
35298 XLAM(LKNT)=XLAM(LKNT-1)
35299 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35300 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35301 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35305 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) GOTO 200
35306 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 200
35309 IF(XMI.GE.AXMJ+XMF+XMFP) THEN
35310 CALL PYTBBC(IX,80,AXMI,GAM)
35313 IDLAM(LKNT,1)=KFCCHI(IX)
35317 XLAM(LKNT)=XLAM(LKNT-1)
35318 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
35319 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
35320 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
35329 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
35330 XLAM(0)=XLAM(0)+XLAM(I)
35332 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
35337 C*********************************************************************
35340 C...Calculates the three-body decay of gluinos into
35341 C...neutralinos and third generation fermions.
35343 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
35345 C...Double precision and integer declarations.
35346 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35347 IMPLICIT INTEGER(I-N)
35348 INTEGER PYK,PYCHGE,PYCOMP
35349 C...Parameter statement to help give large particle numbers.
35350 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35351 &KEXCIT=4000000,KDIMEN=5000000)
35353 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35354 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35355 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35356 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35357 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35358 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
35360 C...Local variables.
35361 EXTERNAL PYSIMP,PYLAMF
35362 DOUBLE PRECISION PYSIMP,PYLAMF
35364 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
35365 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
35366 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
35367 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
35368 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
35369 DOUBLE PRECISION XLN1,XLN2,B1,B2
35370 DOUBLE PRECISION E,XMGLU,GAM
35371 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
35372 SAVE HRB,HLB,FLB,FRB
35373 DOUBLE PRECISION ALPHAW,ALPHAS
35374 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
35375 SAVE HLT,HRT,FLT,FRT
35376 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
35378 DOUBLE PRECISION AMBOT,SINC,COSC
35379 DOUBLE PRECISION AMTOP,SINA,COSA
35380 DOUBLE PRECISION SINW,COSW,TANW
35381 DOUBLE PRECISION ROT1(4,4)
35384 DATA IFIRST/.TRUE./
35387 SINB=TANB/SQRT(1D0+TANB**2)
35399 AMTOP=PYRNMT(PMAS(6,1))
35401 FAKT1=AMBOT/W2/AMW/COSB
35402 FAKT2=AMTOP/W2/AMW/SINB
35413 ROT1(2,1)=-ROT1(1,2)
35414 ROT1(2,2)=ROT1(1,1)
35417 ROT1(4,3)=-ROT1(3,4)
35418 ROT1(4,4)=ROT1(3,3)
35422 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
35427 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
35428 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
35429 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
35431 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
35432 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
35433 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
35434 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
35437 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
35438 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
35439 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
35440 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
35441 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
35442 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
35443 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
35447 C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
35448 C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
35449 C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
35450 C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
35454 IF(NINT(3D0*E).EQ.2) THEN
35461 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
35462 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
35471 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
35472 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
35478 SIN2D=SIND*COSD*2D0
35492 ALPHAW=PYALEM(XMG2)
35493 ALPHAS=PYALPS(XMG2)
35497 XM24=(XMG2+XM2)*(XM2+XMR2)
35499 SMAX=(XMG-ABS(XMR))**2
35500 XMQA=XMG2+2D0*XM2+XMR2
35502 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
35504 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
35506 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
35507 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
35508 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
35509 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
35510 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
35511 & +2D0*(FF*SIND2-HH*COSD2))*W
35512 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
35513 & +4D0*HFL*XM*XMR)*XLN1
35514 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
35515 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
35516 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
35517 & +8D0*HFL*XMQ4*SIN2D)*B1
35518 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
35519 & +4D0*HFR*XMR*XM)*XLN2
35520 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
35521 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
35522 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
35523 & -8D0*HFR*XMQ4*SIN2D)*B2
35524 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
35525 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
35526 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
35527 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
35528 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
35529 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
35530 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
35531 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
35532 G(5)=(2D0*(HH*COSD2-FF*SIND2)
35533 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
35534 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
35535 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
35536 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
35537 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
35538 & +COS2D*XM*(SBAR+XMG2-XMR2))
35539 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
35540 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
35541 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
35542 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
35543 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
35544 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
35545 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
35548 SUMME(LIN)=SUMME(LIN)+G(J)
35553 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
35554 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
35559 C*********************************************************************
35562 C...Calculates the three-body decay of gluinos into
35563 C...charginos and third generation fermions.
35565 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
35567 C...Double precision and integer declarations.
35568 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35569 IMPLICIT INTEGER(I-N)
35570 INTEGER PYK,PYCHGE,PYCOMP
35571 C...Parameter statement to help give large particle numbers.
35572 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35573 &KEXCIT=4000000,KDIMEN=5000000)
35575 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35576 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35577 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35578 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35579 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35580 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
35582 C...Local variables.
35583 EXTERNAL PYSIMP,PYLAMF
35584 DOUBLE PRECISION PYSIMP,PYLAMF
35586 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
35587 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
35588 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
35589 DOUBLE PRECISION SUMME(0:100),A(4,8)
35590 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
35591 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
35592 DOUBLE PRECISION XMGLU,GAM
35593 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
35594 &DDD(2),EEE(2),FFF(2)
35595 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
35596 DOUBLE PRECISION ALPHAW,ALPHAS
35597 DOUBLE PRECISION AMC(2)
35599 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
35600 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
35604 DATA IFIRST/.TRUE./
35607 SINB=TANB/SQRT(1D0+TANB**2)
35616 AMTOP=PYRNMT(PMAS(6,1))
35619 FAKT1=AMBOT/W2/AMW/COSB
35620 FAKT2=AMTOP/W2/AMW/SINB
35625 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
35626 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
35627 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
35628 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
35629 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
35630 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
35631 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
35632 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
35634 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
35635 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
35636 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
35637 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
35642 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
35643 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
35644 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
35645 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
35647 COS2A=COSA**2-SINA**2
35648 SIN2A=SINA*COSA*2D0
35649 COS2C=COSC**2-SINC**2
35650 SIN2C=SINC*COSC*2D0
35657 ALPHAW=PYALEM(XMG2)
35658 ALPHAS=PYALPS(XMG2)
35662 XMQ2=XMG2+XMT2+XMB2+XMR2
35663 XMQ4=XMG*XMT*XMB*XMR
35664 XMQ3=XMG2*XMR2+XMT2*XMB2
35665 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
35666 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
35668 XMST(1)=AMST(1)*AMST(1)
35669 XMST(2)=AMST(1)*AMST(1)
35670 XMST(3)=AMST(2)*AMST(2)
35671 XMST(4)=AMST(2)*AMST(2)
35672 XMSB(1)=AMSB(1)*AMSB(1)
35673 XMSB(2)=AMSB(2)*AMSB(2)
35674 XMSB(3)=AMSB(1)*AMSB(1)
35675 XMSB(4)=AMSB(2)*AMSB(2)
35677 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
35678 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
35679 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
35680 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
35681 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
35682 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
35683 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
35684 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
35686 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
35687 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
35688 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
35689 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
35690 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
35691 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
35692 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
35693 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
35695 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
35696 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
35697 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
35698 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
35699 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
35700 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
35701 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
35702 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
35704 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
35705 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
35706 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
35707 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
35708 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
35709 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
35710 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
35711 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
35713 SMAX=(XMG-ABS(XMR))**2
35714 SMIN=(XMB+XMT)**2+0.1D0
35717 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
35718 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
35720 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
35721 W=DSQRT(W)/2D0/SBAR
35722 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
35723 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
35724 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
35725 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
35726 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
35727 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
35728 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
35729 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
35730 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
35731 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
35732 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
35733 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
35734 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
35735 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
35736 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
35737 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
35738 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
35739 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
35740 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
35741 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
35742 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
35743 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
35744 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
35745 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
35746 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
35747 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
35748 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
35749 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
35750 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
35751 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
35752 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
35753 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
35754 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
35755 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
35756 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
35757 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
35758 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
35759 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
35760 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
35761 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
35762 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
35763 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
35764 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
35766 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
35767 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
35768 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
35769 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
35770 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
35771 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
35772 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
35773 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
35774 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
35775 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
35776 & -A(J,6)*(XMG2+XMR2-SBAR)
35777 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
35778 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
35779 & /(GRS+XMSB(J)+XMST(J))
35783 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
35784 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
35789 C*********************************************************************
35792 C...Calculates decay widths for the neutralinos (admixtures of
35793 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
35795 C...Input: KCIN = KF code for particle
35796 C...Output: XLAM = widths
35797 C... IDLAM = KF codes for decay particles
35798 C... IKNT = number of decay channels defined
35799 C...AUTHOR: STEPHEN MRENNA
35801 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
35802 C...when CHIGAMMA .NE. 0
35803 C...10 FEB 96: Calculate this decay for small tan(beta)
35805 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
35807 C...Double precision and integer declarations.
35808 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35809 IMPLICIT INTEGER(I-N)
35810 INTEGER PYK,PYCHGE,PYCOMP
35811 C...Parameter statement to help give large particle numbers.
35812 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35813 &KEXCIT=4000000,KDIMEN=5000000)
35815 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35816 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35817 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35818 c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35820 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35821 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35822 C COMMON/PYINTS/XXM(20)
35824 COMMON/PYINTC/XXC(10),CXC(8)
35825 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
35827 C...Local variables.
35828 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
35829 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
35831 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
35832 &XMZ,XMZ2,AXMJ,AXMI
35833 DOUBLE PRECISION S12MIN,S12MAX
35834 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
35835 DOUBLE PRECISION PYLAMF,XL
35836 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
35837 DOUBLE PRECISION PYX2XH,PYX2XG
35838 DOUBLE PRECISION XLAM(0:300)
35839 INTEGER IDLAM(300,3)
35840 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
35841 INTEGER ITH(3),KF1,KF2
35843 DOUBLE PRECISION DH(3),EH(3)
35844 DOUBLE PRECISION SR2
35845 DOUBLE PRECISION CBETA,SBETA
35846 DOUBLE PRECISION GAMCON,XMT1,XMT2
35847 DOUBLE PRECISION PYALEM,PI,PYALPS
35848 DOUBLE PRECISION RAT1,RAT2
35849 DOUBLE PRECISION T3T,FCOL
35850 DOUBLE PRECISION ALFA,BETA,TANB
35851 DOUBLE PRECISION PYXXGA
35852 EXTERNAL PYGAUS,PYXXZ6
35853 DOUBLE PRECISION PYGAUS,PYXXZ6
35854 DOUBLE PRECISION PREC
35855 INTEGER KFNCHI(4),KFCCHI(2)
35859 DATA PI/3.141592654D0/
35860 DATA SR2/1.4142136D0/
35861 DATA KFNCHI/1000022,1000023,1000025,1000035/
35862 DATA KFCCHI/1000024,1000037/
35864 C...COUNT THE NUMBER OF DECAY MODES
35873 TANW = SQRT(XW/XW1)
35875 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
35877 IF(KFIN.EQ.KFNCHI(2)) IX=2
35878 IF(KFIN.EQ.KFNCHI(3)) IX=3
35879 IF(KFIN.EQ.KFNCHI(4)) IX=4
35899 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
35904 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
35905 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
35909 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
35910 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
35912 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
35913 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
35917 GAMCON=AEM**3/8D0/PI/XMW2/XW
35918 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
35919 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
35920 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
35921 IDLAM(LKNT,1)=KSUSY1+22
35924 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
35928 C...GRAVITINO DECAY MODES
35930 IF(IMSS(11).EQ.1) THEN
35933 XMGR=PMAS(PYCOMP(IDG),1)
35936 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
35937 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
35942 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
35944 IF(AXMI.GT.XMGR+XMZ) THEN
35949 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
35950 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
35951 & (1D0-XMZ2/XMI2)**4
35953 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
35958 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
35959 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
35961 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
35966 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
35967 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
35969 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
35974 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
35975 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
35977 IF(IX.EQ.1) GOTO 300
35985 C...CHI0_I -> CHI0_J + GAMMA
35986 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
35987 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
35988 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
35989 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
35990 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
35991 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
35992 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
35994 IDLAM(LKNT,1)=KFNCHI(IJ)
35997 GAMCON=AEM**3/8D0/PI/XMW2/XW
35998 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
35999 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
36000 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
36004 C...CHI0_I -> CHI0_J + Z0
36005 IF(AXMI.GE.AXMJ+XMZ) THEN
36007 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
36008 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
36010 GX2=ABS(OLPP)**2+ABS(ORPP)**2
36011 GLR=DBLE(OLPP*DCONJG(ORPP))
36012 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
36013 IDLAM(LKNT,1)=KFNCHI(IJ)
36016 ELSEIF(AXMI.GE.AXMJ) THEN
36023 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
36024 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
36026 C...CHARGED LEPTONS
36028 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36029 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36031 T3I=SIGN(1D0,EI+1D-6)/2D0
36032 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
36033 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
36034 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
36035 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
36037 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
36038 CXC(4)=DCONJG(GLIJ)
36039 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
36041 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
36042 CXC(8)=-DCONJG(GRIJ)
36044 S12MAX=(AXMI-AXMJ)**2
36045 IF( XXC(5).LT.AXMI ) THEN
36048 IF(XXC(6).LT.AXMI ) THEN
36054 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
36056 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36057 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36058 IDLAM(LKNT,1)=KFNCHI(IJ)
36061 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
36063 XLAM(LKNT)=XLAM(LKNT-1)
36064 IDLAM(LKNT,1)=KFNCHI(IJ)
36070 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
36071 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
36072 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
36074 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
36075 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
36077 IF( XXC(5).LT.AXMI ) THEN
36080 IF(XXC(6).LT.AXMI ) THEN
36086 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
36088 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36089 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36090 IDLAM(LKNT,1)=KFNCHI(IJ)
36098 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36099 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36101 T3I=SIGN(1D0,EI+1D-6)/2D0
36102 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
36103 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
36104 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
36105 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
36107 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
36108 CXC(4)=DCONJG(GLIJ)
36109 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
36111 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
36112 CXC(8)=-DCONJG(GRIJ)
36114 S12MAX=(AXMI-AXMJ)**2
36115 IF( XXC(5).LT.AXMI ) THEN
36118 IF( XXC(6).LT.AXMI ) THEN
36125 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36126 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36127 IDLAM(LKNT,1)=KFNCHI(IJ)
36131 XLAM(LKNT)=XLAM(LKNT-1)
36132 IDLAM(LKNT,1)=KFNCHI(IJ)
36137 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
36139 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
36140 IF( XXC(5).LT.AXMI ) THEN
36145 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36146 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36149 XLAM(LKNT)=XLAM(LKNT-1)
36151 IDLAM(LKNT,1)=KFNCHI(IJ)
36157 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36158 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36160 T3I=SIGN(1D0,EI+1D-6)/2D0
36161 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
36162 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
36163 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
36164 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
36166 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
36167 CXC(4)=DCONJG(GLIJ)
36168 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
36170 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
36171 CXC(8)=-DCONJG(GRIJ)
36173 S12MAX=(AXMI-AXMJ)**2
36174 IF( XXC(5).LT.AXMI ) THEN
36177 IF( XXC(6).LT.AXMI ) THEN
36183 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
36185 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36186 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
36187 IDLAM(LKNT,1)=KFNCHI(IJ)
36190 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
36192 XLAM(LKNT)=XLAM(LKNT-1)
36193 IDLAM(LKNT,1)=KFNCHI(IJ)
36199 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
36200 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
36201 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
36203 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
36204 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
36206 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
36207 IF(XXC(5).LT.AXMI) THEN
36209 ELSEIF(XXC(6).LT.AXMI) THEN
36214 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
36216 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36217 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
36218 IDLAM(LKNT,1)=KFNCHI(IJ)
36226 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36227 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36229 T3I=SIGN(1D0,EI+1D-6)/2D0
36230 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
36231 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
36232 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
36233 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
36235 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
36236 CXC(4)=DCONJG(GLIJ)
36237 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
36239 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
36240 CXC(8)=-DCONJG(GRIJ)
36242 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
36243 IF(XXC(5).LT.AXMI) THEN
36245 ELSEIF(XXC(6).LT.AXMI) THEN
36251 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
36253 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36254 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
36255 IDLAM(LKNT,1)=KFNCHI(IJ)
36258 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
36260 XLAM(LKNT)=XLAM(LKNT-1)
36261 IDLAM(LKNT,1)=KFNCHI(IJ)
36269 C...CHI0_I -> CHI0_J + H0_K
36276 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
36277 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
36278 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
36279 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
36280 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
36281 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
36282 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
36283 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
36285 XMH=PMAS(ITH(IH),1)
36287 IF(AXMI.GE.AXMJ+XMH) THEN
36289 XL=PYLAMF(XMI2,XMJ2,XMH2)
36290 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
36292 C...SIGN OF MASSES I,J
36294 IF(IH.EQ.3) XMK=-XMK
36295 GX2=ABS(F21K)**2+ABS(F12K)**2
36296 GLR=DBLE(F21K*DCONJG(F12K))
36297 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
36298 IDLAM(LKNT,1)=KFNCHI(IJ)
36299 IDLAM(LKNT,2)=ITH(IH)
36305 C...CHI0_I -> CHI+_J + W-
36310 IF(AXMI.GE.AXMJ+XMW) THEN
36312 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
36313 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
36314 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
36315 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
36316 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
36317 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
36318 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
36319 IDLAM(LKNT,1)=KFCCHI(IJ)
36323 XLAM(LKNT)=XLAM(LKNT-1)
36324 IDLAM(LKNT,1)=-KFCCHI(IJ)
36327 ELSEIF(AXMI.GE.AXMJ) THEN
36329 S12MAX=(AXMI-AXMJ)**2
36330 RT2I = 1D0/SQRT(2D0)
36331 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
36332 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
36333 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
36334 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
36335 CXC(5)=DCMPLX(0D0,0D0)
36336 CXC(7)=DCMPLX(0D0,0D0)
36340 T3I=SIGN(1D0,EI+1D-6)/2D0
36342 T3J=SIGN(1D0,EJ+1D-6)/2D0
36343 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
36344 & TANW+ZMIXC(IX,2)*T3J)*RT2I
36345 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
36346 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
36347 CXC(6)=DCMPLX(0D0,0D0)
36348 CXC(8)=DCMPLX(0D0,0D0)
36353 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
36354 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
36357 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
36358 IF(XXC(5).LT.AXMI) THEN
36360 ELSEIF(XXC(6).LT.AXMI) THEN
36365 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
36367 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36368 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36369 IDLAM(LKNT,1)=KFCCHI(IJ)
36373 XLAM(LKNT)=XLAM(LKNT-1)
36374 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36375 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36376 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36377 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
36379 XLAM(LKNT)=XLAM(LKNT-1)
36380 IDLAM(LKNT,1)=KFCCHI(IJ)
36384 XLAM(LKNT)=XLAM(LKNT-1)
36385 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36386 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36387 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36391 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
36392 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
36393 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
36395 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
36396 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
36398 IF(XXC(5).LT.AXMI) THEN
36401 IF(XXC(6).LT.AXMI) THEN
36406 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
36408 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36409 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36410 XLAM(LKNT)=XLAM(LKNT-1)
36411 IDLAM(LKNT,1)=KFCCHI(IJ)
36415 XLAM(LKNT)=XLAM(LKNT-1)
36416 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36417 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36418 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36421 C...NOW, DO THE QUARKS
36426 T3I=SIGN(1D0,EI+1D-6)/2D0
36428 T3J=SIGN(1D0,EJ+1D-6)/2D0
36429 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
36430 & TANW+ZMIXC(IX,2)*T3J)
36431 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
36432 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
36433 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
36434 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
36435 IF(XXC(5).LT.AXMI) THEN
36438 IF(XXC(6).LT.AXMI) THEN
36443 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
36445 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
36446 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36447 IDLAM(LKNT,1)=KFCCHI(IJ)
36451 XLAM(LKNT)=XLAM(LKNT-1)
36452 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36453 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36454 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36455 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
36457 XLAM(LKNT)=XLAM(LKNT-1)
36458 IDLAM(LKNT,1)=KFCCHI(IJ)
36462 XLAM(LKNT)=XLAM(LKNT-1)
36463 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36464 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36465 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36473 C...CHI0_I -> CHI+_I + H-
36479 IF(AXMI.GE.AXMJ+XMHP) THEN
36481 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
36482 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
36483 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
36484 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
36486 GX2=ABS(OLPP)**2+ABS(ORPP)**2
36487 GLR=DBLE(OLPP*DCONJG(ORPP))
36488 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
36489 IDLAM(LKNT,1)=KFCCHI(IJ)
36490 IDLAM(LKNT,2)=-ITHC
36493 XLAM(LKNT)=XLAM(LKNT-1)
36494 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36495 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36496 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36502 C...2-BODY DECAYS TO FERMION SFERMION
36504 IF(J.GE.7.AND.J.LE.10) GOTO 290
36507 XMSF1=PMAS(PYCOMP(KF1),1)
36508 XMSF2=PMAS(PYCOMP(KF2),1)
36518 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
36519 IF(MOD(J,2).EQ.0) THEN
36520 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
36521 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
36522 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
36525 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
36526 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
36527 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
36532 IF(AXMI.GE.XMF+XMSF1) THEN
36536 XL=PYLAMF(XMI2,XMA2,XMB2)
36537 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
36538 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
36539 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
36540 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
36545 XLAM(LKNT)=XLAM(LKNT-1)
36546 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36547 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36552 IF(AXMI.GE.XMF+XMSF2) THEN
36556 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
36557 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
36558 XL=PYLAMF(XMI2,XMA2,XMB2)
36559 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
36560 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
36565 XLAM(LKNT)=XLAM(LKNT-1)
36566 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36567 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36572 C...3-BODY DECAY TO Q Q~ GLUINO
36573 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
36574 IF(AXMI.GE.XMJ) THEN
36575 RT2I = 1D0/SQRT(2D0)
36576 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
36584 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36585 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36586 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
36592 T3I=SIGN(1D0,EI+1D-6)/2D0
36593 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36594 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36598 CXC(4)=DCONJG(GLIJ)
36602 CXC(8)=-DCONJG(GRIJ)
36604 S12MAX=(AXMI-AXMJ)**2
36605 C...ALL QUARKS BUT T
36606 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
36608 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
36609 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36610 IDLAM(LKNT,1)=KSUSY1+21
36613 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
36615 XLAM(LKNT)=XLAM(LKNT-1)
36616 IDLAM(LKNT,1)=KSUSY1+21
36622 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
36623 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
36624 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
36626 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
36627 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
36629 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
36632 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
36634 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
36635 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36636 IDLAM(LKNT,1)=KSUSY1+21
36643 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
36644 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
36645 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
36649 T3I=SIGN(1D0,EI+1D-6)/2D0
36650 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36651 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36653 CXC(4)=DCONJG(GLIJ)
36655 CXC(8)=-DCONJG(GRIJ)
36656 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
36658 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
36659 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
36660 IDLAM(LKNT,1)=KSUSY1+21
36663 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
36665 XLAM(LKNT)=XLAM(LKNT-1)
36666 IDLAM(LKNT,1)=KSUSY1+21
36674 C...R-violating decay modes (SKANDS).
36675 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
36680 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
36681 XLAM(0)=XLAM(0)+XLAM(I)
36683 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
36688 C*********************************************************************
36691 C...Calculate decay widths for the charginos (admixtures of
36692 C...charged Wino and charged Higgsino.
36694 C...Input: KCIN = KF code for particle
36695 C...Output: XLAM = widths
36696 C... IDLAM = KF codes for decay particles
36697 C... IKNT = number of decay channels defined
36698 C...AUTHOR: STEPHEN MRENNA
36700 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
36701 C...when CHIENU .NE. 0
36703 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
36705 C...Double precision and integer declarations.
36706 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36707 IMPLICIT INTEGER(I-N)
36708 INTEGER PYK,PYCHGE,PYCOMP
36709 C...Parameter statement to help give large particle numbers.
36710 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36711 &KEXCIT=4000000,KDIMEN=5000000)
36713 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36714 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36715 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36716 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36717 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36719 C COMMON/PYINTS/XXM(20)
36721 COMMON/PYINTC/XXC(10),CXC(8)
36722 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
36724 C...Local variables
36725 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
36726 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
36728 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
36729 &XMZ,XMZ2,AXMJ,AXMI
36730 DOUBLE PRECISION S12MIN,S12MAX
36731 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
36732 DOUBLE PRECISION PYLAMF,XL
36733 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
36734 DOUBLE PRECISION PYX2XH,PYX2XG
36735 DOUBLE PRECISION XLAM(0:300)
36736 INTEGER IDLAM(300,3)
36737 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
36740 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
36741 DOUBLE PRECISION SR2
36742 DOUBLE PRECISION CBETA,SBETA,TANB
36744 DOUBLE PRECISION PYALEM,PI,PYALPS
36745 DOUBLE PRECISION FCOL
36746 INTEGER KF1,KF2,ISF
36747 INTEGER KFNCHI(4),KFCCHI(2)
36749 DOUBLE PRECISION TEMP
36750 EXTERNAL PYGAUS,PYXXZ6
36751 DOUBLE PRECISION PYGAUS,PYXXZ6
36752 DOUBLE PRECISION PREC
36755 DATA ETAH/1D0,1D0,-1D0/
36756 DATA SR2/1.4142136D0/
36757 DATA PI/3.141592654D0/
36759 DATA KFNCHI/1000022,1000023,1000025,1000035/
36760 DATA KFCCHI/1000024,1000037/
36762 C...COUNT THE NUMBER OF DECAY MODES
36770 TANW = SQRT(XW/XW1)
36772 C...1 OR 2 DEPENDING ON CHARGINO TYPE
36774 IF(KFIN.EQ.KFCCHI(2)) IX=2
36792 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
36793 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
36797 C...GRAVITINO DECAY MODES
36799 IF(IMSS(11).EQ.1) THEN
36802 XMGR=PMAS(PYCOMP(IDG),1)
36804 C COSW=SQRT(1D0-XW)
36805 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
36806 IF(AXMI.GT.XMGR+XMW) THEN
36812 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
36813 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
36814 & (1D0-XMW2/XMI2)**4
36816 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
36821 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
36822 & (ABS(UMIXC(IX,2))*SBETA)**2))
36823 & *(1D0-PMAS(37,1)**2/XMI2)**4
36827 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
36828 IF(IX.EQ.1) GOTO 170
36833 C...CHI_2+ -> CHI_1+ + Z0
36834 IF(AXMI.GE.AXMJ+XMZ) THEN
36837 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
36838 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
36839 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
36840 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
36841 GX2=ABS(OLPP)**2+ABS(ORPP)**2
36842 GLR=DBLE(OLPP*DCONJG(ORPP))
36843 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
36844 IDLAM(LKNT,1)=KFCCHI(1)
36848 C...CHARGED LEPTONS
36849 ELSEIF(AXMI.GE.AXMJ) THEN
36851 S12MAX=(AXMI-AXMJ)**2
36854 EI=KCHG(IABS(IA),1)/3D0
36855 T3I=SIGN(1D0,EI+1D-6)/2D0
36860 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
36865 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
36866 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
36867 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
36868 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
36869 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
36870 CXC(2)=DCMPLX(0D0,0D0)
36871 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
36872 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
36873 CXC(5)=-DCMPLX(EI/XW1)*ORPP
36874 CXC(6)=DCMPLX(0D0,0D0)
36875 CXC(7)=-DCMPLX(EI/XW1)*OLPP
36876 CXC(8)=DCMPLX(0D0,0D0)
36877 IF( XXC(5).LT.AXMI ) THEN
36882 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
36884 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36885 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36886 IDLAM(LKNT,1)=KFCCHI(1)
36889 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
36891 XLAM(LKNT)=XLAM(LKNT-1)
36892 IDLAM(LKNT,1)=KFCCHI(1)
36896 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
36898 XLAM(LKNT)=XLAM(LKNT-1)
36899 IDLAM(LKNT,1)=KFCCHI(1)
36909 EI=KCHG(IABS(IA),1)/3D0
36910 T3I=SIGN(1D0,EI+1D-6)/2D0
36911 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
36913 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
36914 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
36915 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
36916 CXC(5)=-DCMPLX(EI/XW1)*ORPP
36917 CXC(7)=-DCMPLX(EI/XW1)*OLPP
36918 IF( XXC(5).LT.AXMI ) THEN
36923 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
36925 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36926 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36927 IDLAM(LKNT,1)=KFCCHI(1)
36931 XLAM(LKNT)=XLAM(LKNT-1)
36932 IDLAM(LKNT,1)=KFCCHI(1)
36936 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
36937 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
36938 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
36940 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
36942 IF( XXC(5).LT.AXMI ) THEN
36947 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
36948 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36949 IDLAM(LKNT,1)=KFCCHI(1)
36958 EI=KCHG(IABS(IA),1)/3D0
36959 T3I=SIGN(1D0,EI+1D-6)/2D0
36960 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
36962 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
36963 CXC(2)=DCMPLX(0D0,0D0)
36964 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
36965 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
36966 CXC(5)=-DCMPLX(EI/XW1)*ORPP
36967 CXC(6)=DCMPLX(0D0,0D0)
36968 CXC(7)=-DCMPLX(EI/XW1)*OLPP
36969 CXC(8)=DCMPLX(0D0,0D0)
36970 IF( XXC(5).LT.AXMI ) THEN
36975 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
36977 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
36978 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36979 IDLAM(LKNT,1)=KFCCHI(1)
36982 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
36984 XLAM(LKNT)=XLAM(LKNT-1)
36985 IDLAM(LKNT,1)=KFCCHI(1)
36990 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
36991 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
36992 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
36994 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
36996 IF( XXC(5).LT.AXMI ) THEN
37001 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
37002 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37003 IDLAM(LKNT,1)=KFCCHI(1)
37012 EI=KCHG(IABS(IA),1)/3D0
37013 T3I=SIGN(1D0,EI+1D-6)/2D0
37014 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
37016 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
37017 CXC(2)=DCMPLX(0D0,0D0)
37018 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
37019 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
37020 CXC(5)=-DCMPLX(EI/XW1)*ORPP
37021 CXC(6)=DCMPLX(0D0,0D0)
37022 CXC(7)=-DCMPLX(EI/XW1)*OLPP
37023 CXC(8)=DCMPLX(0D0,0D0)
37024 IF( XXC(5).LT.AXMI ) THEN
37029 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
37031 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
37032 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37033 IDLAM(LKNT,1)=KFCCHI(1)
37036 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
37038 XLAM(LKNT)=XLAM(LKNT-1)
37039 IDLAM(LKNT,1)=KFCCHI(1)
37047 C...CHI_2+ -> CHI_1+ + H0_K
37055 XMH=PMAS(ITH(IH),1)
37057 C...NO 3-BODY OPTION
37058 IF(AXMI.GE.AXMJ+XMH) THEN
37060 XL=PYLAMF(XMI2,XMJ2,XMH2)
37061 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
37062 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
37063 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
37064 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
37066 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37067 GLR=DBLE(OLPP*DCONJG(ORPP))
37068 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
37069 IDLAM(LKNT,1)=KFCCHI(1)
37070 IDLAM(LKNT,2)=ITH(IH)
37075 C...CHI1 JUMPS TO HERE
37078 C...CHI+_I -> CHI0_J + W+
37083 IF(AXMI.GE.AXMJ+XMW) THEN
37086 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
37088 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
37089 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
37090 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
37091 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
37092 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
37093 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
37094 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
37095 IDLAM(LKNT,1)=KFNCHI(IJ)
37099 ELSEIF(AXMI.GE.AXMJ) THEN
37101 S12MAX=(AXMI-AXMJ)**2
37103 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
37105 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
37106 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
37107 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
37108 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
37109 CXC(5)=DCMPLX(0D0,0D0)
37110 CXC(7)=DCMPLX(0D0,0D0)
37114 T3I=SIGN(1D0,EI+1D-6)/2D0
37116 T3J=SIGN(1D0,EJ+1D-6)/2D0
37117 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
37118 & TANW+ZMIXC(IJ,2)*T3J)/SR2
37119 CXC(4)=-DCONJG(UMIXC(IX,1))*(
37120 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
37121 CXC(6)=DCMPLX(0D0,0D0)
37122 CXC(8)=DCMPLX(0D0,0D0)
37127 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
37128 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
37131 CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
37132 IF(XXC(5).LT.AXMI) THEN
37134 ELSEIF(XXC(6).LT.AXMI) THEN
37139 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
37140 C...--> 1/(16PI)/M**3*(AEM/XW)**2
37141 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
37143 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37144 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
37145 IDLAM(LKNT,1)=KFNCHI(IJ)
37148 C...ONLY DECAY CHI+1 -> E+ NU_E
37149 IF( IMSS(12).NE. 0 ) GOTO 260
37150 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
37152 XLAM(LKNT)=XLAM(LKNT-1)
37153 IDLAM(LKNT,1)=KFNCHI(IJ)
37158 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
37160 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
37161 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
37163 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
37165 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
37166 IF(XXC(5).LT.AXMI) THEN
37168 ELSEIF(XXC(6).LT.AXMI) THEN
37173 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37174 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
37175 IDLAM(LKNT,1)=KFNCHI(IJ)
37180 C...NOW, DO THE QUARKS
37185 T3I=SIGN(1D0,EI+1D-6)/2D0
37187 T3J=SIGN(1D0,EJ+1D-6)/2D0
37188 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
37189 & TANW+ZMIXC(IX,2)*T3J)
37190 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
37191 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
37192 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
37193 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
37194 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
37195 IF(XXC(5).LT.AXMI) THEN
37198 IF(XXC(6).LT.AXMI) THEN
37203 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
37205 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
37206 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37207 IDLAM(LKNT,1)=KFNCHI(IJ)
37210 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
37212 XLAM(LKNT)=XLAM(LKNT-1)
37213 IDLAM(LKNT,1)=KFNCHI(IJ)
37222 C...CHI+_I -> CHI0_J + H+
37228 IF(AXMI.GE.AXMJ+XMHP) THEN
37230 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
37231 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
37232 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
37233 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
37235 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37236 GLR=DBLE(OLPP*DCONJG(ORPP))
37237 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
37238 IDLAM(LKNT,1)=KFNCHI(IJ)
37246 C...2-BODY DECAYS TO FERMION SFERMION
37248 IF(J.GE.7.AND.J.LE.10) GOTO 240
37249 IF(MOD(J,2).EQ.0) THEN
37255 XMSF1=PMAS(PYCOMP(KF1),1)
37256 XMSF2=PMAS(PYCOMP(KF2),1)
37265 IF(MOD(J,2).EQ.0) THEN
37268 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
37269 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
37275 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
37277 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
37282 IF(AXMI.GE.XMF+XMSF1) THEN
37286 XL=PYLAMF(XMI2,XMA2,XMB2)
37287 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
37288 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
37289 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37290 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37292 IF(MOD(J,2).EQ.0) THEN
37302 IF(AXMI.GE.XMF+XMSF2) THEN
37306 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
37307 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
37308 XL=PYLAMF(XMI2,XMA2,XMB2)
37309 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37310 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37312 IF(MOD(J,2).EQ.0) THEN
37322 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
37323 C...A 2-BODY -- 2-BODY CHAIN
37324 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
37325 IF(AXMI.GE.XMJ) THEN
37328 S12MAX=(AXMI-AXMJ)**2
37333 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
37334 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
37337 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
37339 CXC(1)=DCMPLX(0D0,0D0)
37340 CXC(3)=DCMPLX(0D0,0D0)
37341 CXC(5)=DCMPLX(0D0,0D0)
37342 CXC(7)=DCMPLX(0D0,0D0)
37343 CXC(2)=UMIXC(IX,1)*OLPP/SR2
37344 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
37345 CXC(6)=DCMPLX(0D0,0D0)
37346 CXC(8)=DCMPLX(0D0,0D0)
37347 IF(XXC(5).LT.AXMI) THEN
37349 ELSEIF(XXC(6).LT.AXMI) THEN
37354 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
37355 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
37357 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
37358 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37359 IDLAM(LKNT,1)=KSUSY1+21
37362 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
37364 XLAM(LKNT)=XLAM(LKNT-1)
37365 IDLAM(LKNT,1)=KSUSY1+21
37373 C...R-violating decay modes (SKANDS).
37374 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
37379 XLAM(0)=XLAM(0)+XLAM(I)
37380 IF(XLAM(I).LT.0D0) THEN
37381 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
37382 & (IDLAM(I,J),J=1,3)
37386 IF(XLAM(0).EQ.0D0) THEN
37388 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
37389 WRITE(MSTU(11),*) LKNT
37390 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
37396 C*********************************************************************
37399 C...Used in the calculation of inoi -> inoj + f + ~f.
37403 C...Double precision and integer declarations.
37404 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37405 IMPLICIT INTEGER(I-N)
37406 INTEGER PYK,PYCHGE,PYCOMP
37407 C...Parameter statement to help give large particle numbers.
37408 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37409 &KEXCIT=4000000,KDIMEN=5000000)
37411 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37412 C COMMON/PYINTS/XXM(20)
37414 COMMON/PYINTC/XXC(10),CXC(8)
37415 SAVE /PYDAT1/,/PYINTC/
37417 C...Local variables.
37418 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
37419 DOUBLE PRECISION PYXXZ6,X
37420 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
37421 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
37422 DOUBLE PRECISION SIJ
37423 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
37424 DOUBLE PRECISION OL2
37425 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
37428 C...Statement functions.
37429 C...Integral from x to y of (t-a)(b-t) dt.
37430 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
37431 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
37432 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
37433 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
37434 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
37435 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
37436 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
37437 C...Integral from x to y of (t-a)/(b-t) dt.
37438 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
37439 C...Integral from x to y of 1/(t-a) dt.
37440 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
37448 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
37449 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
37450 &( (X-XM22-S)**2 -4D0*XM22*S ) )
37452 S23MIN=(S23AVE-S23DEL)
37453 S23MAX=(S23AVE+S23DEL)
37470 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
37471 SIJ=2D0*XXC(2)*XXC(4)*S13
37472 IF(XMV.LE.1000D0) THEN
37473 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
37474 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
37475 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
37476 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
37477 IF(XXC(5).LE.10000D0) THEN
37478 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
37479 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
37480 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
37481 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
37482 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
37483 & *(S13-XMV**2)/WPROP2
37488 IF(XXC(6).LE.10000D0) THEN
37489 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
37490 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
37491 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
37492 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
37493 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
37494 & *(S13-XMV**2)/WPROP2
37503 IF(XXC(5).LE.10000D0) THEN
37504 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
37505 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
37506 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
37507 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
37511 IF(XXC(6).LE.10000D0) THEN
37512 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
37513 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
37514 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
37515 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
37520 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
37522 IF(PYXXZ6.LT.0D0) THEN
37523 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
37524 WRITE(MSTU(11),*) XXc(1),XXc(2),XXc(3),XXc(4)
37525 WRITE(MSTU(11),*) (XXc(I),I=5,8)
37526 WRITE(MSTU(11),*) (XXc(I),I=9,12)
37527 WRITE(MSTU(11),*) (XXc(I),I=13,16)
37528 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
37529 WRITE(MSTU(11),*) S23MIN,S23MAX
37537 C*********************************************************************
37540 C...Calculates chi0_i -> chi0_j + gamma.
37542 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
37544 C...Double precision and integer declarations.
37545 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37546 IMPLICIT INTEGER(I-N)
37547 INTEGER PYK,PYCHGE,PYCOMP
37549 C...Local variables.
37550 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
37551 DOUBLE PRECISION F1,F2
37553 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
37554 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
37555 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
37556 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
37561 C*********************************************************************
37564 C...Calculates the decay rate for ino -> ino + gauge boson.
37566 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
37568 C...Double precision and integer declarations.
37569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37570 IMPLICIT INTEGER(I-N)
37571 INTEGER PYK,PYCHGE,PYCOMP
37573 C...Local variables.
37574 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
37575 DOUBLE PRECISION XL,PYLAMF,C1
37576 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
37582 XL=PYLAMF(XMI2,XMJ2,XMV2)
37583 PYX2XG=C1/8D0/XMI3*SQRT(XL)
37584 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
37585 &12D0*GLR*XM1*XM2*XMV2)
37590 C*********************************************************************
37593 C...Calculates the decay rate for ino -> ino + H.
37595 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
37597 C...Double precision and integer declarations.
37598 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37599 IMPLICIT INTEGER(I-N)
37600 INTEGER PYK,PYCHGE,PYCOMP
37602 C...Local variables.
37603 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
37604 DOUBLE PRECISION XL,PYLAMF,C1
37605 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
37611 XL=PYLAMF(XMI2,XMJ2,XMV2)
37612 PYX2XH=C1/8D0/XMI3*SQRT(XL)
37613 &*(GX2*(XMI2+XMJ2-XMV2)+
37619 C*********************************************************************
37622 C...Calculates the non-standard decay modes of the Higgs boson.
37624 C...Author: Stephen Mrenna
37625 C...Last Update: April 2001
37626 C......Allow complex values for Z,U, and V
37628 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
37630 C...Double precision and integer declarations.
37631 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37632 IMPLICIT INTEGER(I-N)
37633 INTEGER PYK,PYCHGE,PYCOMP
37634 C...Parameter statement to help give large particle numbers.
37635 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37636 &KEXCIT=4000000,KDIMEN=5000000)
37638 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37639 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37640 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37641 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
37642 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37643 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
37644 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
37646 C...Local variables.
37647 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
37648 COMPLEX*16 QIJ,RIJ,F21K,F12K
37650 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
37651 DOUBLE PRECISION XMI2,XMI3,XMJ2
37652 DOUBLE PRECISION PYLAMF,XL,CF,EI
37654 DOUBLE PRECISION TANW,XW,AEM,C1,AS
37655 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
37656 DOUBLE PRECISION XLAM(0:300)
37657 INTEGER IDLAM(300,3)
37658 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
37660 INTEGER KFNCHI(4),KFCCHI(2)
37661 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
37662 DOUBLE PRECISION SR2
37663 DOUBLE PRECISION BETA,ALFA
37664 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
37665 DOUBLE PRECISION PYALEM
37666 DOUBLE PRECISION AL,AR,ALR
37667 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
37668 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
37669 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
37670 DATA ITH/25,35,36,37/
37671 DATA ETAH/1D0,1D0,-1D0/
37672 DATA SR2/1.4142136D0/
37673 DATA KFNCHI/1000022,1000023,1000025,1000035/
37674 DATA KFCCHI/1000024,1000037/
37676 C...COUNT THE NUMBER OF DECAY MODES
37683 TANW = SQRT(XW/(1D0-XW))
37686 C...1 - 4 DEPENDING ON Higgs species.
37688 IF(KFIN.EQ.ITH(2)) IH=2
37689 IF(KFIN.EQ.ITH(3)) IH=3
37690 IF(KFIN.EQ.ITH(4)) IH=4
37713 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
37718 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
37719 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
37724 IF(IH.EQ.4) GOTO 220
37726 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
37727 C...H0_K -> CHI0_I + CHI0_J
37740 IF(AXMI.GE.AXMJ+AXMK) THEN
37742 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
37743 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
37744 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
37745 & ZMIXC(IJ,3)*ZMIXC(IK,1))
37746 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
37747 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
37748 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
37749 & ZMIXC(IJ,4)*ZMIXC(IK,1))
37750 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
37751 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
37752 C...SIGN OF MASSES I,J
37754 GX2=ABS(F12K)**2+ABS(F21K)**2
37755 GLR=DBLE(F12K*DCONJG(F21K))
37756 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
37757 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
37758 IDLAM(LKNT,1)=KFNCHI(IJ)
37759 IDLAM(LKNT,2)=KFNCHI(IK)
37765 C...H0_K -> CHI+_I CHI-_J
37772 IF(AXMI.GE.AXMJ+AXMK) THEN
37774 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
37775 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
37776 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
37777 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
37778 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37779 GLR=DBLE(OLPP*DCONJG(ORPP))
37781 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
37782 IDLAM(LKNT,1)=KFCCHI(IJ)
37783 IDLAM(LKNT,2)=-KFCCHI(IK)
37789 C...HIGGS TO SFERMION SFERMION
37791 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
37793 XMJL=PMAS(PYCOMP(IJ),1)
37794 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
37795 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
37798 XL=PYLAMF(XMI2,XMJ2,XMJ2)
37805 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
37806 & XMF**2/XMW*SINA/CBETA
37807 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
37808 & XMF**2/XMW*SINA/CBETA
37810 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
37812 ELSEIF(IFL.EQ.15) THEN
37813 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
37819 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
37820 & XMF**2/XMW*COSA/SBETA
37821 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
37822 & XMF**2/XMW*COSA/SBETA
37824 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
37831 ELSEIF(IH.EQ.2) THEN
37833 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
37834 & XMF**2/XMW*COSA/CBETA
37835 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
37836 & XMF**2/XMW*COSA/CBETA
37838 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
37840 ELSEIF(IFL.EQ.15) THEN
37841 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
37847 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
37848 & XMF**2/XMW*SINA/SBETA
37849 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
37850 & XMF**2/XMW*SINA/SBETA
37852 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
37859 ELSEIF(IH.EQ.3) THEN
37865 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
37866 ELSEIF(IFL.EQ.15) THEN
37867 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
37871 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
37875 IF(IH.EQ.3) GOTO 180
37879 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
37886 IF(AXMI.GE.2D0*XMJ) THEN
37888 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
37890 & +2D0*GHLR*ALR)**2
37896 IF(AXMI.GE.2D0*XMJR) THEN
37900 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
37903 XL=PYLAMF(XMI2,XMJ2,XMJ2)
37904 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
37906 & +2D0*GHLR*ALR)**2
37907 IDLAM(LKNT,1)=IJ+KSUSY1
37908 IDLAM(LKNT,2)=-(IJ+KSUSY1)
37913 IF(AXMI.GE.XMJL+XMJR) THEN
37915 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
37916 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
37917 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
37920 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
37921 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
37922 & (GHLL*AL+GHRR*AR)**2
37924 IDLAM(LKNT,2)=-(IJ+KSUSY1)
37928 IDLAM(LKNT,2)=IJ+KSUSY1
37930 XLAM(LKNT)=XLAM(LKNT-1)
37940 C...H+ -> CHI+_I + CHI0_J
37948 IF(AXMI.GE.AXMJ+AXMK) THEN
37950 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
37951 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
37952 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
37953 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
37954 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37955 GLR=DBLE(OLPP*DCONJG(ORPP))
37956 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
37957 IDLAM(LKNT,1)=KFNCHI(IJ)
37958 IDLAM(LKNT,2)=KFCCHI(IK)
37964 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
37965 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
37971 XM1=PMAS(PYCOMP(KSUSY1+6),1)
37972 XM2=PMAS(PYCOMP(KSUSY1+5),1)
37973 IF(XMI.GE.XM1+XM2) THEN
37974 XL=PYLAMF(XMI2,XM1**2,XM2**2)
37976 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
37977 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
37978 IDLAM(LKNT,1)=KSUSY1+6
37979 IDLAM(LKNT,2)=-(KSUSY1+5)
37984 XM1=PMAS(PYCOMP(KSUSY2+6),1)
37985 XM2=PMAS(PYCOMP(KSUSY1+5),1)
37986 IF(XMI.GE.XM1+XM2) THEN
37987 XL=PYLAMF(XMI2,XM1**2,XM2**2)
37989 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
37990 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
37991 IDLAM(LKNT,1)=KSUSY2+6
37992 IDLAM(LKNT,2)=-(KSUSY1+5)
37997 XM1=PMAS(PYCOMP(KSUSY1+6),1)
37998 XM2=PMAS(PYCOMP(KSUSY2+5),1)
37999 IF(XMI.GE.XM1+XM2) THEN
38000 XL=PYLAMF(XMI2,XM1**2,XM2**2)
38002 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
38003 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
38004 IDLAM(LKNT,1)=KSUSY1+6
38005 IDLAM(LKNT,2)=-(KSUSY2+5)
38010 XM1=PMAS(PYCOMP(KSUSY2+6),1)
38011 XM2=PMAS(PYCOMP(KSUSY2+5),1)
38012 IF(XMI.GE.XM1+XM2) THEN
38013 XL=PYLAMF(XMI2,XM1**2,XM2**2)
38015 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
38016 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
38017 IDLAM(LKNT,1)=KSUSY2+6
38018 IDLAM(LKNT,2)=-(KSUSY2+5)
38023 GL=-XMW/SR2*SIN(2D0*BETA)
38025 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
38026 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
38027 IF(XMI.GE.XM1+XM2) THEN
38028 XL=PYLAMF(XMI2,XM1**2,XM2**2)
38030 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
38031 IDLAM(LKNT,1)=-(KSUSY1+IJ)
38032 IDLAM(LKNT,2)=KSUSY1+IJ+1
38040 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
38041 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
38042 IF(XMI.GE.XM1+XM2) THEN
38043 XL=PYLAMF(XMI2,XM1**2,XM2**2)
38045 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
38046 IDLAM(LKNT,1)=-(KSUSY1+IJ)
38047 IDLAM(LKNT,2)=KSUSY1+IJ+1
38052 C...H+ -> TAU1 NUTAUL
38053 XM1=PMAS(PYCOMP(KSUSY1+15),1)
38054 XM2=PMAS(PYCOMP(KSUSY1+16),1)
38055 IF(XMI.GE.XM1+XM2) THEN
38056 XL=PYLAMF(XMI2,XM1**2,XM2**2)
38058 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
38059 IDLAM(LKNT,1)=-(KSUSY1+15)
38060 IDLAM(LKNT,2)= KSUSY1+16
38064 C...H+ -> TAU2 NUTAUL
38065 XM1=PMAS(PYCOMP(KSUSY2+15),1)
38066 XM2=PMAS(PYCOMP(KSUSY1+16),1)
38067 IF(XMI.GE.XM1+XM2) THEN
38068 XL=PYLAMF(XMI2,XM1**2,XM2**2)
38070 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
38071 IDLAM(LKNT,1)=-(KSUSY2+15)
38072 IDLAM(LKNT,2)= KSUSY1+16
38080 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
38081 XLAM(0)=XLAM(0)+XLAM(I)
38083 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
38088 C*********************************************************************
38091 C...Calculates the decay rate for a Higgs to an ino pair.
38093 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
38095 C...Double precision and integer declarations.
38096 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38097 IMPLICIT INTEGER(I-N)
38098 INTEGER PYK,PYCHGE,PYCOMP
38100 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38103 C...Local variables.
38104 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
38105 DOUBLE PRECISION XL,PYLAMF,C1
38106 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
38112 XL=PYLAMF(XMI2,XMJ2,XMK2)
38113 PYH2XX=C1/4D0/XMI3*SQRT(XL)
38114 &*(GX2*(XMI2-XMJ2-XMK2)-
38116 IF(PYH2XX.LT.0D0) THEN
38117 WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
38118 WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GX2,GLR,XM1,XM2,XM3
38125 C*********************************************************************
38128 C...Integration by adaptive Gaussian quadrature.
38129 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
38131 FUNCTION PYGAUS(F, A, B, EPS)
38133 C...Double precision and integer declarations.
38134 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38135 IMPLICIT INTEGER(I-N)
38136 INTEGER PYK,PYCHGE,PYCOMP
38138 C...Local declarations.
38140 DOUBLE PRECISION F,W(12), X(12)
38141 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
38142 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
38143 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
38144 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
38145 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
38146 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
38147 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
38148 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
38149 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
38150 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
38151 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
38152 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
38154 C...The Gaussian quadrature algorithm.
38156 IF(B .EQ. A) GOTO 140
38157 CONST = 5D-3 / ABS(B-A)
38168 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
38173 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
38176 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
38178 IF(BB .NE. B) GOTO 100
38181 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
38183 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
38192 C*********************************************************************
38195 C...Simpson formula for an integral.
38197 FUNCTION PYSIMP(Y,X0,X1,N)
38199 C...Double precision and integer declarations.
38200 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38201 IMPLICIT INTEGER(I-N)
38202 INTEGER PYK,PYCHGE,PYCOMP
38204 C...Local variables.
38205 DOUBLE PRECISION Y,X0,X1,H,S
38211 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
38218 C*********************************************************************
38221 C...The standard lambda function.
38223 FUNCTION PYLAMF(X,Y,Z)
38225 C...Double precision and integer declarations.
38226 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38227 IMPLICIT INTEGER(I-N)
38228 INTEGER PYK,PYCHGE,PYCOMP
38230 C...Local variables.
38231 DOUBLE PRECISION PYLAMF,X,Y,Z
38233 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
38234 IF(PYLAMF.LT.0D0) PYLAMF=0D0
38239 C*********************************************************************
38242 C...Generates 3-body decays of gauginos.
38244 SUBROUTINE PYTBDY(IDIN)
38246 C...Double precision and integer declarations.
38247 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38248 IMPLICIT INTEGER(I-N)
38249 INTEGER PYK,PYCHGE,PYCOMP
38250 C...Parameter statement to help give large particle numbers.
38251 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38252 &KEXCIT=4000000,KDIMEN=5000000)
38254 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38255 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38256 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38257 C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
38258 C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38259 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
38260 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
38261 C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
38262 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
38264 C...Local variables.
38265 DOUBLE PRECISION XM(5)
38266 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
38267 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
38268 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
38269 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
38270 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
38271 DOUBLE PRECISION CPHI1,SPHI1
38272 DOUBLE PRECISION S23DEL,EPS
38273 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
38274 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
38275 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
38277 DATA INOID/22,23,25,35/
38288 S12MIN=(XM(1)+XM(2))**2
38289 S12MAX=(XM(5)-XM(3))**2
38290 YJACO1=S12MAX-S12MIN
38292 C...Initialize some parameters
38301 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
38302 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
38304 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
38305 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
38306 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
38307 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
38312 EI=KCHG(IABS(IA),1)/3D0
38313 T3I=SIGN(1D0,EI+1D-6)/2D0
38314 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
38316 ELSEIF(IZID1*IZID2.NE.0) THEN
38318 GMMZ=PMAS(23,1)*PMAS(23,2)
38320 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
38321 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
38323 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
38324 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
38326 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
38328 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
38330 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
38331 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
38332 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
38333 XM1M2=SMZ(IZID1)*SMZ(IZID2)
38334 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
38336 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
38338 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
38340 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
38342 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
38343 IF(IZID1.NE.0) THEN
38344 XM1M2=SMZ(IZID1)*SMW(IWID2)
38348 XM1M2=SMZ(IZID2)*SMW(IWID1)
38351 RT2I = 1D0/SQRT(2D0)
38353 GMMZ=PMAS(24,1)*PMAS(24,2)
38355 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
38356 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
38359 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
38361 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
38362 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
38363 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
38364 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
38366 T3J=SIGN(1D0,EJ+1D-6)/2D0
38367 QRLS=DCMPLX(0D0,0D0)
38373 XLR2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
38374 XLL2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
38375 IF(MOD(IA,2).EQ.0) THEN
38376 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
38377 & TANW+ZMIXC(IZID2,2)*T3I)
38378 QLRT=-DCONJG(UMIXC(IZID1,1))*(
38379 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
38381 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
38382 & TANW+ZMIXC(IZID2,2)*T3J)
38383 QLRT=-DCONJG(UMIXC(IZID1,1))*(
38384 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
38386 ELSEIF(IWID1*IWID2.NE.0) THEN
38389 XM1M2=SMW(IWID1)*SMW(IWID2)
38391 GMMZ=PMAS(23,1)*PMAS(23,2)
38393 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
38394 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
38395 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
38396 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
38398 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
38399 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
38400 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
38401 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
38402 QRLS=-DCMPLX(EI/XW1)*ORPP
38403 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38404 QRRS=-DCMPLX(EI/XW1)*OLPP
38405 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38406 IF(MOD(IA,2).EQ.0) THEN
38407 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
38408 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
38410 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
38411 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
38413 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
38420 IF(ISKIP.NE.0) THEN
38423 S12=S12MIN+YJACO1*(KT-1)/99
38424 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
38425 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
38426 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
38427 & -(2D0*XM(1)*XM(2))**2
38428 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
38429 & -(2D0*XM(3)*XM(5))**2
38432 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
38434 S23MIN=S23AVE-S23DEL
38435 S23MAX=S23AVE+S23DEL
38436 YJACO2=S23MAX-S23MIN
38439 S23=S23MIN+YJACO2*(KS-1)/99
38442 WU2 = (UH-ZM12)*(UH-ZM22)
38443 WT2 = (TH-ZM12)*(TH-ZM22)
38445 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
38446 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
38447 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
38448 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
38449 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
38450 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
38451 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
38452 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
38453 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
38454 IF(WT0.GT.WTMAX) WTMAX=WT0
38464 BX=S12MIN+0.5D0*YJACO1
38467 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
38475 C...SOLVE FOR F1 AND F2
38476 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
38477 &-(2D0*XM(1)*XM(2))**2
38478 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
38479 &-(2D0*XM(3)*XM(5))**2
38482 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
38484 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
38485 &-(2D0*XM(1)*XM(2))**2
38486 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
38487 &-(2D0*XM(3)*XM(5))**2
38490 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
38493 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
38494 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
38500 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
38501 & -(2D0*XM(1)*XM(2))**2
38502 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
38503 & -(2D0*XM(3)*XM(5))**2
38506 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
38513 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
38514 & -(2D0*XM(1)*XM(2))**2
38515 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
38516 & -(2D0*XM(3)*XM(5))**2
38519 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
38524 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
38534 180 S12=S12MIN+PYR(0)*YJACO1
38537 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
38538 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
38539 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
38540 &-(2D0*XM(1)*XM(2))**2
38541 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
38542 &-(2D0*XM(3)*XM(5))**2
38545 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
38547 S23MIN=S23AVE-S23DEL
38548 S23MAX=S23AVE+S23DEL
38549 YJACO2=S23MAX-S23MIN
38550 S23=S23MIN+PYR(0)*YJACO2
38552 C...CHECK THE SAMPLING
38553 IF(IKNT.GT.100) THEN
38554 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
38557 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
38559 IF(ISKIP.EQ.0) GOTO 190
38565 WU2 = (UH-ZM12)*(UH-ZM22)
38566 WT2 = (TH-ZM12)*(TH-ZM22)
38568 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
38569 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
38571 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
38572 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
38573 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
38574 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
38575 c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
38576 c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
38577 c &/DCMPLX(TH-XML2)
38578 c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
38579 c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
38580 c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
38581 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
38582 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
38583 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
38585 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
38586 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
38588 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
38589 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
38591 P1=SQRT(D1*D1-XM(1)**2)
38592 P2=SQRT(D2*D2-XM(2)**2)
38593 P3=SQRT(D3*D3-XM(3)**2)
38594 CTHE1=2D0*PYR(0)-1D0
38595 ANG1=2D0*PYR(0)*PARU(1)
38599 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
38601 P(N+1,1)=P1*STHE1*CPHI1
38602 P(N+1,2)=P1*STHE1*SPHI1
38607 ANG3=2D0*PYR(0)*PARU(1)
38610 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
38612 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
38614 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
38615 &+P3*STHE3*SPHI3*SPHI1
38616 &+P3*CTHE3*STHE1*CPHI1
38617 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
38618 &-P3*STHE3*SPHI3*CPHI1
38619 &+P3*CTHE3*STHE1*SPHI1
38620 P(N+3,3)=P3*STHE3*CPHI3*STHE1
38625 P(N+2,I)=-P(N+1,I)-P(N+3,I)
38632 C*********************************************************************
38635 C...Finds the s-hat dependent eigenvalues of the inverse propagator
38636 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
38637 C...phase space generation.
38639 SUBROUTINE PYTECM(S1,S2)
38641 C...Double precision and integer declarations.
38642 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38643 IMPLICIT INTEGER(I-N)
38644 INTEGER PYK,PYCHGE,PYCOMP
38645 C...Parameter statement to help give large particle numbers.
38646 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38647 &KEXCIT=4000000,KDIMEN=5000000)
38649 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38650 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38651 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38652 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
38654 C...Local variables.
38655 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12),
38656 &AT(4,4),WI(4),FV1(4),FV2(4),FV3(4),sh,aem,tanw,ct2w,qupd,alprht,
38657 &far,fao,fzr,fzo,shr,R1,R2,S1,S2,WDTP(0:300),WDTE(0:300,0:5)
38660 SH=PMAS(PYCOMP(KTECHN+113),1)**2
38663 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
38664 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
38665 QUPD=2D0*PARP(143)-1D0
38667 ALPRHT=2.91D0*(3D0/PARP(144))
38668 FAR=SQRT(AEM/ALPRHT)
38674 AR(2,2) = SH-PMAS(23,1)**2
38675 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
38676 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
38696 CALL PYWIDT(23,SH,WDTP,WDTE)
38697 AT(2,2) = WDTP(0)*SHR
38698 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
38699 AT(3,3) = WDTP(0)*SHR
38700 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
38701 AT(4,4) = WDTP(0)*SHR
38703 CALL PYEICG(4,4,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
38705 WI(I)=SQRT(ABS(SH-WR(I)))
38708 R1=MIN(WR(1),WR(2),WR(3),WR(4))
38713 IF(ABS(WR(I)-R1).LT.1D-6) THEN
38717 IF(WR(I).LE.R2) THEN
38727 C*********************************************************************
38730 C...Finds eigenvalues of a general complex matrix
38732 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
38733 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
38734 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
38735 C OF A COMPLEX GENERAL MATRIX.
38739 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
38740 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
38741 C DIMENSION STATEMENT.
38743 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
38745 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
38746 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
38748 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
38749 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
38750 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
38754 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
38755 C RESPECTIVELY, OF THE EIGENVALUES.
38757 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
38758 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
38760 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
38761 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
38762 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
38764 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
38766 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
38767 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
38769 C THIS VERSION DATED AUGUST 1983.
38772 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
38774 INTEGER N,NM,IS1,IS2,IERR,MATZ
38775 DOUBLE PRECISION AR(4,4),AI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
38776 X FV1(4),FV2(4),FV3(4)
38777 IF (N .LE. NM) GOTO 100
38781 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
38782 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
38783 IF (MATZ .NE. 0) GOTO 110
38784 C .......... FIND EIGENVALUES ONLY ..........
38785 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
38787 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
38788 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
38789 IF (IERR .NE. 0) GOTO 120
38790 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
38794 C*********************************************************************
38797 C...Auxiliary to PYEICG.
38799 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
38800 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
38802 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
38803 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
38804 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
38806 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
38807 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
38811 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
38812 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
38813 C DIMENSION STATEMENT.
38815 C N IS THE ORDER OF THE MATRIX.
38817 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
38818 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
38819 C SET LOW=1, IGH=N.
38821 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
38822 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
38823 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
38824 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
38825 C THE REDUCTION BY CORTH, IF PERFORMED.
38829 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
38830 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
38831 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
38832 C EIGENVECTORS IS TO BE PERFORMED.
38834 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
38835 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
38836 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
38837 C FOR INDICES IERR+1,...,N.
38840 C ZERO FOR NORMAL RETURN,
38841 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
38842 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
38844 C CALLS PYCDIV FOR COMPLEX DIVISION.
38845 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
38846 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
38848 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
38849 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
38851 C THIS VERSION DATED AUGUST 1983.
38854 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
38856 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
38857 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4)
38858 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
38862 IF (LOW .EQ. IGH) GOTO 130
38863 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
38868 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
38869 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
38870 YR = HR(I,I-1) / NORM
38871 YI = HI(I,I-1) / NORM
38876 SI = YR * HI(I,J) - YI * HR(I,J)
38877 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
38882 SI = YR * HI(J,I) + YI * HR(J,I)
38883 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
38888 C .......... STORE ROOTS ISOLATED BY CBAL ..........
38889 130 DO 140 I = 1, N
38890 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
38899 C .......... SEARCH FOR NEXT EIGENVALUE ..........
38900 150 IF (EN .LT. LOW) GOTO 320
38903 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
38904 C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
38905 160 DO 170 LL = LOW, EN
38907 IF (L .EQ. LOW) GOTO 180
38908 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
38909 X + DABS(HR(L,L)) + DABS(HI(L,L))
38910 TST2 = TST1 + DABS(HR(L,L-1))
38911 IF (TST2 .EQ. TST1) GOTO 180
38913 C .......... FORM SHIFT ..........
38914 180 IF (L .EQ. EN) GOTO 300
38915 IF (ITN .EQ. 0) GOTO 310
38916 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
38919 XR = HR(ENM1,EN) * HR(EN,ENM1)
38920 XI = HI(ENM1,EN) * HR(EN,ENM1)
38921 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
38922 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
38923 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
38924 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
38925 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
38928 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
38932 C .......... FORM EXCEPTIONAL SHIFT ..........
38933 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
38936 210 DO 220 I = LOW, EN
38937 HR(I,I) = HR(I,I) - SR
38938 HI(I,I) = HI(I,I) - SI
38945 C .......... REDUCE TO TRIANGLE (ROWS) ..........
38951 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
38952 XR = HR(I-1,I-1) / NORM
38954 XI = HI(I-1,I-1) / NORM
38957 HI(I-1,I-1) = 0.0D0
38958 HI(I,I-1) = SR / NORM
38965 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
38966 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
38967 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
38968 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
38974 IF (SI .EQ. 0.0D0) GOTO 250
38975 NORM = PYTHAG(HR(EN,EN),SI)
38976 SR = HR(EN,EN) / NORM
38980 C .......... INVERSE OPERATION (COLUMNS) ..........
38981 250 DO 280 J = LP1, EN
38990 IF (I .EQ. J) GOTO 260
38992 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
38993 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
38994 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
38995 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
39000 IF (SI .EQ. 0.0D0) GOTO 160
39005 HR(I,EN) = SR * YR - SI * YI
39006 HI(I,EN) = SR * YI + SI * YR
39010 C .......... A ROOT FOUND ..........
39011 300 WR(EN) = HR(EN,EN) + TR
39012 WI(EN) = HI(EN,EN) + TI
39015 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
39016 C CONVERGED AFTER 30*N ITERATIONS ..........
39021 C*********************************************************************
39024 C...Auxiliary to PYEICG.
39026 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
39027 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
39029 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
39030 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
39031 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
39033 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
39034 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
39035 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
39036 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
39037 C THIS GENERAL MATRIX TO HESSENBERG FORM.
39041 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
39042 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
39043 C DIMENSION STATEMENT.
39045 C N IS THE ORDER OF THE MATRIX.
39047 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
39048 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
39049 C SET LOW=1, IGH=N.
39051 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
39052 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
39053 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
39054 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
39055 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
39057 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
39058 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
39059 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
39060 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
39061 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
39062 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
39067 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
39068 C HAVE BEEN DESTROYED.
39070 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
39071 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
39072 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
39073 C FOR INDICES IERR+1,...,N.
39075 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
39076 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
39077 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
39078 C THE EIGENVECTORS HAS BEEN FOUND.
39081 C ZERO FOR NORMAL RETURN,
39082 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
39083 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
39085 C CALLS PYCDIV FOR COMPLEX DIVISION.
39086 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
39087 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
39089 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
39090 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
39092 C THIS VERSION DATED OCTOBER 1989.
39094 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
39095 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
39098 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
39100 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
39101 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
39102 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
39104 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
39108 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
39117 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
39118 C FROM THE INFORMATION LEFT BY CORTH ..........
39119 IEND = IGH - LOW - 1
39120 IF (IEND.LT.0) GOTO 220
39121 IF (IEND.EQ.0) GOTO 170
39122 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
39123 DO 160 II = 1, IEND
39125 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
39126 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
39127 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
39128 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
39131 DO 120 K = IP1, IGH
39132 ORTR(K) = HR(K,I-1)
39133 ORTI(K) = HI(K,I-1)
39141 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
39142 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
39149 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
39150 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
39156 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
39161 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
39162 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
39163 YR = HR(I,I-1) / NORM
39164 YI = HI(I,I-1) / NORM
39169 SI = YR * HI(I,J) - YI * HR(I,J)
39170 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
39175 SI = YR * HI(J,I) + YI * HR(J,I)
39176 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
39180 DO 200 J = LOW, IGH
39181 SI = YR * ZI(J,I) + YI * ZR(J,I)
39182 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
39187 C .......... STORE ROOTS ISOLATED BY CBAL ..........
39188 220 DO 230 I = 1, N
39189 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
39198 C .......... SEARCH FOR NEXT EIGENVALUE ..........
39199 240 IF (EN .LT. LOW) GOTO 430
39202 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
39203 C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
39204 250 DO 260 LL = LOW, EN
39206 IF (L .EQ. LOW) GOTO 270
39207 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
39208 X + DABS(HR(L,L)) + DABS(HI(L,L))
39209 TST2 = TST1 + DABS(HR(L,L-1))
39210 IF (TST2 .EQ. TST1) GOTO 270
39212 C .......... FORM SHIFT ..........
39213 270 IF (L .EQ. EN) GOTO 420
39214 IF (ITN .EQ. 0) GOTO 550
39215 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
39218 XR = HR(ENM1,EN) * HR(EN,ENM1)
39219 XI = HI(ENM1,EN) * HR(EN,ENM1)
39220 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
39221 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
39222 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
39223 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
39224 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
39227 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
39231 C .......... FORM EXCEPTIONAL SHIFT ..........
39232 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
39235 300 DO 310 I = LOW, EN
39236 HR(I,I) = HR(I,I) - SR
39237 HI(I,I) = HI(I,I) - SI
39244 C .......... REDUCE TO TRIANGLE (ROWS) ..........
39250 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
39251 XR = HR(I-1,I-1) / NORM
39253 XI = HI(I-1,I-1) / NORM
39256 HI(I-1,I-1) = 0.0D0
39257 HI(I,I-1) = SR / NORM
39264 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
39265 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
39266 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
39267 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
39273 IF (SI .EQ. 0.0D0) GOTO 350
39274 NORM = PYTHAG(HR(EN,EN),SI)
39275 SR = HR(EN,EN) / NORM
39279 IF (EN .EQ. N) GOTO 350
39285 HR(EN,J) = SR * YR + SI * YI
39286 HI(EN,J) = SR * YI - SI * YR
39288 C .......... INVERSE OPERATION (COLUMNS) ..........
39289 350 DO 390 J = LP1, EN
39298 IF (I .EQ. J) GOTO 360
39300 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
39301 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
39302 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
39303 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
39306 DO 380 I = LOW, IGH
39311 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
39312 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
39313 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
39314 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
39319 IF (SI .EQ. 0.0D0) GOTO 250
39324 HR(I,EN) = SR * YR - SI * YI
39325 HI(I,EN) = SR * YI + SI * YR
39328 DO 410 I = LOW, IGH
39331 ZR(I,EN) = SR * YR - SI * YI
39332 ZI(I,EN) = SR * YI + SI * YR
39336 C .......... A ROOT FOUND ..........
39337 420 HR(EN,EN) = HR(EN,EN) + TR
39339 HI(EN,EN) = HI(EN,EN) + TI
39343 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
39344 C VECTORS OF UPPER TRIANGULAR FORM ..........
39350 TR = DABS(HR(I,J)) + DABS(HI(I,J))
39351 IF (TR .GT. NORM) NORM = TR
39354 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
39355 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
39363 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
39364 DO 490 II = 1, ENM1
39371 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
39372 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
39377 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
39380 460 YR = 0.01D0 * YR
39382 IF (TST2 .GT. TST1) GOTO 460
39384 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
39385 C .......... OVERFLOW CONTROL ..........
39386 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
39387 IF (TR .EQ. 0.0D0) GOTO 490
39389 TST2 = TST1 + 1.0D0/TST1
39390 IF (TST2 .GT. TST1) GOTO 490
39392 HR(J,EN) = HR(J,EN)/TR
39393 HI(J,EN) = HI(J,EN)/TR
39399 C .......... END BACKSUBSTITUTION ..........
39400 C .......... VECTORS OF ISOLATED ROOTS ..........
39402 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
39410 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
39411 C VECTORS OF ORIGINAL FULL MATRIX.
39412 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
39417 DO 540 I = LOW, IGH
39422 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
39423 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
39431 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
39432 C CONVERGED AFTER 30*N ITERATIONS ..........
39437 C*********************************************************************
39440 C...Auxiliary to PYCMQR
39442 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
39445 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
39447 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
39448 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
39450 S = DABS(BR) + DABS(BI)
39455 S = BRS**2 + BIS**2
39456 CR = (ARS*BRS + AIS*BIS)/S
39457 CI = (AIS*BRS - ARS*BIS)/S
39461 C*********************************************************************
39464 C...Auxiliary to PYCMQR
39466 C (YR,YI) = COMPLEX DSQRT(XR,XI)
39467 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
39470 SUBROUTINE PYCSRT(XR,XI,YR,YI)
39472 DOUBLE PRECISION XR,XI,YR,YI
39473 DOUBLE PRECISION S,TR,TI,PYTHAG
39477 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
39478 IF (TR .GE. 0.0D0) YR = S
39479 IF (TI .LT. 0.0D0) S = -S
39480 IF (TR .LE. 0.0D0) YI = S
39481 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
39482 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
39486 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
39487 DOUBLE PRECISION A,B
39489 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
39491 DOUBLE PRECISION P,R,S,T,U
39492 P = DMAX1(DABS(A),DABS(B))
39493 IF (P .EQ. 0.0D0) GOTO 110
39494 R = (DMIN1(DABS(A),DABS(B))/P)**2
39497 IF (T .EQ. 4.0D0) GOTO 110
39499 U = 1.0D0 + 2.0D0*S
39507 C*********************************************************************
39510 C...Auxiliary to PYEICG
39512 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
39513 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
39514 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
39515 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
39517 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
39518 C EIGENVALUES WHENEVER POSSIBLE.
39522 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
39523 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
39524 C DIMENSION STATEMENT.
39526 C N IS THE ORDER OF THE MATRIX.
39528 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
39529 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
39533 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
39534 C RESPECTIVELY, OF THE BALANCED MATRIX.
39536 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
39537 C ARE EQUAL TO ZERO IF
39538 C (1) I IS GREATER THAN J AND
39539 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
39541 C SCALE CONTAINS INFORMATION DETERMINING THE
39542 C PERMUTATIONS AND SCALING FACTORS USED.
39544 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
39545 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
39546 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
39547 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
39548 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
39549 C = D(J,J) J = LOW,...,IGH
39550 C = P(J) J = IGH+1,...,N.
39551 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
39554 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
39556 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
39557 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
39558 C K,L HAVE BEEN REVERSED.)
39560 C ARITHMETIC IS REAL THROUGHOUT.
39562 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
39563 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
39565 C THIS VERSION DATED AUGUST 1983.
39568 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
39570 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
39571 DOUBLE PRECISION AR(4,4),AI(4,4),SCALE(4)
39572 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
39581 C .......... IN-LINE PROCEDURE FOR ROW AND
39582 C COLUMN EXCHANGE ..........
39584 IF (J .EQ. M) GOTO 130
39604 130 IF(IEXC.EQ.1) GOTO 140
39605 IF(IEXC.EQ.2) GOTO 180
39606 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
39607 C AND PUSH THEM DOWN ..........
39608 140 IF (L .EQ. 1) GOTO 320
39610 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
39611 150 DO 170 JJ = 1, L
39615 IF (I .EQ. J) GOTO 160
39616 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
39625 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
39626 C AND PUSH THEM LEFT ..........
39629 190 DO 210 J = K, L
39632 IF (I .EQ. J) GOTO 200
39633 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
39640 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
39642 220 SCALE(I) = 1.0D0
39643 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
39644 230 NOCONV = .FALSE.
39651 IF (J .EQ. I) GOTO 240
39652 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
39653 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
39655 C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
39656 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
39660 250 IF (C .GE. G) GOTO 260
39665 270 IF (C .LT. G) GOTO 280
39669 C .......... NOW BALANCE ..........
39670 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
39672 SCALE(I) = SCALE(I) * F
39676 AR(I,J) = AR(I,J) * G
39677 AI(I,J) = AI(I,J) * G
39681 AR(J,I) = AR(J,I) * F
39682 AI(J,I) = AI(J,I) * F
39687 IF (NOCONV) GOTO 230
39694 C*********************************************************************
39697 C...Auxiliary to PYEICG.
39699 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
39700 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
39701 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
39702 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
39704 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
39705 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
39706 C BALANCED MATRIX DETERMINED BY CBAL.
39710 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
39711 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
39712 C DIMENSION STATEMENT.
39714 C N IS THE ORDER OF THE MATRIX.
39716 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
39718 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
39719 C AND SCALING FACTORS USED BY CBAL.
39721 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
39723 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
39724 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
39725 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
39729 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
39730 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
39731 C IN THEIR FIRST M COLUMNS.
39733 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
39734 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
39736 C THIS VERSION DATED AUGUST 1983.
39739 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
39741 INTEGER I,J,K,M,N,II,NM,IGH,LOW
39742 DOUBLE PRECISION SCALE(4),ZR(4,4),ZI(4,4)
39745 IF (M .EQ. 0) GOTO 150
39746 IF (IGH .EQ. LOW) GOTO 120
39748 DO 110 I = LOW, IGH
39750 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
39751 C IF THE FOREGOING STATEMENT IS REPLACED BY
39752 C S=1.0D0/SCALE(I). ..........
39754 ZR(I,J) = ZR(I,J) * S
39755 ZI(I,J) = ZI(I,J) * S
39759 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
39760 C IGH+1 STEP 1 UNTIL N DO -- ..........
39761 120 DO 140 II = 1, N
39763 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
39764 IF (I .LT. LOW) I = LOW - II
39766 IF (K .EQ. I) GOTO 140
39782 C*********************************************************************
39785 C...Auxiliary to PYEICG.
39787 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
39788 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
39789 C BY MARTIN AND WILKINSON.
39790 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
39792 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
39793 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
39794 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
39795 C UNITARY SIMILARITY TRANSFORMATIONS.
39799 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
39800 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
39801 C DIMENSION STATEMENT.
39803 C N IS THE ORDER OF THE MATRIX.
39805 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
39806 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
39807 C SET LOW=1, IGH=N.
39809 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
39810 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
39814 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
39815 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
39816 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
39817 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
39818 C HESSENBERG MATRIX.
39820 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
39821 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
39823 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
39825 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
39826 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
39828 C THIS VERSION DATED AUGUST 1983.
39831 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
39833 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
39834 DOUBLE PRECISION AR(4,4),AI(4,4),ORTR(4),ORTI(4)
39835 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
39839 IF (LA .LT. KP1) GOTO 210
39846 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
39848 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
39850 IF (SCALE .EQ. 0.0D0) GOTO 200
39852 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
39855 ORTR(I) = AR(I,M-1) / SCALE
39856 ORTI(I) = AI(I,M-1) / SCALE
39857 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
39861 F = PYTHAG(ORTR(M),ORTI(M))
39862 IF (F .EQ. 0.0D0) GOTO 120
39865 ORTR(M) = (1.0D0 + G) * ORTR(M)
39866 ORTI(M) = (1.0D0 + G) * ORTI(M)
39871 C .......... FORM (I-(U*UT)/H) * A ..........
39872 130 DO 160 J = M, N
39875 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
39878 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
39879 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
39886 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
39887 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
39891 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
39895 C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
39898 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
39899 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
39906 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
39907 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
39912 ORTR(M) = SCALE * ORTR(M)
39913 ORTI(M) = SCALE * ORTI(M)
39914 AR(M,M-1) = -G * AR(M,M-1)
39915 AI(M,M-1) = -G * AI(M,M-1)
39921 C*********************************************************************
39924 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
39927 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
39929 INTEGER N,NP,INDX(N)
39931 COMPLEX*16 A(NP,NP)
39932 PARAMETER (TINY=1.0D-20)
39934 REAL*8 AAMAX,VV(6),DUM
39935 COMPLEX*16 SUM,DUMC
39941 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
39943 IF (AAMAX.EQ.0D0) PAUSE 'SINGULAR MATRIX IN PYLDCM'
39950 SUM=SUM-A(I,K)*A(K,J)
39958 SUM=SUM-A(I,K)*A(K,J)
39962 IF (DUM.GE.AAMAX) THEN
39977 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
39980 A(I,J)=A(I,J)/A(J,J)
39988 C*********************************************************************
39991 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
39994 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
39996 INTEGER N,NP,INDX(N)
39997 COMPLEX*16 A(NP,NP),B(N)
40008 SUM=SUM-A(I,J)*B(J)
40010 ELSE IF (ABS(SUM).NE.0D0) THEN
40018 SUM=SUM-A(I,J)*B(J)
40025 C***********************************************************************
40028 C...Calculates full and partial widths of resonances.
40029 C....copy of PYWIDT, used for techniparticle widths
40031 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
40033 C...Double precision and integer declarations.
40034 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40035 IMPLICIT INTEGER(I-N)
40036 INTEGER PYK,PYCHGE,PYCOMP
40037 C...Parameter statement to help give large particle numbers.
40038 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
40039 &KEXCIT=4000000,KDIMEN=5000000)
40041 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40042 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40043 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
40044 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
40045 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40046 COMMON/PYINT1/MINT(400),VINT(400)
40047 COMMON/PYINT4/MWID(500),WIDS(500,5)
40048 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
40049 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
40051 C...Local arrays and saved variables.
40052 DIMENSION WDTP(0:300),WDTE(0:300,0:5),MOFSV(3,2),WIDWSV(3,2),
40054 SAVE MOFSV,WIDWSV,WID2SV
40055 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
40057 C...Compressed code and sign; mass.
40064 C...Reset width information.
40072 C...Common electroweak and strong constants.
40075 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
40078 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
40080 RADC=1D0+AS/PARU(1)
40082 IF(KFLA.EQ.23) THEN
40085 XWC=1D0/(16D0*XW*XW1)
40086 FAC=(AEM*XWC/3D0)*SHR
40088 DO 130 I=1,MDCY(KC,3)
40090 IF(MDME(IDC,1).LT.0) GOTO 130
40091 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
40092 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
40093 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
40098 AF=SIGN(1D0,EF+0.1D0)
40101 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
40102 IF(I.EQ.6) WID2=WIDS(6,1)
40103 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
40104 ELSEIF(I.LE.16) THEN
40105 C...Z0 -> l+ + l-, nu + nubar
40107 AF=SIGN(1D0,EF+0.1D0)
40110 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
40112 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
40113 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
40115 WDTP(0)=WDTP(0)+WDTP(I)
40116 IF(MDME(IDC,1).GT.0) THEN
40117 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
40118 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
40119 & WDTE(I,MDME(IDC,1))
40120 WDTE(I,0)=WDTE(I,MDME(IDC,1))
40121 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
40126 ELSEIF(KFLA.EQ.24) THEN
40128 FAC=(AEM/(24D0*XW))*SHR
40129 DO 140 I=1,MDCY(KC,3)
40131 IF(MDME(IDC,1).LT.0) GOTO 140
40132 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
40133 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
40134 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
40137 C...W+/- -> q + qbar'
40138 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
40140 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
40141 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
40142 IF(I.GE.13) WID2=WID2*WIDS(7,3)
40144 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
40145 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
40146 IF(I.GE.13) WID2=WID2*WIDS(7,2)
40148 ELSEIF(I.LE.20) THEN
40149 C...W+/- -> l+/- + nu
40152 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
40154 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
40157 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
40158 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
40159 WDTP(0)=WDTP(0)+WDTP(I)
40160 IF(MDME(IDC,1).GT.0) THEN
40161 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
40162 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
40163 WDTE(I,0)=WDTE(I,MDME(IDC,1))
40164 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
40172 C*********************************************************************
40175 C...Calculates R-violating decays of sfermions.
40176 C... * Only L-violating decays included at this point.
40178 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
40180 C...Double precision and integer declarations.
40181 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40182 IMPLICIT INTEGER(I-N)
40183 C...Parameter statement to help give large particle numbers.
40184 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
40185 &KEXCIT=4000000,KDIMEN=5000000)
40187 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40188 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
40189 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
40190 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
40191 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
40192 C...Local variables.
40193 DOUBLE PRECISION XLAM(0:300), RM2, SM, SMT
40194 INTEGER IDLAM(300,3), KFIN, KFSM, I, J, K, LKNT, ICNT,PYCOMP
40195 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
40197 C...IS L-VIOLATION ON ?
40198 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
40199 C...Mass eigenstate counter
40200 ICNT=INT(KFIN/KSUSY1)
40201 C...SM KF code of SUSY particle
40202 KFSM=KFIN-ICNT*KSUSY1
40203 C...Squared Sparticle Mass
40204 SM=PMAS(PYCOMP(KFIN),1)**2
40205 C... Squared mass of top quark
40206 SMT=PMAS(PYCOMP(6),1)**2
40207 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
40208 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15)) THEN
40213 C...~e,~mu,~tau -> nu_I + lepton-_J
40215 IDLAM(LKNT,1)= 12 +2*(I-1)
40216 IDLAM(LKNT,2)= 11 +2*(J-1)
40219 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2 * SM
40220 IF (IMSS(51).NE.0) XLAM(LKNT) =
40221 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40222 C...KINEMATICS CHECK
40223 IF (XLAM(LKNT).EQ.0D0) THEN
40229 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
40235 IDLAM(LKNT,1)=-12 -2*(I-1)
40236 IDLAM(LKNT,2)= 11 +2*(K-1)
40239 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM
40240 IF (IMSS(51).NE.0) XLAM(LKNT) =
40241 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40242 C...KINEMATICS CHECK
40243 IF (XLAM(LKNT).EQ.0D0) THEN
40249 C...~e,~mu,~tau -> u_Jbar + d_K
40254 IDLAM(LKNT,1)=-2 -2*(J-1)
40255 IDLAM(LKNT,2)= 1 +2*(K-1)
40258 IF (IMSS(52).NE.0) THEN
40259 C...Use massive top quark
40260 IF (IDLAM(LKNT,1).EQ.-6) THEN
40261 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2
40264 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
40265 C...If no top quark, all decay products massless
40267 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM
40269 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40271 C...KINEMATICS CHECK
40272 IF (XLAM(LKNT).EQ.0D0) THEN
40279 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
40280 C...No right-handed neutrinos
40282 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
40287 C...~nu_J -> lepton+_I + lepton-_K
40289 IDLAM(LKNT,1)=-11 -2*(I-1)
40290 IDLAM(LKNT,2)= 11 +2*(K-1)
40293 RM2=RVLAM(I,J,K)**2 * SM
40294 IF (IMSS(51).NE.0) XLAM(LKNT) =
40295 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40296 C...KINEMATICS CHECK
40297 IF (XLAM(LKNT).EQ.0D0) THEN
40303 C...~nu_I -> dbar_J + d_K
40308 IDLAM(LKNT,1)=-1 -2*(J-1)
40309 IDLAM(LKNT,2)= 1 +2*(K-1)
40312 RM2=3*RVLAMP(I,J,K)**2 * SM
40313 IF (IMSS(52).NE.0) XLAM(LKNT) =
40314 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40315 C...KINEMATICS CHECK
40316 IF (XLAM(LKNT).EQ.0D0) THEN
40323 C * SDOWN -> NU(BAR) + D and LEPTON- + U
40324 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
40328 C...~d_J -> nu_Ibar + d_K
40330 IDLAM(LKNT,1)=-12 -2*(I-1)
40331 IDLAM(LKNT,2)= 1 +2*(K-1)
40334 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM
40335 IF (IMSS(52).NE.0) XLAM(LKNT) =
40336 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40337 C...KINEMATICS CHECK
40338 IF (XLAM(LKNT).EQ.0D0) THEN
40346 C...~d_K -> nu_I + d_J
40348 IDLAM(LKNT,1)= 12 +2*(I-1)
40349 IDLAM(LKNT,2)= 1 +2*(J-1)
40352 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2 * SM
40353 IF (IMSS(52).NE.0) XLAM(LKNT) =
40354 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40355 C...KINEMATICS CHECK
40356 IF (XLAM(LKNT).EQ.0D0) THEN
40359 C...~d_K -> lepton_I- + u_J
40361 IDLAM(LKNT,1)= 11 +2*(I-1)
40362 IDLAM(LKNT,2)= 2 +2*(J-1)
40365 IF (IMSS(52).NE.0) THEN
40366 C...Use massive top quark
40367 IF (IDLAM(LKNT,2).EQ.6) THEN
40368 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2*(SM-SMT)
40370 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
40371 C...If no top quark, all decay products massless
40373 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2 * SM
40375 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40377 C...KINEMATICS CHECK
40378 IF (XLAM(LKNT).EQ.0D0) THEN
40385 C * SUP -> LEPTON+ + D
40386 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
40390 C...~u_J -> lepton_I+ + d_K
40392 IDLAM(LKNT,1)=-11 -2*(I-1)
40393 IDLAM(LKNT,2)= 1 +2*(K-1)
40396 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM
40397 IF (IMSS(52).NE.0) XLAM(LKNT) =
40398 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
40399 C...KINEMATICS CHECK
40400 IF (XLAM(LKNT).EQ.0D0) THEN
40411 C*********************************************************************
40414 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
40415 C... * Only L-violating decays included at this point.
40417 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
40419 C...Double precision and integer declarations.
40420 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40421 IMPLICIT INTEGER(I-N)
40422 C...Parameter statement to help give large particle numbers.
40423 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
40424 &KEXCIT=4000000,KDIMEN=5000000)
40426 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40427 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40428 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
40429 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
40430 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
40431 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
40432 C...Local parameters
40434 C...Local variables.
40435 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
40436 DOUBLE PRECISION XLAM(0:300),AB,RES,RMS
40437 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), LAMC, RMQ(6)
40438 INTEGER IDLAM(300,3),LKNT,KFIN,PYCOMP,ISM,IDR,IDR2
40442 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
40444 C...LEPTON NUMBER VIOLATING DECAYS
40445 IF (((IMSS(51).GE.1).OR.(IMSS(52).GE.1))) THEN
40447 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
40448 C...WHICH NEUTRALINO ?
40450 IF (KFSM.EQ.23) NCHI=2
40451 IF (KFSM.EQ.25) NCHI=3
40452 IF (KFSM.EQ.35) NCHI=4
40455 IF (SMZ(NCHI).LT.0D0) ISM=-ISM
40457 C...Useful parameters for the calculation of the A and B constants.
40458 WMASS = PMAS(PYCOMP(24),1)
40459 ECHG = 2*SQRT(PARU(103)*PARU(1))
40460 COSB=1/(SQRT(1+RMSS(5)**2))
40461 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
40462 COSW=SQRT(1-PARU(102))
40463 SINW=SQRT(PARU(102))
40464 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
40465 C...Run quark masses to neutralino mass squared (for Higgs-type
40467 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
40469 RMQ(I)=PYMRUN(I,SQMCHI)
40472 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
40474 ZPMIX(I,1)= ZMIX(I,1)*COSW+ZMIX(I,2)*SINW
40475 ZPMIX(I,2)=-ZMIX(I,1)*SINW+ZMIX(I,2)*COSW
40476 ZPMIX(I,3)= ZMIX(I,3)
40477 ZPMIX(I,4)= ZMIX(I,4)
40480 C1=GW*ZMIX(NCHI,3)/(2.*COSB*WMASS)
40481 C1U=GW*ZMIX(NCHI,4)/(2.*SINB*WMASS)
40482 C2=ECHG*ZPMIX(NCHI,1)
40483 C3=GW*ZPMIX(NCHI,2)/COSW
40487 C x=1-2 : Select A or B constant (1:A ; 2:B)
40488 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
40489 C 11-16:e,nu_e,mu,...)
40490 C z=1-2 : Mass eigenstate number
40491 C...CALCULATE COUPLINGS
40493 CMS=PMAS(PYCOMP(I),1)
40494 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) - SFMIX(I,3)
40495 & *(C2-C3*SINW**2))
40496 AB(1,I,2)=ISM*(-CMS*C1*SFMIX(I,2) + SFMIX(I,4)
40497 & *(C2-C3*SINW**2))
40498 AB(2,I,1)= -CMS*C1*SFMIX(I,3) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
40500 AB(2,I,2)=CMS*C1*SFMIX(I,4) + SFMIX(I,2)*(C2+C3*(5D-1 - SINW
40503 AB(2,I+1,1)=5D-1*C3
40508 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) + SFMIX(J,3)
40509 & *ED*(C2-ED*C3*SINW**2))
40510 AB(1,J,2)=ISM*(-CMS*C1*SFMIX(J,2) - SFMIX(J,4)
40511 & *ED*(C2-ED*C3*SINW**2))
40512 AB(2,J,1)=-CMS*C1*SFMIX(J,3) + SFMIX(J,1)
40513 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
40514 AB(2,J,2)=CMS*C1*SFMIX(J,4) - SFMIX(J,2)
40515 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
40518 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) + SFMIX(J,3)
40519 & *EU*(C2-C3*SINW**2))
40520 AB(1,J,2)=ISM*(-CMS*C1U*SFMIX(J,2) - SFMIX(J,4)
40521 & *EU*(C2-C3*SINW**2))
40522 AB(2,J,1)=-CMS*C1U*SFMIX(J,3) + SFMIX(J,1)
40523 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
40524 AB(2,J,2)=CMS*C1U*SFMIX(J,4) - SFMIX(J,2)
40525 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
40528 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
40529 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
40530 C...STEP IN I,J,K USING SINGLE COUNTER
40532 C...LAMBDA COUPLING ASYM IN I,J
40533 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
40535 IDLAM(LKNT,1)=-12 -2*MOD(ISC/9,3)
40536 IDLAM(LKNT,2)=-11 -2*MOD(ISC/3,3)
40537 IDLAM(LKNT,3)= 11 +2*MOD(ISC,3)
40539 IF(IMSS(51).EQ.0) GOTO 130
40540 C...Set coupling, and decay product masses on/off
40541 LAMC=RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40543 C...Resonance KF codes (1=I,2=J,3=K)
40544 KFR(1)=-IDLAM(LKNT,1)
40545 KFR(2)=-IDLAM(LKNT,2)
40546 KFR(3)=-IDLAM(LKNT,3)
40547 C...Calculate width.
40548 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40550 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*32)
40551 C...Charge conjugate mode.
40553 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
40554 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
40555 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
40556 XLAM(LKNT)=XLAM(LKNT-1)
40557 C...KINEMATICS CHECK
40558 IF (XLAM(LKNT).EQ.0D0) THEN
40564 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
40565 C * CHI0 -> NUBAR_I + DBAR_J + D_K
40568 IDLAM(LKNT,1)=-12 -2*MOD(ISC/9,3)
40569 IDLAM(LKNT,2)= -1 -2*MOD(ISC/3,3)
40570 IDLAM(LKNT,3)= 1 +2*MOD(ISC,3)
40572 IF(IMSS(52).EQ.0) GOTO 150
40573 C...Set coupling, and decay product masses on/off
40574 LAMC=3*RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40576 C...Resonance KF codes (1=I,2=J,3=K)
40577 KFR(1)=-IDLAM(LKNT,1)
40578 KFR(2)=-IDLAM(LKNT,2)
40579 KFR(3)=-IDLAM(LKNT,3)
40580 C...Calculate width.
40581 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40583 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*32)
40584 C...Charge conjugate mode.
40586 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
40587 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
40588 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
40589 XLAM(LKNT)=XLAM(LKNT-1)
40590 C...KINEMATICS CHECK
40591 IF (XLAM(LKNT).EQ.0D0) THEN
40595 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
40597 IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3)
40598 IDLAM(LKNT,2)= -2 -2*MOD(ISC/3,3)
40599 IDLAM(LKNT,3)= 1 +2*MOD(ISC,3)
40601 IF(IMSS(52).EQ.0) GOTO 160
40602 C...Set coupling, and decay product masses on/off
40603 LAMC=3*RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40605 IF (IDLAM(LKNT,2).EQ.-6) DCMASS=.TRUE.
40606 C...Resonance KF codes (1=I,2=J,3=K)
40607 KFR(1)=-IDLAM(LKNT,1)
40608 KFR(2)=-IDLAM(LKNT,2)
40609 KFR(3)=-IDLAM(LKNT,3)
40610 C...Calculate width.
40611 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40613 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*32)
40614 C...Charge conjugate mode.
40616 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
40617 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
40618 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
40619 XLAM(LKNT)=XLAM(LKNT-1)
40620 C...KINEMATICS CHECK
40621 IF (XLAM(LKNT).EQ.0D0) THEN
40632 C*********************************************************************
40635 C...Calculates R-violating chargino decay widths.
40636 C... * Only L-violating decays included at this point.
40638 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
40640 C...Double precision and integer declarations.
40641 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40642 IMPLICIT INTEGER(I-N)
40643 C...Parameter statement to help give large particle numbers.
40644 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
40645 &KEXCIT=4000000,KDIMEN=5000000)
40647 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40648 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40649 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
40650 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
40651 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
40652 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
40653 C...Local variables.
40654 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
40655 DOUBLE PRECISION XLAM(0:300),AB, RES, RMS, C1U, C1V, C2, C3
40656 DOUBLE PRECISION LAMC, RMQ(6)
40657 INTEGER IDLAM(300,3),LKNT,KFIN,PYCOMP
40661 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
40663 C...LEPTON NUMBER VIOLATING DECAYS
40664 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
40666 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
40668 C...WHICH CHARGINO ?
40670 IF (KFSM.EQ.37) NCHI = 2
40672 C...Useful parameters for calculating the A and B constants.
40673 IF (SMW(NCHI).LT.0D0) ISM=-1
40674 WMASS = PMAS(PYCOMP(24),1)
40675 COSB = 1/(SQRT(1+RMSS(5)**2))
40676 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
40677 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
40678 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
40679 C...Running masses at Q^2=MCHI^2.
40681 RMQ(I)=PYMRUN(I,SQMCHI)
40684 C...Signs chosen to agree with U & V convention used in hep-ph/9912407.
40685 C1U = -UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
40686 C1V = -VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
40690 C x=1-2 : A or B coefficient (1:A ; 2:B)
40691 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
40692 C 11-16:e,nu_e,mu,...)
40693 C z=1-2 : Mass eigenstate number
40697 AB(2,I,1) = PMAS(PYCOMP(I),1)*C1U*SFMIX(I,3) +
40699 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) -
40701 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
40703 AB(2,I+1,1) = ISM*C3
40706 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
40707 AB(1,J,2) = RMQ(J+1)*C1V*SFMIX(J,2)
40708 AB(2,J,1) = ISM*(RMQ(J)*C1U*SFMIX(J,3) + SFMIX(J,1)*C2)
40709 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) + SFMIX(J,2)*C2)
40711 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
40712 AB(1,J,2) = RMQ(J-1)*C1U*SFMIX(J,2)
40713 AB(2,J,1) = ISM*(RMQ(J)*C1V*SFMIX(J,3) - SFMIX(J,1)*C3)
40714 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) + SFMIX(J,2)*C3)
40717 C...LOOP OVER DECAY MODES
40720 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
40721 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
40723 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
40724 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
40725 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
40727 IF(IMSS(51).EQ.0) GOTO 120
40728 C...Set coupling, and decay product masses on/off
40730 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40732 C...Resonance KF codes (1=I,2=J,3=K).
40735 KFR(3) = -IDLAM(LKNT,3)+1
40736 C...Calculate width.
40737 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40739 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40740 C...KINEMATICS CHECK
40741 IF (XLAM(LKNT).EQ.0D0) THEN
40745 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
40746 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
40748 IDLAM(LKNT,1)= 12 +2*MOD(ISC/9,3)
40749 IDLAM(LKNT,2)= 12 +2*MOD(ISC/3,3)
40750 IDLAM(LKNT,3)=-11 -2*MOD(ISC,3)
40752 IF(IMSS(51).EQ.0) GOTO 130
40753 C...Set coupling, and decay product masses on/off
40755 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40756 C...I,J SYMMETRY => FACTOR 2
40759 C...Resonance KF codes (1=I,2=J,3=K)
40760 KFR(1)=IDLAM(LKNT,1)-1
40761 KFR(2)=IDLAM(LKNT,2)-1
40763 C...Calculate width.
40764 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
40765 & IDLAM(LKNT,3),XLAM(LKNT))
40766 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40767 C...KINEMATICS CHECK
40768 IF (XLAM(LKNT).EQ.0D0) THEN
40773 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
40775 IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3)
40776 IDLAM(LKNT,2)=-11 -2*MOD(ISC/3,3)
40777 IDLAM(LKNT,3)= 11 +2*MOD(ISC,3)
40779 IF(IMSS(51).EQ.0) GOTO 140
40780 C...Set coupling, and decay product masses on/off
40782 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40783 C...I,J SYMMETRY => FACTOR 2
40786 C...Resonance KF codes (1=I,2=J,3=K)
40787 KFR(1)=-IDLAM(LKNT,1)+1
40788 KFR(2)=-IDLAM(LKNT,2)+1
40790 C...Calculate width.
40791 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40793 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40794 C...KINEMATICS CHECK
40795 IF (XLAM(LKNT).EQ.0D0) THEN
40801 C...LQD TYPE R-VIOLATION
40802 C...LOOP OVER DECAY MODES
40805 C...CHI+ -> NUBAR_I + DBAR_J + U_K
40807 IDLAM(LKNT,1)=-12 -2*MOD(ISC/9,3)
40808 IDLAM(LKNT,2)= -1 -2*MOD(ISC/3,3)
40809 IDLAM(LKNT,3)= 2 +2*MOD(ISC,3)
40811 IF(IMSS(52).EQ.0) GOTO 150
40812 C...Set coupling, and decay product masses on/off
40814 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40816 IF (IDLAM(LKNT,3).EQ.6) DCMASS=.TRUE.
40817 C...Resonance KF codes (1=I,2=J,3=K)
40820 KFR(3)=-IDLAM(LKNT,3)+1
40821 C...Calculate width.
40822 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40824 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40825 C...KINEMATICS CHECK
40826 IF (XLAM(LKNT).EQ.0D0) THEN
40830 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
40832 IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3)
40833 IDLAM(LKNT,2)= -2 -2*MOD(ISC/3,3)
40834 IDLAM(LKNT,3)= 2 +2*MOD(ISC,3)
40836 IF(IMSS(52).EQ.0) GOTO 160
40837 C...Set coupling, and decay product masses on/off
40839 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40841 IF (-IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.6) DCMASS=.TRUE.
40842 C...Resonance KF codes (1=I,2=J,3=K)
40845 KFR(3)=-IDLAM(LKNT,3)+1
40846 C...Calculate width.
40847 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40849 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40850 C...KINEMATICS CHECK
40851 IF (XLAM(LKNT).EQ.0D0) THEN
40855 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
40857 IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3)
40858 IDLAM(LKNT,2)= -1 -2*MOD(ISC/3,3)
40859 IDLAM(LKNT,3)= 1 +2*MOD(ISC,3)
40861 IF(IMSS(52).EQ.0) GOTO 170
40862 C...Set coupling, and decay product masses on/off
40864 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40866 C...Resonance KF codes (1=I,2=J,3=K)
40867 KFR(1)=-IDLAM(LKNT,1)+1
40868 KFR(2)=-IDLAM(LKNT,2)+1
40870 C...Calculate width.
40871 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40873 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40874 C...KINEMATICS CHECK
40875 IF (XLAM(LKNT).EQ.0D0) THEN
40879 C * CHI+ -> NU_I + U_J + DBAR_K.
40881 IDLAM(LKNT,1)= 12 +2*MOD(ISC/9,3)
40882 IDLAM(LKNT,2)= 2 +2*MOD(ISC/3,3)
40883 IDLAM(LKNT,3)= -1 -2*MOD(ISC,3)
40885 IF(IMSS(52).EQ.0) GOTO 180
40886 C...Set coupling, and decay product masses on/off
40889 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
40890 IF (IDLAM(LKNT,2).EQ.6) DCMASS=.TRUE.
40891 C...Resonance KF codes (1=I,2=J,3=K)
40892 KFR(1)=-IDLAM(LKNT,1)+1
40893 KFR(2)=-IDLAM(LKNT,2)+1
40895 C...Calculate width.
40896 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
40898 XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64)
40899 C...KINEMATICS CHECK
40900 IF (XLAM(LKNT).EQ.0D0) THEN
40911 C*********************************************************************
40914 C...Auxiliary function to PYRVSF for calculating R-Violating
40915 C...sfermion widths. Though the decay products are most often treated
40916 C...as massless in the calculation, the kinematical boundary of phase
40917 C...space is tested using the true masses.
40918 C...MODE = 1: All decay products massive
40919 C...MODE = 2: Decay product 1 massless
40920 C...MODE = 3: Decay product 2 massless
40921 C...MODE = 4: All decay products massless
40923 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
40925 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40926 IMPLICIT INTEGER (I-N)
40927 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40928 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40929 SAVE /PYDAT1/,/PYDAT2/
40930 DOUBLE PRECISION SM(3), PYRVSB, RM2
40932 INTEGER KFIN, ID1,ID2, PYCOMP, KC(3), MODE
40936 SM(1)=PMAS(KC(1),1)**2
40937 SM(2)=PMAS(KC(2),1)**2
40938 SM(3)=PMAS(KC(3),1)**2
40939 C...Kinematics check
40940 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
40944 C...CM momenta squared
40945 IF (MODE.EQ.1) THEN
40946 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
40947 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
40948 ELSE IF (MODE.EQ.2) THEN
40949 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
40950 ELSE IF (MODE.EQ.3) THEN
40951 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
40955 C...Calculate Width
40956 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
40961 C*********************************************************************
40964 C...Main routine for R-Violating neutralino/chargino 3-body widths.
40966 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
40968 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40969 IMPLICIT INTEGER (I-N)
40970 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
40971 &KEXCIT=4000000,KDIMEN=5000000)
40972 PARAMETER (EPS=1D-2)
40973 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40974 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
40975 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
40976 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
40977 DOUBLE PRECISION RMS, XLIM(3,3), RES, XLAM, XLAM0, PREF
40978 INTEGER INTC, KC(0:3), KFIN,ID1,ID2,ID3,KFR,PYCOMP
40980 LOGICAL DCMASS, DCHECK(6)
40981 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
40988 RMS(INTC)=PMAS(KC(INTC),1)
40991 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
40992 XLIM(1,1)=(RMS(1)+RMS(2))**2
40993 XLIM(1,2)=(RMS(0)-RMS(3))**2
40994 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
40995 XLIM(2,1)=(RMS(2)+RMS(3))**2
40996 XLIM(2,2)=(RMS(0)-RMS(1))**2
40997 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
40998 XLIM(3,1)=(RMS(1)+RMS(3))**2
40999 XLIM(3,2)=(RMS(0)-RMS(2))**2
41000 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
41001 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
41005 C...INITIALIZE RESONANCE INFORMATION
41008 IRES=2*(JRES-1)+IMASS
41010 DCHECK(IRES)=.FALSE.
41011 C...NO RIGHT-HANDED NEUTRINOS
41012 IF((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR.(IABS(KFR(JRES
41013 & )).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))) GOTO 110
41014 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
41015 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
41016 RES(IRES,3) = IABS(KFR(JRES))
41017 RES(IRES,4) = IMASS
41018 IF (KFR(JRES).LT.0) RES(IRES,5) = 1D0
41019 IF (KFR(JRES).GT.0) RES(IRES,5) = 0D0
41023 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
41025 C...RESONANCE CONTRIBUTIONS
41026 C...(Only sum contributions where the resonance is off shell).
41027 C...LOOP OVER MASS STATES
41030 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
41031 & +RMS(3)))).AND.ABS(SFMIX(NINT(RES(IDR,3)),J)).GT.EPS
41032 & .AND.RES(IDR,1).NE.0D0) THEN
41033 DCHECK(IDR) =.TRUE.
41034 XLAM = XLAM + SFMIX(NINT(RES(IDR,3)),J)**2 * PYRVI1(2,3,1)
41038 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
41039 & +RMS(3)))).AND.ABS(SFMIX(NINT(RES(IDR,3)),J)).GT.EPS
41040 & .AND.RES(IDR,1).NE.0D0) THEN
41041 DCHECK(IDR) =.TRUE.
41042 XLAM = XLAM + SFMIX(NINT(RES(IDR,3)),J)**2 * PYRVI1(1,3,2)
41046 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
41047 & +RMS(2)))).AND.ABS(SFMIX(NINT(RES(IDR,3)),2+J)).GT.EPS
41048 & .AND.RES(IDR,1).NE.0D0) THEN
41049 DCHECK(IDR) =.TRUE.
41050 XLAM = XLAM + SFMIX(NINT(RES(IDR,3)),2+J)**2 * PYRVI1(1,2,3)
41054 C... L-R INTERFERENCES
41055 C... (Only add contributions where both contributing diagrams
41056 C... are non-resonant).
41058 IF (DCHECK(1).AND.DCHECK(2)) THEN
41059 XLAM = XLAM + PYRVI2(2,1,3)
41060 & * SFMIX(NINT(RES(1,3)),1+2*NINT(RES(1,5)))
41061 & * SFMIX(NINT(RES(2,3)),2+2*NINT(RES(2,5)))
41065 IF (DCHECK(3).AND.DCHECK(4)) THEN
41066 XLAM = XLAM + PYRVI2(1,3,2)
41067 & * SFMIX(NINT(RES(3,3)),1+2*NINT(RES(3,5)))
41068 & * SFMIX(NINT(RES(4,3)),2+2*NINT(RES(4,5)))
41072 IF (DCHECK(5).AND.DCHECK(6)) THEN
41073 XLAM = XLAM + PYRVI2(1,2,3)
41074 & * SFMIX(NINT(RES(5,3)),1+2*NINT(RES(5,5)))
41075 & * SFMIX(NINT(RES(6,3)),2+2*NINT(RES(6,5)))
41078 C... TRUE INTERFERENCES
41079 C... (Only add contributions where both contributing diagrams
41080 C... are non-resonant).
41082 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2.
41087 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
41088 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
41089 & SFMIX(NINT(RES(IDR,3)),IKR1)*SFMIX(NINT(RES(IDR2,3)),IKR2)
41094 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
41095 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
41096 & SFMIX(NINT(RES(IDR,3)),2+IKR1)*SFMIX(NINT(RES(IDR2,3)),IKR2)
41101 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
41102 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
41103 & SFMIX(NINT(RES(IDR,3)),2+IKR1)*SFMIX(NINT(RES(IDR2,3)),IKR2)
41110 C*********************************************************************
41113 C...Function to integrate resonance contributions
41115 FUNCTION PYRVI1(ID1,ID2,ID3)
41118 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
41119 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
41120 INTEGER ID1,ID2,ID3, IANTI, IDR, IDR2, KFR
41121 LOGICAL MFLAG,DCMASS
41122 EXTERNAL PYRVG1,PYGAUS
41123 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
41124 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41125 SAVE/PYRVNV/,/PYRVPM/
41126 C...Initialize mass and width information
41134 C...A->B and B->A for antisparticles
41135 IANTI=NINT(RES(IDR,5))
41136 A(1)=AB(1+IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41137 B(1)=AB(2-IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41138 C...Integration boundaries and mass flag
41139 LO=(RM(1)+RM(2))**2
41140 HI=(RM(0)-RM(3))**2
41142 PYRVI1=PYGAUS(PYRVG1,LO,HI,1D-2)
41146 C*********************************************************************
41149 C...Function to integrate L-R interference contributions
41151 FUNCTION PYRVI2(ID1,ID2,ID3)
41154 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
41155 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
41156 INTEGER ID1,ID2,ID3, IANTI, IDR, IDR2, KFR
41157 LOGICAL MFLAG,DCMASS
41158 EXTERNAL PYRVG2,PYGAUS
41159 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
41160 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41161 SAVE/PYRVNV/,/PYRVPM/
41162 C...Initialize mass and width information
41170 RESM(2)=RES(IDR+1,1)
41171 RESW(2)=RES(IDR+1,2)
41172 C...A->B and B->A for antisparticles
41173 IANTI=NINT(RES(IDR,5))
41174 A(1)=AB(1+IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41175 B(1)=AB(2-IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41176 A(2)=AB(1+IANTI,NINT(RES(IDR+1,3)),NINT(RES(IDR+1,4)))
41177 B(2)=AB(2-IANTI,NINT(RES(IDR+1,3)),NINT(RES(IDR+1,4)))
41178 C...Boundaries and mass flag
41179 LO=(RM(1)+RM(2))**2
41180 HI=(RM(0)-RM(3))**2
41182 PYRVI2=PYGAUS(PYRVG2,LO,HI,1D-2)
41186 C*********************************************************************
41189 C...Function to integrate true interference contributions
41191 FUNCTION PYRVI3(ID1,ID2,ID3)
41194 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
41195 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
41196 INTEGER ID1,ID2,ID3, IANTI, IDR, IDR2, KFR
41197 LOGICAL MFLAG,DCMASS
41198 EXTERNAL PYRVG3,PYGAUS
41199 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3)
41200 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41201 SAVE/PYRVNV/,/PYRVPM/
41202 C...Initialize mass and width information
41210 RESM(2)=RES(IDR2,1)
41211 RESW(2)=RES(IDR2,2)
41212 C...A -> B and B -> A for antisparticles
41213 IANTI=NINT(RES(IDR,5))
41214 A(1)=AB(1+IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41215 B(1)=AB(2-IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4)))
41216 IANTI=NINT(RES(IDR2,5))
41217 A(2)=AB(1+IANTI,NINT(RES(IDR2,3)),NINT(RES(IDR2,4)))
41218 B(2)=AB(2-IANTI,NINT(RES(IDR2,3)),NINT(RES(IDR2,4)))
41219 C...Boundaries and mass flag
41220 LO=(RM(1)+RM(2))**2
41221 HI=(RM(0)-RM(3))**2
41223 PYRVI3=PYGAUS(PYRVG3,LO,HI,1D-2)
41227 C*********************************************************************
41230 C...Integrand for resonance contributions
41235 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41236 DOUBLE PRECISION X, RM, A, B, RESM, RESW, YMIN, YMAX, DELTAY,PYRVR
41237 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SQ1,SR1,SR2,A1,A2
41240 RVR=PYRVR(X,RESM(1),RESW(1))
41241 C1=2D0*SQRT(MAX(0D0,X))
41242 IF (.NOT.MFLAG) THEN
41246 PYRVG1=DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
41248 E2=(X-RM(1)**2+RM(2)**2)/C1
41249 E3=(RM(0)**2-X-RM(3)**2)/C1
41251 SR1=SQRT(MAX(0D0,E2**2-RM(2)**2))
41252 SR2=SQRT(MAX(0D0,E3**2-RM(3)**2))
41253 YMIN=SQ1-(SR1+SR2)**2
41254 YMAX=SQ1-(SR1-SR2)**2
41256 A1=4*A(1)*B(1)*RM(3)*RM(0)
41257 A2=(A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
41258 PYRVG1=DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
41263 C*********************************************************************
41266 C...Integrand for L-R interference contributions
41271 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41272 DOUBLE PRECISION X, RM, A, B, RESM, RESW, YMIN, YMAX, DELTAY,PYRVS
41273 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SQ1,SR1,SR2
41276 C1=2D0*SQRT(MAX(0D0,X))
41277 RVS=PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
41278 IF (.NOT.MFLAG) THEN
41282 PYRVG2=DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
41284 E2=(X-RM(1)**2+RM(2)**2)/C1
41285 E3=(RM(0)**2-X-RM(3)**2)/C1
41287 SR1=SQRT(MAX(0D0,E2**2-RM(2)**2))
41288 SR2=SQRT(MAX(0D0,E3**2-RM(3)**2))
41289 YMIN=SQ1-(SR1+SR2)**2
41290 YMAX=SQ1-(SR1-SR2)**2
41292 PYRVG2=DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
41293 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
41294 & + 2*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
41299 C*********************************************************************
41302 C...Function to do Y integration over true interference contributions
41307 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41308 C...Second Dalitz variable for PYRVG4
41310 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
41311 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
41312 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAUS
41314 EXTERNAL PYGAUS,PYRVG4
41315 SAVE/PYRVPM/,/PYG2DX/
41316 C1=2D0*SQRT(MAX(0D0,X))
41318 IF (.NOT.MFLAG) THEN
41324 E2=(X-RM(1)**2+RM(2)**2)/C1
41325 E3=(RM(0)**2-X-RM(3)**2)/C1
41327 SR1=SQRT(MAX(0D0,E2**2-RM(2)**2))
41328 SR2=SQRT(MAX(0D0,E3**2-RM(3)**2))
41329 YMIN=SQ1-(SR1+SR2)**2
41330 YMAX=SQ1-(SR1-SR2)**2
41332 PYRVG3=PYGAUS(PYRVG4,YMIN,YMAX,1D-2)
41336 C*********************************************************************
41339 C...Integrand for true intereference contributions
41344 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
41346 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
41348 SAVE /PYRVPM/,/PYG2DX/
41350 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
41351 IF (.NOT.MFLAG) THEN
41352 PYRVG4=RVS*B(1)*B(2)*X*Y
41354 PYRVG4=RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
41355 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
41356 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
41357 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
41362 C*********************************************************************
41365 C...Breit-Wigner for resonance contributions
41367 FUNCTION PYRVR(Mab2,RM,RW)
41370 DOUBLE PRECISION Mab2,RM,RW,PYRVR
41371 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
41375 C*********************************************************************
41378 C...Interference function
41380 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
41383 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
41384 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
41389 C*********************************************************************
41392 C...Stores one parton/particle in commonblock PYJETS.
41394 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
41396 C...Double precision and integer declarations.
41397 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41398 IMPLICIT INTEGER(I-N)
41399 INTEGER PYK,PYCHGE,PYCOMP
41401 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41402 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41403 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41404 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41406 C...Standard checks.
41408 IF(MSTU(12).GE.1) CALL PYLIST(0)
41409 IPA=MAX(1,IABS(IP))
41410 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
41411 &'(PY1ENT:) writing outside PYJETS memory')
41413 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
41415 C...Find mass. Reset K, P and V vectors.
41417 IF(MSTU(10).EQ.1) PM=P(IPA,5)
41418 IF(MSTU(10).GE.2) PM=PYMASS(KF)
41425 C...Store parton/particle in K and P vectors.
41427 IF(IP.LT.0) K(IPA,1)=2
41430 P(IPA,4)=MAX(PE,PM)
41431 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
41432 P(IPA,1)=PA*SIN(THE)*COS(PHI)
41433 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
41434 P(IPA,3)=PA*COS(THE)
41436 C...Set N. Optionally fragment/decay.
41438 IF(IP.EQ.0) CALL PYEXEC
41443 C*********************************************************************
41446 C...Stores two partons/particles in their CM frame,
41447 C...with the first along the +z axis.
41449 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
41451 C...Double precision and integer declarations.
41452 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41453 IMPLICIT INTEGER(I-N)
41454 INTEGER PYK,PYCHGE,PYCOMP
41456 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41457 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41458 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41459 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41461 C...Standard checks.
41463 IF(MSTU(12).GE.1) CALL PYLIST(0)
41464 IPA=MAX(1,IABS(IP))
41465 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
41466 &'(PY2ENT:) writing outside PYJETS memory')
41469 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
41470 &'(PY2ENT:) unknown flavour code')
41472 C...Find masses. Reset K, P and V vectors.
41474 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
41475 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
41477 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
41478 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
41487 C...Check flavours.
41488 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
41489 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
41490 IF(MSTU(19).EQ.1) THEN
41493 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
41494 & '(PY2ENT:) unphysical flavour combination')
41499 C...Store partons/particles in K vectors for normal case.
41502 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
41505 C...Store partons in K vectors for parton shower evolution.
41509 K(IPA,4)=MSTU(5)*(IPA+1)
41511 K(IPA+1,4)=MSTU(5)*IPA
41512 K(IPA+1,5)=K(IPA+1,4)
41515 C...Check kinematics and store partons/particles in P vectors.
41516 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
41517 &'(PY2ENT:) energy smaller than sum of masses')
41518 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
41521 P(IPA,4)=SQRT(PM1**2+PA**2)
41524 P(IPA+1,4)=SQRT(PM2**2+PA**2)
41527 C...Set N. Optionally fragment/decay.
41529 IF(IP.EQ.0) CALL PYEXEC
41534 C*********************************************************************
41537 C...Stores three partons or particles in their CM frame,
41538 C...with the first along the +z axis and the third in the (x,z)
41539 C...plane with x > 0.
41541 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
41543 C...Double precision and integer declarations.
41544 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41545 IMPLICIT INTEGER(I-N)
41546 INTEGER PYK,PYCHGE,PYCOMP
41548 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41549 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41550 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41551 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41553 C...Standard checks.
41555 IF(MSTU(12).GE.1) CALL PYLIST(0)
41556 IPA=MAX(1,IABS(IP))
41557 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
41558 &'(PY3ENT:) writing outside PYJETS memory')
41562 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
41563 &'(PY3ENT:) unknown flavour code')
41565 C...Find masses. Reset K, P and V vectors.
41567 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
41568 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
41570 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
41571 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
41573 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
41574 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
41583 C...Check flavours.
41584 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
41585 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
41586 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
41587 IF(MSTU(19).EQ.1) THEN
41589 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
41590 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
41591 & KQ1+KQ3.EQ.4)) THEN
41593 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
41599 C...Store partons/particles in K vectors for normal case.
41602 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
41604 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
41607 C...Store partons in K vectors for parton shower evolution.
41613 IF(KQ1.EQ.-1) KCS=5
41614 K(IPA,KCS)=MSTU(5)*(IPA+1)
41615 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
41616 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
41617 K(IPA+1,9-KCS)=MSTU(5)*IPA
41618 K(IPA+2,KCS)=MSTU(5)*IPA
41619 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
41622 C...Check kinematics.
41624 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
41625 &0.5D0*X3*PECM.LE.PM3) MKERR=1
41626 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
41627 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
41628 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
41629 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
41630 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
41631 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
41632 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
41633 IF(MKERR.NE.0) CALL PYERRM(13,
41634 &'(PY3ENT:) unphysical kinematical variable setup')
41636 C...Store partons/particles in P vectors.
41638 P(IPA,4)=SQRT(PA1**2+PM1**2)
41640 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
41641 P(IPA+2,3)=PA3*CTHE3
41642 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
41644 P(IPA+1,1)=-P(IPA+2,1)
41645 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
41646 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
41649 C...Set N. Optionally fragment/decay.
41651 IF(IP.EQ.0) CALL PYEXEC
41656 C*********************************************************************
41659 C...Stores four partons or particles in their CM frame, with
41660 C...the first along the +z axis, the last in the xz plane with x > 0
41661 C...and the second having y < 0 and y > 0 with equal probability.
41663 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
41665 C...Double precision and integer declarations.
41666 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41667 IMPLICIT INTEGER(I-N)
41668 INTEGER PYK,PYCHGE,PYCOMP
41670 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41671 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41672 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41673 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41675 C...Standard checks.
41677 IF(MSTU(12).GE.1) CALL PYLIST(0)
41678 IPA=MAX(1,IABS(IP))
41679 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
41680 &'(PY4ENT:) writing outside PYJETS momory')
41685 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
41686 &'(PY4ENT:) unknown flavour code')
41688 C...Find masses. Reset K, P and V vectors.
41690 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
41691 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
41693 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
41694 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
41696 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
41697 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
41699 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
41700 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
41709 C...Check flavours.
41710 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
41711 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
41712 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
41713 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
41714 IF(MSTU(19).EQ.1) THEN
41716 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
41717 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
41718 & KQ1+KQ4.EQ.4)) THEN
41719 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
41722 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
41729 C...Store partons/particles in K vectors for normal case.
41732 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
41734 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
41737 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
41740 C...Store partons for parton shower evolution from q-g-g-qbar or
41742 ELSEIF(KQ1+KQ2.NE.0) THEN
41748 IF(KQ1.EQ.-1) KCS=5
41749 K(IPA,KCS)=MSTU(5)*(IPA+1)
41750 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
41751 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
41752 K(IPA+1,9-KCS)=MSTU(5)*IPA
41753 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
41754 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
41755 K(IPA+3,KCS)=MSTU(5)*IPA
41756 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
41758 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
41764 K(IPA,4)=MSTU(5)*(IPA+1)
41766 K(IPA+1,4)=MSTU(5)*IPA
41767 K(IPA+1,5)=K(IPA+1,4)
41768 K(IPA+2,4)=MSTU(5)*(IPA+3)
41769 K(IPA+2,5)=K(IPA+2,4)
41770 K(IPA+3,4)=MSTU(5)*(IPA+2)
41771 K(IPA+3,5)=K(IPA+3,4)
41774 C...Check kinematics.
41776 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
41777 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
41779 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
41780 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
41781 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
41782 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
41783 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
41784 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
41785 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
41786 STHE4=SQRT(1D0-CTHE4**2)
41787 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
41788 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
41789 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
41790 STHE2=SQRT(1D0-CTHE2**2)
41791 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
41792 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
41793 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
41794 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
41795 IF(MKERR.EQ.1) CALL PYERRM(13,
41796 &'(PY4ENT:) unphysical kinematical variable setup')
41798 C...Store partons/particles in P vectors.
41800 P(IPA,4)=SQRT(PA1**2+PM1**2)
41802 P(IPA+3,1)=PA4*STHE4
41803 P(IPA+3,3)=PA4*CTHE4
41804 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
41806 P(IPA+1,1)=PA2*STHE2*CPHI2
41807 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
41808 P(IPA+1,3)=PA2*CTHE2
41809 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
41811 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
41812 P(IPA+2,2)=-P(IPA+1,2)
41813 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
41814 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
41817 C...Set N. Optionally fragment/decay.
41819 IF(IP.EQ.0) CALL PYEXEC
41824 C*********************************************************************
41827 C...An interface from a two-fermion generator to include
41828 C...parton showers and hadronization.
41830 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
41832 C...Double precision and integer declarations.
41833 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41834 IMPLICIT INTEGER(I-N)
41835 INTEGER PYK,PYCHGE,PYCOMP
41837 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41838 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41839 SAVE /PYJETS/,/PYDAT1/
41841 DIMENSION IJOIN(2),INTAU(2)
41843 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
41849 C...Loop through entries and pick up all final fermions/antifermions.
41853 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
41855 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
41856 IF(K(I,2).GT.0) THEN
41860 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
41866 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
41872 C...Check that event is arranged according to conventions.
41873 IF(I1.EQ.0.OR.I2.EQ.0) THEN
41874 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
41877 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
41880 C...Check whether fermion pair is quarks or leptons.
41881 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
41883 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
41886 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
41889 C...Decide whether to allow or not photon radiation in showers.
41891 IF(IRAD.EQ.0) MSTJ(41)=1
41893 C...Do colour joining and parton showers.
41896 IF(IQL12.EQ.1) THEN
41899 CALL PYJOIN(2,IJOIN)
41901 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
41902 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
41903 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
41904 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
41907 C...Do fragmentation and decays. Possibly except tau decay.
41911 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
41925 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
41933 C*********************************************************************
41936 C...An interface from a four-fermion generator to include
41937 C...parton showers and hadronization.
41939 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
41941 C...Double precision and integer declarations.
41942 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41943 IMPLICIT INTEGER(I-N)
41944 INTEGER PYK,PYCHGE,PYCOMP
41946 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41947 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41948 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41949 COMMON/PYINT1/MINT(400),VINT(400)
41950 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
41952 DIMENSION IJOIN(2),INTAU(4)
41954 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
41960 C...Loop through entries and pick up all final fermions/antifermions.
41966 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
41968 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
41969 IF(K(I,2).GT.0) THEN
41972 ELSEIF(I3.EQ.0) THEN
41975 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
41980 ELSEIF(I4.EQ.0) THEN
41983 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
41989 C...Check that event is arranged according to conventions.
41990 IF(I3.EQ.0.OR.I4.EQ.0) THEN
41991 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
41993 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
41994 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
41997 C...Check which fermion pairs are quarks and which leptons.
41998 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
42000 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
42003 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
42005 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
42007 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
42010 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
42013 C...Decide whether to allow or not photon radiation in showers.
42015 IF(IRAD.EQ.0) MSTJ(41)=1
42017 C...Decide on dipole pairing.
42022 IF(IQL12.EQ.IQL34) THEN
42025 DELTA=ATOTSQ-A1SQ-A2SQ
42026 IF(ISTRAT.EQ.1) THEN
42027 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
42028 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
42029 ELSEIF(ISTRAT.EQ.2) THEN
42030 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
42031 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
42033 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
42039 C...If colour reconnection then bookkeep W+W- or Z0Z0
42040 C...and copy q qbar q qbar consecutively.
42041 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
42050 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
42054 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
42068 P(N+1,J)=P(IP1,J)+P(IP2,J)
42069 P(N+2,J)=P(IP3,J)+P(IP4,J)
42081 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42083 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
42089 C...Remove original q qbar q qbar and update counters.
42090 K(IP1,1)=K(IP1,1)+10
42091 K(IP2,1)=K(IP2,1)+10
42092 K(IP3,1)=K(IP3,1)+10
42093 K(IP4,1)=K(IP4,1)+10
42104 C...Do colour joinings and parton showers.
42105 IF(IQL12.EQ.1) THEN
42108 CALL PYJOIN(2,IJOIN)
42110 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
42111 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
42112 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
42113 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
42116 IF(IQL34.EQ.1) THEN
42119 CALL PYJOIN(2,IJOIN)
42121 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
42122 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
42123 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
42124 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
42127 C...Optionally do colour reconnection.
42130 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
42131 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
42135 C...Do fragmentation and decays. Possibly except tau decay.
42139 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
42153 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
42161 C*********************************************************************
42164 C...An interface from a six-fermion generator to include
42165 C...parton showers and hadronization.
42167 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
42169 C...Double precision and integer declarations.
42170 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42171 IMPLICIT INTEGER(I-N)
42172 INTEGER PYK,PYCHGE,PYCOMP
42174 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42175 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42176 SAVE /PYJETS/,/PYDAT1/
42178 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
42180 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
42186 C...Loop through entries and pick up all final fermions/antifermions.
42194 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
42196 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
42197 IF(K(I,2).GT.0) THEN
42200 ELSEIF(I3.EQ.0) THEN
42202 ELSEIF(I5.EQ.0) THEN
42205 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
42210 ELSEIF(I4.EQ.0) THEN
42212 ELSEIF(I6.EQ.0) THEN
42215 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
42221 C...Check that event is arranged according to conventions.
42222 IF(I5.EQ.0.OR.I6.EQ.0) THEN
42223 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
42225 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
42226 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
42229 C...Check which fermion pairs are quarks and which leptons.
42230 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
42232 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
42235 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
42237 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
42239 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
42242 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
42244 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
42246 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
42249 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
42252 C...Decide whether to allow or not photon radiation in showers.
42254 IF(IRAD.EQ.0) MSTJ(41)=1
42256 C...Allow dipole pairings only among leptons and quarks separately.
42259 IF(IQL34.EQ.IQL56) P13D=P13
42261 IF(IQL12.EQ.IQL34) P21D=P21
42263 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
42265 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
42267 IF(IQL12.EQ.IQL56) P32D=P32
42269 C...Decide whether t+tbar.
42271 IF(PYR(0).LT.PTOP) THEN
42274 C...If t+tbar: reconstruct t's.
42280 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
42281 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
42289 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
42291 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
42295 C...If t+tbar: colour join t's and let them shower.
42298 CALL PYJOIN(2,IJOIN)
42299 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
42300 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
42301 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
42303 C...If t+tbar: pick up the t's after shower.
42307 IF(K(I,2).EQ.6) ITNEW=I
42308 IF(K(I,2).EQ.-6) ITBNEW=I
42311 C...If t+tbar: loop over two top systems.
42326 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
42327 & '(PY6FRM:) not b in t decay')
42329 C...If t+tbar: find boost from original to new top frame.
42331 BETAO(J)=P(ITO,J)/P(ITO,4)
42332 BETAN(J)=P(ITN,J)/P(ITN,4)
42335 C...If t+tbar: boost copy of b by t shower and connect it in colour.
42345 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
42346 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
42347 K(IB,4)=MSTU(5)*ITN
42348 K(IB,5)=MSTU(5)*ITN
42349 K(ITN,4)=K(ITN,4)+IB
42350 K(ITN,5)=K(ITN,5)+IB
42351 K(ITN,1)=K(ITN,1)+10
42352 K(IBO,1)=K(IBO,1)+10
42354 C...If t+tbar: construct W recoiling against b.
42362 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
42363 IF(IABS(KCHW).EQ.3) THEN
42364 K(IW,2)=ISIGN(24,KCHW)
42366 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
42370 C...If t+tbar: construct W momentum, including boost by t shower.
42372 P(IW,J)=P(IW1,J)+P(IW2,J)
42374 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
42376 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
42377 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
42379 C...If t+tbar: boost b and W to top rest frame.
42381 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
42383 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42384 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42386 C...If t+tbar: let b shower and pick up modified W.
42387 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
42388 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
42389 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
42391 IF(IABS(K(I,2)).EQ.24) IWM=I
42394 C...If t+tbar: take copy of W decay products.
42403 K(IW1,1)=K(IW1,1)+10
42404 K(IW2,1)=K(IW2,1)+10
42405 K(IWM,1)=K(IWM,1)+10
42419 C...If t+tbar: boost W decay products, first by effects of t shower,
42420 C...then by those of b shower. b and its shower simple boost back.
42421 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
42422 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
42423 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42424 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
42425 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
42426 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
42427 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
42428 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
42429 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
42433 C...Decide on dipole pairing.
42437 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
42438 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
42442 ELSEIF(PRN.LT.P12D+P13D) THEN
42446 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
42450 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
42454 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
42464 C...Do colour joinings and parton showers
42465 C...(except ones already made for t+tbar).
42467 IF(IQL12.EQ.1) THEN
42470 CALL PYJOIN(2,IJOIN)
42472 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
42473 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
42474 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
42475 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
42478 IF(IQL34.EQ.1) THEN
42481 CALL PYJOIN(2,IJOIN)
42483 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
42484 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
42485 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
42486 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
42488 IF(IQL56.EQ.1) THEN
42491 CALL PYJOIN(2,IJOIN)
42493 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
42494 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
42495 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
42496 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
42499 C...Do fragmentation and decays. Possibly except tau decay.
42503 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
42517 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
42525 C*********************************************************************
42528 C...An interface from a four-parton generator to include
42529 C...parton showers and hadronization.
42531 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
42533 C...Double precision and integer declarations.
42534 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42535 IMPLICIT INTEGER(I-N)
42536 INTEGER PYK,PYCHGE,PYCOMP
42538 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42539 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42540 SAVE /PYJETS/,/PYDAT1/
42542 DIMENSION IJOIN(2),PTOT(4),BETA(3)
42544 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
42550 C...Loop through entries and pick up all final partons.
42556 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
42558 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
42559 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
42562 ELSEIF(I3.EQ.0) THEN
42565 CALL PYERRM(16,'(PY4JET:) more than two quarks')
42567 ELSEIF(K(I,2).LT.0) THEN
42570 ELSEIF(I4.EQ.0) THEN
42573 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
42578 ELSEIF(I4.EQ.0) THEN
42581 CALL PYERRM(16,'(PY4JET:) more than two gluons')
42587 C...Check that event is arranged according to conventions.
42588 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
42589 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
42591 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
42592 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
42595 C...Check whether second pair are quarks or gluons.
42596 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
42598 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
42601 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
42604 C...Boost partons to their cm frame.
42606 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
42608 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
42610 BETA(J)=PTOT(J)/PTOT(4)
42612 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42613 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42614 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42615 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
42618 C...Decide and set up shower history for q qbar q' qbar' events.
42619 IF(IQG34.EQ.1) THEN
42620 W1=PY4JTW(0,I1,I3,I4)
42621 W2=PY4JTW(0,I2,I3,I4)
42622 IF(W1.GT.PYR(0)*(W1+W2)) THEN
42623 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
42625 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
42628 C...Decide and set up shower history for q qbar g g events.
42630 W1=PY4JTW(I1,I3,I2,I4)
42631 W2=PY4JTW(I1,I4,I2,I3)
42632 W3=PY4JTW(0,I3,I1,I4)
42633 W4=PY4JTW(0,I4,I1,I3)
42634 W5=PY4JTW(0,I3,I2,I4)
42635 W6=PY4JTW(0,I4,I2,I3)
42636 W7=PY4JTW(0,I1,I3,I4)
42637 W8=PY4JTW(0,I2,I3,I4)
42638 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
42640 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
42641 ELSEIF(W1+W2.GT.WR) THEN
42642 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
42643 ELSEIF(W1+W2+W3.GT.WR) THEN
42644 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
42645 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
42646 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
42647 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
42648 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
42649 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
42650 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
42651 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
42652 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
42654 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
42658 C...Boost back original partons and mark them as deleted.
42659 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
42660 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
42661 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
42662 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
42668 C...Rotate shower initiating partons to be along z axis.
42669 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
42670 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
42671 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
42672 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
42674 C...Set up copy of shower initiating partons as on mass shell.
42684 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
42695 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
42696 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
42698 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
42700 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
42703 C...Decide whether to allow or not photon radiation in showers.
42704 C...Connect up colours.
42706 IF(IRAD.EQ.0) MSTJ(41)=1
42709 CALL PYJOIN(2,IJOIN)
42711 C...Decide on maximum virtuality and do parton shower.
42712 IF(PMAX.LT.PARJ(82)) THEN
42717 CALL PYSHOW(NSAV+1,-8,PQMAX)
42719 C...Rotate and boost back system.
42720 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
42722 C...Do fragmentation and decays.
42725 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
42734 C*********************************************************************
42737 C...Auxiliary to PY4JET, to evaluate weight of configuration.
42739 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
42741 C...Double precision and integer declarations.
42742 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42743 IMPLICIT INTEGER(I-N)
42744 INTEGER PYK,PYCHGE,PYCOMP
42746 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42749 C...First case: when both original partons radiate.
42750 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
42753 P(N+1,J)=P(IA1,J)+P(IA2,J)
42754 P(N+2,J)=P(IA3,J)+P(IA4,J)
42756 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42758 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
42760 Z1=P(IA1,4)/P(N+1,4)
42761 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
42762 Z2=P(IA3,4)/P(N+2,4)
42763 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
42765 C...Second case: when one original parton radiates to three.
42766 C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
42769 P(N+2,J)=P(IA3,J)+P(IA4,J)
42770 P(N+1,J)=P(N+2,J)+P(IA2,J)
42772 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42774 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
42776 IF(K(IA2,2).EQ.21) THEN
42777 Z1=P(N+2,4)/P(N+1,4)
42778 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
42781 Z1=P(IA2,4)/P(N+1,4)
42782 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
42785 Z2=P(IA3,4)/P(N+2,4)
42786 IF(K(IA2,2).EQ.21) THEN
42787 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
42789 ELSEIF(K(IA3,2).EQ.21) THEN
42790 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
42792 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
42802 C*********************************************************************
42805 C...Auxiliary to PY4JET, to set up chosen configuration.
42807 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
42809 C...Double precision and integer declarations.
42810 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42811 IMPLICIT INTEGER(I-N)
42812 INTEGER PYK,PYCHGE,PYCOMP
42814 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42826 C...First case: when both original partons radiate.
42827 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
42830 C...Set up flavour and history pointers for new partons.
42848 C...Set up momenta for new partons.
42850 P(N+1,J)=P(IA1,J)+P(IA2,J)
42851 P(N+2,J)=P(IA3,J)+P(IA4,J)
42857 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42859 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
42861 QMAX=MIN(P(N+1,5),P(N+2,5))
42863 C...Second case: q radiates twice.
42864 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
42865 C...IA5=N+2 does not radiate.
42866 ELSEIF(K(IA2,2).EQ.21) THEN
42868 C...Set up flavour and history pointers for new partons.
42886 C...Set up momenta for new partons.
42888 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
42890 P(N+3,J)=P(IA3,J)+P(IA4,J)
42895 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42897 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
42901 C...Third case: q radiates g, g branches.
42902 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
42903 C...IA5=N+2 does not radiate.
42906 C...Set up flavour and history pointers for new partons.
42924 C...Set up momenta for new partons.
42926 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
42929 P(N+4,J)=P(IA3,J)+P(IA4,J)
42933 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
42935 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
42945 C*********************************************************************
42948 C...Connects a sequence of partons with colour flow indices,
42949 C...as required for subsequent shower evolution (or other operations).
42951 SUBROUTINE PYJOIN(NJOIN,IJOIN)
42953 C...Double precision and integer declarations.
42954 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42955 IMPLICIT INTEGER(I-N)
42956 INTEGER PYK,PYCHGE,PYCOMP
42958 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42959 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42960 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42961 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
42965 C...Check that partons are of right types to be connected.
42966 IF(NJOIN.LT.2) GOTO 120
42970 IF(I.LE.0.OR.I.GT.N) GOTO 120
42971 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
42973 IF(KC.EQ.0) GOTO 120
42974 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
42975 IF(KQ.EQ.0) GOTO 120
42976 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
42977 IF(KQ.NE.2) KQSUM=KQSUM+KQ
42978 IF(IJN.EQ.1) KQS=KQ
42980 IF(KQSUM.NE.0) GOTO 120
42982 C...Connect the partons sequentially (closing for gluon loop).
42984 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
42988 IF(IJN.NE.1) IP=IJOIN(IJN-1)
42989 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
42990 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
42991 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
42992 K(I,KCS)=MSTU(5)*IN
42993 K(I,9-KCS)=MSTU(5)*IP
42994 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
42995 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
42998 C...Error exit: no action taken.
43000 120 CALL PYERRM(12,
43001 &'(PYJOIN:) given entries can not be joined by one string')
43006 C*********************************************************************
43009 C...Sets values of commonblock variables.
43011 SUBROUTINE PYGIVE(CHIN)
43013 C...Double precision and integer declarations.
43014 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43015 IMPLICIT INTEGER(I-N)
43016 INTEGER PYK,PYCHGE,PYCOMP
43018 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43019 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43020 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43021 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43022 COMMON/PYDAT4/CHAF(500,2)
43024 COMMON/PYDATR/MRPY(6),RRPY(100)
43025 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
43026 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43027 COMMON/PYINT1/MINT(400),VINT(400)
43028 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43029 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
43030 COMMON/PYINT4/MWID(500),WIDS(500,5)
43031 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
43032 COMMON/PYINT6/PROC(0:500)
43034 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
43035 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
43037 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43038 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
43039 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
43040 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
43041 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/
43042 C...Local arrays and character variables.
43043 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
43044 &CHNEW2*28,CHNAM*6,CHVAR(52)*6,CHALP(2)*26,CHIND*8,CHINI*10,
43046 DIMENSION MSVAR(52,8)
43048 C...For each variable to be translated give: name,
43049 C...integer/real/character, no. of indices, lower&upper index bounds.
43050 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
43051 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
43052 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
43053 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
43054 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
43055 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB'/
43056 DATA ((MSVAR(I,J),J=1,8),I=1,52)/ 1,7*0, 1,2,1,4000,1,5,2*0,
43057 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
43058 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
43059 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
43060 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
43061 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
43062 &1,1,1,6,4*0, 2,1,1,100,4*0,
43063 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
43064 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
43065 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
43066 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
43067 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
43068 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
43069 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
43070 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
43071 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
43072 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3/
43073 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
43074 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
43076 C...Length of character variable. Subdivide it into instructions.
43077 IF(MSTU(12).GE.1) CALL PYLIST(0)
43081 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
43084 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
43086 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
43091 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
43093 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
43095 C...Peel off any text following exclamation mark.
43097 DO 140 LLOW2=LHIG2,1,-1
43098 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
43100 IF(LBIT.EQ.0) RETURN
43102 C...Identify commonblock variable.
43105 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
43106 &LNAM.LE.6) GOTO 150
43107 CHNAM=CHBIT(1:LNAM-1)//' '
43108 DO 170 LCOM=1,LNAM-1
43110 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
43111 & CHALP(2)(LALP:LALP)
43116 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
43119 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
43121 IF(LLOW.LT.LTOT) GOTO 120
43125 C...Identify any indices.
43130 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
43133 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
43135 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
43136 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
43137 & IVAR.EQ.37)) THEN
43138 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
43139 READ(CHIND,'(I8)') KF
43141 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
43143 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
43146 IF(LLOW.LT.LTOT) GOTO 120
43149 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
43150 READ(CHIND,'(I8)') I1
43153 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
43156 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
43159 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
43161 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
43162 READ(CHIND,'(I8)') I2
43164 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
43167 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
43170 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
43172 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
43173 READ(CHIND,'(I8)') I3
43178 C...Check that indices allowed.
43180 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
43181 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
43183 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
43185 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
43187 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
43189 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
43192 IF(LLOW.LT.LTOT) GOTO 120
43196 C...Save old value of variable.
43199 ELSEIF(IVAR.EQ.2) THEN
43201 ELSEIF(IVAR.EQ.3) THEN
43203 ELSEIF(IVAR.EQ.4) THEN
43205 ELSEIF(IVAR.EQ.5) THEN
43207 ELSEIF(IVAR.EQ.6) THEN
43209 ELSEIF(IVAR.EQ.7) THEN
43211 ELSEIF(IVAR.EQ.8) THEN
43213 ELSEIF(IVAR.EQ.9) THEN
43215 ELSEIF(IVAR.EQ.10) THEN
43217 ELSEIF(IVAR.EQ.11) THEN
43219 ELSEIF(IVAR.EQ.12) THEN
43221 ELSEIF(IVAR.EQ.13) THEN
43223 ELSEIF(IVAR.EQ.14) THEN
43225 ELSEIF(IVAR.EQ.15) THEN
43227 ELSEIF(IVAR.EQ.16) THEN
43229 ELSEIF(IVAR.EQ.17) THEN
43231 ELSEIF(IVAR.EQ.18) THEN
43233 ELSEIF(IVAR.EQ.19) THEN
43235 ELSEIF(IVAR.EQ.20) THEN
43237 ELSEIF(IVAR.EQ.21) THEN
43239 ELSEIF(IVAR.EQ.22) THEN
43241 ELSEIF(IVAR.EQ.23) THEN
43243 ELSEIF(IVAR.EQ.24) THEN
43245 ELSEIF(IVAR.EQ.25) THEN
43247 ELSEIF(IVAR.EQ.26) THEN
43249 ELSEIF(IVAR.EQ.27) THEN
43251 ELSEIF(IVAR.EQ.28) THEN
43253 ELSEIF(IVAR.EQ.29) THEN
43255 ELSEIF(IVAR.EQ.30) THEN
43257 ELSEIF(IVAR.EQ.31) THEN
43259 ELSEIF(IVAR.EQ.32) THEN
43261 ELSEIF(IVAR.EQ.33) THEN
43262 IOLD=ICOL(I1,I2,I3)
43263 ELSEIF(IVAR.EQ.34) THEN
43265 ELSEIF(IVAR.EQ.35) THEN
43267 ELSEIF(IVAR.EQ.36) THEN
43269 ELSEIF(IVAR.EQ.37) THEN
43271 ELSEIF(IVAR.EQ.38) THEN
43273 ELSEIF(IVAR.EQ.39) THEN
43275 ELSEIF(IVAR.EQ.40) THEN
43277 ELSEIF(IVAR.EQ.41) THEN
43279 ELSEIF(IVAR.EQ.42) THEN
43280 ROLD=SIGT(I1,I2,I3)
43281 ELSEIF(IVAR.EQ.43) THEN
43283 ELSEIF(IVAR.EQ.44) THEN
43285 ELSEIF(IVAR.EQ.45) THEN
43287 ELSEIF(IVAR.EQ.46) THEN
43289 ELSEIF(IVAR.EQ.47) THEN
43291 ELSEIF(IVAR.EQ.48) THEN
43293 ELSEIF(IVAR.EQ.49) THEN
43295 ELSEIF(IVAR.EQ.50) THEN
43296 ROLD=RVLAM(I1,I2,I3)
43297 ELSEIF(IVAR.EQ.51) THEN
43298 ROLD=RVLAMP(I1,I2,I3)
43299 ELSEIF(IVAR.EQ.52) THEN
43300 ROLD=RVLAMB(I1,I2,I3)
43303 C...Print current value of variable. Loop back.
43304 IF(LNAM.GE.LBIT) THEN
43306 CHBIT(15:60)=' has the value '
43307 IF(MSVAR(IVAR,1).EQ.1) THEN
43308 WRITE(CHBIT(51:60),'(I10)') IOLD
43309 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
43310 WRITE(CHBIT(47:60),'(F14.5)') ROLD
43311 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
43316 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
43318 IF(LLOW.LT.LTOT) GOTO 120
43322 C...Read in new variable value.
43323 IF(MSVAR(IVAR,1).EQ.1) THEN
43325 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
43326 READ(CHINI,'(I10)') INEW
43327 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
43329 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
43331 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
43332 CHNEW=CHBIT(LNAM+1:LBIT)//' '
43334 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
43337 C...Store new variable value.
43340 ELSEIF(IVAR.EQ.2) THEN
43342 ELSEIF(IVAR.EQ.3) THEN
43344 ELSEIF(IVAR.EQ.4) THEN
43346 ELSEIF(IVAR.EQ.5) THEN
43348 ELSEIF(IVAR.EQ.6) THEN
43350 ELSEIF(IVAR.EQ.7) THEN
43352 ELSEIF(IVAR.EQ.8) THEN
43354 ELSEIF(IVAR.EQ.9) THEN
43356 ELSEIF(IVAR.EQ.10) THEN
43358 ELSEIF(IVAR.EQ.11) THEN
43360 ELSEIF(IVAR.EQ.12) THEN
43362 ELSEIF(IVAR.EQ.13) THEN
43364 ELSEIF(IVAR.EQ.14) THEN
43366 ELSEIF(IVAR.EQ.15) THEN
43368 ELSEIF(IVAR.EQ.16) THEN
43370 ELSEIF(IVAR.EQ.17) THEN
43372 ELSEIF(IVAR.EQ.18) THEN
43374 ELSEIF(IVAR.EQ.19) THEN
43376 ELSEIF(IVAR.EQ.20) THEN
43378 ELSEIF(IVAR.EQ.21) THEN
43380 ELSEIF(IVAR.EQ.22) THEN
43382 ELSEIF(IVAR.EQ.23) THEN
43384 ELSEIF(IVAR.EQ.24) THEN
43386 ELSEIF(IVAR.EQ.25) THEN
43388 ELSEIF(IVAR.EQ.26) THEN
43390 ELSEIF(IVAR.EQ.27) THEN
43392 ELSEIF(IVAR.EQ.28) THEN
43394 ELSEIF(IVAR.EQ.29) THEN
43396 ELSEIF(IVAR.EQ.30) THEN
43398 ELSEIF(IVAR.EQ.31) THEN
43400 ELSEIF(IVAR.EQ.32) THEN
43402 ELSEIF(IVAR.EQ.33) THEN
43403 ICOL(I1,I2,I3)=INEW
43404 ELSEIF(IVAR.EQ.34) THEN
43406 ELSEIF(IVAR.EQ.35) THEN
43408 ELSEIF(IVAR.EQ.36) THEN
43410 ELSEIF(IVAR.EQ.37) THEN
43412 ELSEIF(IVAR.EQ.38) THEN
43414 ELSEIF(IVAR.EQ.39) THEN
43416 ELSEIF(IVAR.EQ.40) THEN
43418 ELSEIF(IVAR.EQ.41) THEN
43420 ELSEIF(IVAR.EQ.42) THEN
43421 SIGT(I1,I2,I3)=RNEW
43422 ELSEIF(IVAR.EQ.43) THEN
43424 ELSEIF(IVAR.EQ.44) THEN
43426 ELSEIF(IVAR.EQ.45) THEN
43428 ELSEIF(IVAR.EQ.46) THEN
43430 ELSEIF(IVAR.EQ.47) THEN
43432 ELSEIF(IVAR.EQ.48) THEN
43434 ELSEIF(IVAR.EQ.49) THEN
43436 ELSEIF(IVAR.EQ.50) THEN
43437 RVLAM(I1,I2,I3)=RNEW
43438 ELSEIF(IVAR.EQ.51) THEN
43439 RVLAMP(I1,I2,I3)=RNEW
43440 ELSEIF(IVAR.EQ.52) THEN
43441 RVLAMB(I1,I2,I3)=RNEW
43444 C...Write old and new value. Loop back.
43446 CHBIT(15:60)=' changed from to '
43447 IF(MSVAR(IVAR,1).EQ.1) THEN
43448 WRITE(CHBIT(33:42),'(I10)') IOLD
43449 WRITE(CHBIT(51:60),'(I10)') INEW
43450 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
43451 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
43452 WRITE(CHBIT(29:42),'(F14.5)') ROLD
43453 WRITE(CHBIT(47:60),'(F14.5)') RNEW
43454 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
43455 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
43458 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
43460 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
43461 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
43464 IF(LLOW.LT.LTOT) GOTO 120
43466 C...Format statement for output on unit MSTU(11) (by default 6).
43467 5000 FORMAT(5X,A60)
43468 5100 FORMAT(5X,A88)
43473 C*********************************************************************
43476 C...Administrates the fragmentation and decay chain.
43480 C...Double precision and integer declarations.
43481 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43482 IMPLICIT INTEGER(I-N)
43483 INTEGER PYK,PYCHGE,PYCOMP
43485 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43486 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43487 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43488 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43489 COMMON/PYINT4/MWID(500),WIDS(500,5)
43490 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
43492 DIMENSION PS(2,6),IJOIN(100)
43494 C...Initialize and reset.
43496 IF(MSTU(12).GE.1) CALL PYLIST(0)
43497 MSTU(31)=MSTU(31)+1
43501 IF(MSTU(17).LE.0) MSTU(90)=0
43504 C...Sum up momentum, energy and charge for starting entries.
43512 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
43514 PS(1,J)=PS(1,J)+P(I,J)
43516 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
43520 C...Prepare system for subsequent fragmentation/decay.
43523 C...Loop through jet fragmentation and particle decays.
43529 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
43532 C...Deal with any remaining undecayed resonance
43533 C...(normally the task of PYEVNT, so seldom used).
43534 ELSEIF(MWID(KC).NE.0) THEN
43536 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
43539 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 160
43540 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
43543 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 170
43544 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 170
43547 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
43556 C...Particle decay if unstable and allowed. Save long-lived particle
43557 C...decays until second pass after Bose-Einstein effects.
43558 ELSEIF(KCHG(KC,2).EQ.0) THEN
43559 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
43560 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
43563 C...Decay products may develop a shower.
43564 IF(MSTJ(92).GT.0) THEN
43566 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
43567 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
43568 CALL PYSHOW(IP1,IP1+1,QMAX)
43571 ELSEIF(MSTJ(92).LT.0) THEN
43573 CALL PYSHOW(IP1,-3,P(IP,5))
43578 C...Jet fragmentation: string or independent fragmentation.
43579 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
43581 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
43582 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
43583 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
43584 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
43585 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
43588 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
43589 IF(MFRAG.EQ.2) CALL PYINDF(IP)
43590 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
43591 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
43594 C...Loop back if enough space left in PYJETS and no error abort.
43595 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
43596 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
43598 ELSEIF(IP.LT.N) THEN
43599 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
43602 C...Include simple Bose-Einstein effect parametrization if desired.
43603 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
43608 C...Check that momentum, energy and charge were conserved.
43610 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 200
43612 PS(2,J)=PS(2,J)+P(I,J)
43614 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
43616 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
43617 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
43618 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
43619 &'(PYEXEC:) four-momentum was not conserved')
43620 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
43621 &'(PYEXEC:) charge was not conserved')
43626 C*********************************************************************
43629 C...Rearranges partons along strings.
43630 C...Allows small systems to collapse into one or two particles.
43631 C...Checks flavours and colour singlet invarient masses.
43633 SUBROUTINE PYPREP(IP)
43635 C...Double precision and integer declarations.
43636 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43637 INTEGER PYK,PYCHGE,PYCOMP
43639 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43640 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43641 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43642 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43643 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
43645 DIMENSION DPS(5),DPC(5),UE(3),PG(5),
43646 &E1(3),E2(3),E3(3),E4(3),ECL(3)
43648 C...Function to give four-product.
43649 FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
43651 C...Rearrange parton shower product listing along strings: begin loop.
43654 DO 120 I=MAX(1,IP),N
43655 IF(K(I,1).NE.3) GOTO 120
43657 IF(KC.EQ.0) GOTO 120
43659 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
43661 C...Pick up loose string end.
43663 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
43667 IF(NSTP.GT.4*N) THEN
43668 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
43672 C...Copy undecayed parton.
43673 IF(K(IA,1).EQ.3) THEN
43674 IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
43675 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
43680 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
43690 IF(K(I1,1).EQ.1) GOTO 120
43693 C...GOTO next parton in colour space.
43695 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
43697 IA=MOD(K(IB,KCS),MSTU(5))
43698 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
43701 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
43702 & MSTU(5)).EQ.0) KCS=9-KCS
43703 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
43704 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
43707 IF(IA.LE.0.OR.IA.GT.N) THEN
43708 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
43711 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
43712 & MSTU(5)).EQ.IB) THEN
43713 IF(MREV.EQ.1) KCS=9-KCS
43714 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
43715 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
43717 IF(MREV.EQ.0) KCS=9-KCS
43718 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
43719 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
43721 IF(IA.NE.I) GOTO 100
43727 C...Done if no checks on small-mass systems.
43728 IF(MSTJ(14).LT.0) RETURN
43729 IF(MSTJ(14).EQ.0) GOTO 540
43731 C...Find lowest-mass colour singlet jet system.
43736 DO 190 I=MAX(1,IP),N
43737 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
43738 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
43745 DPS(5)=PYMASS(K(I,2))
43746 ELSEIF(K(I,1).EQ.2) THEN
43748 DPS(J)=DPS(J)+P(I,J)
43750 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
43752 DPS(J)=DPS(J)+P(I,J)
43755 DPS(5)=DPS(5)+PYMASS(K(I,2))
43756 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
43758 IF(PD.LT.PDMIN) THEN
43772 C...Done if lowest-mass system above threshold for string frag.
43773 IF(PDMIN.GE.PARJ(32)) GOTO 540
43775 C...Fill small-mass system as cluster.
43777 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
43787 C...Set up history, assuming cluster -> 2 hadrons.
43793 IF(MSTU(16).NE.2) THEN
43808 C...Form two particles from flavours of lowest-mass system, if feasible.
43810 200 NTRY = NTRY + 1
43812 IF(IABS(K(IC1,2)).NE.21) THEN
43813 KC1=PYCOMP(K(IC1,2))
43814 KC2=PYCOMP(K(IC2,2))
43815 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 540
43816 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
43817 KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
43818 IF(KQ1+KQ2.NE.0) GOTO 540
43819 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
43821 IF(IABS(K(IC2,2)).GT.10) K1=K(IC2,2)
43823 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
43824 CALL PYDCYK(K(IC1,2)+K(IC2,2)-K1,-KFLN,KFLDMP,K(N+3,2))
43825 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
43828 IF(IABS(K(IC2,2)).NE.21) GOTO 540
43829 C...No room for popcorn mesons in closed string -> 2 hadrons.
43831 220 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
43832 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
43833 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
43834 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 220
43836 P(N+2,5)=PYMASS(K(N+2,2))
43837 P(N+3,5)=PYMASS(K(N+3,2))
43839 C...If it does not work: try again (a number of times), give up
43840 C...(if no place to shuffle momentum), or form one hadron.
43841 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
43842 IF(NTRY.LT.MSTJ(17)) THEN
43844 ELSEIF(NSIN.EQ.1) THEN
43851 C...Perform two-particle decay of jet system.
43852 C...First step: find reference axis in decaying system rest frame.
43853 C...(Borrow slot N+2 for temporary direction.)
43857 DO 250 I=IC1+1,IC2-1
43858 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
43859 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
43860 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
43862 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
43866 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
43868 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
43869 PHI1=PYANGL(P(N+2,1),P(N+2,2))
43871 C...Second step: generate isotropic/anisotropic decay.
43872 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
43873 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
43875 PT2=(1D0-UE(3)**2)*PA**2
43876 IF(MSTJ(16).LE.0) THEN
43879 IF(EXP(-PT2/(2D0*PARJ(21)**2)).LT.PYR(0)) GOTO 260
43880 PR1=P(N+2,5)**2+PT2
43881 PR2=P(N+3,5)**2+PT2
43882 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
43884 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
43885 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD)))
43887 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
43889 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
43890 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
43895 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
43896 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
43898 C...Third step: move back to event frame and set production vertex.
43899 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
43909 C...Else form one particle, if possible.
43917 C...Select hadron flavour from available quark flavours.
43918 310 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
43920 ELSEIF(IABS(K(IC1,2)).NE.21) THEN
43921 CALL PYKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
43923 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
43924 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
43926 IF(K(N+2,2).EQ.0) GOTO 310
43927 P(N+2,5)=PYMASS(K(N+2,2))
43929 C...Use old algorithm for E/p conservation? (EN)
43930 IF (MSTJ(16).LE.0) GOTO 480
43932 C...Find the string piece closest to the cluster by a loop
43933 C...over the undecayed partons not in present cluster. (EN)
43937 DO 340 I1=MAX(1,IP),N-1
43938 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
43940 ELSEIF(K(I1,1).EQ.2) THEN
43944 IF(K(I2,1).GT.10) GOTO 320
43945 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 320
43947 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
43949 E1(J)=P(I1,J)/P(I1,4)
43950 E2(J)=P(I2,J)/P(I2,4)
43951 ECL(J)=P(N+1,J)/P(N+1,4)
43956 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
43957 E3S=E3(1)**2+E3(2)**2+E3(3)**2
43958 E4S=E4(1)**2+E4(2)**2+E4(3)**2
43959 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
43960 IF(E34.LE.0D0) THEN
43962 ELSEIF(E34.LT.E3S) THEN
43963 DDMIN=E4S-E34**2/E3S
43965 DDMIN=E4S-2D0*E34+E3S
43968 C...Is this the smallest so far?
43969 IF(DDMIN.LT.DGLOMI) THEN
43974 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
43979 C... Check if there are any strings to connect to the new gluon. (EN)
43980 IF (IBEG.EQ.0) GOTO 480
43982 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
43983 IF (P(N+1,5).GE.P(N+2,5)) THEN
43985 C...Construct 'gluon' that is needed to put hadron on the mass shell.
43986 FRAC=P(N+2,5)/P(N+1,5)
43988 P(N+2,J)=FRAC*P(N+1,J)
43989 PG(J)=(1D0-FRAC)*P(N+1,J)
43992 C... Copy string with new gluon put in.
43996 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 360
43997 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0) GOTO 360
44018 IF(K(I,1).EQ.12) GOTO 360
44021 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
44022 C...from string piece endpoints.
44025 C...Begin by copying string that should give energy to cluster.
44029 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 390
44030 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0) GOTO 390
44042 IF(K(I,1).EQ.12) GOTO 390
44045 C...Set initial Phad.
44047 P(NSAV+2,J)=P(NSAV+1,J)
44050 C...Calculate Pg, a part of which will be added to Phad later. (EN)
44051 420 IF(MSTJ(16).EQ.1) THEN
44055 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
44056 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
44059 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
44061 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
44063 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
44064 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
44066 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
44067 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
44068 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
44070 C...If all gluon energy eaten, zero it and take a step back.
44072 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3) THEN
44075 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
44082 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N) THEN
44085 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
44092 IF(ITER.EQ.1) GOTO 420
44094 C...If also all endpoint energy eaten, revert to old procedure.
44095 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
44096 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5)) THEN
44107 C... Construct the collapsed hadron and modified string partons.
44109 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
44110 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
44111 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
44113 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
44114 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
44116 C...Finished with string collapse in new scheme.
44120 C... Use old algorithm; by choice or when in trouble.
44122 C...Find parton/particle which combines to largest extra mass.
44127 IF(IR.NE.0) GOTO 500
44128 DO 490 I=MAX(1,IP),N
44129 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
44130 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 490
44131 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
44132 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 490
44133 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 490
44134 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
44136 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
44137 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
44138 IF(HSR.GT.HSM) THEN
44146 C...Shuffle energy and momentum to put new particle on mass shell.
44151 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
44152 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
44153 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
44155 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
44156 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
44160 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
44164 C...Mark collapsed system and store daughter pointers. Iterate.
44165 520 DO 530 I=IC1,IC2
44166 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
44167 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
44169 IF(MSTU(16).NE.2) THEN
44174 K(I,5)=NSAV+1+NBODY
44178 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
44180 C...Check flavours and invariant masses in parton systems.
44187 DO 580 I=MAX(1,IP),N
44188 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 580
44190 IF(KC.EQ.0) GOTO 580
44191 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
44192 IF(KQ.EQ.0) GOTO 580
44198 DPS(5)=DPS(5)+PYMASS(K(I,2))
44201 DPS(J)=DPS(J)+P(I,J)
44203 IF(K(I,1).EQ.1) THEN
44204 IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
44205 & PYERRM(2,'(PYPREP:) unphysical flavour combination')
44206 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
44207 & (0.9D0*PARJ(32)+DPS(5))**2) THEN
44208 CALL PYERRM(3,'(PYPREP:) too small mass in jet system')
44222 C*********************************************************************
44225 C...Handles the fragmentation of an arbitrary colour singlet
44226 C...jet system according to the Lund string fragmentation model.
44228 SUBROUTINE PYSTRF(IP)
44230 C...Double precision and integer declarations.
44231 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44232 IMPLICIT INTEGER(I-N)
44233 INTEGER PYK,PYCHGE,PYCOMP
44235 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44236 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44237 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44238 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
44239 C...Local arrays. All MOPS variables ends with MO
44240 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
44241 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
44242 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
44243 &INMO(9),PM2QMO(2),XTMO(2)
44245 C...Function: four-product of two vectors.
44246 FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
44247 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
44250 C...Reset counters. Identify parton system.
44263 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
44264 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
44265 IF(MSTU(21).GE.1) RETURN
44267 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
44269 IF(KC.EQ.0) GOTO 110
44270 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
44271 IF(KQ.EQ.0) GOTO 110
44272 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
44273 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
44274 IF(MSTU(21).GE.1) RETURN
44277 C...Take copy of partons to be considered. Check flavour sum.
44282 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
44284 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
44286 IF(KQ.NE.2) KQSUM=KQSUM+KQ
44287 IF(K(I,1).EQ.41) THEN
44289 IF(KQSUM.EQ.KQ) MJU(1)=N+NP
44290 IF(KQSUM.NE.KQ) MJU(2)=N+NP
44292 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
44293 IF(KQSUM.NE.0) THEN
44294 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
44295 IF(MSTU(21).GE.1) RETURN
44298 C...Boost copied system to CM frame (for better numerical precision).
44299 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
44302 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
44306 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
44308 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
44309 IF(P(I,3).GT.0D0) THEN
44310 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
44311 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
44312 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
44314 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
44315 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
44316 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
44321 C...Search for very nearby partons that may be recombined.
44328 140 IF(NR.GE.3) THEN
44331 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
44333 IF(I.EQ.N+NR) I1=N+1
44334 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
44335 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
44337 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
44339 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
44340 & P(I1,2)**2+P(I1,3)**2))
44341 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
44342 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
44343 IF(PDR.LT.PDRMIN) THEN
44349 C...Recombine very nearby partons to avoid machine precision problems.
44350 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
44352 P(N+1,J)=P(N+1,J)+P(N+NR,J)
44354 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44358 ELSEIF(PDRMIN.LT.PARU12) THEN
44360 P(IR,J)=P(IR,J)+P(IR+1,J)
44362 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
44364 DO 190 I=IR+1,N+NR-1
44370 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
44372 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
44373 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
44379 C...Reset particle counter. Skip ahead if no junctions are present;
44380 C...this is usually the case!
44381 NRS=MAX(5*NR+11,NP)
44384 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
44388 ELSEIF(NTRY.GT.100) THEN
44389 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
44390 IF(MSTU(21).GE.1) RETURN
44394 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580
44395 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
44396 & ' junction strings not handled by MSTJ(12)>3 options')
44399 IF(MJU(JT).EQ.0) GOTO 570
44402 C...Find and sum up momentum on three sides of junction. Check flavours.
44410 DO 240 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
44411 IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
44416 PJU(IU,J)=PJU(IU,J)+P(I1,J)
44420 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
44422 IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
44423 & K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
44424 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
44425 IF(MSTU(21).GE.1) RETURN
44428 C...Calculate (approximate) boost to rest frame of junction.
44429 T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
44430 & (PJU(1,5)*PJU(2,5))
44431 T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
44432 & (PJU(1,5)*PJU(3,5))
44433 T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
44434 & (PJU(2,5)*PJU(3,5))
44435 T11=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T13)/(1D0-T23))
44436 T22=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T23)/(1D0-T13))
44437 TSQ=SQRT((2D0*T11*T22+T12-1D0)*(1D0+T12))
44438 T1F=(TSQ-T22*(1D0+T12))/(1D0-T12**2)
44439 T2F=(TSQ-T11*(1D0+T12))/(1D0-T12**2)
44441 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
44443 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
44445 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
44449 C...Put junction at rest if motion could give inconsistencies.
44450 IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
44460 C...Start preparing for fragmentation of two strings from junction.
44463 NS=IJU(IU+1)-IJU(IU)
44465 C...Junction strings: find longitudinal string directions.
44470 DP(1,J)=0.5D0*P(IS1,J)
44471 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
44472 DP(2,J)=0.5D0*P(IS2,J)
44473 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
44475 IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+
44477 IF(IS.EQ.NS) DP(2,5)=0D0
44481 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
44482 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
44483 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
44488 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
44489 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
44490 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
44492 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
44494 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
44495 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
44499 C...Junction strings: initialize flavour, momentum and starting pos.
44503 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
44507 ELSEIF(NTRY.GT.100) THEN
44508 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
44509 IF(MSTU(21).GE.1) RETURN
44514 IE(1)=K(N+1+(JT/2)*(NP-1),3)
44519 DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
44525 KFL(1)=K(IJU(IU),2)
44533 C...Junction strings: find initial transverse directions.
44536 DP(2,J)=P(IN(4)+1,J)
44540 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
44541 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
44542 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
44543 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
44544 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
44545 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
44546 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
44547 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
44548 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
44550 DHCX1=DFOUR(3,1)/DHC12
44551 DHCX2=DFOUR(3,2)/DHC12
44552 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
44553 DHCY1=DFOUR(4,1)/DHC12
44554 DHCY2=DFOUR(4,2)/DHC12
44555 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
44556 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
44558 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
44560 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
44564 C...Junction strings: produce new particle, origin.
44566 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
44567 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
44568 IF(MSTU(21).GE.1) RETURN
44576 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
44577 390 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
44578 IF(K(I,2).EQ.0) GOTO 320
44579 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
44580 & IABS(KFL(3)).GT.10) THEN
44581 IF(PYR(0).GT.PARJ(19)) GOTO 390
44583 P(I,5)=PYMASS(K(I,2))
44584 CALL PYPTDI(KFL(1),PX(3),PY(3))
44585 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
44586 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
44587 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
44588 & MSTU(90).LT.8) THEN
44589 MSTU(90)=MSTU(90)+1
44590 MSTU(90+MSTU(90))=I
44591 PARU(90+MSTU(90))=Z
44593 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
44598 C...Junction strings: stepping within or from 'low' string region easy.
44599 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
44600 & P(IN(1),5)**2.GE.PR(1)) THEN
44601 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
44602 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
44604 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
44607 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
44608 P(IN(2)+2,4)=P(IN(2)+2,3)
44611 IF(IN(2).GT.N+NR+4*NS) GOTO 320
44612 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
44613 P(IN(1)+2,4)=P(IN(1)+2,3)
44619 C...Junction strings: find new transverse directions.
44620 420 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
44621 & IN(1).GT.IN(2)) GOTO 320
44622 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
44629 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
44630 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
44632 IF(DHC12.LE.1D-2) THEN
44633 P(IN(1)+2,4)=P(IN(1)+2,3)
44639 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
44640 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
44641 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
44642 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
44643 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
44644 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
44645 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
44646 DHCX1=DFOUR(3,1)/DHC12
44647 DHCX2=DFOUR(3,2)/DHC12
44648 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
44649 DHCY1=DFOUR(4,1)/DHC12
44650 DHCY2=DFOUR(4,2)/DHC12
44651 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
44652 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
44654 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
44656 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
44659 C...Express pT with respect to new axes, if sensible.
44660 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
44661 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
44662 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
44668 C...Junction strings: sum up known four-momentum, coefficients for m2.
44671 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
44672 & PY(3)*P(IN(3)+1,J)
44673 DO 450 IN1=IN(4),IN(1)-4,4
44674 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
44676 DO 460 IN2=IN(5),IN(2)-4,4
44677 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
44681 DHM(2)=2D0*FOUR(I,IN(1))
44682 DHM(3)=2D0*FOUR(I,IN(2))
44683 DHM(4)=2D0*FOUR(IN(1),IN(2))
44685 C...Junction strings: find coefficients for Gamma expression.
44686 DO 490 IN2=IN(1)+1,IN(2),4
44687 DO 480 IN1=IN(1),IN2-1,4
44688 DHC=2D0*FOUR(IN1,IN2)
44689 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
44690 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
44691 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
44692 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
44696 C...Junction strings: solve (m2, Gamma) equation system for energies.
44697 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
44698 IF(ABS(DHS1).LT.1D-4) GOTO 320
44699 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
44700 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
44701 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
44702 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
44703 & ABS(DHS1)-DHS2/DHS1)
44704 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 320
44705 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
44706 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
44708 C...Junction strings: step to new region if necessary.
44709 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
44710 P(IN(2)+2,4)=P(IN(2)+2,3)
44713 IF(IN(2).GT.N+NR+4*NS) GOTO 320
44714 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
44715 P(IN(1)+2,4)=P(IN(1)+2,3)
44720 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
44721 P(IN(1)+2,4)=P(IN(1)+2,3)
44727 C...Junction strings: particle four-momentum, remainder, loop back.
44729 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
44730 & P(IN(2)+2,4)*P(IN(2),J)
44731 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
44733 IF(P(I,4).LT.P(I,5)) GOTO 320
44734 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
44735 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
44736 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
44741 IF(IN(3).NE.IN(6)) THEN
44743 P(IN(6),J)=P(IN(3),J)
44744 P(IN(6)+1,J)=P(IN(3)+1,J)
44749 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
44750 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
44755 C...Junction strings: save quantities left after each string.
44756 IF(IABS(KFL(1)).GT.10) GOTO 320
44760 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
44764 C...Junction strings: put together to new effective string endpoint.
44766 KFJS(JT)=K(K(MJU(JT+2),3),2)
44767 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
44768 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
44769 IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
44770 & IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
44773 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
44774 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
44776 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
44780 C...Open versus closed strings. Choose breakup region for latter.
44781 580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
44784 ELSEIF(MJU(1).NE.0) THEN
44787 ELSEIF(MJU(2).NE.0) THEN
44790 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
44797 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
44798 W2SUM=W2SUM+P(N+NR+IS,1)
44803 W2SUM=W2SUM-P(N+NR+NB,1)
44804 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600
44807 C...Find longitudinal string directions (i.e. lightlike four-vectors).
44809 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
44810 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
44813 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
44814 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
44816 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
44817 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
44822 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
44825 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
44826 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
44829 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
44830 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
44831 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
44833 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
44835 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
44836 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
44840 C...Begin initialization: sum up energy, set starting position.
44844 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
44848 ELSEIF(NTRY.GT.100) THEN
44849 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
44850 IF(MSTU(21).GE.1) RETURN
44857 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
44862 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
44863 IF(NS.GT.NR) IRANK(JT)=1
44864 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
44865 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
44866 IN(3*JT+2)=IN(3*JT+1)+1
44867 IN(3*JT+3)=N+NR+4*NS+2*JT-1
44868 DO 670 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
44874 C.. MOPS variables and switches
44880 C...Initialize flavour and pT variables for open string.
44884 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
44888 KFL(JT)=K(IE(JT),2)
44889 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
44891 PMQ(JT)=PYMASS(KFL(JT))
44895 C...Closed string: random initial breakup flavour, pT and vertex.
44897 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
44899 700 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
44900 C.. Closed string: first vertex diq attempt => enforced second
44902 IF(IABS(KFL(1)).GT.10)THEN
44907 IF(IBMO.EQ.1) MSTU(121)=-1
44909 CALL PYPTDI(KFL(1),PX(1),PY(1))
44912 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
44913 710 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
44914 ZR=PR3/(Z*P(N+NR+1,5)**2)
44915 IF(ZR.GE.1D0) GOTO 710
44918 PMQ(JT)=PYMASS(KFL(JT))
44919 GAM(JT)=PR3*(1D0-Z)/Z
44920 IN1=N+NR+3+4*(JT/2)*(NS-1)
44923 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
44926 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
44932 PM2QMO(JT)=PMQ(JT)**2
44933 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
44936 C...Find initial transverse directions (i.e. spacelike four-vectors).
44938 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
44947 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
44948 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
44949 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
44950 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
44951 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
44952 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
44953 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
44954 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
44955 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
44957 DHCX1=DFOUR(3,1)/DHC12
44958 DHCX2=DFOUR(3,2)/DHC12
44959 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
44960 DHCY1=DFOUR(4,1)/DHC12
44961 DHCY2=DFOUR(4,2)/DHC12
44962 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
44963 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
44965 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
44967 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
44972 P(IN3+2,J)=P(IN3,J)
44973 P(IN3+3,J)=P(IN3+1,J)
44978 C...Remove energy used up in junction string fragmentation.
44979 IF(MJU(1)+MJU(2).GT.0) THEN
44981 IF(NJS(JT).EQ.0) GOTO 790
44983 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
44988 C...Produce new particle: side, origin.
44990 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
44991 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
44992 IF(MSTU(21).GE.1) RETURN
44994 C.. New side priority for popcorn systems
44995 IF(MSTU(121).LE.0)THEN
44997 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
44998 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
45002 IRANK(JT)=IRANK(JT)+1
45008 C...Generate flavour, hadron and pT.
45010 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
45011 IF(K(I,2).EQ.0) GOTO 640
45013 IF(MSTU(121).EQ.-1) GOTO 840
45014 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
45015 &IABS(KFL(3)).GT.10) THEN
45016 IF(PYR(0).GT.PARJ(19)) GOTO 810
45018 P(I,5)=PYMASS(K(I,2))
45019 CALL PYPTDI(KFL(JT),PX(3),PY(3))
45020 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
45022 C...Final hadrons for small invariant mass.
45024 PMQ(3)=PYMASS(KFL(3))
45026 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
45027 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
45028 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
45029 &WMIN-0.5D0*PARJ(36)*PMQ(3)
45030 WREM2=FOUR(N+NRS,N+NRS)
45031 IF(WREM2.LT.0.10D0) GOTO 640
45032 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
45033 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1010
45035 C...Choose z, which gives Gamma. Shift z for heavy flavours.
45036 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
45037 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
45038 &MSTU(90).LT.8) THEN
45039 MSTU(90)=MSTU(90)+1
45040 MSTU(90+MSTU(90))=I
45041 PARU(90+MSTU(90))=Z
45045 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
45046 &MOD(KFL2A/1000,10)).GE.4) THEN
45047 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
45048 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
45049 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
45050 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
45051 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1010
45053 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
45055 C.. MOPS baryon model modification
45056 XTMO3=(1D0-Z)*XTMO(JT)
45057 IF(IABS(KFL(3)).LE.10) NRVMO=0
45058 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
45062 IF(IABS(KFL(JT)).LE.10)THEN
45063 XBMO=MIN(XTMO3,1D0-(2D-10))
45066 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
45067 GTSTMO=1D0-PARF(192)**PGMO
45069 IF(IRANK(JT).EQ.1) THEN
45074 IF(XBMO.LT.1D0-(1D-10))THEN
45075 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
45076 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
45079 IF(MSTJ(12).GE.5)THEN
45080 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
45081 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
45082 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
45087 C.. MOPS Accepting popcorn system hadron.
45088 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
45089 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
45091 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
45093 & '(PYSTRF:) no more memory left in PYJETS')
45094 IF(MSTU(21).GE.1) RETURN
45106 DO 820 LINE=1,I-N-NR
45107 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
45108 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
45115 C..Reject popcorn system, flag=-1 if enforcing new one
45117 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
45122 C..Lift restoring string outside MOPS block
45123 840 IF(MSTU(121).LT.0) THEN
45124 IF(MSTU(121).EQ.-2) MSTU(121)=0
45127 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 810
45138 DO 850 LINE=1,I-N-NR
45139 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
45140 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
45148 C.. MOPS end of modification
45154 C...Stepping within or from 'low' string region easy.
45155 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
45156 &P(IN(1),5)**2.GE.PR(JT)) THEN
45157 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
45158 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
45160 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
45163 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
45164 P(IN(JR)+2,4)=P(IN(JR)+2,3)
45167 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
45168 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
45169 P(IN(JT)+2,4)=P(IN(JT)+2,3)
45175 C...Find new transverse directions (i.e. spacelike string vectors).
45176 890 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
45177 &IN(1).GT.IN(2)) GOTO 640
45178 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
45185 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
45186 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
45188 IF(DHC12.LE.1D-2) THEN
45189 P(IN(JT)+2,4)=P(IN(JT)+2,3)
45195 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
45196 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
45197 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
45198 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
45199 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
45200 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
45201 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
45202 DHCX1=DFOUR(3,1)/DHC12
45203 DHCX2=DFOUR(3,2)/DHC12
45204 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
45205 DHCY1=DFOUR(4,1)/DHC12
45206 DHCY2=DFOUR(4,2)/DHC12
45207 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
45208 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
45210 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
45212 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
45215 C...Express pT with respect to new axes, if sensible.
45216 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
45217 & FOUR(IN(3*JT+3)+1,IN(3)))
45218 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
45219 & FOUR(IN(3*JT+3)+1,IN(3)+1))
45220 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
45226 C...Sum up known four-momentum. Gives coefficients for m2 expression.
45229 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
45230 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
45231 DO 920 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
45232 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
45234 DO 930 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
45235 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
45239 DHM(2)=2D0*FOUR(I,IN(1))
45240 DHM(3)=2D0*FOUR(I,IN(2))
45241 DHM(4)=2D0*FOUR(IN(1),IN(2))
45243 C...Find coefficients for Gamma expression.
45244 DO 960 IN2=IN(1)+1,IN(2),4
45245 DO 950 IN1=IN(1),IN2-1,4
45246 DHC=2D0*FOUR(IN1,IN2)
45247 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
45248 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
45249 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
45250 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
45254 C...Solve (m2, Gamma) equation system for energies taken.
45255 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
45256 IF(ABS(DHS1).LT.1D-4) GOTO 640
45257 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
45258 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
45259 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
45260 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
45261 &ABS(DHS1)-DHS2/DHS1)
45262 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 640
45263 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
45264 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
45266 C...Step to new region if necessary.
45267 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
45268 P(IN(JR)+2,4)=P(IN(JR)+2,3)
45271 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
45272 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
45273 P(IN(JT)+2,4)=P(IN(JT)+2,3)
45278 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
45279 P(IN(JT)+2,4)=P(IN(JT)+2,3)
45285 C...Four-momentum of particle. Remaining quantities. Loop back.
45287 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
45288 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
45290 IF(P(I,4).LT.P(I,5)) GOTO 640
45296 IF(IN(3).NE.IN(3*JT+3)) THEN
45298 P(IN(3*JT+3),J)=P(IN(3),J)
45299 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
45304 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
45305 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
45309 C...Final hadron: side, flavour, hadron, mass.
45315 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
45316 IF(K(I,2).EQ.0) GOTO 640
45317 P(I,5)=PYMASS(K(I,2))
45318 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
45320 C...Final two hadrons: find common setup of four-vectors.
45322 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
45323 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
45324 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
45325 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
45326 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
45327 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
45328 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
45329 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
45330 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
45331 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
45334 C...Solve kinematics for final two hadrons, if possible.
45335 WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
45336 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
45337 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
45338 IF(FD.GE.1D0) GOTO 640
45339 FA=WREM2+PR(JT)-PR(JR)
45340 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
45342 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
45343 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB)))
45344 FB=SIGN(FB,JS*(PYR(0)-PREV))
45347 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
45348 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
45349 &4D0*WREM2*PR(JT))),DBLE(JS))
45351 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
45352 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
45353 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
45354 P(I,J)=P(N+NRS,J)-P(I-1,J)
45356 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640
45358 C...Mark jets as fragmented and give daughter pointers.
45360 DO 1030 I=NSAV+1,NSAV+NP
45363 IF(MSTU(16).NE.2) THEN
45372 C...Document string system. Move up particles.
45383 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
45387 K(I,J)=K(I+NRS-1,J)
45388 P(I,J)=P(I+NRS-1,J)
45393 DO 1070 IZ=MSTU90+1,MSTU91
45394 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
45395 PARU9T(IZ)=PARU(90+IZ)
45399 C...Order particles in rank along the chain. Update mother pointer.
45402 K(I-NSAV+N,J)=K(I,J)
45403 P(I-NSAV+N,J)=P(I,J)
45407 DO 1120 I=N+1,2*N-NSAV
45408 IF(K(I,3).NE.IE(1)) GOTO 1120
45414 IF(MSTU(16).NE.2) K(I1,3)=NSAV
45415 DO 1110 IZ=MSTU90+1,MSTU91
45416 IF(MSTU9T(IZ).EQ.I) THEN
45417 MSTU(90)=MSTU(90)+1
45418 MSTU(90+MSTU(90))=I1
45419 PARU(90+MSTU(90))=PARU9T(IZ)
45423 DO 1150 I=2*N-NSAV,N+1,-1
45424 IF(K(I,3).EQ.IE(1)) GOTO 1150
45430 IF(MSTU(16).NE.2) K(I1,3)=NSAV
45431 DO 1140 IZ=MSTU90+1,MSTU91
45432 IF(MSTU9T(IZ).EQ.I) THEN
45433 MSTU(90)=MSTU(90)+1
45434 MSTU(90+MSTU(90))=I1
45435 PARU(90+MSTU(90))=PARU9T(IZ)
45440 C...Boost back particle system. Set production vertices.
45443 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
45447 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
45448 IF(P(I,3).GT.0D0) THEN
45449 HHPEZ=(P(I,4)+P(I,3))*HHBZ
45450 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
45451 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
45453 HHPEZ=(P(I,4)-P(I,3))/HHBZ
45454 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
45455 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
45468 C*********************************************************************
45471 C...Handles the fragmentation of a jet system (or a single
45472 C...jet) according to independent fragmentation models.
45474 SUBROUTINE PYINDF(IP)
45476 C...Double precision and integer declarations.
45477 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45478 IMPLICIT INTEGER(I-N)
45479 INTEGER PYK,PYCHGE,PYCOMP
45481 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45482 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45483 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45484 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
45486 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
45487 &KFLO(2),PXO(2),PYO(2),WO(2)
45489 C.. MOPS error message
45490 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
45491 &' are not treated as expected in independent fragmentation')
45493 C...Reset counters. Identify parton system and take copy. Check flavour.
45503 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
45504 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
45505 IF(MSTU(21).GE.1) RETURN
45507 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
45509 IF(KC.EQ.0) GOTO 110
45510 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
45511 IF(KQ.EQ.0) GOTO 110
45513 IF(KQ.NE.2) KQSUM=KQSUM+KQ
45515 K(NSAV+NJET,J)=K(I,J)
45516 P(NSAV+NJET,J)=P(I,J)
45517 DPS(J)=DPS(J)+P(I,J)
45520 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
45521 &K(I+1,1).EQ.2)) GOTO 110
45522 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
45523 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
45524 IF(MSTU(21).GE.1) RETURN
45527 C...Boost copied system to CM frame. Find CM energy and sum flavours.
45530 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
45531 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
45537 DO 140 I=NSAV+1,NSAV+NJET
45541 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
45542 ELSEIF(KFA.GT.1000) THEN
45543 KFLA=MOD(KFA/1000,10)
45544 KFLB=MOD(KFA/100,10)
45545 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
45546 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
45550 C...Loop over attempts made. Reset counters.
45553 IF(NTRY.GT.200) THEN
45554 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
45555 IF(MSTU(21).GE.1) RETURN
45565 C...Loop over jets to be fragmented.
45566 DO 230 IP1=NSAV+1,NSAV+NJET
45571 C...Initial flavour and momentum values. Jet along +z axis.
45572 KFLH=IABS(K(IP1,2))
45573 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
45575 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
45577 C...Initial values for quark or diquark jet.
45578 170 IF(IABS(K(IP1,2)).NE.21) THEN
45581 CALL PYPTDI(0,PXO(1),PYO(1))
45584 C...Initial values for gluon treated like random quark jet.
45585 ELSEIF(MSTJ(2).LE.2) THEN
45587 IF(MSTJ(2).EQ.2) MSTJ(91)=1
45588 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
45589 CALL PYPTDI(0,PXO(1),PYO(1))
45592 C...Initial values for gluon treated like quark-antiquark jet pair,
45593 C...sharing energy according to Altarelli-Parisi splitting function.
45596 IF(MSTJ(2).EQ.4) MSTJ(91)=1
45597 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
45599 CALL PYPTDI(0,PXO(1),PYO(1))
45602 WO(1)=WF*PYR(0)**(1D0/3D0)
45606 C...Initial values for rank, flavour, pT and W+.
45616 C...New hadron. Generate flavour and hadron species.
45618 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
45619 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
45620 IF(MSTU(21).GE.1) RETURN
45627 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
45628 IF(K(I,2).EQ.0) GOTO 180
45629 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
45630 IF(PYR(0).GT.PARJ(19)) GOTO 200
45633 C...Find hadron mass. Generate four-momentum.
45634 P(I,5)=PYMASS(K(I,2))
45635 CALL PYPTDI(KFL1,PX2,PY2)
45638 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
45639 CALL PYZDIS(KFL1,KFL2,PR,Z)
45641 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
45643 MSTU(90)=MSTU(90)+1
45644 MSTU(90+MSTU(90))=I
45645 PARU(90+MSTU(90))=Z
45647 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
45648 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
45649 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
45650 & P(I,3).LE.0.001D0) THEN
45651 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
45657 C...Remaining flavour and momentum.
45666 C...Check if pL acceptable. Go back for new hadron if enough energy.
45667 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
45669 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
45671 IF(W.GT.PARJ(31)) GOTO 190
45674 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
45675 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
45677 C...Rotate jet to new direction.
45678 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
45679 PHI=PYANGL(P(IP1,1),P(IP1,2))
45681 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
45682 K(K(IP1,3),4)=NSAV1+1
45685 C...End of jet generation loop. Skip conservation in some cases.
45687 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
45688 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
45690 C...Subtract off produced hadron flavours, finished if zero.
45691 DO 240 I=NSAV+NJET+1,N
45693 KFLA=MOD(KFA/1000,10)
45694 KFLB=MOD(KFA/100,10)
45695 KFLC=MOD(KFA/10,10)
45697 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
45698 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
45700 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
45701 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
45702 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
45705 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
45706 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
45707 IF(NREQ.EQ.0) GOTO 320
45709 C...Take away flavour of low-momentum particles until enough freedom.
45713 DO 260 I=NSAV+NJET+1,N
45714 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
45715 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
45716 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
45718 IF(IREM.EQ.0) GOTO 150
45720 KFA=IABS(K(IREM,2))
45721 KFLA=MOD(KFA/1000,10)
45722 KFLB=MOD(KFA/100,10)
45723 KFLC=MOD(KFA/10,10)
45724 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
45725 IF(K(IREM,1).EQ.8) GOTO 250
45727 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
45728 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
45729 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
45731 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
45732 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
45733 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
45736 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
45737 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
45738 IF(NREQ.GT.NREM) GOTO 250
45739 DO 270 I=NSAV+NJET+1,N
45740 IF(K(I,1).EQ.8) K(I,1)=1
45743 C...Find combination of existing and new flavours for hadron.
45745 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
45746 IF(NREQ.LT.NREM) NFET=1
45747 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
45749 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
45750 KFLF(J)=ISIGN(1,NFL(1))
45751 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
45752 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
45754 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
45756 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
45757 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
45758 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
45759 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
45760 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
45761 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
45762 IF(NFET.LE.2) KFLF(3)=0
45763 IF(KFLF(3).NE.0) THEN
45764 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
45765 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
45766 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
45767 & KFLFC=KFLFC+ISIGN(2,KFLFC)
45771 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
45772 IF(KF.EQ.0) GOTO 280
45773 DO 300 J=1,MAX(2,NFET)
45774 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
45777 C...Store hadron at random among free positions.
45778 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
45779 DO 310 I=NSAV+NJET+1,N
45780 IF(K(I,1).EQ.7) NPOS=NPOS-1
45781 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
45784 P(I,5)=PYMASS(K(I,2))
45785 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
45788 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
45789 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
45790 IF(NREM.GT.0) GOTO 280
45792 C...Compensate for missing momentum in global scheme (3 options).
45793 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
45796 DO 330 I=NSAV+NJET+1,N
45797 PSI(J)=PSI(J)+P(I,J)
45800 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
45802 DO 350 I=NSAV+NJET+1,N
45803 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
45804 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
45805 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
45806 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
45808 DO 370 I=NSAV+NJET+1,N
45809 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
45810 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
45811 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
45812 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
45814 P(I,J)=P(I,J)-PSI(J)*PW/PWS
45816 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
45819 C...Compensate for missing momentum withing each jet separately.
45820 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
45821 DO 390 I=N+1,N+NJET
45827 DO 410 I=NSAV+NJET+1,N
45830 K(IR2,1)=K(IR2,1)+1
45831 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
45832 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
45834 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
45836 P(IR2,4)=P(IR2,4)+P(I,4)
45837 P(IR2,5)=P(IR2,5)+PLS
45840 DO 420 I=N+1,N+NJET
45841 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
45843 DO 440 I=NSAV+NJET+1,N
45846 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
45847 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
45849 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
45852 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
45856 C...Scale momenta for energy conservation.
45857 IF(MOD(MSTJ(3),5).NE.0) THEN
45861 DO 450 I=NSAV+NJET+1,N
45864 PQS=PQS+P(I,5)**2/P(I,4)
45866 IF(PMS.GE.PECM) GOTO 150
45869 PFAC=(PECM-PQS)/(PES-PQS)
45872 DO 480 I=NSAV+NJET+1,N
45876 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
45878 PQS=PQS+P(I,5)**2/P(I,4)
45880 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
45883 C...Origin of produced particles and parton daughter pointers.
45884 490 DO 500 I=NSAV+NJET+1,N
45885 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
45886 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
45888 DO 510 I=NSAV+1,NSAV+NJET
45891 IF(MSTU(16).NE.2) THEN
45895 K(I1,4)=K(I1,4)-NJET+1
45896 K(I1,5)=K(I1,5)-NJET+1
45897 IF(K(I1,5).LT.K(I1,4)) THEN
45904 C...Document independent fragmentation system. Remove copy of jets.
45915 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
45917 DO 540 I=NSAV+NJET,N
45919 K(I-NJET+1,J)=K(I,J)
45920 P(I-NJET+1,J)=P(I,J)
45921 V(I-NJET+1,J)=V(I,J)
45925 DO 550 IZ=MSTU90+1,MSTU(90)
45926 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
45929 C...Boost back particle system. Set production vertices.
45930 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
45931 &DPS(2)/DPS(4),DPS(3)/DPS(4))
45941 C*********************************************************************
45944 C...Handles the decay of unstable particles.
45946 SUBROUTINE PYDECY(IP)
45948 C...Double precision and integer declarations.
45949 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45950 IMPLICIT INTEGER(I-N)
45951 INTEGER PYK,PYCHGE,PYCOMP
45953 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45954 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45955 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45956 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45957 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
45959 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
45960 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
45962 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
45964 C...Functions: momentum in two-particle decays and four-product.
45965 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
45966 FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
45968 C...Initial values.
45972 KFS=ISIGN(1,K(IP,2))
45976 C...Choose lifetime and determine decay vertex.
45977 IF(K(IP,1).EQ.5) THEN
45979 ELSEIF(K(IP,1).NE.4) THEN
45980 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
45983 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
45986 C...Determine whether decay allowed or not.
45988 IF(MSTJ(22).EQ.2) THEN
45989 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
45990 ELSEIF(MSTJ(22).EQ.3) THEN
45991 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
45992 ELSEIF(MSTJ(22).EQ.4) THEN
45993 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
45994 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
45996 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
46001 C...Interface to external tau decay library (for tau polarization).
46002 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
46004 C...Starting values for pointers and momenta.
46008 PCMTAU(J)=P(ITAU,J)
46011 C...Iterate to find position and code of mother of tau.
46013 120 IMTAU=K(IMTAU,3)
46015 IF(IMTAU.EQ.0) THEN
46016 C...If no known origin then impossible to do anything further.
46020 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
46021 C...If tau -> tau + gamma then add gamma energy and loop.
46022 IF(K(K(IMTAU,4),2).EQ.22) THEN
46024 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
46026 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
46028 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
46033 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
46034 C...If coming from weak decay of hadron then W is not stored in record,
46035 C...but can be reconstructed by adding neutrino momentum.
46036 KFORIG=-ISIGN(24,K(ITAU,2))
46038 DO 160 II=K(IMTAU,4),K(IMTAU,5)
46039 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
46041 PCMTAU(J)=PCMTAU(J)+P(II,J)
46047 C...If coming from resonance decay then find latest copy of this
46048 C...resonance (may not completely agree).
46051 DO 170 II=IMTAU+1,IP-1
46052 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
46053 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
46056 PCMTAU(J)=P(IORIG,J)
46060 C...Boost tau to rest frame of production process (where known)
46061 C...and rotate it to sit along +z axis.
46063 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
46065 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
46066 & -DBETAU(2),-DBETAU(3))
46067 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
46068 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
46069 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
46070 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
46072 C...Call tau decay routine (if meaningful) and fill extra info.
46073 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
46074 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
46075 DO 200 II=NSAV+1,NSAV+NDECAY
46084 C...Boost back decay tau and decay products.
46088 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
46089 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
46090 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
46091 & DBETAU(2),DBETAU(3))
46093 C...Skip past ordinary tau decay treatment.
46101 C...B-Bbar mixing: flip sign of meson appropriately.
46103 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
46105 IF(KFA.EQ.531) XBBMIX=PARJ(77)
46106 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
46107 IF(MMIX.EQ.1) KFS=-KFS
46110 C...Check existence of decay channels. Particle/antiparticle rules.
46112 IF(MDCY(KC,2).GT.0) THEN
46113 MDMDCY=MDME(MDCY(KC,2),2)
46114 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
46116 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
46117 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
46120 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
46121 IF(KCHG(KC,3).EQ.0) THEN
46124 IF(PYR(0).GT.0.5D0) KFS=-KFS
46125 ELSEIF(KFS.GT.0) THEN
46133 C...Sum branching ratios of allowed decay channels.
46136 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
46137 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
46138 & KFSN*MDME(IDL,1).NE.3) GOTO 230
46139 IF(MDME(IDL,2).GT.100) GOTO 230
46141 BRSU=BRSU+BRAT(IDL)
46144 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
46148 C...Select decay channel among allowed ones.
46149 240 RBR=BRSU*PYR(0)
46152 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
46153 &KFSN*MDME(IDL,1).NE.3) THEN
46154 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
46155 ELSEIF(MDME(IDL,2).GT.100) THEN
46156 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
46160 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
46163 C...Start readout of decay channel: matrix element, reset counters.
46166 IF(MOD(NTRY,200).EQ.0) THEN
46167 WRITE(CIDC,'(I4)') IDC
46168 C...Do not print warning for some well-known special cases.
46169 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
46170 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
46174 IF(NTRY.GT.1000) THEN
46175 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
46176 IF(MSTU(21).GE.1) RETURN
46182 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
46185 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
46187 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
46193 IF(KFA.GT.80) MHADDY=1
46194 C.. Random flavour and popcorn system memory.
46200 C...Read out decay products. Convert to standard flavour code.
46202 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
46204 IF(JT.LE.5) KP=KFDP(IDC,JT)
46205 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
46206 IF(KP.EQ.0) GOTO 280
46209 IF(KPA.GT.80) MHADDY=1
46210 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
46212 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
46214 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
46215 KFP=-KFS*MOD(KFA/10,10)
46216 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
46217 KFP=KFS*(100*MOD(KFA/10,100)+3)
46218 ELSEIF(KPA.EQ.81) THEN
46219 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
46220 ELSEIF(KP.EQ.82) THEN
46221 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
46222 IF(KFP.EQ.0) GOTO 260
46226 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
46227 ELSEIF(KP.EQ.-82) THEN
46230 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
46232 C...Add decay product to event record or to quark flavour list.
46235 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
46238 C...set rndmflav popcorn system pointer
46239 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
46241 PSQ=PSQ+PYMASS(KFLO(NQ))
46242 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
46243 & MOD(NQ,2).EQ.1) THEN
46248 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
46249 IF(K(I,2).EQ.0) GOTO 260
46251 P(I,5)=PYMASS(K(I,2))
46256 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
46257 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
46259 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
46260 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
46270 C...Check masses for resonance decays.
46271 IF(MHADDY.EQ.0) THEN
46272 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
46275 C...Choose decay multiplicity in phase space model.
46276 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
46278 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
46279 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
46281 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
46282 IF(IRNDMO.EQ.0) THEN
46285 ELSEIF(IRNDMO.EQ.1) THEN
46290 IF(NTRY.GT.1000) THEN
46291 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
46292 IF(MSTU(21).GE.1) RETURN
46294 IF(MMAT.LE.20) THEN
46295 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
46296 & SIN(PARU(2)*PYR(0))
46297 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
46298 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
46299 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
46300 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
46301 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
46305 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
46307 IF(MSTU(121).GT.MSTU(125)) GOTO 300
46309 C...Form hadrons from flavour content.
46313 IF(ND.EQ.NP+NQ/2) GOTO 330
46314 DO 320 I=N+NP+1,N+ND-NQ/2
46315 C.. Stick to started popcorn system, else pick side at random
46317 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
46318 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
46319 IF(K(I,2).EQ.0) GOTO 300
46320 MSTU(125)=MSTU(125)-1
46322 IF(MSTU(121).GT.0) JTMO=JT
46328 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
46329 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
46330 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
46333 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
46334 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
46335 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
46336 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
46338 C...Check that sum of decay product masses not too large.
46340 DO 340 I=N+NP+1,N+ND
46345 P(I,5)=PYMASS(K(I,2))
46348 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
46350 C...Rescale energy to subtract off spectator quark mass.
46351 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
46352 & .AND.NP.GE.3) THEN
46354 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
46356 P(N+NP,J)=PQT*PV(1,J)
46357 PV(1,J)=(1D0-PQT)*PV(1,J)
46359 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
46363 C...Fully specified final state: check mass broadening effects.
46365 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
46369 C...Determine position of grandmother, number of sisters.
46375 IF(IM.LT.0.OR.IM.GE.IP) IM=0
46376 IF(IM.NE.0) KFAM=IABS(K(IM,2))
46378 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
46379 IF(K(IL,3).EQ.IM) NM=NM+1
46380 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
46382 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
46383 & MOD(KFAM/1000,10).NE.0) NM=0
46385 KFAS=IABS(K(ISIS,2))
46386 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
46387 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
46392 C...Kinematics of one-particle decays.
46400 C...Calculate maximum weight ND-particle decay.
46403 WTMAX=1D0/WTCOR(ND-2)
46404 PMAX=PV(1,5)-PS+P(N+ND,5)
46406 DO 380 IL=ND-1,1,-1
46407 PMAX=PMAX+P(N+IL,5)
46408 PMIN=PMIN+P(N+IL+1,5)
46409 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
46413 C...Find virtual gamma mass in Dalitz decay.
46414 390 IF(ND.EQ.2) THEN
46415 ELSEIF(MMAT.EQ.2) THEN
46416 PMES=4D0*PMAS(11,1)**2
46417 PMRHO2=PMAS(131,1)**2
46418 PGRHO2=PMAS(131,2)**2
46419 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
46420 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
46421 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
46422 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
46423 IF(WT.LT.PYR(0)) GOTO 400
46424 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
46426 C...M-generator gives weight. If rejected, try again.
46431 DO 420 IL2=IL1-1,1,-1
46432 IF(RSAV.LE.RORD(IL2)) GOTO 430
46433 RORD(IL2+1)=RORD(IL2)
46435 430 RORD(IL2+1)=RSAV
46439 DO 450 IL=ND-1,1,-1
46440 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
46442 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
46444 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
46447 C...Perform two-particle decays in respective CM frame.
46448 460 DO 480 IL=1,ND-1
46449 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
46450 UE(3)=2D0*PYR(0)-1D0
46452 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
46453 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
46456 PV(IL+1,J)=-PA*UE(J)
46458 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
46459 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
46462 C...Lorentz transform decay products to lab frame.
46466 DO 530 IL=ND-1,1,-1
46468 BE(J)=PV(IL,J)/PV(IL,4)
46470 GA=PV(IL,4)/PV(IL,5)
46472 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
46474 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
46476 P(I,4)=GA*(P(I,4)+BEP)
46480 C...Check that no infinite loop in matrix element weight.
46482 IF(NTRY.GT.800) GOTO 560
46484 C...Matrix elements for omega and phi decays.
46486 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
46487 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
46488 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
46489 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
46491 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
46492 ELSEIF(MMAT.EQ.2) THEN
46493 FOUR12=FOUR(N+1,N+2)
46494 FOUR13=FOUR(N+1,N+3)
46495 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
46496 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
46497 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
46499 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
46500 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
46501 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
46502 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
46504 FOUR12=FOUR(IP,N+1)
46505 FOUR02=FOUR(IM,N+1)
46509 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
46510 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
46511 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
46512 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
46513 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
46514 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
46516 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
46517 ELSEIF(MMAT.EQ.4) THEN
46518 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
46519 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
46520 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
46521 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
46522 & ((1D0-HX3)/(HX1*HX2))**2
46523 IF(WT.LT.2D0*PYR(0)) GOTO 390
46524 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
46527 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
46528 ELSEIF(MMAT.EQ.41) THEN
46529 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
46530 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
46531 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
46533 C...Matrix elements for weak decays (only semileptonic for c and b)
46534 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
46535 & .AND.ND.EQ.3) THEN
46536 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
46537 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
46538 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
46539 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
46543 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
46546 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
46547 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
46548 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
46551 C...Scale back energy and reattach spectator.
46552 560 IF(MREM.EQ.1) THEN
46554 PV(1,J)=PV(1,J)/(1D0-PQT)
46560 C...Low invariant mass for system with spectator quark gives particle,
46561 C...not two jets. Readjust momenta accordingly.
46562 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
46564 PM2=PYMASS(K(N+2,2))
46566 PM3=PYMASS(K(N+3,2))
46567 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
46568 & (PARJ(32)+PM2+PM3)**2) GOTO 630
46571 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
46572 IF(K(N+2,2).EQ.0) GOTO 260
46573 P(N+2,5)=PYMASS(K(N+2,2))
46574 PS=P(N+1,5)+P(N+2,5)
46579 ELSEIF(MMAT.EQ.44) THEN
46581 PM3=PYMASS(K(N+3,2))
46583 PM4=PYMASS(K(N+4,2))
46584 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
46585 & (PARJ(32)+PM3+PM4)**2) GOTO 600
46588 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
46589 IF(K(N+3,2).EQ.0) GOTO 260
46590 P(N+3,5)=PYMASS(K(N+3,2))
46592 P(N+3,J)=P(N+3,J)+P(N+4,J)
46594 P(N+3,4)=SQRT(P(N+3,1)**2+P(N+3,2)**2+P(N+3,3)**2+P(N+3,5)**2)
46595 HA=P(N+1,4)**2-P(N+2,4)**2
46596 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
46597 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
46598 & (P(N+1,3)-P(N+2,3))**2
46599 HD=(PV(1,4)-P(N+3,4))**2
46600 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
46603 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
46605 PCOR=HH*(P(N+1,J)-P(N+2,J))
46606 P(N+1,J)=P(N+1,J)+PCOR
46607 P(N+2,J)=P(N+2,J)-PCOR
46609 P(N+1,4)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2+P(N+1,5)**2)
46610 P(N+2,4)=SQRT(P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2+P(N+2,5)**2)
46614 C...Check invariant mass of W jets. May give one particle or start over.
46615 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
46616 &.AND.IABS(K(N+1,2)).LT.10) THEN
46617 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
46619 PM1=PYMASS(K(N+1,2))
46621 PM2=PYMASS(K(N+2,2))
46622 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
46623 KFLDUM=INT(1.5D0+PYR(0))
46624 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
46625 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
46626 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
46627 PSM=PYMASS(KF1)+PYMASS(KF2)
46628 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
46629 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
46630 IF(MMAT.EQ.48) GOTO 390
46631 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
46634 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
46635 IF(K(N+1,2).EQ.0) GOTO 260
46636 P(N+1,5)=PYMASS(K(N+1,2))
46639 PS=P(N+1,5)+P(N+2,5)
46640 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
46647 C...Phase space decay of partons from W decay.
46648 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
46654 PV(1,J)=P(N+1,J)+P(N+2,J)
46663 PSQ=PYMASS(KFLO(1))
46665 PSQ=PSQ+PYMASS(KFLO(2))
46670 C...Boost back for rapidly moving particle.
46674 BE(J)=P(IP,J)/P(IP,4)
46678 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
46680 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
46682 P(I,4)=GA*(P(I,4)+BEP)
46686 C...Fill in position of decay vertex.
46694 C...Set up for parton shower evolution from jets.
46695 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
46699 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
46700 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
46701 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
46702 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
46703 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
46704 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
46706 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
46709 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
46710 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
46711 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
46712 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
46714 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
46715 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
46718 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
46719 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
46720 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
46721 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
46723 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
46724 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
46726 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
46731 KCP=PYCOMP(K(NSAV+1,2))
46732 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
46734 IF(KQP.LT.0) JCON=5
46735 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
46736 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
46737 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
46738 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
46740 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
46743 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
46744 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
46745 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
46746 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
46750 C...Mark decayed particle; special option for B-Bbar mixing.
46751 IF(K(IP,1).EQ.5) K(IP,1)=15
46752 IF(K(IP,1).LE.10) K(IP,1)=11
46753 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
46761 C*********************************************************************
46764 C...Handles flavour production in the decay of unstable particles
46765 C...and small string clusters.
46767 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
46769 C...Double precision and integer declarations.
46770 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46771 IMPLICIT INTEGER(I-N)
46772 INTEGER PYK,PYCHGE,PYCOMP
46774 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46775 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46776 SAVE /PYDAT1/,/PYDAT2/
46779 C.. Call PYKFDI directly if no popcorn option is on
46780 IF(MSTJ(12).LT.2) THEN
46781 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
46788 IF(KFL1.EQ.0) RETURN
46793 NMAX=MIN(MSTU(125),10)
46795 C.. Identify rank 0 cluster qq
46797 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
46800 C.. Join jets: Fails if store not empty
46801 IF(MSTU(121).GT.0) THEN
46805 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
46806 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
46807 C.. Pick popcorn meson from store, return same qq, decrease store
46808 KF=MSTU(NSTO+MSTU(121))
46810 MSTU(121)=MSTU(121)-1
46812 C.. Generate new flavour. Then done if no diquark is generated
46813 100 CALL PYKFDI(KFL1,0,KFL3,KF)
46814 IF(MSTU(121).EQ.-1) GOTO 100
46816 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
46818 C.. Simple case if no dynamical popcorn suppressions are considered
46819 IF(MSTJ(12).LT.4) THEN
46820 IF(MSTU(121).EQ.0) RETURN
46823 CALL PYKFDI(KFPREV,0,KFL3,KFM)
46824 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
46825 IF(IABS(KFL3).LE.10)THEN
46832 C test output qq against fake Gamma, then return if no popcorn.
46835 CALL PYZDIS(1,2103,5D0,Z)
46837 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
46842 IF(MSTU(121).EQ.0) RETURN
46844 C..Set store size memory. Pick fake dynamical variables of qq.
46846 CALL PYPTDI(1,PX3,PY3)
46852 C.. Pick next popcorn meson, test with fake dynamical variables
46856 CALL PYKFDI(KFPREV,0,KFL3,KFM)
46857 IF(MSTU(121).EQ.-1) GOTO 100
46858 CALL PYPTDI(KFL3,PX3,PY3)
46859 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
46860 CALL PYZDIS(KFPREV,KFL3,PM,Z)
46867 IF(MSTJ(12).GT.4)THEN
46868 POPMN=SQRT((1D0-X)*(G/X-GB))
46869 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
46870 PTST=EXP((POPM-POPMN)*PARF(193))
46875 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
46878 IF(RTST.GT.PTST*GTST)THEN
46880 IF(RTST.GT.PTST) MSTU(121)=-1
46885 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
46886 IF(MSTU(121).GT.0) GOTO 110
46888 C.. Test accepted system size. If OK set global popcorn size variable.
46889 IF(NMES.GT.NMAX)THEN
46900 C********************************************************************
46903 C...Generates a new flavour pair and combines off a hadron
46905 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
46907 C...Double precision and integer declarations.
46908 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46909 IMPLICIT INTEGER(I-N)
46910 INTEGER PYK,PYCHGE,PYCOMP
46912 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46913 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46914 SAVE /PYDAT1/,/PYDAT2/
46918 IF(MSTU(123).EQ.0.AND.MSTJ(12).GT.0) CALL PYKFIN
46920 C...Default flavour values. Input consistency checks.
46925 IF(KF1A.EQ.0) RETURN
46927 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
46928 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
46929 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
46932 C...Check if tabulated flavour probabilities are to be used.
46933 IF(MSTJ(15).EQ.1) THEN
46934 IF(MSTJ(12).GE.5) CALL PYERRM(29,
46935 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
46936 & ' together with MSTJ(12)>=5 modification')
46938 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
46939 KFL1A=MOD(KF1A/1000,10)
46940 KFL1B=MOD(KF1A/100,10)
46942 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
46943 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
46944 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
46945 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
46949 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
46950 KFL2A=MOD(KF2A/1000,10)
46951 KFL2B=MOD(KF2A/100,10)
46953 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
46954 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
46955 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
46957 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
46960 C.. Recognize rank 0 diquark case
46962 KFDIQ=MAX(KF1A,KF2A)
46963 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
46965 C.. Join two flavours to meson or baryon. Test for popcorn.
46968 IF(KFDIQ.GT.10) THEN
46969 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
46970 & CALL PYNMES(KFDIQ)
46971 IF(MSTU(121).NE.0) THEN
46982 C.. Separate incoming flavours, curtain flavour consistency check
46988 KFL1A=MOD(KF1A/1000,10)
46989 KFL1B=MOD(KF1A/100,10)
46992 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
46993 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
46994 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
46996 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
47000 KFQOLD=KFL1A+KFL1B-KFQPOP
47003 C...Meson/baryon choice. Set number of mesons if starting a popcorn
47006 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
47007 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
47011 ELSEIF(KF1A.GT.10)THEN
47013 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
47014 IF(MSTU(121).GT.0) MBARY=-1
47017 C..x->H+q: Choose single vertex quark. Jump to form hadron.
47018 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
47019 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
47020 KFL3=ISIGN(KFQVER,-KFIN)
47024 C..x->H+qq: (IDW=proper PARF position for diquark weights)
47027 IF(MSTU(121).EQ.0) IDW=150
47029 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
47030 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
47031 C.. Shift to s-curtain parameters if needed
47032 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
47033 PARF(194)=PARF(138)*PARF(139)
47034 PARF(193)=PARJ(8)+PARJ(9)
47038 C.. x->H+qq: Get vertex quark
47039 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
47041 MSTU(121)=MSTU(121)-1
47042 IF(IDW.EQ.170) THEN
47043 IF(MSTU(121).EQ.0)THEN
47044 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
47046 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
47049 IF(MSTU(121).EQ.0)THEN
47050 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
47052 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
47058 RMES=PYR(0)*PARF(194)
47060 RMES=RMES-PARF(IPOS+IMES)
47061 IF(IMES.EQ.30) THEN
47066 IF(RMES.GT.0D0) GOTO 120
47069 IF(KMUL.EQ.2) KFJ=10003
47070 IF(KMUL.EQ.3) KFJ=10001
47071 IF(KMUL.EQ.4) KFJ=20003
47072 IF(KMUL.EQ.5) KFJ=5
47074 KFQVER=MOD(IMES,5)+1
47075 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
47076 IF(KFQVER.GT.3)THEN
47081 IF(MBARY.EQ.-1) IDW=170
47083 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
47084 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
47085 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
47086 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
47088 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
47092 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
47094 IF(KFQPOP.NE.KFQVER)THEN
47096 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
47097 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
47098 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
47100 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
47102 KFL3=ISIGN(KFDIQ,KFIN)
47104 C..x->M+y: flavour for meson.
47105 130 IF(MBARY.LE.0)THEN
47106 KFLA=MAX(KFQOLD,KFQVER)
47107 KFLB=MIN(KFQOLD,KFQVER)
47109 IF(KFLA.NE.KFQOLD) KFS=-KFS
47110 C... Form meson, with spin and flavour mixing for diagonal states.
47111 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
47112 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
47113 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
47116 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
47117 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
47118 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
47119 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
47120 IF(PYR(0).LT.PARJ(14)) KMUL=2
47121 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
47123 IF(RMUL.LT.PARJ(15)) KMUL=3
47124 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
47125 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
47128 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
47129 IF(KMUL.EQ.5) KFLS=5
47130 IF(KFLA.NE.KFLB)THEN
47131 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
47134 IMIX=2*KFLA+10*KMUL
47135 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
47136 & INT(RMIX+PARF(IMIX)))+KFLS
47137 IF(KFLA.GE.4) KF=110*KFLA+KFLS
47139 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
47140 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
47142 C..Optional extra suppression of eta and eta'.
47143 C..Allow shift to qq->B+q in old version (set IRANK to 0)
47144 IF(KF.EQ.221.OR.KF.EQ.331)THEN
47145 IF(PYR(0).GT.PARJ(25+KF/300))THEN
47146 IF(KF2A.GT.0) GOTO 130
47147 IF(MSTJ(12).LT.4) IRANK=0
47153 C.. x->B+y: Flavour for baryon
47156 IF(KF1A.LE.10) KFLA=KFQOLD
47157 KFLB=MOD(KFDIQ/1000,10)
47158 KFLC=MOD(KFDIQ/100,10)
47159 KFLDS=MOD(KFDIQ,10)
47160 KFLD=MAX(KFLA,KFLB,KFLC)
47161 KFLF=MIN(KFLA,KFLB,KFLC)
47162 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
47164 C... SU(6) factors for formation of baryon.
47168 IF(KFLB.NE.KFLC)THEN
47171 IF(KFLB.GT.2) KDMAX=KDMAX+2
47173 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
47178 SU6MAX=PARF(140+KDMAX)
47181 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
47186 SU6OCT=PARF(60+KBARY)
47187 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
47188 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
47189 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
47191 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
47193 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
47195 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
47196 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
47198 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
47202 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
47205 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
47206 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
47208 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
47210 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
47211 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
47215 C...Use tabulated probabilities to select new flavour and hadron.
47216 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
47219 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
47222 ELSEIF(KTAB2.EQ.0) THEN
47231 DO 150 KT3=KT3L,KT3U
47232 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
47238 DO 170 KT3=KT3L,KT3U
47240 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
47241 IF(RFL.LE.0D0) GOTO 190
47246 C...Reconstruct flavour of produced quark/diquark.
47247 IF(KTAB3.LE.6) THEN
47250 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
47253 IF(KTAB3.GE.8) KFL3A=2
47254 IF(KTAB3.GE.11) KFL3A=3
47255 IF(KTAB3.GE.16) KFL3A=4
47256 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
47257 KFL3=1000*KFL3A+100*KFL3B+1
47258 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
47260 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
47263 C...Reconstruct meson code.
47264 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
47266 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
47267 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
47269 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
47270 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
47271 & 25*KTABS)) KF=330+2*KTABS+1
47272 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
47273 KFLA=MAX(KTAB1,KTAB3)
47274 KFLB=MIN(KTAB1,KTAB3)
47276 IF(KFLA.NE.KF1A) KFS=-KFS
47277 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
47278 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
47280 IF(KFL1A.EQ.KFL3A) THEN
47281 KFLA=MAX(KFL1B,KFL3B)
47282 KFLB=MIN(KFL1B,KFL3B)
47283 IF(KFLA.NE.KFL1B) KFS=-KFS
47284 ELSEIF(KFL1A.EQ.KFL3B) THEN
47288 ELSEIF(KFL1B.EQ.KFL3A) THEN
47291 ELSEIF(KFL1B.EQ.KFL3B) THEN
47292 KFLA=MAX(KFL1A,KFL3A)
47293 KFLB=MIN(KFL1A,KFL3A)
47294 IF(KFLA.NE.KFL1A) KFS=-KFS
47296 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
47299 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
47301 C...Reconstruct baryon code.
47303 IF(KTAB1.GE.7) THEN
47312 KFLD=MAX(KFLA,KFLB,KFLC)
47313 KFLF=MIN(KFLA,KFLB,KFLC)
47314 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
47315 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
47316 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
47319 C...Check that constructed flavour code is an allowed one.
47320 IF(KFL2.NE.0) KFL3=0
47323 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
47331 C*********************************************************************
47334 C...Generates number of popcorn mesons and stores some relevant
47337 SUBROUTINE PYNMES(KFDIQ)
47339 C...Double precision and integer declarations.
47340 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47341 IMPLICIT INTEGER(I-N)
47342 INTEGER PYK,PYCHGE,PYCOMP
47344 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47345 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47346 SAVE /PYDAT1/,/PYDAT2/
47349 IF(MSTJ(12).LT.2) RETURN
47351 C..Old version: Get 1 or 0 popcorn mesons
47352 IF(MSTJ(12).LT.5)THEN
47354 IF(KFDIQ.NE.0) THEN
47356 KFA=MOD(KFDIQA/1000,10)
47357 KFB=MOD(KFDIQA/100,10)
47360 IF(KFA.EQ.3) POPWT=PARF(133)
47361 IF(KFB.EQ.3) POPWT=PARF(134)
47362 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
47364 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
47368 C..New version: Store popcorn- or rank 0 diquark parameters
47371 PARF(194)=PARF(139)
47372 IF(KFDIQ.NE.0) THEN
47375 PARF(194)=PARF(140)
47377 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
47378 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
47379 & '(PYNMES:) Neglecting too large popcorn possibility')
47383 C..New version: Get number of popcorn mesons
47386 110 MSTU(121)=MSTU(121)+1
47387 RTST=RTST/PARF(194)
47388 IF(RTST.LT.1D0) GOTO 110
47389 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
47390 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
47394 C***************************************************************
47397 C...Precalculates a set of diquark and popcorn weights.
47401 C...Double precision and integer declarations.
47402 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47403 IMPLICIT INTEGER(I-N)
47404 INTEGER PYK,PYCHGE,PYCOMP
47406 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47407 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47408 SAVE /PYDAT1/,/PYDAT2/
47410 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
47414 C..Diquark indices for dimensional variables
47423 C.. *** SU(6) factors **
47424 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
47426 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
47427 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
47428 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
47431 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
47433 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
47434 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
47436 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
47437 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
47440 C..SU(6)max q q' s,c,b
47441 SU6MUD =MAX(SU6(1) , SU6(8) )
47442 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
47443 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
47444 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
47445 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
47446 SU6M(IUS0)=SU6M(ISU0)
47447 SU6M(ISS1)=SU6M(IUU1)
47448 SU6M(IUS1)=SU6M(ISU1)
47450 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
47452 PARF(142)=SU6M(IUD1)
47453 PARF(143)=SU6M(ISU0)
47454 PARF(144)=SU6M(ISU1)
47455 PARF(145)=SU6M(ISS1)
47457 C..diquark SU(6) survival =
47458 C..sum over quark (quark tunnel weight)*(SU(6)).
47459 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
47460 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
47461 DMB(IUS0)=DMB(ISU0)
47462 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
47463 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
47464 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
47465 DMB(IUS1)=DMB(ISU1)
47466 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
47468 C.. *** Tunneling factors for Diquark production***
47469 C.. T: half a curtain pair = sqrt(curtain pair factor)
47470 IF(MSTJ(12).GE.5) THEN
47472 PMUD1=PYMASS(2103)-PMUD0
47473 PMUS0=PYMASS(3201)-PMUD0
47474 PMUS1=PYMASS(3203)-PMUS0-PMUD0
47475 PMSS1=PYMASS(3303)-PMUS0-PMUD0
47476 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
47477 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
47478 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
47479 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
47480 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
47481 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
47482 QBB(IUD1)=QBB(IUU1)
47484 PAR2M=SQRT(PARJ(2))
47485 PAR3M=SQRT(PARJ(3))
47486 PAR4M=SQRT(PARJ(4))
47487 QBB(ISU0)=PAR2M*PAR3M
47489 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
47491 QBB(ISU1)=PAR4M*QBB(ISU0)
47492 QBB(IUS1)=PAR4M*QBB(IUS0)
47496 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
47497 QBM(ISU0)=QBB(ISU0)
47498 QBM(IUS0)=PARJ(2)*QBB(IUS0)
47499 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
47500 QBM(IUU1)=6D0*QBB(IUU1)
47501 QBM(ISU1)=3D0*QBB(ISU1)
47502 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
47503 QBM(IUD1)=3D0*QBB(IUD1)
47505 C.. Combine T and tau to diquark weight for q-> B+B+..
47507 QBB(I)=QBB(I)*QBM(I)
47510 IF(MSTJ(12).GE.5)THEN
47511 C..New version: tau for rank 0 diquark.
47512 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
47513 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
47514 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
47515 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
47516 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
47517 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
47518 DMB(7+IUD1)=DMB(7+IUU1)/2D0
47520 C..New version: curtain flavour ratios.
47521 C.. s/u for q->B+M+...
47522 C.. s/u for rank 0 diquark: su -> ...M+B+...
47523 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
47524 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
47525 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
47526 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
47527 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
47528 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
47529 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
47531 C..Old version: reset unused rank 0 diquark weights and
47532 C.. unused diquark SU(6) survival weights
47534 IF(MSTJ(12).LT.3) DMB(I)=1D0
47538 C..Old version: Shuffle PARJ(7) into tau
47539 QBM(IUS0)=QBM(IUS0)*PARJ(7)
47540 QBM(ISS1)=QBM(ISS1)*PARJ(7)
47541 QBM(IUS1)=QBM(IUS1)*PARJ(7)
47543 C..Old version: curtain flavour ratios.
47544 C.. s/u for q->B+M+...
47545 C.. s/u for rank 0 diquark: su -> ...M+B+...
47546 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
47547 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
47548 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
47549 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
47550 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
47553 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
47554 C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
47556 DMB(7+I)=DMB(7+I)*DMB(I)
47557 DMB(I)=DMB(I)*QBM(I)
47558 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
47559 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
47562 C.. *** Popcorn factors ***
47564 IF(MSTJ(12).LT.5)THEN
47565 C.. Old version: Resulting popcorn weights.
47567 WS=PARF(135)*PARF(138)
47569 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
47571 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
47572 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
47573 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
47574 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
47575 & (1D0+QBB(IUD1)+QBB(IUU1)+
47576 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
47578 C..New version: Store weights for popcorn mesons,
47579 C..get prel. popcorn weights.
47580 DO 150 IPOS=201,1400
47589 IF(MR.EQ.7) PARF(193)=PARJ(10)
47590 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
47591 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
47592 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
47594 IF(NMES.EQ.1) SQWT=PARJ(2)
47596 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
47597 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
47598 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
47600 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
47601 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
47604 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
47606 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
47607 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
47613 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
47614 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
47615 IF(PJWT.LE.0D0) GOTO 190
47616 IF(PJWT.GT.1D0) PJWT=1D0
47618 IMIX=2*KFQOLD+10*KMUL
47620 IF(KMUL.EQ.2) KFJ=10003
47621 IF(KMUL.EQ.3) KFJ=10001
47622 IF(KMUL.EQ.4) KFJ=20003
47623 IF(KMUL.EQ.5) KFJ=5
47625 KFLA=MAX(KFQOLD,KFQVER)
47626 KFLB=MIN(KFQOLD,KFQVER)
47627 SWT=PARJ(11+KFLA/3+KFLA/4)
47628 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
47630 QWT=SQWT/(2D0+SQWT)
47631 IF(KFQVER.LT.3)THEN
47632 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
47633 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
47635 IF(KFQVER.NE.KFQOLD)THEN
47637 KFM=100*KFLA+10*KFLB+KFJ
47638 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
47639 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
47640 WTTOT=WTTOT+PARF(IPOS+IMES)
47643 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
47644 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
47645 IF(ID.EQ.5) DWT=PARF(IMIX)
47647 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
47648 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
47649 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
47650 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
47651 PARF(IPOS+5*KMUL+ID)=
47652 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
47654 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
47660 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
47662 IF(MR.EQ.7) PARF(140)=
47663 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
47664 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
47665 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
47671 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
47676 C..Recombine diquark weights to flavour and spin ratios
47677 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
47678 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
47679 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
47680 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
47681 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
47682 PARF(155)=QBB(ISU1)/QBB(ISU0)
47683 PARF(156)=QBB(IUS1)/QBB(IUS0)
47684 PARF(157)=QBB(IUD1)
47686 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
47687 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
47688 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
47689 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
47690 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
47691 PARF(165)=QBM(ISU1)/QBM(ISU0)
47692 PARF(166)=QBM(IUS1)/QBM(IUS0)
47693 PARF(167)=QBM(IUD1)
47695 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
47696 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
47697 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
47698 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
47699 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
47700 PARF(175)=DMB(ISU1)/DMB(ISU0)
47701 PARF(176)=DMB(IUS1)/DMB(IUS0)
47702 PARF(177)=DMB(IUD1)
47704 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
47705 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
47706 PARF(187)=DMB(7+IUD1)
47712 C*********************************************************************
47715 C...Generates transverse momentum according to a Gaussian.
47717 SUBROUTINE PYPTDI(KFL,PX,PY)
47719 C...Double precision and integer declarations.
47720 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47721 IMPLICIT INTEGER(I-N)
47722 INTEGER PYK,PYCHGE,PYCOMP
47724 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47727 C...Generate p_T and azimuthal angle, gives p_x and p_y.
47729 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
47730 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
47731 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
47732 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
47740 C*********************************************************************
47743 C...Generates the longitudinal splitting variable z.
47745 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
47747 C...Double precision and integer declarations.
47748 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47749 IMPLICIT INTEGER(I-N)
47750 INTEGER PYK,PYCHGE,PYCOMP
47752 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47753 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47754 SAVE /PYDAT1/,/PYDAT2/
47756 C...Check if heavy flavour fragmentation.
47760 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
47762 C...Lund symmetric scaling function: determine parameters of shape.
47763 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
47764 &MSTJ(11).GE.4) THEN
47766 IF(MSTJ(91).EQ.1) FA=PARJ(43)
47767 IF(KFLB.GE.10) FA=FA+PARJ(45)
47769 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
47772 IF(KFLA.GE.10) FC=FC-PARJ(45)
47773 IF(KFLB.GE.10) FC=FC+PARJ(45)
47774 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
47776 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
47777 FC=FC+FRED*FBB*PARF(100+KFLH)**2
47780 IF(ABS(FC-1D0).GT.0.01D0) MC=2
47782 C...Determine position of maximum. Special cases for a = 0 or a = c.
47783 IF(FA.LT.0.02D0) THEN
47786 IF(FC.GT.FB) ZMAX=FB/FC
47787 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
47792 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
47793 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
47796 C...Subdivide z range if distribution very peaked near endpoint.
47798 IF(ZMAX.LT.0.1D0) THEN
47804 ZDIVC=ZDIV**(1D0-FC)
47805 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
47807 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
47809 FSCB=SQRT(4D0+(FC/FB)**2)
47810 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
47811 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
47812 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
47813 FINT=1D0+FB*(1D0-ZDIV)
47816 C...Choice of z, preweighted for peaks at low or high z.
47820 IF(FINT*PYR(0).LE.1D0) THEN
47822 ELSEIF(MC.EQ.1) THEN
47826 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
47829 ELSEIF(MMAX.EQ.3) THEN
47830 IF(FINT*PYR(0).LE.1D0) THEN
47832 FPRE=EXP(FB*(Z-ZDIV))
47834 Z=ZDIV+Z*(1D0-ZDIV)
47838 C...Weighting according to correct formula.
47839 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
47840 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
47841 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
47842 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
47843 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
47845 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
47847 FC=PARJ(50+MAX(1,KFLH))
47848 IF(MSTJ(91).EQ.1) FC=PARJ(59)
47850 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
47851 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
47852 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
47853 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
47856 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
47857 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
47864 C*********************************************************************
47867 C...Generates timelike parton showers from given partons.
47869 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
47871 C...Double precision and integer declarations.
47872 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47873 IMPLICIT INTEGER(I-N)
47874 INTEGER PYK,PYCHGE,PYCOMP
47875 C...Parameter statement to help give large particle numbers.
47876 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47877 &KEXCIT=4000000,KDIMEN=5000000)
47879 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
47880 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47881 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47882 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
47884 DIMENSION PMTH(5,50),PS(5),PMA(19),PMSD(10),IEP(10),IPA(10),
47885 &KFLA(10),KFLD(10),KFL(10),ITRY(10),ISI(10),ISL(10),DP(10),
47886 &DPT(5,4),KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
47887 &PHIIIS(2,2),ISII(2),ISSET(3),ISCOL(0:40),ISCHG(0:40),
47890 C...Check that QMAX not too low.
47891 IF(MSTJ(41).LE.0) THEN
47893 ELSEIF(MSTJ(41).EQ.1) THEN
47894 IF(QMAX.LE.PARJ(82).AND.IP2.GT.-8) RETURN
47896 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GT.-8)
47900 C...Initialization of cutoff masses etc.
47908 PMTH(1,21)=PYMASS(21)
47909 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
47910 PMTH(3,21)=2D0*PMTH(2,21)
47911 PMTH(4,21)=PMTH(3,21)
47912 PMTH(5,21)=PMTH(3,21)
47913 PMTH(1,22)=PYMASS(22)
47914 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
47915 PMTH(3,22)=2D0*PMTH(2,22)
47916 PMTH(4,22)=PMTH(3,22)
47917 PMTH(5,22)=PMTH(3,22)
47919 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
47920 PMQT1E=MIN(PMQTH1,PARJ(90))
47922 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
47923 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
47926 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
47928 PMTH(1,IFL)=PYMASS(IFL)
47929 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
47930 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
47931 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
47932 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
47935 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
47936 IF(MSTJ(41).GE.2) KSH(IFL)=1
47937 PMTH(1,IFL)=PYMASS(IFL)
47938 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
47939 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
47940 PMTH(4,IFL)=PMTH(3,IFL)
47941 PMTH(5,IFL)=PMTH(3,IFL)
47943 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
47945 ALFM=LOG(PT2MIN/ALAMS)
47947 C...Store positions of shower initiating partons.
47949 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
47952 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
47957 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
47958 & .AND.IP2.GE.-7) THEN
47963 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
47971 & '(PYSHOW:) failed to reconstruct showering system')
47972 IF(MSTU(21).GE.1) RETURN
47975 C...Check on phase space available for emission.
47982 KFLA(I)=IABS(K(IPA(I),2))
47984 C...Special cutoff masses for initial partons (may be a heavy quark,
47985 C...squark, ..., and need not be on the mass shell).
47987 IF(NPA.LE.1) IREF(I)=IR
47988 IF(NPA.GE.2) IREF(I+1)=IR
47989 IF(KFLA(I).LE.8) THEN
47991 IF(MSTJ(41).GE.2) ISCHG(IR)=1
47992 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
47993 & KFLA(I).EQ.17) THEN
47994 IF(MSTJ(41).GE.2) ISCHG(IR)=1
47995 ELSEIF(KFLA(I).EQ.21) THEN
47997 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
47998 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
48000 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
48003 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
48005 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
48006 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
48007 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
48008 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
48009 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
48010 ELSEIF(ISCOL(IR).EQ.1) THEN
48011 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
48012 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
48013 PMTH(4,IR)=PMTH(3,IR)
48014 PMTH(5,IR)=PMTH(3,IR)
48015 ELSEIF(ISCHG(IR).EQ.1) THEN
48016 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
48017 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
48018 PMTH(4,IR)=PMTH(3,IR)
48019 PMTH(5,IR)=PMTH(3,IR)
48021 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
48023 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
48025 PS(J)=PS(J)+P(IPA(I),J)
48028 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
48029 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
48030 IF(NPA.EQ.1) PS(5)=PS(4)
48031 IF(PS(5).LE.PM+PMQT1E) RETURN
48033 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
48036 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
48037 KFSRCE=IABS(K(K(IP1,3),2))
48039 IPAR1=MAX(1,K(IP1,3))
48040 IPAR2=MAX(1,K(IP2,3))
48041 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
48042 & KFSRCE=IABS(K(K(IPAR1,3),2))
48045 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
48046 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
48047 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
48048 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
48049 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
48050 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
48051 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
48052 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
48054 C...Identify two primary showerers.
48056 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
48057 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
48058 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
48059 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
48060 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
48061 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
48062 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
48063 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
48065 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
48066 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
48067 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
48068 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
48069 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
48070 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
48071 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
48072 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
48074 C...Order of showerers. Presence of gluino.
48075 ITYPMN=MIN(ITYPE1,ITYPE2)
48076 ITYPMX=MAX(ITYPE1,ITYPE2)
48078 IF(ITYPE1.GT.ITYPE2) IORD=2
48080 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
48082 C...Check if 3-jet matrix elements to be used.
48085 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
48086 IF(MSTJ(38).NE.0) THEN
48090 ELSEIF(MSTJ(47).GE.6) THEN
48096 C...Vector/axial vector -> q + qbar; q -> q + V.
48097 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
48098 & ITYPES.EQ.3)) THEN
48100 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
48102 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
48103 & K(IP1,2)+K(IP2,2).EQ.0)) THEN
48104 C...gamma*/Z0: assume e+e- initial state if unknown.
48106 IF(KFSRCE.EQ.23) THEN
48107 IANNFL=K(K(IP1,3),3)
48108 IF(IANNFL.NE.0) THEN
48109 KANNFL=IABS(K(IANNFL,2))
48110 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
48113 AI=SIGN(1D0,EI+0.1D0)
48114 VI=AI-4D0*EI*PARU(102)
48115 EF=KCHG(KFLA(1),1)/3D0
48116 AF=SIGN(1D0,EF+0.1D0)
48117 VF=AF-4D0*EF*PARU(102)
48118 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
48121 SQWZ=PS(5)*PMAS(23,2)
48122 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
48123 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
48124 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
48125 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
48127 ALPHA=VECT/(VECT+AXIV)
48128 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
48131 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
48132 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
48134 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
48135 & ITYPES.EQ.1)) THEN
48138 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
48139 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
48141 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
48143 ELSEIF(KFSRCE.EQ.36) THEN
48146 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
48147 & ITYPES.EQ.1)) THEN
48150 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
48151 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
48152 & ITYPES.EQ.3)) THEN
48154 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
48155 & ITYPES.EQ.2)) THEN
48157 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
48159 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
48160 & ITYPES.EQ.2)) THEN
48163 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
48164 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
48165 & ITYPES.EQ.5)) THEN
48167 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
48168 & ITYPES.EQ.2)) THEN
48170 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
48171 & ITYPES.EQ.1)) THEN
48174 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
48175 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
48177 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
48178 & ITYPES.EQ.2)) THEN
48180 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
48181 & ITYPES.EQ.1)) THEN
48184 C...g -> ~g + ~g (eikonal approximation).
48185 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
48188 M3JC=5*ICLASS+ICOMBI
48192 C...Find if interference with initial state partons.
48194 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
48199 KCA=PYCOMP(KFLA(I))
48200 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
48202 IF(KCII(I).NE.0) THEN
48204 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
48205 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
48206 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
48208 IIIS(I,NIIS(I))=ICSI
48213 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
48216 C...Boost interfering initial partons to rest frame
48217 C...and reconstruct their polar and azimuthal angles.
48221 K(N+I,J)=K(IPA(I),J)
48222 P(N+I,J)=P(IPA(I),J)
48226 DO 220 I=3,2+NIIS(1)
48228 K(N+I,J)=K(IIIS(1,I-2),J)
48229 P(N+I,J)=P(IIIS(1,I-2),J)
48233 DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
48235 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
48236 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
48240 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
48241 & -PS(2)/PS(4),-PS(3)/PS(4))
48242 PHI=PYANGL(P(N+1,1),P(N+1,2))
48243 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
48244 THE=PYANGL(P(N+1,3),P(N+1,1))
48245 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
48246 DO 250 I=3,2+NIIS(1)
48247 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
48248 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
48250 DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
48251 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
48252 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
48253 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
48257 C...Boost 3 or more partons to their rest frame.
48258 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
48259 &-PS(2)/PS(4),-PS(3)/PS(4))
48261 C...Define imagined single initiator of shower for parton system.
48263 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
48264 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
48265 IF(MSTU(21).GE.1) RETURN
48284 C...Loop over partons that may branch.
48287 IF(NPA.EQ.1) IM=NS-1
48290 IF(IM.GT.N) GOTO 590
48293 IF(KSH(IR).EQ.0) GOTO 280
48294 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 280
48299 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
48300 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
48301 IF(MSTU(21).GE.1) RETURN
48304 C...Position of aunt (sister to branching parton).
48305 C...Origin and flavour of daughters.
48308 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
48309 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
48321 K(N+I,2)=K(IPA(I),2)
48323 ELSEIF(KFLM.NE.21) THEN
48326 IREF(N+1-NS)=IREF(IM-NS)
48327 IREF(N+2-NS)=IABS(K(N+2,2))
48328 ELSEIF(K(IM,5).EQ.21) THEN
48336 IREF(N+1-NS)=IABS(K(N+1,2))
48337 IREF(N+2-NS)=IABS(K(N+2,2))
48340 C...Reset flags on daughters and tries made.
48345 KFLD(IP)=IABS(K(N+IP,2))
48346 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
48350 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
48354 C...Maximum virtuality of daughters.
48357 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
48358 P(N+I,5)=MIN(QMAX,PS(5))
48360 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
48361 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
48364 IF(MSTJ(43).LE.2) PEM=V(IM,2)
48365 IF(MSTJ(43).GE.3) PEM=P(IM,4)
48366 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
48367 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
48368 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
48372 IF(ISI(I).EQ.1) THEN
48374 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
48376 V(N+I,5)=P(N+I,5)**2
48379 C...Choose one of the daughters for evolution.
48381 IF(NEP.EQ.1) INUM=1
48383 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
48386 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
48388 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
48394 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
48395 RPM=P(N+I,5)/PMSD(I)
48397 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
48405 C...Cancel choice of predetermined daughter already treated.
48408 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
48409 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
48410 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
48411 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
48412 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
48415 C...Store information on choice of evolving daughter.
48419 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
48422 KFL(I)=IABS(K(IEP(I),2))
48424 ITRY(INUM)=ITRY(INUM)+1
48425 IF(ITRY(INUM).GT.200) THEN
48426 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
48427 IF(MSTU(21).GE.1) RETURN
48431 IF(KSH(IR).EQ.0) GOTO 440
48432 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 440
48434 C...Check if evolution already predetermined for daughter.
48436 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
48437 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
48438 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
48439 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
48440 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
48443 IF(IPSPD.NE.0) ISSET(INUM)=1
48445 C...Select side for interference with initial state partons.
48446 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
48449 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
48451 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
48452 IF(PYR(0).GT.0.5D0) ISII(III)=1
48453 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
48455 IF(PYR(0).GT.0.5D0) ISII(III)=2
48459 C...Calculate allowed z range.
48462 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
48465 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
48466 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
48468 IF(MOD(MSTJ(43),2).EQ.1) THEN
48470 ZCE=PMTH(2,22)/PMED
48471 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
48473 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
48474 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
48476 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
48477 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
48478 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
48481 ZCE=MIN(ZCE,0.49991D0)
48482 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
48483 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
48484 P(IEP(1),5)=PMTH(1,IR)
48485 V(IEP(1),5)=P(IEP(1),5)**2
48489 C...Integral of Altarelli-Parisi z kernel for QCD.
48490 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
48491 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
48492 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
48493 ELSEIF(MSTJ(49).EQ.0) THEN
48494 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
48495 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
48497 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
48498 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
48499 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
48500 ELSEIF(MSTJ(49).EQ.1) THEN
48501 FBR=(1D0-2D0*ZC)/3D0
48502 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
48504 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
48505 ELSEIF(KFL(1).EQ.21) THEN
48506 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
48508 FBR=2D0*LOG((1D0-ZC)/ZC)
48511 C...Reset QCD probability for colourless.
48512 IF(ISCOL(IR).EQ.0) FBR=0D0
48514 C...Integral of Altarelli-Parisi kernel for photon emission.
48516 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
48517 IF(KFL(1).LE.18) THEN
48518 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
48520 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
48523 C...Inner veto algorithm starts. Find maximum mass for evolution.
48524 400 PMS=V(IEP(1),5)
48529 IRI=IREF(IEP(I)-NS)
48530 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
48533 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
48536 C...Select mass for daughter in QCD evolution.
48538 DO 420 IFF=4,MSTJ(45)
48539 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
48541 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
48542 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
48543 C...Already predetermined choice.
48544 IF(IPSPD.NE.0) THEN
48545 PMSQCD=P(IPSPD,5)**2
48546 ELSEIF(FBR.LT.1D-3) THEN
48548 ELSEIF(MSTJ(44).LE.0) THEN
48549 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
48550 ELSEIF(MSTJ(44).EQ.1) THEN
48551 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
48553 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
48555 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
48556 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
48557 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
48561 C...Select mass for daughter in QED evolution.
48562 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
48563 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
48564 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
48565 IF(FBRE.LT.1D-3) THEN
48568 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
48569 & (PARU(101)*FBRE)))
48571 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
48572 PMSQED=PMSQED+PMTH(1,IR)**2
48573 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
48575 IF(PMSQED.GT.PMSQCD) THEN
48581 C...Check whether daughter mass below cutoff.
48582 P(IEP(1),5)=SQRT(V(IEP(1),5))
48583 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
48584 P(IEP(1),5)=PMTH(1,IR)
48585 V(IEP(1),5)=P(IEP(1),5)**2
48589 C...Already predetermined choice of z, and flavour in g -> qqbar.
48590 IF(IPSPD.NE.0) THEN
48593 PMSGD1=P(IPSGD1,5)**2
48594 PMSGD2=P(IPSGD2,5)**2
48595 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
48596 & 4D0*PMSGD1*PMSGD2))
48597 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
48598 & PMSGD1+PMSGD2)/ALAMPS
48599 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
48600 IF(KFL(1).NE.21) THEN
48603 K(IEP(1),5)=IABS(K(IPSGD1,2))
48606 C...Select z value of branching: q -> qgamma.
48607 ELSEIF(MCE.EQ.2) THEN
48608 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
48609 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 400
48612 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
48613 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
48614 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
48615 C...Only do z weighting when no ME correction afterwards.
48616 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 400
48618 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
48619 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
48620 IF(PYR(0).GT.0.5D0) Z=1D0-Z
48621 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 400
48623 ELSEIF(MSTJ(49).NE.1) THEN
48625 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 400
48626 KFLB=1+INT(MSTJ(45)*PYR(0))
48627 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
48628 IF(PMQ.GE.1D0) GOTO 400
48629 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
48630 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 400
48631 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
48632 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
48633 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 400
48635 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 400
48639 C...Ditto for scalar gluon model.
48640 ELSEIF(KFL(1).NE.21) THEN
48641 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
48643 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
48644 Z=ZC+(1D0-2D0*ZC)*PYR(0)
48647 Z=ZC+(1D0-2D0*ZC)*PYR(0)
48648 KFLB=1+INT(MSTJ(45)*PYR(0))
48649 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
48650 IF(PMQ.GE.1D0) GOTO 400
48654 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
48655 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
48656 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
48657 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
48658 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 400
48660 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
48661 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
48662 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
48663 IF(PT2APP.LT.PT2MIN) GOTO 400
48664 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 400
48668 C...Check if z consistent with chosen m.
48669 IF(KFL(1).EQ.21) THEN
48670 IRGD1=IABS(K(IEP(1),5))
48674 IRGD2=IABS(K(IEP(1),5))
48678 ELSEIF(NEP.GE.3) THEN
48680 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
48681 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
48683 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
48684 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
48686 IF(MOD(MSTJ(43),2).EQ.1) THEN
48687 PMQTH3=0.5D0*PARJ(82)
48688 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
48689 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
48690 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
48691 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
48692 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
48696 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
48699 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
48700 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
48701 ELSEIF(IPSPD.NE.0) THEN
48705 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 400
48707 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
48709 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
48711 C...Width suppression for q -> q + g.
48712 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
48714 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
48718 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
48719 IF(MSTJ(40).EQ.1) THEN
48720 IF(CHI.LT.PYR(0)) GOTO 400
48721 ELSEIF(MSTJ(40).EQ.2) THEN
48722 IF(1D0-CHI.LT.PYR(0)) GOTO 400
48726 C...Three-jet matrix element correction.
48731 C...QED matrix elements: only for massless case so far.
48732 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
48733 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
48734 X2=1D0-V(IEP(1),5)/V(NS+1,5)
48735 X3=(1D0-X1)+(1D0-X2)
48737 KI2=K(IPA(3-INUM),2)
48738 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
48739 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
48740 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
48741 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
48742 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
48743 ELSEIF(MCE.EQ.2) THEN
48745 C...QCD matrix elements, including mass effects.
48746 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
48750 IF(IR.GE.31.AND.IGM.EQ.0) THEN
48751 C...QCD ME: original parton, first branching.
48752 PM2ME=PMTH(1,63-IR)
48754 ELSEIF(IR.GE.31) THEN
48755 C...QCD ME: original parton, subsequent branchings.
48756 PM2ME=PMTH(1,63-IR)
48757 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
48758 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
48759 ELSEIF(K(IM,2).EQ.21) THEN
48760 C...QCD ME: secondary partons, first branching.
48763 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
48764 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
48765 & 4D0*PS1ME*PM2ME**2))
48766 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
48768 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
48771 C...QCD ME: secondary partons, subsequent branchings.
48773 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
48774 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
48777 C...Construct ME variables.
48780 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
48781 X2=1D0+R2ME**2-PS1ME/ECMME**2
48782 C...Call ME, with right order important for two inequivalent showerers.
48783 IF(IR.EQ.IORD+30) THEN
48784 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
48786 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
48788 C...Split up total ME when two radiating partons.
48790 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
48791 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
48792 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
48793 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
48794 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
48795 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
48796 & MAX(1D-10,2D0-X1-X2)
48797 C...Evaluate shower rate to be compared with.
48798 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
48799 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
48800 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
48801 ELSEIF(MSTJ(49).NE.1) THEN
48803 C...Toy model scalar theory matrix elements; no mass effects.
48805 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
48806 X2=1D0-V(IEP(1),5)/V(NS+1,5)
48807 X3=(1D0-X1)+(1D0-X2)
48808 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
48810 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
48814 IF(WME.LT.PYR(0)*WSHOW) GOTO 400
48817 C...Impose angular ordering by rejection of nonordered emission.
48818 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
48819 PEMAO=V(IM,1)*P(IM,4)
48820 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
48821 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
48823 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
48824 & .OR.MSTJ(42).EQ.7)) THEN
48826 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
48827 & .OR.MSTJ(42).EQ.6)) THEN
48829 PMDAO=PMTH(2,K(IEP(1),5))
48830 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
48833 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
48834 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
48835 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
48839 430 IF(K(IAOM,5).EQ.22) THEN
48841 IF(K(IAOM,3).LE.NS) MAOM=0
48842 IF(MAOM.EQ.1) GOTO 430
48844 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
48845 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
48846 IF(THE2ID.LT.THE2IM) GOTO 400
48850 C...Impose user-defined maximum angle at first branching.
48851 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
48852 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
48853 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
48854 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400
48855 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
48856 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
48857 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400
48858 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
48859 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
48860 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 400
48864 C...Impose angular constraint in first branching from interference
48865 C...with initial state partons.
48866 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
48867 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
48868 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
48869 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 400
48870 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
48871 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 400
48875 C...End of inner veto algorithm. Check if only one leg evolved so far.
48879 IF(NEP.EQ.1) GOTO 480
48880 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 340
48883 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
48884 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 340
48888 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
48892 PMSUM=PMSUM+P(N+I,5)
48894 IF(PMSUM.GE.PS(5)) GOTO 340
48895 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
48898 IF(KSH(IRDA).EQ.0) GOTO 470
48899 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 470
48900 IF(IRDA.EQ.21) THEN
48901 IRGD1=IABS(K(I1,5))
48905 IRGD2=IABS(K(I1,5))
48908 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
48909 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
48911 IF(I1.EQ.N+1) ZM=V(IM,1)
48912 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
48913 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
48914 & 4D0*V(N+1,5)*V(N+2,5))
48915 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
48918 IF(MOD(MSTJ(43),2).EQ.1) THEN
48919 PMQTH3=0.5D0*PARJ(82)
48920 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
48921 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
48922 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
48923 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
48924 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
48928 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
48931 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
48932 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
48936 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
48937 & ISSET(1).EQ.0) THEN
48939 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
48940 & ISSET(2).EQ.0) THEN
48944 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
48946 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
48948 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
48951 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
48952 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
48953 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
48954 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
48955 IF(ISL(1).EQ.1) ISL(2)=0
48956 IF(ISL(1).EQ.0) ISLM=1
48957 IF(ISL(2).EQ.0) ISLM=2
48959 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 340
48964 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
48965 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
48966 PMQ1=V(N+1,5)/V(IM,5)
48967 PMQ2=V(N+2,5)/V(IM,5)
48968 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
48973 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 340
48977 C...Accepted branch. Construct four-momentum for initial partons.
48983 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
48985 P(N+1,4)=P(IPA(1),4)
48987 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
48988 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
48991 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
48996 P(N+2,4)=P(IM,5)-PED1
48999 ELSEIF(NEP.GE.3) THEN
49000 C...Rescale all momenta for energy conservation.
49006 P(N+I,J)=P(IPA(I),J)
49009 PQS=PQS+P(N+I,5)**2/P(N+I,4)
49012 FAC=(PS(5)-PQS)/(PES-PQS)
49017 P(N+I,J)=FAC*P(N+I,J)
49019 P(N+I,4)=SQRT(P(N+I,5)**2+P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
49022 PQS=PQS+P(N+I,5)**2/P(N+I,4)
49024 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 510
49026 C...Construct transverse momentum for ordinary branching in shower.
49030 540 LOOPPT=LOOPPT+1
49031 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
49032 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
49033 IF(PZM.LE.0D0) THEN
49035 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
49036 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
49037 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
49038 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
49039 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
49040 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
49042 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
49044 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
49047 ELSEIF(PTS.LT.0D0) THEN
49050 PT=SQRT(MAX(0D0,PTS))
49052 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
49054 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
49055 & .AND.IAU.NE.0) THEN
49056 IF(K(IGM,3).NE.0) MAZIP=1
49058 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
49059 IF(MAZIP.EQ.0) ZAU=0D0
49060 IF(K(IGM,2).NE.21) THEN
49061 HAZIP=2D0*ZAU/(1D0+ZAU**2)
49063 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
49065 IF(K(N+1,2).NE.21) THEN
49066 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
49068 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
49072 C...Find coefficient of azimuthal asymmetry due to soft gluon
49075 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
49076 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
49077 IF(K(IGM,3).NE.0) MAZIC=N+1
49078 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
49079 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
49080 & ZM.GT.0.5D0) MAZIC=N+2
49081 IF(K(IAU,2).EQ.22) MAZIC=0
49083 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
49085 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
49086 IF(MAZIC.EQ.0) ZGM=1D0
49087 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
49088 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
49089 HAZIC=MIN(0.95D0,HAZIC)
49093 C...Construct energies for ordinary branching in shower.
49094 550 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
49095 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
49096 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
49097 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
49098 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
49099 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
49100 P(N+1,4)=PEM*V(IM,1)
49102 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
49103 & SQRT(PMLS)*ZM)/V(IM,5)
49106 C...Already predetermined choice of phi angle or not
49108 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
49110 IF(K(IPSPD,4).GT.0) THEN
49112 IF(IM.EQ.NS+2) THEN
49113 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
49115 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
49118 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
49120 IF(K(IPSPD,4).GT.0) THEN
49122 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
49123 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
49124 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
49125 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
49126 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
49127 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
49131 C...Construct momenta for ordinary branching in shower.
49132 P(N+1,1)=PT*COS(PHI)
49133 P(N+1,2)=PT*SIN(PHI)
49134 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
49135 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
49136 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
49137 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
49138 ELSEIF(PZM.GT.0D0) THEN
49139 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
49140 & 2D0*PEM*P(N+1,4))/PZM
49146 P(N+2,3)=PZM-P(N+1,3)
49147 P(N+2,4)=PEM-P(N+1,4)
49148 IF(MSTJ(43).LE.2) THEN
49149 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
49150 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
49154 C...Rotate and boost daughters.
49156 IF(MSTJ(43).LE.2) THEN
49157 BEX=P(IGM,1)/P(IGM,4)
49158 BEY=P(IGM,2)/P(IGM,4)
49159 BEZ=P(IGM,3)/P(IGM,4)
49160 GA=P(IGM,4)/P(IGM,5)
49161 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
49170 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
49171 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
49172 IF(PTIMB.GT.1D-4) THEN
49173 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
49178 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
49179 & SIN(THE)*COS(PHI)*P(I,3)
49180 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
49181 & SIN(THE)*SIN(PHI)*P(I,3)
49182 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
49184 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
49185 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
49186 P(I,1)=DP(1)+DGABP*BEX
49187 P(I,2)=DP(2)+DGABP*BEY
49188 P(I,3)=DP(3)+DGABP*BEZ
49189 P(I,4)=GA*(DP(4)+DBP)
49193 C...Weight with azimuthal distribution, if required.
49194 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
49200 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
49201 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
49202 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
49204 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
49205 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
49207 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
49208 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
49209 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
49210 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
49211 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
49212 IF(MAZIP.NE.0) THEN
49213 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
49216 IF(MAZIC.NE.0) THEN
49217 IF(MAZIC.EQ.N+2) CAD=-CAD
49218 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
49219 & .LT.PYR(0)) GOTO 550
49224 C...Azimuthal anisotropy due to interference with initial state partons.
49225 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
49226 &K(N+2,2).EQ.21)) THEN
49228 IF(ISII(III).GE.1) THEN
49230 IF(K(N+1,2).NE.21) IAZIID=N+2
49231 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
49232 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
49233 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
49234 IF(III.EQ.2) THEIID=PARU(1)-THEIID
49235 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
49236 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
49237 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
49238 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
49239 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
49240 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
49241 & .LT.PYR(0)) GOTO 550
49245 C...Continue loop over partons that may branch, until none left.
49246 IF(IGM.GE.0) K(IM,1)=14
49249 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
49250 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
49251 IF(MSTU(21).GE.1) N=NS
49252 IF(MSTU(21).GE.1) RETURN
49256 C...Set information on imagined shower initiator.
49257 590 IF(NPA.GE.2) THEN
49261 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
49269 C...Reconstruct string drawing information.
49270 DO 600 I=NS+1+IIM,N
49271 KQ=KCHG(PYCOMP(K(I,2)),2)
49272 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
49274 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
49275 & IABS(K(I,2)).LE.18) THEN
49277 ELSEIF(K(I,1).LE.10) THEN
49278 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
49279 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
49280 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
49281 ID1=MOD(K(I,4),MSTU(5))
49282 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
49283 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
49284 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
49285 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
49286 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
49287 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
49288 K(ID1,4)=K(ID1,4)+MSTU(5)*I
49289 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
49290 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
49291 K(ID2,5)=K(ID2,5)+MSTU(5)*I
49293 ID1=MOD(K(I,4),MSTU(5))
49295 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
49296 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
49297 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
49298 K(ID1,4)=K(ID1,4)+MSTU(5)*I
49299 K(ID1,5)=K(ID1,5)+MSTU(5)*I
49309 C...Transformation from CM frame.
49311 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
49312 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
49314 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
49315 ELSEIF(NPA.EQ.2) THEN
49320 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
49321 & /(1D0+GA)-P(IPA(1),4))
49322 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
49323 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
49324 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
49326 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
49328 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
49331 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
49334 C...Decay vertex of shower.
49341 C...Delete trivial shower, else connect initiators.
49342 IF(N.LE.NS+NPA+IIM) THEN
49347 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
49348 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
49349 K(NS+IIM+IP,3)=IPA(IP)
49350 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
49351 IF(K(NS+IIM+IP,1).NE.1) THEN
49352 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
49353 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
49361 C*********************************************************************
49364 C...Auxiliary to PYSHOW.
49365 C...Matrix elements for gluon (or photon) emission from
49366 C...a two-body state; to be used by the parton shower routine.
49367 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
49368 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
49369 C... = (alpha-strong/2 pi) * CF * PYMAEL,
49370 C...i.e. normalization is such that one recovers the familiar
49371 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
49372 C...Coupling structure:
49373 C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
49374 C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
49375 C... = 16-19 : q -> q V
49376 C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
49377 C... = 26-29 : q -> q S
49378 C... = 31-34 : V -> ~q ~qbar (~q = squark)
49379 C... = 36-39 : ~q -> ~q V
49380 C... = 41-44 : S -> ~q ~qbar
49381 C... = 46-49 : ~q -> ~q S
49382 C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
49383 C... = 56-59 : ~q -> q chi
49384 C... = 61-64 : q -> ~q chi
49385 C... = 66-69 : ~g -> q ~qbar
49386 C... = 71-74 : ~q -> q ~g
49387 C... = 76-79 : q -> ~q ~g
49388 C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
49389 C...Note that the order of the decay products is important.
49390 C...In each set of four, the variants are ordered as:
49391 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
49392 C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
49393 C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
49394 C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
49396 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
49398 C...Double precision and integer declarations.
49399 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49400 IMPLICIT INTEGER(I-N)
49402 C...Check input values. Return zero outside allowed phase space.
49404 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
49405 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
49406 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
49407 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
49408 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
49409 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
49411 C...Initial values and flags.
49419 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
49421 C...Eikonal expression; also acts as default.
49422 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
49424 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
49426 ELSEIF(ICOMBI.EQ.2) THEN
49427 ANUM=(2D0-X1-X2)**2
49428 ELSEIF(ICOMBI.EQ.3) THEN
49429 ANUM=ALPCOR*(2D0-X1-X2)**2
49431 ANUM=0.5D0*(2D0-X1-X2)**2
49433 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
49434 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
49435 & R1**2/(1D0+R2**2-R1**2-X2)**2-
49436 & R2**2/(1D0+R1**2-R2**2-X1)**2)
49439 C...V -> q qbar (V = gamma*/Z0/W+-/...).
49440 ELSEIF(ICLASS.EQ.2) THEN
49441 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49442 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
49443 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
49444 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
49445 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
49446 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
49447 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
49448 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
49449 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
49450 & (-1+R1**2-R2**2+X2)**2
49451 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
49452 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
49453 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
49454 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
49455 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
49456 & -X1-X2)**2+X1*(2-X1-X2)**2)/
49457 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49458 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
49459 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
49460 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
49461 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
49462 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
49466 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49467 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
49468 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
49469 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
49470 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
49471 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
49472 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
49473 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
49474 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
49475 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
49476 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
49477 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
49478 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
49479 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
49480 & -X1-X2)**2+X1*(2-X1-X2)**2)/
49481 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49482 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
49483 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
49484 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
49485 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
49486 & +X2)/(-1-R1**2+R2**2+X1)**2
49490 IF(ICOMBI.EQ.4) THEN
49491 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
49492 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
49493 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
49494 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
49495 & (-1-R1**2+R2**2+X1)**2
49497 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
49498 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
49499 & -R1**2*X2**2+X1*X2**2)/
49500 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49501 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
49502 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
49503 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
49504 & (-1+R1**2-R2**2+X2)**2
49510 ELSEIF(ICLASS.EQ.3) THEN
49511 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49512 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
49513 & +R1**2*R2**2-2D0*R2**4)
49514 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
49515 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
49516 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
49517 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
49518 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
49519 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
49520 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
49521 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
49522 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
49523 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
49524 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
49525 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
49526 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
49527 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
49528 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
49529 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
49530 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
49531 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
49532 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
49535 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49536 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
49537 & +R1**2*R2**2-2D0*R2**4)
49538 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
49539 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
49540 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
49541 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
49542 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
49543 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
49544 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
49545 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
49546 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
49547 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
49548 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
49549 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
49550 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
49551 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
49552 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
49553 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
49554 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
49555 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
49556 & +X1*X2**2)/(-2+X1+X2)**2
49559 IF(ICOMBI.EQ.4) THEN
49560 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
49561 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
49562 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
49563 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
49564 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
49565 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
49566 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
49567 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
49568 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
49569 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
49570 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
49571 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
49572 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
49573 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
49574 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
49575 & +X1*X2**2)/(2-X1-X2)**2
49579 C...S -> q qbar (S = h0/H0/A0/H+-/...).
49580 ELSEIF(ICLASS.EQ.4) THEN
49581 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49582 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
49583 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
49584 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
49585 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
49586 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
49587 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
49588 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49589 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
49590 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
49591 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
49594 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49595 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
49596 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
49597 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
49598 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
49599 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
49600 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
49601 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
49602 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
49603 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
49604 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
49605 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49608 IF(ICOMBI.EQ.4) THEN
49609 RLO4=PS*(1D0-R1**2-R2**2)
49610 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
49611 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
49612 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
49613 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
49614 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49615 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
49616 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
49621 ELSEIF(ICLASS.EQ.5) THEN
49622 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49623 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
49624 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
49625 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
49626 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
49627 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49628 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
49629 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
49630 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49631 & (-1+R1**2-R2**2+X2)**2
49634 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49635 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
49636 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
49637 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
49638 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
49639 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49640 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
49641 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
49642 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49643 & (-1+R1**2-R2**2+X2)**2
49646 IF(ICOMBI.EQ.4) THEN
49647 RLO4=PS*(1D0+R1**2-R2**2)
49648 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
49649 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
49650 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
49651 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
49652 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
49653 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
49657 C...V -> ~q ~qbar (~q = squark).
49658 ELSEIF(ICLASS.EQ.6) THEN
49659 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
49660 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
49661 & (-1-R1**2+R2**2+X1)**2
49662 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
49663 & (-1-R1**2+R2**2+X1)
49664 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
49665 & /(-1+R1**2-R2**2+X2)**2
49666 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
49667 & (-1+R1**2-R2**2+X2)
49668 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
49669 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
49670 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
49671 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49675 ELSEIF(ICLASS.EQ.7) THEN
49676 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
49677 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
49678 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
49679 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
49680 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
49681 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
49682 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
49683 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
49684 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
49685 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
49686 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
49692 ELSEIF(ICLASS.EQ.8) THEN
49694 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
49695 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
49696 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
49697 & -R1**2*X2**2+X1*X2**2)/
49698 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
49703 ELSEIF(ICLASS.EQ.9) THEN
49705 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
49706 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
49707 & -(X1+X2)/(-2+X1+X2)**2
49710 C...chi -> q ~qbar (chi = neutralino/chargino).
49711 ELSEIF(ICLASS.EQ.10) THEN
49712 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49713 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
49714 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
49715 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
49716 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
49717 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49718 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
49719 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49720 & (-1+R1**2-R2**2+X2)**2
49723 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49724 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
49725 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
49726 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
49727 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
49728 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49729 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
49730 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49731 & (-1+R1**2-R2**2+X2)**2
49734 IF(ICOMBI.EQ.4) THEN
49735 RLO4=PS*(1+R1**2-R2**2)
49736 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
49737 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
49738 & +X2+R1**2*X2-X1*X2/2)/
49739 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
49740 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
49741 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
49746 ELSEIF(ICLASS.EQ.11) THEN
49747 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49748 RLO1=PS*(1D0-(R1+R2)**2)
49749 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
49750 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
49751 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
49752 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
49753 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
49754 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
49755 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
49758 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49759 RLO2=PS*(1D0-(R1-R2)**2)
49760 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
49762 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
49763 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
49764 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
49765 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
49766 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
49767 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
49770 IF(ICOMBI.EQ.4) THEN
49771 RLO4=PS*(1D0-R1**2-R2**2)
49772 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
49773 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
49774 & +3*R1**2*X2-R2**2*X2-X1*X2)/
49775 & (-1+R1**2-R2**2+X2)**2
49776 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
49777 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
49778 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
49783 ELSEIF(ICLASS.EQ.12) THEN
49784 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49785 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
49786 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
49787 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
49788 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
49789 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
49790 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
49791 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
49794 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49795 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
49796 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
49797 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
49798 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
49799 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
49800 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
49801 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
49804 IF(ICOMBI.EQ.4) THEN
49805 RLO4=PS*(1D0-R1**2+R2**2)
49806 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
49807 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
49808 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
49809 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
49810 & +R1**2*X2-X1*X2/2-X2**2/2)/
49811 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
49816 ELSEIF(ICLASS.EQ.13) THEN
49817 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49818 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
49819 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
49820 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
49821 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
49822 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
49823 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
49824 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
49825 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
49826 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
49827 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
49828 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
49829 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
49830 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49831 & (3*(-1+R1**2-R2**2+X2)**2)
49835 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49836 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
49837 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
49838 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
49839 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
49840 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
49841 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
49842 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
49843 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
49844 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
49845 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
49846 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49847 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
49848 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
49849 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49850 & (3*(-1+R1**2-R2**2+X2)**2)
49854 IF(ICOMBI.EQ.4) THEN
49855 RLO4=PS*(1D0+R1**2-R2**2)
49856 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
49857 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
49858 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
49859 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
49860 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
49861 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49862 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
49863 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49864 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
49865 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
49866 & (3*(-1+R1**2-R2**2+X2)**2)
49872 ELSEIF(ICLASS.EQ.14) THEN
49873 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49874 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
49875 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
49876 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
49877 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
49878 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
49879 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
49880 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
49881 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
49882 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
49883 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
49884 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
49885 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
49886 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
49887 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
49889 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
49890 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
49891 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
49895 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49896 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
49897 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
49898 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
49899 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
49900 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
49901 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
49902 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
49903 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
49904 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
49905 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
49906 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
49908 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
49909 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
49910 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
49911 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
49912 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
49913 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
49917 IF(ICOMBI.EQ.4) THEN
49918 RLO4=PS*(1-R1**2-R2**2)
49919 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
49920 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
49921 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
49922 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
49923 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
49924 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
49925 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
49926 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
49927 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
49928 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
49929 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
49930 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
49931 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
49932 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
49933 RFO4=9D0*RFO4/128D0
49938 ELSEIF(ICLASS.EQ.15) THEN
49939 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
49940 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
49941 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
49942 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
49943 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
49944 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
49945 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
49946 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
49947 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
49948 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
49949 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
49950 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
49951 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
49952 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
49953 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
49954 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
49958 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
49959 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
49960 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
49961 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
49962 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
49963 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
49964 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
49965 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
49966 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
49967 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
49968 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
49969 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
49970 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
49971 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
49972 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
49973 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
49977 IF(ICOMBI.EQ.4) THEN
49978 RLO4=PS*(1D0-R1**2+R2**2)
49979 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
49980 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
49981 & -R2**2*X2/2-X1*X2/2)/
49982 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
49983 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
49984 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
49985 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
49986 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
49987 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
49988 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
49989 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
49990 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
49995 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
49996 ELSEIF(ICLASS.EQ.16) THEN
49998 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
50000 ELSEIF(ICOMBI.EQ.2) THEN
50001 ANUM=(2D0-X1-X2)**2
50002 ELSEIF(ICOMBI.EQ.3) THEN
50003 ANUM=ALPCOR*(2D0-X1-X2)**2
50005 ANUM=0.5D0*(2D0-X1-X2)**2
50007 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
50008 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
50009 & R1**2/(1D0+R2**2-R1**2-X2)**2-
50010 & R2**2/(1D0+R1**2-R2**2-X1)**2)
50015 C...Find relevant LO and FO expression.
50016 IF(ICOMBI.EQ.0) THEN
50017 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
50020 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
50023 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
50024 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
50025 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
50026 ELSEIF(ISSET4.EQ.1) THEN
50029 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
50030 RLO=0.5D0*(RLO1+RLO2)
50031 RFO=0.5D0*(RFO1+RFO2)
50032 ELSEIF(ISSET1.EQ.1) THEN
50036 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
50047 C*********************************************************************
50050 C...Modifies an event so as to approximately take into account
50051 C...Bose-Einstein effects according to a simple phenomenological
50052 C...parametrization.
50054 SUBROUTINE PYBOEI(NSAV)
50056 C...Double precision and integer declarations.
50057 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50058 IMPLICIT INTEGER(I-N)
50059 INTEGER PYK,PYCHGE,PYCOMP
50060 C...Parameter statement to help give large particle numbers.
50061 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50062 &KEXCIT=4000000,KDIMEN=5000000)
50064 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50065 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50066 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50067 COMMON/PYINT1/MINT(400),VINT(400)
50068 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
50069 C...Local arrays and data.
50070 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
50071 &BEIW(100),BEI3W(100)
50072 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
50073 C...Statement function: squared invariant mass.
50074 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
50075 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
50077 C...Boost event to overall CM frame. Calculate CM energy.
50078 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
50084 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
50085 & .AND.K(I,3).GT.0) THEN
50086 KFMA=IABS(K(K(I,3),2))
50087 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
50089 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
50091 DPS(J)=DPS(J)+P(I,J)
50094 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
50098 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
50101 C...Check if we have separated strings
50103 C...Reserve copy of particles by species at end of record.
50109 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
50110 NBE(IBE)=NBE(IBE-1)
50112 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
50113 DO 140 IIBE=1,IBE-1
50114 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
50117 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
50119 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
50120 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
50121 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
50124 NBE(IBE)=NBE(IBE)+1
50131 P(NBE(IBE),1)=0.0D0
50132 P(NBE(IBE),2)=0.0D0
50133 P(NBE(IBE),3)=0.0D0
50134 P(NBE(IBE),4)=0.0D0
50135 P(NBE(IBE),5)=0.0D0
50136 SMMIN=MIN(SMMIN,P(I,5))
50137 C...Check if particles comes from different W's or Z's
50138 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
50140 150 IF(K(IM,3).GT.0) THEN
50142 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
50144 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
50145 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
50146 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
50147 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
50150 C...Check if particles comes from different strings.
50151 IF(PARJ(94).GT.0.0D0) THEN
50153 160 IF(K(IM,3).GT.0) THEN
50155 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
50163 P(NBE(IBE),5)=-1.0D0
50166 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
50168 C...Calculate separation between W+ and W- or between two Z0's.
50169 C...No separation if there has been re-connections.
50171 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
50172 IF(K(IWP,2).EQ.23) THEN
50181 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
50182 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
50183 TAUP=-TAUPD*LOG(PYR(IDUM))
50184 TAUN=-TAUND*LOG(PYR(IDUM))
50185 DXP=TAUP*PYP(IWP,8)/DMP
50186 DXN=TAUN*PYP(IWN,8)/DMN
50188 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
50189 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
50192 C...Add separation between strings.
50193 IF(PARJ(94).GT.0.0D0) THEN
50194 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
50199 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
50200 DO 220 IBE=1,MIN(9,MSTJ(52))
50201 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
50204 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
50205 IF(I2M.EQ.I1M) GOTO 200
50207 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
50208 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
50209 & (P(I1,5)+P(I2,5))**2
50210 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
50219 C...Tabulate integral for subsequent momentum shift.
50220 DO 400 IBE=1,MIN(9,MSTJ(52))
50221 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
50222 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
50224 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
50225 & NBE(7)-NBE(6)).LE.1) GOTO 270
50226 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
50227 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
50228 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
50229 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
50230 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
50231 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
50232 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
50233 QDELW=0.1D0*MIN(PMHQ,SIGW)
50234 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
50235 IF(MSTJ(51).EQ.1) THEN
50236 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
50237 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
50238 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
50239 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
50240 BEEX=EXP(0.5D0*QDEL/PARJ(93))
50241 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
50242 BEEXW=EXP(0.5D0*QDELW/SIGW)
50243 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
50244 BERT=EXP(-QDEL/PARJ(93))
50245 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
50246 BERTW=EXP(-QDELW/SIGW)
50247 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
50249 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
50250 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
50251 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
50252 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
50255 QBIN=QDEL*(IBIN-0.5D0)
50256 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
50257 IF(MSTJ(51).EQ.1) THEN
50259 BEI(IBIN)=BEI(IBIN)*BEEX
50261 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
50263 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
50265 DO 240 IBIN=1,NBIN3
50266 QBIN=QDEL3*(IBIN-0.5D0)
50267 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
50268 IF(MSTJ(51).EQ.1) THEN
50270 BEI3(IBIN)=BEI3(IBIN)*BEEX3
50272 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
50274 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
50276 DO 250 IBIN=1,NBINW
50277 QBIN=QDELW*(IBIN-0.5D0)
50278 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
50279 IF(MSTJ(51).EQ.1) THEN
50281 BEIW(IBIN)=BEIW(IBIN)*BEEXW
50283 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
50285 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
50287 DO 260 IBIN=1,NBIN3W
50288 QBIN=QDEL3W*(IBIN-0.5D0)
50289 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
50290 & SQRT(QBIN**2+PMHQ**2)
50291 IF(MSTJ(51).EQ.1) THEN
50292 BEEX3W=BEEX3W*BERT3W
50293 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
50295 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
50297 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
50300 C...Loop through particle pairs and find old relative momentum.
50301 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
50303 DO 380 I2M=I1M+1,NBE(IBE)
50304 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
50305 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
50307 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
50308 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
50309 IF(Q2OLD.LE.0.0D0) GOTO 380
50312 C...Calculate new relative momentum.
50317 IF(QOLD.LT.1D-3*QDEL) THEN
50319 ELSEIF(QOLD.LE.QDEL) THEN
50321 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
50324 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
50325 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
50326 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
50328 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
50330 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
50331 IF(QOLD.LT.1D-3*QDEL3) THEN
50333 ELSEIF(QOLD.LE.QDEL3) THEN
50335 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
50338 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
50339 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
50340 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
50342 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
50344 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
50347 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
50348 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
50349 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
50351 IF(QOLD.LT.1D-3*QDELW) THEN
50353 ELSEIF(QOLD.LE.QDELW) THEN
50355 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
50358 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
50359 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
50360 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
50362 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
50364 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
50365 IF(QOLD.LT.1D-3*QDEL3W) THEN
50367 ELSEIF(QOLD.LE.QDEL3W) THEN
50369 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
50372 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
50373 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
50374 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
50376 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
50378 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
50380 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
50382 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
50384 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
50385 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
50387 IF(MSTJ(54).GE.1) THEN
50388 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
50390 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
50391 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
50393 ELSEIF(MSTJ(54).LE.-1) THEN
50394 EDEL=P(I1,4)+P(I2,4)-
50395 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
50396 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
50397 & (P(I1,3)-P(I2,3))**2
50402 SM1=(P(I1,5)+SMMIN)**2
50403 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
50404 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
50405 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
50406 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
50407 & K(I3M,5).NE.K(I1M,5)) GOTO 360
50409 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
50412 SM3=(P(I3,5)+SMMIN)**2
50413 IF(MSTJ(54).EQ.-2) THEN
50414 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
50415 & S23*MIN(SM1,SM3))*SM1)
50417 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
50418 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
50419 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
50420 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
50422 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
50423 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
50426 IF(WMAX*WI.GE.1.0) GOTO 360
50428 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
50429 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
50430 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
50431 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
50432 & K(I4M,5).NE.K(I1M,5)) GOTO 350
50434 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
50436 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
50437 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
50438 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
50440 IF(MSTJ(54).EQ.-2) THEN
50444 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
50445 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
50446 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
50447 W=MIN(W,MIN(S23,S24)*S13*S14)
50450 C...weight=1-cos(theta)/mtot2
50451 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
50452 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
50453 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
50454 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
50456 IF(W.LE.WMAX) GOTO 350
50458 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
50459 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
50460 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
50461 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
50462 IF(W.LE.WMAX) GOTO 350
50468 IF(MI4.EQ.0) GOTO 380
50471 EOLD=P(I3,4)+P(I4,4)
50473 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
50474 & (P(I3,3)+P(I4,3))**2
50475 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
50476 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
50477 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
50479 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
50480 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
50487 C...Shift momenta and recalculate energies.
50491 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
50495 P(I,J)=P(I,J)+P(IM,J)
50497 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
50500 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
50505 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
50506 440 ALPHA=(ESUMP-ESUM)/PROD
50507 PARJ(96)=PARJ(96)+ALPHA
50510 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
50513 P(I,J)=P(I,J)+ALPHA*V(IM,J)
50515 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
50518 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
50521 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
50525 C...Rescale all momenta for energy conservation.
50529 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
50531 PQS=PQS+P(I,5)**2/P(I,4)
50534 FAC=(PECM-PQS)/(PES-PQS)
50536 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
50540 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
50543 C...Boost back to correct reference frame.
50544 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
50546 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
50552 C*********************************************************************
50555 C...Calculates the momentum shift in a system of two particles assuming
50556 C...the relative momentum squared should be shifted to Q2NEW. NI is the
50557 C...last position occupied in /PYJETS/.
50559 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
50561 C...Double precision and integer declarations.
50562 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50563 IMPLICIT INTEGER(I-N)
50564 INTEGER PYK,PYCHGE,PYCOMP
50565 C...Parameter statement to help give large particle numbers.
50566 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50567 &KEXCIT=4000000,KDIMEN=5000000)
50569 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50571 SAVE /PYJETS/,/PYDAT1/
50572 C...Local arrays and data.
50576 IF(MSTJ(55).EQ.0) THEN
50578 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
50579 & (P(I1,3)-P(I2,3))**2
50580 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
50581 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
50585 DA=SE*DE*DP12-DP2*DQ2SE
50586 DB=DP2*DQ2SE-DP12**2
50587 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
50589 PD=HA*(P(I1,J)-P(I2,J))
50601 DP(J)=P(I1,J)+P(I2,J)
50604 C...Boost to cms and rotate first particle to z-axis
50605 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
50606 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
50607 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
50608 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
50609 S=Q2NEW+(P(I1,5)+P(I2,5))**2
50610 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
50614 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
50618 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
50619 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
50620 CALL PYROBO(NI+1,NI+2,THE,PHI,
50621 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
50624 P(NI+1,J)=P(NI+1,J)-P(I1,J)
50625 P(NI+2,J)=P(NI+2,J)-P(I2,J)
50631 C*********************************************************************
50634 C...Gives the mass of a particle/parton.
50636 FUNCTION PYMASS(KF)
50638 C...Double precision and integer declarations.
50639 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50640 IMPLICIT INTEGER(I-N)
50641 INTEGER PYK,PYCHGE,PYCOMP
50643 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50644 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50645 SAVE /PYDAT1/,/PYDAT2/
50647 C...Reset variables. Compressed code. Special case for popcorn diquarks.
50656 C...Guarantee use of constituent masses for internal checks.
50657 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
50658 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
50660 PYMASS=PARF(100+KFA)
50661 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
50662 ELSEIF(KFA.LE.10) THEN
50664 ELSEIF(MSTJ(93).EQ.1) THEN
50665 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
50667 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
50670 C...Other masses can be read directly off table.
50675 C...Optional mass broadening according to truncated Breit-Wigner
50676 C...(either in m or in m^2).
50677 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
50678 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
50679 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
50680 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
50683 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
50684 & (PM0*PMAS(KC,2)))
50685 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
50686 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
50687 & (PMUPP-PMLOW)*PYR(0))))
50695 C*********************************************************************
50698 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
50699 C...for Higgs couplings. Everything else sent on to PYMASS.
50701 FUNCTION PYMRUN(KF,Q2)
50703 C...Double precision and integer declarations.
50704 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50705 IMPLICIT INTEGER(I-N)
50706 INTEGER PYK,PYCHGE,PYCOMP
50708 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50709 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50710 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
50711 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
50713 C...Most masses not handled here.
50715 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
50718 C...Current-algebra masses, but no Q2 dependence.
50719 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
50720 PYMRUN=PARF(90+KFA)
50722 C...Running current-algebra masses.
50725 PYMRUN=PARF(90+KFA)*
50726 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
50727 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
50733 C*********************************************************************
50736 C...Gives the particle/parton name as a character string.
50738 SUBROUTINE PYNAME(KF,CHAU)
50740 C...Double precision and integer declarations.
50741 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50742 IMPLICIT INTEGER(I-N)
50743 INTEGER PYK,PYCHGE,PYCOMP
50745 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50746 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50747 COMMON/PYDAT4/CHAF(500,2)
50749 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
50750 C...Local character variable.
50753 C...Read out code with distinction particle/antiparticle.
50756 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
50762 C*********************************************************************
50765 C...Gives three times the charge for a particle/parton.
50767 FUNCTION PYCHGE(KF)
50769 C...Double precision and integer declarations.
50770 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50771 IMPLICIT INTEGER(I-N)
50772 INTEGER PYK,PYCHGE,PYCOMP
50774 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50777 C...Read out charge and change sign for antiparticle.
50780 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
50785 C*********************************************************************
50788 C...Compress the standard KF codes for use in mass and decay arrays;
50789 C...also checks whether a given code actually is defined.
50791 FUNCTION PYCOMP(KF)
50793 C...Double precision and integer declarations.
50794 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50795 IMPLICIT INTEGER(I-N)
50796 INTEGER PYK,PYCHGE,PYCOMP
50798 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50799 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50800 SAVE /PYDAT1/,/PYDAT2/
50801 C...Local arrays and saved data.
50802 DIMENSION KFORD(100:500),KCORD(101:500)
50803 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
50805 C...Whenever necessary reorder codes for faster search.
50806 IF(MSTU(20).EQ.0) THEN
50811 IF(KFA.LE.100) GOTO 120
50813 DO 100 I1=NFORD-1,0,-1
50814 IF(KFA.GE.KFORD(I1)) GOTO 110
50815 KFORD(I1+1)=KFORD(I1)
50816 KCORD(I1+1)=KCORD(I1)
50818 110 KFORD(I1+1)=KFA
50826 C...Fast action if same code as in latest call.
50827 IF(KF.EQ.KFLAST) THEN
50832 C...Starting values. Remove internal diquark flags.
50835 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
50836 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
50838 C...Simple cases: direct translation.
50839 IF(KFA.GT.KFORD(NFORD)) THEN
50840 ELSEIF(KFA.LE.100) THEN
50843 C...Else binary search.
50847 130 IAVG=(IMIN+IMAX)/2
50848 IF(KFORD(IAVG).GT.KFA) THEN
50850 IF(IMAX.GT.IMIN+1) GOTO 130
50851 ELSEIF(KFORD(IAVG).LT.KFA) THEN
50853 IF(IMAX.GT.IMIN+1) GOTO 130
50859 C...Check if antiparticle allowed.
50860 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
50861 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
50864 C...Save codes for possible future fast action.
50871 C*********************************************************************
50874 C...Informs user of errors in program execution.
50876 SUBROUTINE PYERRM(MERR,CHMESS)
50878 C...Double precision and integer declarations.
50879 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50880 IMPLICIT INTEGER(I-N)
50881 INTEGER PYK,PYCHGE,PYCOMP
50883 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50884 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50885 SAVE /PYJETS/,/PYDAT1/
50886 C...Local character variable.
50887 CHARACTER CHMESS*(*)
50889 C...Write first few warnings, then be silent.
50890 IF(MERR.LE.10) THEN
50891 MSTU(27)=MSTU(27)+1
50893 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
50894 & MERR,MSTU(31),CHMESS
50896 C...Write first few errors, then be silent or stop program.
50897 ELSEIF(MERR.LE.20) THEN
50898 MSTU(23)=MSTU(23)+1
50900 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
50901 & MERR-10,MSTU(31),CHMESS
50902 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
50903 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
50904 WRITE(MSTU(11),5200)
50905 IF(MERR.NE.17) CALL PYLIST(2)
50909 C...Stop program in case of irreparable error.
50911 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
50915 C...Formats for output.
50916 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
50917 &' PYEXEC calls:'/5X,A)
50918 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
50919 &' PYEXEC calls:'/5X,A)
50920 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
50922 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
50923 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
50928 C*********************************************************************
50931 C...Calculates the running alpha_electromagnetic.
50933 FUNCTION PYALEM(Q2)
50935 C...Double precision and integer declarations.
50936 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50937 IMPLICIT INTEGER(I-N)
50938 INTEGER PYK,PYCHGE,PYCOMP
50940 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50943 C...Calculate real part of photon vacuum polarization.
50944 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
50945 C...For hadrons use parametrization of H. Burkhardt et al.
50946 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
50947 AEMPI=PARU(101)/(3D0*PARU(1))
50948 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
50950 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
50952 ELSEIF(MSTU(101).EQ.2) THEN
50953 RPIGG=1D0-PARU(101)/PARU(103)
50954 ELSEIF(Q2.LT.0.09D0) THEN
50955 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
50956 ELSEIF(Q2.LT.9D0) THEN
50957 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
50958 & 0.00238D0*LOG(1D0+3.927D0*Q2)
50959 ELSEIF(Q2.LT.1D4) THEN
50960 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
50961 & 0.00299D0*LOG(1D0+Q2)
50963 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
50964 & 0.00293D0*LOG(1D0+Q2)
50967 C...Calculate running alpha_em.
50968 PYALEM=PARU(101)/(1D0-RPIGG)
50974 C*********************************************************************
50977 C...Gives the value of alpha_strong.
50979 FUNCTION PYALPS(Q2)
50981 C...Double precision and integer declarations.
50982 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50983 IMPLICIT INTEGER(I-N)
50984 INTEGER PYK,PYCHGE,PYCOMP
50986 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50987 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50988 SAVE /PYDAT1/,/PYDAT2/
50990 C...Constant alpha_strong trivial. Pick artificial Lambda.
50991 IF(MSTU(111).LE.0) THEN
50993 MSTU(118)=MSTU(112)
50995 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
50996 & ((33D0-2D0*MSTU(112))*PARU(111)))
50997 PARU(118)=PARU(111)
51001 C...Find effective Q2, number of flavours and Lambda.
51003 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
51006 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
51007 Q2THR=PARU(113)*PMAS(NF,1)**2
51008 IF(Q2EFF.LT.Q2THR) THEN
51010 ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF))
51014 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
51015 Q2THR=PARU(113)*PMAS(NF+1,1)**2
51016 IF(Q2EFF.GT.Q2THR) THEN
51018 ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF))
51022 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
51023 PARU(117)=SQRT(ALAM2)
51025 C...Evaluate first or second order alpha_strong.
51026 B0=(33D0-2D0*NF)/6D0
51027 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
51028 IF(MSTU(111).EQ.1) THEN
51029 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
51031 B1=(153D0-19D0*NF)/6D0
51032 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
51041 C*********************************************************************
51044 C...Reconstructs an angle from given x and y coordinates.
51046 FUNCTION PYANGL(X,Y)
51048 C...Double precision and integer declarations.
51049 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51050 IMPLICIT INTEGER(I-N)
51051 INTEGER PYK,PYCHGE,PYCOMP
51053 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51058 IF(R.LT.1D-20) RETURN
51059 IF(ABS(X)/R.LT.0.8D0) THEN
51060 PYANGL=SIGN(ACOS(X/R),Y)
51063 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
51064 PYANGL=PARU(1)-PYANGL
51065 ELSEIF(X.LT.0D0) THEN
51066 PYANGL=-PARU(1)-PYANGL
51073 C*********************************************************************
51076 C...Generates random numbers uniformly distributed between
51077 C...0 and 1, excluding the endpoints.
51079 * FUNCTION PYR(IDUMMY)
51081 *C...Double precision and integer declarations.
51082 * IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51083 * IMPLICIT INTEGER(I-N)
51084 * INTEGER PYK,PYCHGE,PYCOMP
51086 * COMMON/PYDATR/MRPY(6),RRPY(100)
51088 *C...Equivalence between commonblock and local variables.
51089 * EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
51090 * &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
51091 * &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
51093 *C...Initialize generation from given seed.
51094 * IF(MRPY2.EQ.0) THEN
51095 * IJ=MOD(MRPY1/30082,31329)
51096 * KL=MOD(MRPY1,30082)
51097 * I=MOD(IJ/177,177)+2
51099 * K=MOD(KL/169,178)+1
51105 * M=MOD(MOD(I*J,179)*K,179)
51109 * L=MOD(53*L+1,169)
51110 * IF(MOD(L*M,64).GE.32) S=S+T
51117 * TWOM24=0.5D0*TWOM24
51119 * RRPY98=362436D0*TWOM24
51120 * RRPY99=7654321D0*TWOM24
51121 * RRPY00=16777213D0*TWOM24
51128 *C...Generate next random number.
51129 * 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
51130 * IF(RUNI.LT.0D0) RUNI=RUNI+1D0
51133 * IF(MRPY4.EQ.0) MRPY4=97
51135 * IF(MRPY5.EQ.0) MRPY5=97
51136 * RRPY98=RRPY98-RRPY99
51137 * IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
51139 * IF(RUNI.LT.0D0) RUNI=RUNI+1D0
51140 * IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
51142 *C...Update counters. Random number to output.
51144 * IF(MRPY3.EQ.1000000000) THEN
51153 C*********************************************************************
51156 C...Dumps the state of the random number generator on a file
51157 C...for subsequent startup from this state onwards.
51159 * SUBROUTINE PYRGET(LFN,MOVE)
51161 C...Double precision and integer declarations.
51162 * IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51163 * IMPLICIT INTEGER(I-N)
51164 * INTEGER PYK,PYCHGE,PYCOMP
51166 * COMMON/PYDATR/MRPY(6),RRPY(100)
51168 C...Local character variable.
51169 * CHARACTER CHERR*8
51171 C...Backspace required number of records (or as many as there are).
51172 * IF(MOVE.LT.0) THEN
51173 * NBCK=MIN(MRPY(6),-MOVE)
51174 * DO 100 IBCK=1,NBCK
51175 * BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
51177 * MRPY(6)=MRPY(6)-NBCK
51180 C...Unformatted write on unit LFN.
51181 * WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
51182 * &(RRPY(I2),I2=1,100)
51183 * MRPY(6)=MRPY(6)+1
51187 * 110 WRITE(CHERR,'(I8)') IERR
51188 * CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
51194 C*********************************************************************
51197 C...Reads a state of the random number generator from a file
51198 C...for subsequent generation from this state onwards.
51200 * SUBROUTINE PYRSET(LFN,MOVE)
51202 C...Double precision and integer declarations.
51203 * IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51204 * IMPLICIT INTEGER(I-N)
51205 * INTEGER PYK,PYCHGE,PYCOMP
51207 * COMMON/PYDATR/MRPY(6),RRPY(100)
51209 C...Local character variable.
51210 * CHARACTER CHERR*8
51212 C...Backspace required number of records (or as many as there are).
51213 * IF(MOVE.LT.0) THEN
51214 * NBCK=MIN(MRPY(6),-MOVE)
51215 * DO 100 IBCK=1,NBCK
51216 * BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
51218 * MRPY(6)=MRPY(6)-NBCK
51221 C...Unformatted read from unit LFN.
51222 * NFOR=1+MAX(0,MOVE)
51223 * DO 110 IFOR=1,NFOR
51224 * READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
51225 * & (RRPY(I2),I2=1,100)
51227 * MRPY(6)=MRPY(6)+NFOR
51231 * 120 WRITE(CHERR,'(I8)') IERR
51232 * CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
51238 C*********************************************************************
51241 C...Performs rotations and boosts.
51243 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
51245 C...Double precision and integer declarations.
51246 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51247 IMPLICIT INTEGER(I-N)
51248 INTEGER PYK,PYCHGE,PYCOMP
51250 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
51251 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51252 SAVE /PYJETS/,/PYDAT1/
51254 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
51256 C...Find and check range of rotation/boost.
51258 IF(IMIN.LE.0) IMIN=1
51259 IF(MSTU(1).GT.0) IMIN=MSTU(1)
51261 IF(IMAX.LE.0) IMAX=N
51262 IF(MSTU(2).GT.0) IMAX=MSTU(2)
51263 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
51264 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
51268 C...Optional resetting of V (when not set before.)
51269 IF(MSTU(33).NE.0) THEN
51270 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
51278 C...Rotate, typically from z axis to direction (theta,phi).
51279 IF(THE**2+PHI**2.GT.1D-20) THEN
51280 ROT(1,1)=COS(THE)*COS(PHI)
51282 ROT(1,3)=SIN(THE)*COS(PHI)
51283 ROT(2,1)=COS(THE)*SIN(PHI)
51285 ROT(2,3)=SIN(THE)*SIN(PHI)
51290 IF(K(I,1).LE.0) GOTO 140
51296 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
51297 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
51302 C...Boost, typically from rest to momentum/energy=beta.
51303 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
51307 DB=SQRT(DBX**2+DBY**2+DBZ**2)
51309 IF(DB.GT.EPS1) THEN
51310 C...Rescale boost vector if too close to unity.
51311 CALL PYERRM(3,'(PYROBO:) boost vector too large')
51317 DGA=1D0/SQRT(1D0-DB**2)
51319 IF(K(I,1).LE.0) GOTO 160
51324 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
51325 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
51326 P(I,1)=DP(1)+DGABP*DBX
51327 P(I,2)=DP(2)+DGABP*DBY
51328 P(I,3)=DP(3)+DGABP*DBZ
51329 P(I,4)=DGA*(DP(4)+DBP)
51330 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
51331 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
51332 V(I,1)=DV(1)+DGABV*DBX
51333 V(I,2)=DV(2)+DGABV*DBY
51334 V(I,3)=DV(3)+DGABV*DBZ
51335 V(I,4)=DGA*(DV(4)+DBV)
51342 C*********************************************************************
51345 C...Performs global manipulations on the event record, in particular
51346 C...to exclude unstable or undetectable partons/particles.
51348 SUBROUTINE PYEDIT(MEDIT)
51350 C...Double precision and integer declarations.
51351 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51352 IMPLICIT INTEGER(I-N)
51353 INTEGER PYK,PYCHGE,PYCOMP
51355 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
51356 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51357 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51358 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
51360 DIMENSION NS(2),PTS(2),PLS(2)
51362 C...Remove unwanted partons/particles.
51363 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
51365 IF(MSTU(2).GT.0) IMAX=MSTU(2)
51366 I1=MAX(1,MSTU(1))-1
51367 DO 110 I=MAX(1,MSTU(1)),IMAX
51368 IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
51369 IF(MEDIT.EQ.1) THEN
51370 IF(K(I,1).GT.10) GOTO 110
51371 ELSEIF(MEDIT.EQ.2) THEN
51372 IF(K(I,1).GT.10) GOTO 110
51374 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
51376 ELSEIF(MEDIT.EQ.3) THEN
51377 IF(K(I,1).GT.10) GOTO 110
51379 IF(KC.EQ.0) GOTO 110
51380 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
51381 ELSEIF(MEDIT.EQ.5) THEN
51382 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
51384 IF(KC.EQ.0) GOTO 110
51385 IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
51388 C...Pack remaining partons/particles. Origin no longer known.
51397 IF(I1.LT.N) MSTU(3)=0
51398 IF(I1.LT.N) MSTU(70)=0
51401 C...Selective removal of class of entries. New position of retained.
51402 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
51405 K(I,3)=MOD(K(I,3),MSTU(5))
51406 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
51407 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
51408 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
51409 & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
51410 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
51411 & K(I,2).EQ.94)) GOTO 120
51412 IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
51414 K(I,3)=K(I,3)+MSTU(5)*I1
51417 C...Find new event history information and replace old.
51419 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0)
51422 130 IM=MOD(K(ID,3),MSTU(5))
51423 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
51424 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
51425 & K(IM,2).NE.94) THEN
51429 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
51430 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
51435 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
51436 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
51437 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
51438 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
51439 & K(K(I,4),3)/MSTU(5)
51440 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
51441 & K(K(I,5),3)/MSTU(5)
51443 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
51444 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
51445 KCD=MOD(K(I,4),MSTU(5))
51446 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
51447 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
51448 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
51449 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
51450 KCD=MOD(K(I,5),MSTU(5))
51451 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
51452 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
51456 C...Pack remaining entries.
51461 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
51468 K(I1,3)=MOD(K(I1,3),MSTU(5))
51470 IF(I.EQ.MSTU(90+IZ)) THEN
51471 MSTU(90)=MSTU(90)+1
51472 MSTU(90+MSTU(90))=I1
51473 PARU(90+MSTU(90))=PARU(90+IZ)
51477 IF(I1.LT.N) MSTU(3)=0
51478 IF(I1.LT.N) MSTU(70)=0
51481 C...Fill in some missing daughter pointers (lost in colour flow).
51482 ELSEIF(MEDIT.EQ.16) THEN
51484 IF(K(I,1).LE.10.OR.K(I,1).GT.20) GOTO 220
51485 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
51486 C...Find daughters who point to mother.
51488 IF(K(I1,3).NE.I) THEN
51489 ELSEIF(K(I,4).EQ.0) THEN
51495 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
51496 IF(K(I,4).NE.0) GOTO 220
51497 C...Find daughters who point to documentation version of mother.
51499 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
51500 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
51501 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
51503 IF(K(I1,3).NE.IM) THEN
51504 ELSEIF(K(I,4).EQ.0) THEN
51510 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
51511 IF(K(I,4).NE.0) GOTO 220
51512 C...Find daughters who point to documentation daughters who,
51513 C...in their turn, point to documentation mother.
51517 IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN
51519 IF(ID1.EQ.IM) ID1=I1
51523 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
51524 ELSEIF(K(I,4).EQ.0) THEN
51530 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
51533 C...Save top entries at bottom of PYJETS commonblock.
51534 ELSEIF(MEDIT.EQ.21) THEN
51535 IF(2*N.GE.MSTU(4)) THEN
51536 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
51541 K(MSTU(4)-I,J)=K(I,J)
51542 P(MSTU(4)-I,J)=P(I,J)
51543 V(MSTU(4)-I,J)=V(I,J)
51548 C...Restore bottom entries of commonblock PYJETS to top.
51549 ELSEIF(MEDIT.EQ.22) THEN
51550 DO 260 I=1,MSTU(32)
51552 K(I,J)=K(MSTU(4)-I,J)
51553 P(I,J)=P(MSTU(4)-I,J)
51554 V(I,J)=V(MSTU(4)-I,J)
51559 C...Mark primary entries at top of commonblock PYJETS as untreated.
51560 ELSEIF(MEDIT.EQ.23) THEN
51565 IF(K(KH,1).GT.20) KH=0
51567 IF(KH.NE.0) GOTO 280
51569 IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
51573 C...Place largest axis along z axis and second largest in xy plane.
51574 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
51575 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
51576 & P(MSTU(61),2)),0D0,0D0,0D0)
51577 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
51578 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
51579 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
51580 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
51581 IF(MEDIT.EQ.31) RETURN
51583 C...Rotate to put slim jet along +z axis.
51590 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
51591 IF(MSTU(41).GE.2) THEN
51593 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
51594 & KC.EQ.18) GOTO 300
51595 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
51598 IS=2D0-SIGN(0.5D0,P(I,3))
51600 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
51602 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
51603 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
51605 C...Rotate to put second largest jet into -z,+x quadrant.
51607 IF(P(I,3).GE.0D0) GOTO 310
51608 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
51609 IF(MSTU(41).GE.2) THEN
51611 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
51612 & KC.EQ.18) GOTO 310
51613 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
51616 IS=2D0-SIGN(0.5D0,P(I,1))
51617 PLS(IS)=PLS(IS)-P(I,3)
51619 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
51626 C*********************************************************************
51629 C...Gives program heading, or lists an event, or particle
51630 C...data, or current parameter values.
51632 SUBROUTINE PYLIST(MLIST)
51634 C...Double precision and integer declarations.
51635 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51636 IMPLICIT INTEGER(I-N)
51637 INTEGER PYK,PYCHGE,PYCOMP
51638 C...Parameter statement to help give large particle numbers.
51639 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51640 &KEXCIT=4000000,KDIMEN=5000000)
51642 C...HEPEVT commonblock.
51643 PARAMETER (NMXHEP=4000)
51644 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
51645 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
51646 DOUBLE PRECISION PHEP,VHEP
51649 C...User process event common block.
51651 PARAMETER (MAXNUP=500)
51652 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
51653 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
51654 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
51655 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
51656 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
51660 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
51661 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51662 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51663 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
51664 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
51665 C...Local arrays, character variables and data.
51666 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
51668 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
51670 C...Initialization printout: version number and date of last change.
51671 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
51674 IF(MLIST.EQ.0) RETURN
51677 C...List event data, including additional lines after N.
51678 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
51679 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
51680 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
51681 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
51683 IF(MLIST.GE.2) LMX=16
51686 IF(MSTU(2).GT.0) IMAX=MSTU(2)
51687 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
51688 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
51689 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
51690 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
51692 C...Get particle name, pad it and check it is not too long.
51693 CALL PYNAME(K(I,2),CHAP)
51696 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
51700 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
51702 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
51705 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
51707 CHAC=CHDL(MDL)(1:2*LDL)//' '
51709 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
51710 & CHDL(MDL)(LDL+1:2*LDL)//' '
51711 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
51715 C...Add information on string connection.
51716 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
51720 IF(KC.NE.0) KCC=KCHG(KC,2)
51721 IF(IABS(K(I,2)).EQ.39) THEN
51722 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
51723 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
51725 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
51726 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
51727 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
51728 ELSEIF(KCC.NE.0) THEN
51730 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
51734 C...Write data for particle/jet.
51735 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
51736 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
51738 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
51739 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
51741 ELSEIF(MLIST.EQ.1) THEN
51742 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
51744 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
51745 & K(I,1).EQ.14)) THEN
51746 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
51747 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
51748 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
51751 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),
51754 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
51756 C...Insert extra separator lines specified by user.
51757 IF(MSTU(70).GE.1) THEN
51759 DO 110 J=1,MIN(10,MSTU(70))
51760 IF(I.EQ.MSTU(70+J)) ISEP=1
51762 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
51763 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
51767 C...Sum of charges and momenta.
51771 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
51772 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
51773 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
51774 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
51775 ELSEIF(MLIST.EQ.1) THEN
51776 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
51778 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
51781 C...Simple listing of HEPEVT entries (mainly for test purposes).
51782 ELSEIF(MLIST.EQ.5) THEN
51783 WRITE(MSTU(11),7500)
51785 IF(ISTHEP(I).EQ.0) GOTO 140
51786 WRITE(MSTU(11),7600) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
51787 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
51791 C...Simple listing of user-process entries (mainly for test purposes).
51792 ELSEIF(MLIST.EQ.7) THEN
51793 WRITE(MSTU(11),7300)
51795 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
51796 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
51799 C...Give simple list of KF codes defined in program.
51800 ELSEIF(MLIST.EQ.11) THEN
51801 WRITE(MSTU(11),6600)
51803 CALL PYNAME(KF,CHAP)
51804 CALL PYNAME(-KF,CHAN)
51805 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
51806 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
51810 DO 170 KFLB=1,KFLA-(3-KFLS)/2
51811 KF=1000*KFLA+100*KFLB+KFLS
51812 CALL PYNAME(KF,CHAP)
51813 CALL PYNAME(-KF,CHAN)
51814 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
51820 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
51821 IF(KMUL.EQ.5) KFLS=5
51823 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
51824 IF(KMUL.EQ.4) KFLR=2
51826 DO 200 KFLC=1,KFLB-1
51827 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
51828 CALL PYNAME(KF,CHAP)
51829 CALL PYNAME(-KF,CHAN)
51830 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
51833 CALL PYNAME(KFK,CHAP)
51834 WRITE(MSTU(11),6700) KFK,CHAP
51836 CALL PYNAME(KFK,CHAP)
51837 WRITE(MSTU(11),6700) KFK,CHAP
51840 KF=10000*KFLR+110*KFLB+KFLS
51841 CALL PYNAME(KF,CHAP)
51842 WRITE(MSTU(11),6700) KF,CHAP
51846 CALL PYNAME(KF,CHAP)
51847 WRITE(MSTU(11),6700) KF,CHAP
51849 CALL PYNAME(KF,CHAP)
51850 WRITE(MSTU(11),6700) KF,CHAP
51856 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
51858 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
51859 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
51860 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
51861 CALL PYNAME(KF,CHAP)
51862 CALL PYNAME(-KF,CHAN)
51863 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
51870 IF(KF.LT.1000000) GOTO 270
51871 CALL PYNAME(KF,CHAP)
51872 CALL PYNAME(-KF,CHAN)
51873 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
51874 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
51877 C...List parton/particle data table. Check whether to be listed.
51878 ELSEIF(MLIST.EQ.12) THEN
51879 WRITE(MSTU(11),6800)
51880 DO 300 KC=1,MSTU(6)
51882 IF(KF.EQ.0) GOTO 300
51883 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
51886 C...Find particle name and mass. Print information.
51887 CALL PYNAME(KF,CHAP)
51888 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
51889 CALL PYNAME(-KF,CHAN)
51890 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
51891 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
51893 C...Particle decay: channel number, branching ratios, matrix element,
51894 C...decay products.
51895 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
51897 CALL PYNAME(KFDP(IDC,J),CHAD(J))
51899 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
51904 C...List parameter value table.
51905 ELSEIF(MLIST.EQ.13) THEN
51906 WRITE(MSTU(11),7100)
51908 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
51912 C...Format statements for output on unit MSTU(11) (by default 6).
51913 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
51914 &5X,'KF orig p_x p_y p_z E m'/)
51915 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
51916 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
51917 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
51918 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
51919 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
51920 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
51921 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
51922 5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
51923 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
51924 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
51925 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
51926 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
51927 5900 FORMAT(66X,5(1X,F12.3))
51928 6000 FORMAT(1X,78('='))
51929 6100 FORMAT(1X,130('='))
51930 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
51931 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
51932 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
51933 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
51935 6600 FORMAT(///20X,'List of KF codes in program'/)
51936 6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
51937 6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
51938 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
51939 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
51940 &1X,'ME',3X,'Br.rat.',4X,'decay products')
51941 6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
51942 &1X,1P,E13.5,3X,I2)
51943 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
51944 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
51945 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
51946 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
51947 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
51948 &//' I IST ID Mothers Colours p_x p_y p_z',
51950 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
51951 7500 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
51952 &//' I IST ID Mothers Daughters p_x p_y p_z',
51954 7600 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
51959 C*********************************************************************
51962 C...Writes a logo for the program.
51966 C...Double precision and integer declarations.
51967 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51968 IMPLICIT INTEGER(I-N)
51969 INTEGER PYK,PYCHGE,PYCOMP
51970 C...Parameter for length of information block.
51971 PARAMETER (IREFER=18)
51973 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51974 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
51975 SAVE /PYDAT1/,/PYPARS/
51976 C...Local arrays and character variables.
51978 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
51979 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
51981 C...Data on months, logo, titles, and references.
51982 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
51983 &'Oct','Nov','Dec'/
51984 DATA (LOGO(J),J=1,19)/
51986 &' *:::!!:::::::::::* ',
51987 &' *::::::!!::::::::::::::* ',
51988 &' *::::::::!!::::::::::::::::* ',
51989 &' *:::::::::!!:::::::::::::::::* ',
51990 &' *:::::::::!!:::::::::::::::::* ',
51991 &' *::::::::!!::::::::::::::::*! ',
51992 &' *::::::!!::::::::::::::* !! ',
51993 &' !! *:::!!:::::::::::* !! ',
51994 &' !! !* -><- * !! ',
52004 DATA (LOGO(J),J=20,38)/
52005 &'Welcome to the Lund Monte Carlo!',
52007 &'PPP Y Y TTTTT H H III A ',
52008 &'P P Y Y T H H I A A ',
52009 &'PPP Y T HHHHH I AAAAA',
52010 &'P Y T H H I A A',
52011 &'P Y T H H III A A',
52013 &'This is PYTHIA version x.xxx ',
52014 &'Last date of change: xx xxx 199x',
52016 &'Now is xx xxx 199x at xx:xx:xx ',
52018 &'Disclaimer: this program comes ',
52019 &'without any guarantees. Beware ',
52020 &'of errors and use common sense ',
52021 &'when interpreting results. ',
52023 &'Copyright T. Sjostrand (2001) '/
52024 DATA (REFER(J),J=1,18)/
52025 &'An archive of program versions and d',
52026 &'ocumentation is found on the web: ',
52027 &'http://www.thep.lu.se/~torbjorn/Pyth',
52031 &'When you cite this program, currentl',
52032 &'y the official reference is ',
52033 &'T. Sjostrand, P. Eden, C. Friberg, L',
52034 &'. Lonnblad, G. Miu, S. Mrenna and ',
52035 &'E. Norrbin, Computer Physics Commun.',
52036 &' 135 (2001) 238. ',
52037 &'The large manual is ',
52039 &'T. Sjostrand, L. Lonnblad and S. Mre',
52040 &'nna, LU TP 01-21 [hep-ph/0108264]. ',
52041 &'Also remember that the program, to a',
52042 &' large extent, represents original '/
52043 DATA (REFER(J),J=19,2*IREFER)/
52044 &'physics research. Other publications',
52045 &' of special relevance to your ',
52046 &'studies may therefore deserve separa',
52050 &'Main author: Torbjorn Sjostrand; Dep',
52051 &'artment of Theoretical Physics 2, ',
52052 &' Lund University, Solvegatan 14A, S',
52053 &'-223 62 Lund, Sweden; ',
52054 &' phone: + 46 - 46 - 222 48 16; e-ma',
52055 &'il: torbjorn@thep.lu.se ',
52056 &'SUSY author: Stephen Mrenna, Physics',
52057 &' Department, UC Davis, ',
52058 &' One Shields Avenue, Davis, CA 9561',
52060 &' phone: + 1 - 530 - 752 - 2661; e-m',
52061 &'ail: mrenna@physics.ucdavis.edu '/
52063 C...Check that PYDATA linked.
52064 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
52066 & 'Error: PYDATA has not been linked.'
52067 WRITE(*,'(1X,A)') 'Execution stopped!'
52070 C...Write current version number and current date+time.
52072 WRITE(VERS,'(I1)') MSTP(181)
52073 LOGO(28)(24:24)=VERS
52074 WRITE(SUBV,'(I3)') MSTP(182)
52075 LOGO(28)(26:28)=SUBV
52076 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
52077 WRITE(DATE,'(I2)') MSTP(185)
52078 LOGO(29)(22:23)=DATE
52079 LOGO(29)(25:27)=MONTH(MSTP(184))
52080 WRITE(YEAR,'(I4)') MSTP(183)
52081 LOGO(29)(29:32)=YEAR
52083 IF(IDATI(1).LE.0) THEN
52086 WRITE(DATE,'(I2)') IDATI(3)
52088 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
52089 WRITE(YEAR,'(I4)') IDATI(1)
52090 LOGO(31)(15:18)=YEAR
52091 WRITE(HOUR,'(I2)') IDATI(4)
52092 LOGO(31)(23:24)=HOUR
52093 WRITE(MINU,'(I2)') IDATI(5)
52094 LOGO(31)(26:27)=MINU
52095 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
52096 WRITE(SECO,'(I2)') IDATI(6)
52097 LOGO(31)(29:30)=SECO
52098 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
52102 C...Loop over lines in header. Define page feed and side borders.
52103 DO 100 ILIN=1,29+IREFER
52112 C...Separator lines and logos.
52113 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
52114 LINE(4:77)='***********************************************'//
52115 & '***************************'
52116 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
52117 LINE(6:37)=LOGO(ILIN-5)
52118 LINE(44:75)=LOGO(ILIN+14)
52119 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
52120 LINE(5:40)=REFER(2*ILIN-51)
52121 LINE(41:76)=REFER(2*ILIN-50)
52124 C...Write lines to appropriate unit.
52125 WRITE(MSTU(11),'(A79)') LINE
52131 C*********************************************************************
52134 C...Facilitates the updating of particle and decay data
52135 C...by allowing it to be done in an external file.
52137 SUBROUTINE PYUPDA(MUPDA,LFN)
52139 C...Double precision and integer declarations.
52140 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52141 IMPLICIT INTEGER(I-N)
52142 INTEGER PYK,PYCHGE,PYCOMP
52144 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52145 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52146 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
52147 COMMON/PYDAT4/CHAF(500,2)
52149 COMMON/PYINT4/MWID(500),WIDS(500,5)
52150 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
52151 C...Local arrays, character variables and data.
52152 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
52153 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
52154 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
52155 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
52156 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
52157 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
52158 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
52160 C...Write header if not yet done.
52161 IF(MSTU(12).GE.1) CALL PYLIST(0)
52163 C...Write information on file for editing.
52164 IF(MUPDA.EQ.1) THEN
52166 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
52167 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
52168 & MWID(KC),MDCY(KC,1)
52169 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
52170 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
52171 & (KFDP(IDC,J),J=1,5)
52175 C...Read complete set of information from edited file or
52176 C...read partial set of new or updated information from edited file.
52177 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
52179 C...Reset counters.
52183 IF(MUPDA.EQ.2) THEN
52188 DO 130 KC=1,MSTU(6)
52189 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
52190 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
52194 C...Begin of loop: read new line; unknown whether particle or
52196 140 READ(LFN,5200,END=190) CHINL
52198 C...Identify particle code and whether already defined (for MUPDA=3).
52199 IF(CHINL(2:10).NE.' ') THEN
52202 IF(MUPDA.EQ.2) THEN
52215 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
52218 C...Remove duplicate old decay data.
52219 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
52220 IDCREP=MDCY(KCREP,2)
52221 NDCREP=MDCY(KCREP,3)
52223 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
52225 DO 180 I=IDCREP,NDC-NDCREP
52226 MDME(I,1)=MDME(I+NDCREP,1)
52227 MDME(I,2)=MDME(I+NDCREP,2)
52228 BRAT(I)=BRAT(I+NDCREP)
52230 KFDP(I,J)=KFDP(I+NDCREP,J)
52235 ELSEIF(KCREP.NE.0) THEN
52243 C...Study line with particle data.
52244 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
52245 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
52246 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
52247 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
52248 & MWID(KC),MDCY(KC,1)
52252 C...Study line with decay data.
52255 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
52256 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
52257 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
52258 MDCY(KC,3)=MDCY(KC,3)+1
52259 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
52260 & (KFDP(NDC,J),J=1,5)
52263 C...End of loop; ensure that PYCOMP tables are updated.
52268 C...Perform possible tests that new information is consistent.
52269 DO 220 KC=1,MSTU(6)
52271 IF(KF.EQ.0) GOTO 220
52272 WRITE(CHKF,5300) KF
52273 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
52274 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
52275 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
52277 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
52278 IF(MDME(IDC,2).GT.80) GOTO 210
52280 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
52284 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
52286 ELSEIF(PYCOMP(KP).EQ.0) THEN
52291 PMS=PMS-PMAS(KPC,1)
52292 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
52296 IF(KQ.NE.0) MERR=MAX(2,MERR)
52297 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
52299 IF(MERR.EQ.3) CALL PYERRM(17,
52300 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
52301 IF(MERR.EQ.2) CALL PYERRM(17,
52302 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
52303 IF(MERR.EQ.1) CALL PYERRM(7,
52304 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
52305 BRSUM=BRSUM+BRAT(IDC)
52307 WRITE(CHTMP,5500) BRSUM
52308 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
52309 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
52310 & CHTMP(9:16)//' for KF ='//CHKF)
52313 C...Write DATA statements for inclusion in program.
52314 ELSEIF(MUPDA.EQ.4) THEN
52316 C...Find out how many codes and decay channels are actually used.
52320 IF(KCHG(I,4).NE.0) THEN
52322 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
52326 C...Initialize writing of DATA statements for inclusion in program.
52329 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
52332 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
52336 C...Loop through variables for conversion to characters.
52338 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
52339 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
52340 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
52341 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
52342 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
52343 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
52344 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
52345 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
52346 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
52347 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
52348 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
52349 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
52350 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
52351 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
52352 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
52353 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
52354 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
52355 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
52356 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
52357 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
52358 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
52359 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
52361 C...Replace variables beyond what is properly defined.
52363 IF(IDIM.GT.KCC) CHTMP=' 0'
52364 ELSEIF(IVAR.LE.8) THEN
52365 IF(IDIM.GT.KCC) CHTMP=' 0.0'
52366 ELSEIF(IVAR.LE.11) THEN
52367 IF(IDIM.GT.KCC) CHTMP=' 0'
52368 ELSEIF(IVAR.LE.13) THEN
52369 IF(IDIM.GT.NDC) CHTMP=' 0'
52370 ELSEIF(IVAR.LE.14) THEN
52371 IF(IDIM.GT.NDC) CHTMP=' 0.0'
52372 ELSEIF(IVAR.LE.19) THEN
52373 IF(IDIM.GT.NDC) CHTMP=' 0'
52374 ELSEIF(IVAR.LE.21) THEN
52375 IF(IDIM.GT.KCC) CHTMP=' '
52377 IF(IDIM.GT.KCC) CHTMP=' 0'
52380 C...Length of variable, trailing decimal zeros, quotation marks.
52384 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
52385 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
52387 CHNEW=CHTMP(LLOW:LHIG)//' '
52389 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
52392 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
52393 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
52398 CHNEW(LNEW+1:LNEW+2)='D0'
52401 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
52402 DO 260 LL=LNEW,1,-1
52403 IF(CHNEW(LL:LL).EQ.'''') THEN
52405 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
52411 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
52415 C...Form composite character string, often including repetition counter.
52416 IF(CHNEW.NE.CHOLD) THEN
52423 IF(NRPT.GE.2) LRPT=LNEW+3
52424 IF(NRPT.GE.10) LRPT=LNEW+4
52425 IF(NRPT.GE.100) LRPT=LNEW+5
52426 IF(NRPT.GE.1000) LRPT=LNEW+6
52429 WRITE(CHTMP,5400) NRPT
52431 IF(NRPT.GE.10) LRPT=2
52432 IF(NRPT.GE.100) LRPT=3
52433 IF(NRPT.GE.1000) LRPT=4
52434 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
52438 C...Add characters to end of line, to new line (after storing old line),
52439 C...or to new block of lines (after writing old block).
52440 IF(LLIN+LCOM.LE.70) THEN
52441 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
52443 ELSEIF(NLIN.LE.19) THEN
52444 CHLIN(LLIN+1:72)=' '
52447 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
52450 CHLIN(LLIN:72)='/'//' '
52452 WRITE(CHTMP,5400) IDIM-NRPT
52453 CHBLK(1)(30:33)=CHTMP(13:16)
52455 WRITE(LFN,5700) CHBLK(ILIN)
52459 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
52460 & ',I= , )/'//CHCOM(1:LCOM)//','
52461 WRITE(CHTMP,5400) IDIM-NRPT+1
52462 CHLIN(25:28)=CHTMP(13:16)
52467 C...Write final block of lines.
52468 CHLIN(LLIN:72)='/'//' '
52470 WRITE(CHTMP,5400) NDIM
52471 CHBLK(1)(30:33)=CHTMP(13:16)
52473 WRITE(LFN,5700) CHBLK(ILIN)
52478 C...Formats for reading and writing particle data.
52479 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
52480 5100 FORMAT(10X,2I5,F12.6,5I10)
52491 C*********************************************************************
52494 C...Provides various integer-valued event related data.
52498 C...Double precision and integer declarations.
52499 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52500 IMPLICIT INTEGER(I-N)
52501 INTEGER PYK,PYCHGE,PYCOMP
52503 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52504 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52505 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52506 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
52508 C...Default value. For I=0 number of entries, number of stable entries
52509 C...or 3 times total charge.
52511 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
52512 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
52514 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
52516 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
52517 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
52520 ELSEIF(I.EQ.0) THEN
52522 C...For I > 0 direct readout of K matrix or charge.
52523 ELSEIF(J.LE.5) THEN
52525 ELSEIF(J.EQ.6) THEN
52528 C...Status (existing/fragmented/decayed), parton/hadron separation.
52529 ELSEIF(J.LE.8) THEN
52530 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
52531 IF(J.EQ.8) PYK=PYK*K(I,2)
52532 ELSEIF(J.LE.12) THEN
52536 IF(KC.NE.0) KQ=KCHG(KC,2)
52537 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
52538 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
52540 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
52542 C...Heaviest flavour in hadron/diquark.
52543 ELSEIF(J.EQ.13) THEN
52545 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
52546 IF(KFA.LT.10) PYK=KFA
52547 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
52548 PYK=PYK*ISIGN(1,K(I,2))
52550 C...Particle history: generation, ancestor, rank.
52551 ELSEIF(J.LE.15) THEN
52558 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
52561 ELSEIF(J.EQ.16) THEN
52563 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
52564 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
52571 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
52572 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
52574 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
52575 IF(ILP.EQ.1) GOTO 120
52577 IF(K(I1,1).EQ.12) THEN
52579 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
52580 & .AND.K(I3,2).NE.93) PYK=PYK+1
52586 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
52590 C...Particle coming from collapsing jet system or not.
52591 ELSEIF(J.EQ.17) THEN
52598 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
52599 IF(PYK.EQ.1) PYK=-1
52603 IF(KCHG(KC,2).EQ.0) GOTO 150
52604 IF(K(I1,1).NE.12) PYK=0
52605 IF(K(I1,1).NE.12) RETURN
52608 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
52610 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
52612 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
52614 C...Number of decay products. Colour flow.
52615 ELSEIF(J.EQ.18) THEN
52616 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
52617 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
52618 ELSEIF(J.LE.22) THEN
52619 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
52620 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
52621 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
52622 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
52623 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
52630 C*********************************************************************
52633 C...Provides various real-valued event related data.
52637 C...Double precision and integer declarations.
52638 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52639 IMPLICIT INTEGER(I-N)
52640 INTEGER PYK,PYCHGE,PYCOMP
52642 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52643 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52644 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52645 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
52649 C...Set default value. For I = 0 sum of momenta or charges,
52650 C...or invariant mass of system.
52652 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
52653 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
52655 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
52657 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
52661 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
52665 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
52666 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
52668 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
52670 ELSEIF(I.EQ.0) THEN
52672 C...Direct readout of P matrix.
52673 ELSEIF(J.LE.5) THEN
52676 C...Charge, total momentum, transverse momentum, transverse mass.
52677 ELSEIF(J.LE.12) THEN
52678 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
52679 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
52680 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
52681 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
52682 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
52684 C...Theta and phi angle in radians or degrees.
52685 ELSEIF(J.LE.16) THEN
52686 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
52687 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
52688 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
52690 C...True rapidity, rapidity with pion mass, pseudorapidity.
52691 ELSEIF(J.LE.19) THEN
52693 IF(J.EQ.17) PMR=P(I,5)
52694 IF(J.EQ.18) PMR=PYMASS(211)
52695 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
52696 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
52699 C...Energy and momentum fractions (only to be used in CM frame).
52700 ELSEIF(J.LE.25) THEN
52701 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
52702 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
52703 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
52704 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
52705 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
52706 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
52712 C*********************************************************************
52715 C...Performs sphericity tensor analysis to give sphericity,
52716 C...aplanarity and the related event axes.
52718 SUBROUTINE PYSPHE(SPH,APL)
52720 C...Double precision and integer declarations.
52721 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52722 IMPLICIT INTEGER(I-N)
52723 INTEGER PYK,PYCHGE,PYCOMP
52725 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52727 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52728 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
52730 DIMENSION SM(3,3),SV(3,3)
52732 C...Calculate matrix to be diagonalized.
52741 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
52742 IF(MSTU(41).GE.2) THEN
52744 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
52745 & KC.EQ.18) GOTO 140
52746 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
52750 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
52752 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
52753 & MAX(1D-10,PA)**(PARU(41)-2D0)
52756 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
52762 C...Very low multiplicities (0 or 1) not considered.
52764 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
52771 SM(J1,J2)=SM(J1,J2)/PS
52775 C...Find eigenvalues to matrix (third degree equation).
52776 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
52777 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
52778 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
52779 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
52780 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
52781 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
52782 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
52783 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
52784 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
52785 IF(P(N+2,4).LT.1D-5) THEN
52786 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
52792 C...Find first and last eigenvector by solving equation system.
52795 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
52797 SV(J1,J2)=SM(J1,J2)
52798 SV(J2,J1)=SM(J1,J2)
52804 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
52807 SMAX=ABS(SV(J1,J2))
52811 DO 220 J3=JA+1,JA+2
52813 RL=SV(J1,JB)/SV(JA,JB)
52815 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
52816 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
52818 SMAX=ABS(SV(J1,J2))
52822 JB2=JB+2-3*((JB+1)/3)
52823 P(N+I,JB1)=-SV(JC,JB2)
52824 P(N+I,JB2)=SV(JC,JB1)
52825 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
52827 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
52828 SGN=(-1D0)**INT(PYR(0)+0.5D0)
52830 P(N+I,J)=SGN*P(N+I,J)/PA
52834 C...Middle axis orthogonal to other two. Fill other codes.
52835 SGN=(-1D0)**INT(PYR(0)+0.5D0)
52836 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
52837 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
52838 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
52851 C...Calculate sphericity and aplanarity. Select storing option.
52852 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
52856 IF(MSTU(43).LE.1) MSTU(3)=3
52857 IF(MSTU(43).GE.2) N=N+3
52862 C*********************************************************************
52865 C...Performs thrust analysis to give thrust, oblateness
52866 C...and the related event axes.
52868 SUBROUTINE PYTHRU(THR,OBL)
52870 C...Double precision and integer declarations.
52871 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52872 IMPLICIT INTEGER(I-N)
52873 INTEGER PYK,PYCHGE,PYCOMP
52875 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52876 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52877 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52878 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
52880 DIMENSION TDI(3),TPR(3)
52882 C...Take copy of particles that are to be considered in thrust analysis.
52886 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
52887 IF(MSTU(41).GE.2) THEN
52889 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
52890 & KC.EQ.18) GOTO 100
52891 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
52894 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
52895 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
52905 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
52907 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
52908 & P(N+NP,4)**(PARU(42)-1D0)
52909 PS=PS+P(N+NP,4)*P(N+NP,5)
52912 C...Very low multiplicities (0 or 1) not considered.
52914 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
52920 C...Loop over thrust and major. T axis along z direction in latter case.
52924 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
52926 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
52927 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
52928 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
52931 C...Find and order particles with highest p (pT for major).
52932 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
52936 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
52937 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
52938 IF(P(I,4).LE.P(ILF,4)) GOTO 140
52940 P(ILF+1,J)=P(ILF,J)
52949 C...Find and order initial axes with highest thrust (major).
52950 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
52953 NC=2**(MIN(MSTU(44),NP)-1)
52958 DO 200 ILF=1,MIN(MSTU(44),NP)
52959 SGN=P(N+NP+ILF+3,5)
52960 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
52962 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
52965 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
52966 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
52967 IF(TDS.LE.P(ILG,4)) GOTO 230
52969 P(ILG+1,J)=P(ILG,J)
52972 ILG=N+NP+MSTU(44)+4
52979 C...Iterate direction of axis until stable maximum.
52986 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
52987 IF(THP.GT.1D-10) TDI(J)=TPR(J)
52991 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
52993 TPR(J)=TPR(J)+SGN*P(I,J)
52996 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
52997 IF(THP.GE.THPS+PARU(48)) GOTO 270
52999 C...Save good axis. Try new initial axis until a number of tries agree.
53000 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
53001 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
53003 SGN=(-1D0)**INT(PYR(0)+0.5D0)
53005 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
53011 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
53014 C...Find minor axis and value by orthogonality.
53015 SGN=(-1D0)**INT(PYR(0)+0.5D0)
53016 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
53017 P(N+NP+3,2)=SGN*P(N+NP+2,1)
53021 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
53026 C...Fill axis information. Rotate back to original coordinate system.
53034 P(N+ILD,J)=P(N+NP+ILD,J)
53038 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
53040 C...Calculate thrust and oblateness. Select storing option.
53042 OBL=P(N+2,4)-P(N+3,4)
53045 IF(MSTU(43).LE.1) MSTU(3)=3
53046 IF(MSTU(43).GE.2) N=N+3
53051 C*********************************************************************
53054 C...Subdivides the particle content of an event into jets/clusters.
53056 SUBROUTINE PYCLUS(NJET)
53058 C...Double precision and integer declarations.
53059 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53060 IMPLICIT INTEGER(I-N)
53061 INTEGER PYK,PYCHGE,PYCOMP
53063 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53064 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53065 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53066 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
53067 C...Local arrays and saved variables.
53069 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
53071 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
53072 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
53073 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
53074 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
53075 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
53076 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
53077 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
53079 C...If first time, reset. If reentering, skip preliminaries.
53080 IF(MSTU(48).LE.0) THEN
53086 PIMASS=PMAS(PYCOMP(211),1)
53089 IF(MSTU(43).GE.2) N=N-NJET
53090 DO 110 I=N+1,N+NJET
53091 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
53093 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
53096 R2ACC=PARU(45)*PS(5)**2
53102 C...Find which particles are to be considered in cluster search.
53104 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
53105 IF(MSTU(41).GE.2) THEN
53107 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
53108 & KC.EQ.18) GOTO 140
53109 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
53112 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
53113 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
53118 C...Take copy of these particles, with space left for jets later on.
53124 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
53125 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
53126 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53127 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
53129 PS(J)=PS(J)+P(N+NP,J)
53139 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
53141 C...Very low multiplicities not considered.
53142 IF(NP.LT.MSTU(47)) THEN
53143 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
53148 C...Find precluster configuration. If too few jets, make harder cuts.
53150 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
53153 R2ACC=PARU(45)*PS(5)**2
53155 RINIT=1.25D0*PARU(43)
53156 IF(NP.LE.MSTU(47)+2) RINIT=0D0
53157 170 RINIT=0.8D0*RINIT
53160 DO 180 I=N+NP+1,N+2*NP
53164 C...Sum up small momentum region. Jet if enough absolute momentum.
53165 IF(MSTU(46).LE.2) THEN
53169 DO 210 I=N+NP+1,N+2*NP
53170 IF(P(I,5).GT.2D0*RINIT) GOTO 210
53174 P(N+1,J)=P(N+1,J)+P(I,J)
53177 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
53178 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
53179 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
53180 IF(NREM.EQ.0) GOTO 170
53183 C...Find fastest remaining particle.
53186 DO 230 I=N+NP+1,N+2*NP
53187 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
53192 P(N+NPRE,J)=P(IMAX,J)
53197 C...Sum up precluster around it according to pT separation.
53198 IF(MSTU(46).LE.2) THEN
53199 DO 260 I=N+NP+1,N+2*NP
53200 IF(K(I,4).NE.0) GOTO 260
53202 IF(R2.GT.RINIT**2) GOTO 260
53206 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
53209 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
53211 C...Sum up precluster around it according to mass or
53212 C...Durham pT separation.
53216 DO 280 I=N+NP+1,N+2*NP
53217 IF(K(I,4).NE.0) GOTO 280
53218 IF(MSTU(46).LE.4) THEN
53223 IF(R2.GE.R2MIN) GOTO 280
53229 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
53231 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
53238 C...Check if more preclusters to be found. Start over if too few.
53239 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
53240 IF(NREM.GT.0) GOTO 220
53243 C...Reassign all particles to nearest jet. Sum up new jet momenta.
53246 310 IF(MSTU(46).LE.1) THEN
53247 DO 330 I=N+1,N+NJET
53252 DO 360 I=N+NP+1,N+2*NP
53254 DO 340 IJET=N+1,N+NJET
53255 IF(P(IJET,5).LT.RINIT) GOTO 340
53257 IF(R2.GE.R2MIN) GOTO 340
53263 V(IMIN,J)=V(IMIN,J)+P(I,J)
53267 DO 380 I=N+1,N+NJET
53271 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
53276 C...Find two closest jets.
53277 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
53278 DO 400 ITRY1=N+1,N+NJET-1
53279 DO 390 ITRY2=ITRY1+1,N+NJET
53280 IF(MSTU(46).LE.2) THEN
53281 R2=R2T(ITRY1,ITRY2)
53282 ELSEIF(MSTU(46).LE.4) THEN
53283 R2=R2M(ITRY1,ITRY2)
53285 R2=R2D(ITRY1,ITRY2)
53287 IF(R2.GE.R2MIN) GOTO 390
53294 C...If allowed, join two closest jets and start over.
53295 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
53296 IREC=MIN(IMIN1,IMIN2)
53297 IDEL=MAX(IMIN1,IMIN2)
53299 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
53301 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
53302 DO 430 I=IDEL+1,N+NJET
53307 IF(MSTU(46).GE.2) THEN
53308 DO 440 I=N+NP+1,N+2*NP
53310 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
53311 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
53317 C...Divide up broad jet if empty cluster in list of final ones.
53318 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
53319 DO 450 I=N+1,N+NJET
53322 DO 460 I=N+NP+1,N+2*NP
53323 K(N+K(I,4),5)=K(N+K(I,4),5)+1
53326 DO 470 I=N+1,N+NJET
53327 IF(K(I,5).EQ.0) IEMP=I
53333 DO 480 I=N+NP+1,N+2*NP
53334 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
53337 IF(R2.LE.R2MAX) GOTO 480
53344 P(IEMP,J)=P(ISPL,J)
53345 P(IJET,J)=P(IJET,J)-P(ISPL,J)
53347 P(IEMP,5)=P(ISPL,5)
53348 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
53349 IF(NLOOP.LE.2) GOTO 300
53354 C...If generalized thrust has not yet converged, continue iteration.
53355 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
53361 C...Reorder jets according to energy.
53362 DO 510 I=N+1,N+NJET
53367 DO 540 INEW=N+1,N+NJET
53369 DO 520 ITRY=N+1,N+NJET
53370 IF(V(ITRY,4).LE.PEMAX) GOTO 520
53379 P(INEW,J)=V(IMAX,J)
53385 C...Clean up particle-jet assignments and jet information.
53386 DO 550 I=N+NP+1,N+2*NP
53389 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
53390 K(IORI,4)=K(IORI,4)+1
53394 DO 570 I=N+1,N+NJET
53397 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
53401 IF(K(I,4).EQ.0) IEMP=I
53404 C...Select storing option. Output variables. Check for failure.
53410 PARU(63)=SQRT(R2MIN)
53411 IF(NJET.LE.1) PARU(63)=0D0
53413 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
53417 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
53418 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
53424 C*********************************************************************
53427 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
53428 C...as used for calorimeters at hadron colliders.
53430 SUBROUTINE PYCELL(NJET)
53432 C...Double precision and integer declarations.
53433 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53434 IMPLICIT INTEGER(I-N)
53435 INTEGER PYK,PYCHGE,PYCOMP
53437 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53438 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53439 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53440 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
53442 C...Loop over all particles. Find cell that was hit by given particle.
53443 PTLRAT=1D0/SINH(PARU(51))**2
53447 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
53448 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
53449 IF(MSTU(41).GE.2) THEN
53451 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
53452 & KC.EQ.18) GOTO 110
53453 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
53457 PT=SQRT(P(I,1)**2+P(I,2)**2)
53458 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
53459 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
53460 & (ETA/PARU(51)+1D0))))
53461 PHI=PYANGL(P(I,1),P(I,2))
53462 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
53463 & (PHI/PARU(1)+1D0))))
53464 IETPH=MSTU(52)*IETA+IPHI
53466 C...Add to cell already hit, or book new cell.
53468 IF(IETPH.EQ.K(IC,3)) THEN
53474 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
53475 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
53483 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
53484 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
53488 C...Smear true bin content by calorimeter resolution.
53489 IF(MSTU(53).GE.1) THEN
53492 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
53493 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
53494 & COS(PARU(2)*PYR(0))
53495 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
53497 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
53501 C...Remove cells below threshold.
53502 IF(PARU(58).GT.0D0) THEN
53506 IF(P(IC,5).GT.PARU(58)) THEN
53518 C...Find initiator cell: the one with highest pT of not yet used ones.
53522 IF(K(IC,5).NE.2) GOTO 160
53523 IF(P(IC,5).LE.ETMAX) GOTO 160
53529 IF(ETMAX.LT.PARU(52)) GOTO 220
53530 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
53531 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
53545 C...Sum up unused cells within required distance of initiator.
53547 IF(K(IC,5).EQ.0) GOTO 170
53548 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
53549 DPHIA=ABS(P(IC,2)-PHI)
53550 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
53552 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
53553 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
53555 K(NJ,4)=K(NJ,4)+K(IC,4)
53556 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
53557 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
53558 P(NJ,5)=P(NJ,5)+P(IC,5)
53561 C...Reject cluster below minimum ET, else accept.
53562 IF(P(NJ,5).LT.PARU(53)) THEN
53565 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
53567 ELSEIF(MSTU(54).LE.2) THEN
53568 P(NJ,3)=P(NJ,3)/P(NJ,5)
53569 P(NJ,4)=P(NJ,4)/P(NJ,5)
53570 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
53573 IF(K(IC,5).LT.0) K(IC,5)=0
53580 IF(K(IC,5).GE.0) GOTO 210
53581 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
53582 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
53583 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
53584 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
53590 C...Arrange clusters in falling ET sequence.
53591 220 DO 250 I=1,NJ-NC
53594 IF(K(IJ,5).EQ.0) GOTO 230
53595 IF(P(IJ,5).LT.ETMAX) GOTO 230
53603 K(N+I,4)=K(IJMAX,4)
53606 P(N+I,J)=P(IJMAX,J)
53612 C...Convert to massless or massive four-vectors.
53613 IF(MSTU(54).EQ.2) THEN
53614 DO 260 I=N+1,N+NJET
53616 P(I,1)=P(I,5)*COS(P(I,4))
53617 P(I,2)=P(I,5)*SIN(P(I,4))
53618 P(I,3)=P(I,5)*SINH(ETA)
53619 P(I,4)=P(I,5)*COSH(ETA)
53622 ELSEIF(MSTU(54).GE.3) THEN
53623 DO 270 I=N+1,N+NJET
53624 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
53628 C...Information about storage.
53632 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
53633 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
53638 C*********************************************************************
53641 C...Determines, approximately, the two jet masses that minimize
53642 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
53644 SUBROUTINE PYJMAS(PMH,PML)
53646 C...Double precision and integer declarations.
53647 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53648 IMPLICIT INTEGER(I-N)
53649 INTEGER PYK,PYCHGE,PYCOMP
53651 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53652 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53653 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53654 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
53656 DIMENSION SM(3,3),SAX(3),PS(3,5)
53669 PIMASS=PMAS(PYCOMP(211),1)
53671 C...Take copy of particles that are to be considered in mass analysis.
53673 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
53674 IF(MSTU(41).GE.2) THEN
53676 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
53677 & KC.EQ.18) GOTO 170
53678 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
53681 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
53682 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
53691 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
53692 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
53693 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53695 C...Fill information in sphericity tensor and total momentum vector.
53698 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
53701 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
53703 PS(3,J)=PS(3,J)+P(N+NP,J)
53707 C...Very low multiplicities (0 or 1) not considered.
53709 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
53714 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
53717 C...Find largest eigenvalue to matrix (third degree equation).
53720 SM(J1,J2)=SM(J1,J2)/PSS
53723 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
53724 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
53725 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
53726 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
53727 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
53728 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
53729 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
53731 C...Find largest eigenvector by solving equation system.
53733 SM(J1,J1)=SM(J1,J1)-SMA
53735 SM(J2,J1)=SM(J1,J2)
53741 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
53744 SMAX=ABS(SM(J1,J2))
53748 DO 250 J3=JA+1,JA+2
53750 RL=SM(J1,JB)/SM(JA,JB)
53752 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
53753 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
53755 SMAX=ABS(SM(J1,J2))
53759 JB2=JB+2-3*((JB+1)/3)
53760 SAX(JB1)=-SM(JC,JB2)
53761 SAX(JB2)=SM(JC,JB1)
53762 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
53764 C...Divide particles into two initial clusters by hemisphere.
53766 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
53768 IF(PSAX.LT.0D0) IS=2
53771 PS(IS,J)=PS(IS,J)+P(I,J)
53774 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
53775 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
53777 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
53781 PS(3,J)=PS(1,J)-PS(2,J)
53784 PPS=P(I,4)*PS(3,4)-P(I,1)*PS(3,1)-P(I,2)*PS(3,2)-P(I,3)*PS(3,3)
53785 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
53786 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
53787 IF(PMDI.LT.PMD) THEN
53793 C...Loop back if significant reduction in sum of m^2.
53794 IF(PMD.LT.-PARU(48)*PMS) THEN
53798 PS(IS,J)=PS(IS,J)-P(IM,J)
53799 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
53805 C...Final masses and output.
53808 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
53809 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
53810 PMH=MAX(PS(1,5),PS(2,5))
53811 PML=MIN(PS(1,5),PS(2,5))
53816 C*********************************************************************
53819 C...Calculates the first few Fox-Wolfram moments.
53821 SUBROUTINE PYFOWO(H10,H20,H30,H40)
53823 C...Double precision and integer declarations.
53824 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53825 IMPLICIT INTEGER(I-N)
53826 INTEGER PYK,PYCHGE,PYCOMP
53828 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53829 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53830 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53831 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
53833 C...Copy momenta for particles and calculate H0.
53838 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
53839 IF(MSTU(41).GE.2) THEN
53841 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
53842 & KC.EQ.18) GOTO 110
53843 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
53846 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
53847 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
53858 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
53864 C...Very low multiplicities (0 or 1) not considered.
53866 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
53874 C...Calculate H1 - H4.
53880 DO 120 I2=I1+1,N+NP
53881 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
53882 & (P(I1,4)*P(I2,4))
53883 H10=H10+P(I1,4)*P(I2,4)*CTHE
53884 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
53885 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
53886 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
53891 C...Calculate H1/H0 - H4/H0. Output.
53894 H10=(HD+2D0*H10)/H0
53895 H20=(HD+2D0*H20)/H0
53896 H30=(HD+2D0*H30)/H0
53897 H40=(HD+2D0*H40)/H0
53902 C*********************************************************************
53905 C...Evaluates various properties of an event, with statistics
53906 C...accumulated during the course of the run and
53907 C...printed at the end.
53909 SUBROUTINE PYTABU(MTABU)
53911 C...Double precision and integer declarations.
53912 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53913 IMPLICIT INTEGER(I-N)
53914 INTEGER PYK,PYCHGE,PYCOMP
53916 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53917 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53918 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53919 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
53920 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
53921 C...Local arrays, character variables, saved variables and data.
53922 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
53923 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
53924 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
53925 &KFDM(8),KFDC(200,0:8),NPDC(200)
53926 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
53927 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
53928 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
53929 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
53930 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
53931 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
53932 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
53933 &NEVDC/0/,NKFDC/0/,NREDC/0/
53935 C...Reset statistics on initial parton state.
53936 IF(MTABU.EQ.10) THEN
53940 C...Identify and order flavour content of initial state.
53941 ELSEIF(MTABU.EQ.11) THEN
53943 KFM1=2*IABS(MSTU(161))
53944 IF(MSTU(161).GT.0) KFM1=KFM1-1
53945 KFM2=2*IABS(MSTU(162))
53946 IF(MSTU(162).GT.0) KFM2=KFM2-1
53947 KFMN=MIN(KFM1,KFM2)
53948 KFMX=MAX(KFM1,KFM2)
53950 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
53953 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
53954 & KFMX.LT.KFIS(I,2))) THEN
53960 110 IF(IKFIS.LT.0) THEN
53963 IF(NKFIS.GE.100) RETURN
53964 DO 130 I=NKFIS,IKFIS,-1
53965 KFIS(I+1,1)=KFIS(I,1)
53966 KFIS(I+1,2)=KFIS(I,2)
53968 NPIS(I+1,J)=NPIS(I,J)
53978 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
53980 C...Count number of partons in initial state.
53983 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
53984 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
53985 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
53990 IF(IM.LE.0.OR.IM.GT.N) THEN
53992 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
53994 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
53995 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
54005 IF(NP.GE.11) NPCO=8
54006 IF(NP.GE.16) NPCO=9
54007 IF(NP.GE.26) NPCO=10
54008 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
54011 C...Write statistics on initial parton state.
54012 ELSEIF(MTABU.EQ.12) THEN
54013 FAC=1D0/MAX(1,NEVIS)
54014 WRITE(MSTU(11),5000) NEVIS
54017 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
54019 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
54020 CALL PYNAME(KFM1,CHAU)
54022 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
54024 IF(KFIS(I,1).EQ.0) KFMX=0
54026 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
54027 CALL PYNAME(KFM2,CHAU)
54029 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
54030 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
54031 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
54034 C...Copy statistics on initial parton state into /PYJETS/.
54035 ELSEIF(MTABU.EQ.13) THEN
54036 FAC=1D0/MAX(1,NEVIS)
54039 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
54041 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
54043 IF(KFIS(I,1).EQ.0) KFMX=0
54045 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
54052 P(I,J)=FAC*NPIS(I,J)
54053 V(I,J)=FAC*NPIS(I,J+5)
54067 C...Reset statistics on number of particles/partons.
54068 ELSEIF(MTABU.EQ.20) THEN
54075 C...Identify whether particle/parton is primary or not.
54076 ELSEIF(MTABU.EQ.21) THEN
54080 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
54081 MSTU(62)=MSTU(62)+1
54084 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
54086 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
54088 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
54090 ELSEIF(KC.EQ.0) THEN
54091 ELSEIF(K(K(I,3),1).EQ.13) THEN
54093 IF(IM.LE.0.OR.IM.GT.N) THEN
54095 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
54098 ELSEIF(KCHG(KC,2).EQ.0) THEN
54099 KCM=PYCOMP(K(K(I,3),2))
54101 IF(KCHG(KCM,2).NE.0) MPRI=1
54104 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
54105 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
54107 IF(K(I,1).LE.10) THEN
54109 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
54112 C...Fill statistics on number of particles/partons in event.
54114 KFS=3-ISIGN(1,K(I,2))-MPRI
54116 IF(KFA.EQ.KFFS(IP)) THEN
54119 ELSEIF(KFA.LT.KFFS(IP)) THEN
54125 220 IF(IKFFS.LT.0) THEN
54128 IF(NKFFS.GE.400) RETURN
54129 DO 240 IP=NKFFS,IKFFS,-1
54130 KFFS(IP+1)=KFFS(IP)
54132 NPFS(IP+1,J)=NPFS(IP,J)
54141 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
54144 C...Write statistics on particle/parton composition of events.
54145 ELSEIF(MTABU.EQ.22) THEN
54146 FAC=1D0/MAX(1,NEVFS)
54147 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
54149 CALL PYNAME(KFFS(I),CHAU)
54152 IF(KC.NE.0) MDCYF=MDCY(KC,1)
54153 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
54154 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
54157 C...Copy particle/parton composition information into /PYJETS/.
54158 ELSEIF(MTABU.EQ.23) THEN
54159 FAC=1D0/MAX(1,NEVFS)
54165 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
54167 P(I,J)=FAC*NPFS(I,J)
54187 C...Reset factorial moments statistics.
54188 ELSEIF(MTABU.EQ.30) THEN
54194 FM1FM(IM,IB,IP)=0D0
54195 FM2FM(IM,IB,IP)=0D0
54200 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
54201 ELSEIF(MTABU.EQ.31) THEN
54206 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
54207 IF(MSTU(41).GE.2) THEN
54209 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
54210 & KC.EQ.18) GOTO 410
54211 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
54212 & PYCHGE(K(I,2)).EQ.0) GOTO 410
54215 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
54216 IF(MSTU(42).GE.2) PMR=P(I,5)
54217 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
54218 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
54220 IF(ABS(YETA).GT.PARU(57)) GOTO 410
54221 PHI=PYANGL(P(I,1),P(I,2))
54222 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
54223 IYETA=MAX(0,MIN(511,IYETA))
54224 IPHI=512D0*(PHI+PARU(1))/PARU(2)
54225 IPHI=MAX(0,MIN(511,IPHI))
54228 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
54231 C...Order particles in (pseudo)rapidity and/or azimuth.
54232 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
54233 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
54237 IF(NUPP.EQ.NLOW+1) THEN
54242 DO 350 I1=NUPP-1,NLOW+1,-1
54243 IF(IYETA.GE.K(I1,1)) GOTO 360
54246 360 K(I1+1,1)=IYETA
54247 DO 370 I1=NUPP-1,NLOW+1,-1
54248 IF(IPHI.GE.K(I1,2)) GOTO 380
54252 DO 390 I1=NUPP-1,NLOW+1,-1
54253 IF(IYEP.GE.K(I1,3)) GOTO 400
54263 C...Calculate sum of factorial moments in event.
54271 IF(IM.LE.2) IBIN=2**(10-IB)
54272 IF(IM.EQ.3) IBIN=4**(10-IB)
54273 IAGR=K(NLOW+1,IM)/IBIN
54275 DO 440 I=NLOW+2,NUPP+1
54277 IF(ICUT.EQ.IAGR) THEN
54281 ELSEIF(NAGR.EQ.2) THEN
54282 FEVFM(IB,1)=FEVFM(IB,1)+2D0
54283 ELSEIF(NAGR.EQ.3) THEN
54284 FEVFM(IB,1)=FEVFM(IB,1)+6D0
54285 FEVFM(IB,2)=FEVFM(IB,2)+6D0
54286 ELSEIF(NAGR.EQ.4) THEN
54287 FEVFM(IB,1)=FEVFM(IB,1)+12D0
54288 FEVFM(IB,2)=FEVFM(IB,2)+24D0
54289 FEVFM(IB,3)=FEVFM(IB,3)+24D0
54291 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
54292 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
54293 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
54295 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
54296 & (NAGR-3D0)*(NAGR-4D0)
54304 C...Add results to total statistics.
54307 IF(FEVFM(1,IP).LT.0.5D0) THEN
54309 ELSEIF(IM.LE.2) THEN
54310 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
54312 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
54314 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
54315 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
54319 NMUFM=NMUFM+(NUPP-NLOW)
54322 C...Write accumulated statistics on factorial moments.
54323 ELSEIF(MTABU.EQ.32) THEN
54324 FAC=1D0/MAX(1,NEVFM)
54325 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
54326 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
54327 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
54329 WRITE(MSTU(11),5500)
54332 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
54334 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
54335 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
54336 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
54338 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
54339 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
54342 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
54347 C...Copy statistics on factorial moments into /PYJETS/.
54348 ELSEIF(MTABU.EQ.33) THEN
54349 FAC=1D0/MAX(1,NEVFM)
54356 IF(IM.NE.2) K(I,3)=2**(IB-1)
54358 IF(IM.NE.1) K(I,4)=2**(IB-1)
54360 P(I,1)=2D0*PARU(57)/K(I,3)
54361 V(I,1)=PARU(2)/K(I,4)
54363 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
54364 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
54380 C...Reset statistics on Energy-Energy Correlation.
54381 ELSEIF(MTABU.EQ.40) THEN
54392 C...Find particles to include, with proper assumed mass.
54393 ELSEIF(MTABU.EQ.41) THEN
54399 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
54400 IF(MSTU(41).GE.2) THEN
54402 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
54403 & KC.EQ.18) GOTO 570
54404 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
54405 & PYCHGE(K(I,2)).EQ.0) GOTO 570
54408 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
54409 IF(MSTU(42).GE.2) PMR=P(I,5)
54410 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
54411 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
54418 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
54419 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
54422 IF(NUPP.EQ.NLOW) RETURN
54424 C...Analyze Energy-Energy Correlation in event.
54425 FAC=(2D0/ECM**2)*50D0/PARU(1)
54429 DO 600 I1=NLOW+2,NUPP
54430 DO 590 I2=NLOW+1,I1-1
54431 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
54432 & (P(I1,5)*P(I2,5))
54433 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
54434 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
54435 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
54439 FE1EC(J)=FE1EC(J)+FEVEE(J)
54440 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
54441 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
54442 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
54443 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
54444 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
54448 C...Write statistics on Energy-Energy Correlation.
54449 ELSEIF(MTABU.EQ.42) THEN
54450 FAC=1D0/MAX(1,NEVEE)
54451 WRITE(MSTU(11),5700) NEVEE
54454 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
54455 FEEC2=FAC*FE1EC(51-J)
54456 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
54458 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
54459 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
54460 & FEEC2,FEES2,FEECA,FEESA
54463 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
54464 ELSEIF(MTABU.EQ.43) THEN
54465 FAC=1D0/MAX(1,NEVEE)
54472 P(I,1)=FAC*FE1EC(I)
54473 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
54474 P(I,2)=FAC*FE1EC(51-I)
54475 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
54476 P(I,3)=FAC*FE1EA(I)
54477 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
54478 P(I,4)=PARU(1)*(I-1)/50D0
54479 P(I,5)=PARU(1)*I/50D0
54494 C...Reset statistics on decay channels.
54495 ELSEIF(MTABU.EQ.50) THEN
54500 C...Identify and order flavour content of final state.
54501 ELSEIF(MTABU.EQ.51) THEN
54505 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
54512 IF(K(I,2).LT.0) KFM=KFM-1
54513 DO 650 IDS=NDS-1,1,-1
54515 IF(KFM.LT.KFDM(IDS)) GOTO 660
54516 KFDM(IDS+1)=KFDM(IDS)
54522 C...Find whether old or new final state.
54524 IF(NDS.LT.KFDC(IDC,0)) THEN
54527 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
54529 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
54532 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
54541 700 IF(IKFDC.LT.0) THEN
54543 ELSEIF(NKFDC.GE.200) THEN
54547 DO 720 IDC=NKFDC,IKFDC,-1
54548 NPDC(IDC+1)=NPDC(IDC)
54550 KFDC(IDC+1,I)=KFDC(IDC,I)
54556 KFDC(IKFDC,I)=KFDM(I)
54560 NPDC(IKFDC)=NPDC(IKFDC)+1
54562 C...Write statistics on decay channels.
54563 ELSEIF(MTABU.EQ.52) THEN
54564 FAC=1D0/MAX(1,NEVDC)
54565 WRITE(MSTU(11),5900) NEVDC
54567 DO 740 I=1,KFDC(IDC,0)
54570 IF(2*KF.NE.KFM) KF=-KF
54571 CALL PYNAME(KF,CHAU)
54573 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
54575 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
54577 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
54579 C...Copy statistics on decay channels into /PYJETS/.
54580 ELSEIF(MTABU.EQ.53) THEN
54581 FAC=1D0/MAX(1,NEVDC)
54587 K(IDC,5)=KFDC(IDC,0)
54592 DO 770 I=1,KFDC(IDC,0)
54595 IF(2*KF.NE.KFM) KF=-KF
54596 IF(I.LE.5) P(IDC,I)=KF
54597 IF(I.GE.6) V(IDC,I-5)=KF
54599 V(IDC,5)=FAC*NPDC(IDC)
54614 C...Format statements for output on unit MSTU(11) (default 6).
54615 5000 FORMAT(///20X,'Event statistics - initial state'/
54616 &20X,'based on an analysis of ',I6,' events'//
54617 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
54618 &'according to fragmenting system multiplicity'/
54619 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
54620 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
54621 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
54622 5200 FORMAT(///20X,'Event statistics - final state'/
54623 &20X,'based on an analysis of ',I7,' events'//
54624 &5X,'Mean primary multiplicity =',F10.4/
54625 &5X,'Mean final multiplicity =',F10.4/
54626 &5X,'Mean charged multiplicity =',F10.4//
54627 &5X,'Number of particles produced per event (directly and via ',
54628 &'decays/branchings)'/
54629 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
54630 &8X,'Total'/35X,'prim seco prim seco'/)
54631 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
54632 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
54633 &20X,'based on an analysis of ',I6,' events'//
54634 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
54635 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
54637 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
54638 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
54639 &20X,'based on an analysis of ',I6,' events'//
54640 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
54641 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
54642 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
54643 5900 FORMAT(///20X,'Decay channel analysis - final state'/
54644 &20X,'based on an analysis of ',I6,' events'//
54645 &2X,'Probability',10X,'Complete final state'/)
54646 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
54647 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
54648 &'or table overflow)')
54653 C*********************************************************************
54656 C...Handles the generation of an e+e- annihilation jet event.
54658 SUBROUTINE PYEEVT(KFL,ECM)
54660 C...Double precision and integer declarations.
54661 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54662 IMPLICIT INTEGER(I-N)
54663 INTEGER PYK,PYCHGE,PYCOMP
54665 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54666 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54667 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54668 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
54670 C...Check input parameters.
54671 IF(MSTU(12).GE.1) CALL PYLIST(0)
54672 IF(KFL.LT.0.OR.KFL.GT.8) THEN
54673 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
54674 IF(MSTU(21).GE.1) RETURN
54676 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
54677 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
54678 IF(ECM.LT.ECMMIN) THEN
54679 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
54680 IF(MSTU(21).GE.1) RETURN
54683 C...Check consistency of MSTJ options set.
54684 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
54686 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
54689 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
54691 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
54695 C...Initialize alpha_strong and total cross-section.
54696 MSTU(111)=MSTJ(108)
54697 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
54699 PARU(112)=PARJ(121)
54700 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
54701 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
54702 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
54704 IF(MSTJ(116).GE.3) MSTJ(116)=1
54707 C...Add initial e+e- to event record (documentation only).
54710 IF(NTRY.GT.100) THEN
54711 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
54716 IF(MSTJ(115).GE.2) THEN
54718 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
54720 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
54724 C...Radiative photon (in initial state).
54727 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
54729 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
54730 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
54732 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
54733 K(NC,3)=MIN(MSTJ(115)/2,1)
54736 C...Virtual exchange boson (gamma or Z0).
54737 IF(MSTJ(115).GE.3) THEN
54740 IF(MSTJ(102).EQ.2) KF=23
54744 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
54750 C...Choice of flavour and jet configuration.
54751 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
54752 IF(KFLC.EQ.0) GOTO 100
54753 CALL PYXJET(ECMC,NJET,CUT)
54755 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
54757 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
54758 IF(NJET.EQ.2) MSTJ(120)=1
54760 C...Fill jet configuration and origin.
54761 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
54762 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
54764 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
54765 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
54766 &-KFLC,ECMC,X1,X2,X4,X12,X14)
54767 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
54768 &-KFLC,ECMC,X1,X2,X4,X12,X14)
54769 IF(MSTU(24).NE.0) GOTO 100
54771 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
54774 C...Angular orientation according to matrix element.
54775 IF(MSTJ(106).EQ.1) THEN
54776 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
54777 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
54778 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
54781 C...Rotation and boost from radiative photon.
54783 DBEK=-PAK/(ECM-PAK)
54784 NMIN=NC+1-MSTJ(115)/3
54785 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
54786 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
54787 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
54790 C...Generate parton shower. Rearrange along strings and check.
54791 IF(MSTJ(101).EQ.5) THEN
54792 CALL PYSHOW(N-1,N,ECMC)
54794 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
54795 IF(MSTJ(105).GE.0) MSTU(28)=0
54798 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
54801 C...Fragmentation/decay generation. Information for PYTABU.
54802 IF(MSTJ(105).EQ.1) CALL PYEXEC
54809 C*********************************************************************
54812 C...Calculates total cross-section, including initial state
54813 C...radiation effects.
54815 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
54817 C...Double precision and integer declarations.
54818 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54819 IMPLICIT INTEGER(I-N)
54820 INTEGER PYK,PYCHGE,PYCOMP
54822 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54823 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54824 SAVE /PYDAT1/,/PYDAT2/
54826 C...Status, (optimized) Q^2 scale, alpha_strong.
54828 MSTJ(119)=10*MSTJ(102)+KFL
54829 IF(MSTJ(111).EQ.0) THEN
54831 ELSEIF(MSTU(111).EQ.0) THEN
54832 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
54833 & ((33D0-2D0*MSTU(112))*PARU(111)))))
54834 Q2R=PARJ(168)*ECM**2
54836 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
54837 & (2D0*PARU(112)/ECM)**2))
54838 Q2R=PARJ(168)*ECM**2
54840 ALSPI=PYALPS(Q2R)/PARU(1)
54842 C...QCD corrections factor in R.
54843 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
54845 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
54847 ELSEIF(MSTJ(109).EQ.0) THEN
54848 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
54849 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
54850 & LOG(PARJ(168))*ALSPI**2)
54851 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
54852 RQCD=1D0+(3D0/4D0)*ALSPI
54854 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
54857 C...Calculate Z0 width if default value not acceptable.
54858 IF(MSTJ(102).GE.3) THEN
54859 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
54860 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
54863 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
54864 & (2D0*PYMASS(KFLC)/ ECM)**2))
54865 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
54866 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
54867 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
54869 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
54873 C...Calculate propagator and related constants for QFD case.
54874 POLL=1D0-PARJ(131)*PARJ(132)
54875 IF(MSTJ(102).GE.2) THEN
54876 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
54877 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
54878 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
54879 VE=4D0*PARU(102)-1D0
54880 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
54881 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
54886 C...Loop over different flavours: charge, velocity.
54891 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
54892 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
54895 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
54896 QF=KCHG(KFLC,1)/3D0
54898 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
54900 C...Calculate R and sum of charges for QED or QFD case.
54901 RQQ=RQQ+3D0*QF**2*POLL
54902 IF(MSTJ(102).LE.1) THEN
54903 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
54905 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
54906 RQV=RQV-6D0*QF*VF*SF1I
54907 RVA=RVA+3D0*(VF**2+1D0)*SF1W
54908 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
54909 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
54913 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
54915 C...Calculate cross-section, including QCD corrections.
54918 PARJ(143)=RTOT*RQCD
54919 PARJ(144)=PARJ(143)
54920 PARJ(145)=PARJ(141)*86.8D0/ECM**2
54921 PARJ(146)=PARJ(142)*86.8D0/ECM**2
54922 PARJ(147)=PARJ(143)*86.8D0/ECM**2
54923 PARJ(148)=PARJ(147)
54924 PARJ(157)=RSUM*RQCD
54928 IF(MSTJ(107).LE.0) RETURN
54930 C...Virtual cross-section.
54932 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
54933 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
54934 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
54935 &1.526D0*LOG(ECM**2/0.932D0)
54937 C...Soft and hard radiative cross-section in QED case.
54938 IF(MSTJ(102).LE.1) THEN
54939 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
54940 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
54941 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
54943 C...Soft and hard radiative cross-section in QFD case.
54945 SZM=1D0-(PARJ(123)/ECM)**2
54946 SZW=PARJ(123)*PARJ(124)/ECM**2
54947 PARJ(161)=-RQQ/RSUM
54948 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
54949 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
54950 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
54951 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
54952 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
54953 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
54954 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
54955 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
54956 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
54957 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
54958 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
54959 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
54960 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
54963 C...Total cross-section and fraction of hard photon events.
54964 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
54965 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
54966 PARJ(144)=PARJ(157)
54967 PARJ(148)=PARJ(144)*86.8D0/ECM**2
54973 C*********************************************************************
54976 C...Generates initial state photon radiation.
54978 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
54980 C...Double precision and integer declarations.
54981 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54982 IMPLICIT INTEGER(I-N)
54983 INTEGER PYK,PYCHGE,PYCOMP
54985 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54988 C...Function: cumulative hard photon spectrum in QFD case.
54989 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
54990 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
54992 C...Determine whether radiative photon or not.
54995 IF(PARJ(160).LT.PYR(0)) RETURN
54998 C...Photon energy range. Find photon momentum in QED case.
55000 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
55001 IF(MSTJ(102).LE.1) THEN
55002 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
55003 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
55005 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
55007 SZM=1D0-(PARJ(123)/ECM)**2
55008 SZW=PARJ(123)*PARJ(124)/ECM**2
55011 FXKD=1D-4*(FXKU-FXKL)
55012 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
55017 IF(FXKV.GT.FXKR) THEN
55024 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
55025 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
55029 C...Photon polar and azimuthal angle.
55030 PME=2D0*(PYMASS(11)/ECM)**2
55031 120 CTHM=PME*(2D0/PME)**PYR(0)
55032 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
55033 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
55035 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
55036 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
55037 THEK=PYANGL(CTHE,STHE)
55038 PHIK=PARU(2)*PYR(0)
55040 C...Rotation angle for hadronic system.
55042 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
55044 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
55045 &(2D0-XK*(1D0-SGN*CTHE)))
55050 C*********************************************************************
55053 C...Selects flavour for produced qqbar pair.
55055 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
55057 C...Double precision and integer declarations.
55058 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55059 IMPLICIT INTEGER(I-N)
55060 INTEGER PYK,PYCHGE,PYCOMP
55062 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55063 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55064 SAVE /PYDAT1/,/PYDAT2/
55066 C...Calculate maximum weight in QED or QFD case.
55067 IF(MSTJ(102).LE.1) THEN
55070 POLL=1D0-PARJ(131)*PARJ(132)
55071 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
55072 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
55073 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
55074 VE=4D0*PARU(102)-1D0
55075 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
55076 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
55077 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
55078 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
55079 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
55083 C...Choose flavour. Gives charge and velocity.
55086 IF(NTRY.GT.100) THEN
55087 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
55092 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
55095 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
55096 QF=KCHG(KFLC,1)/3D0
55098 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
55100 C...Calculate weight in QED or QFD case.
55101 IF(MSTJ(102).LE.1) THEN
55103 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
55105 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
55106 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
55107 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
55109 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
55112 C...Weighting or new event (radiative photon). Cross-section update.
55113 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
55114 PARJ(158)=PARJ(158)+1D0
55115 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
55116 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
55117 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
55118 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
55119 PARJ(148)=PARJ(144)*86.8D0/ECM**2
55124 C*********************************************************************
55127 C...Selects number of jets in matrix element approach.
55129 SUBROUTINE PYXJET(ECM,NJET,CUT)
55131 C...Double precision and integer declarations.
55132 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55133 IMPLICIT INTEGER(I-N)
55134 INTEGER PYK,PYCHGE,PYCOMP
55136 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55138 C...Local array and data.
55140 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
55142 C...Trivial result for two-jets only, including parton shower.
55143 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
55146 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
55147 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
55149 IF(MSTJ(109).EQ.2) CF=1D0
55150 IF(MSTJ(111).EQ.0) THEN
55153 ELSEIF(MSTU(111).EQ.0) THEN
55154 PARJ(169)=MIN(1D0,PARJ(129))
55155 Q2=PARJ(169)*ECM**2
55156 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
55157 & ((33D0-2D0*MSTU(112))*PARU(111)))))
55158 Q2R=PARJ(168)*ECM**2
55160 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
55161 Q2=PARJ(169)*ECM**2
55162 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
55163 & (2D0*PARU(112)/ECM)**2))
55164 Q2R=PARJ(168)*ECM**2
55167 C...alpha_strong for R and R itself.
55168 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
55169 IF(IABS(MSTJ(101)).EQ.1) THEN
55171 ELSEIF(MSTJ(109).EQ.0) THEN
55172 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
55173 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
55174 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
55176 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
55179 C...alpha_strong for jet rate. Initial value for y cut.
55180 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
55181 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
55182 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
55183 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
55184 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
55186 C...Parametrization of first order three-jet cross-section.
55187 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
55190 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
55191 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
55192 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
55193 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
55194 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
55198 C...Parametrization of second order three-jet cross-section.
55199 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
55200 & CUT.GE.0.25D0) THEN
55202 ELSEIF(MSTJ(110).LE.1) THEN
55203 CT=LOG(1D0/CUT-2D0)
55204 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
55205 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
55207 C...Interpolation in second/first order ratio for Zhu parametrization.
55208 ELSEIF(MSTJ(110).EQ.2) THEN
55211 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
55217 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
55219 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
55222 C...Shift in second order three-jet cross-section with optimized Q^2.
55223 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
55224 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
55225 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
55227 C...Parametrization of second order four-jet cross-section.
55228 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
55231 CT=LOG(1D0/CUT-5D0)
55232 IF(CUT.LE.0.018D0) THEN
55233 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
55234 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
55236 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
55237 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
55239 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
55240 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
55241 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
55242 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
55243 & 0.002093D0*CT**3)
55244 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
55246 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
55247 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
55250 C...If negative three-jet rate, change y' optimization parameter.
55251 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
55252 & PARJ(169).LT.0.99D0) THEN
55253 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
55254 Q2=PARJ(169)*ECM**2
55255 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
55259 C...If too high cross-section, use harder cuts, or fail.
55260 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
55261 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
55262 & PARJ(169).LT.0.99D0) THEN
55263 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
55264 Q2=PARJ(169)*ECM**2
55265 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
55267 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
55269 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
55271 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
55272 & PARJ(154))**(-1D0/3D0)
55273 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
55277 C...Scalar gluon (first order only).
55279 ALSPI=PYALPS(ECM**2)/PARU(1)
55280 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
55282 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
55283 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
55288 C...Select number of jets.
55290 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
55292 ELSEIF(MSTJ(101).LE.0) THEN
55293 NJET=MIN(4,2-MSTJ(101))
55297 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
55298 IF(PARJ(154).GT.RNJ) NJET=4
55304 C*********************************************************************
55307 C...Selects the kinematical variables of three-jet events.
55309 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
55311 C...Double precision and integer declarations.
55312 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55313 IMPLICIT INTEGER(I-N)
55314 INTEGER PYK,PYCHGE,PYCOMP
55316 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55319 DIMENSION ZHUP(5,12)
55321 C...Coefficients of Zhu second order parametrization.
55322 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
55323 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
55324 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
55325 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
55326 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
55327 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
55328 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
55329 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
55330 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
55331 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
55332 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
55334 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
55335 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
55338 C...Event type. Mass effect factors and other common constants.
55342 QME=(2D0*PMQ/ECM)**2
55343 IF(MSTJ(109).NE.1) THEN
55345 CUTD=LOG(1D0/CUT-2D0)
55346 IF(MSTJ(109).EQ.0) THEN
55350 WTMX=MIN(20D0,37D0-6D0*CUTD)
55351 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
55359 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
55360 ALS2PI=PARU(118)/PARU(2)
55362 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
55363 & LOG(PARJ(169))*ALS2PI
55364 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
55366 C...Choose three-jet events in allowed region.
55368 110 Y13L=CUTL+CUTD*PYR(0)
55369 Y23L=CUTL+CUTD*PYR(0)
55373 IF(Y12.LE.CUT) GOTO 110
55374 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
55376 C...Second order corrections.
55377 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
55382 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
55383 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
55384 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
55385 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
55386 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
55387 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
55388 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
55389 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
55390 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
55391 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
55392 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
55393 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
55394 & TR*(2D0*CUTL/3D0-10D0/9D0)+
55395 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
55396 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
55397 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
55398 & Y13*Y23)/(Y12+Y13)**2)/WT1+
55399 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
55400 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
55401 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
55402 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
55403 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
55404 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
55405 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
55406 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
55407 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
55408 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
55410 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
55411 C...Second order corrections; Zhu parametrization of ERT.
55416 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
55420 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
55421 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
55422 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
55423 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
55426 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
55427 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
55428 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
55429 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
55431 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
55432 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
55433 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
55434 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
55435 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
55437 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
55438 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
55439 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
55442 C...Impose mass cuts (gives two jets). For fixed jet number new try.
55446 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
55447 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
55448 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
55449 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
55450 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
55452 C...Scalar gluon model (first order only, no mass effects).
55455 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
55456 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
55457 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
55458 X1=1D0-0.5D0*(X3+YD)
55459 X2=1D0-0.5D0*(X3-YD)
55460 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
55461 IF(MSTJ(102).GE.2) THEN
55462 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
55463 & X3**2*PYR(0)) NJET=2
55465 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
55471 C*********************************************************************
55474 C...Selects the kinematical variables of four-jet events.
55476 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
55478 C...Double precision and integer declarations.
55479 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55480 IMPLICIT INTEGER(I-N)
55481 INTEGER PYK,PYCHGE,PYCOMP
55483 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55486 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
55488 C...Common constants. Colour factors for QCD and Abelian gluon theory.
55490 QME=(2D0*PMQ/ECM)**2
55491 CT=LOG(1D0/CUT-5D0)
55492 IF(MSTJ(109).EQ.0) THEN
55502 C...Choice of process (qqbargg or qqbarqqbar).
55505 IF(PARJ(155).GT.PYR(0)) IT=2
55506 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
55507 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
55508 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
55509 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
55512 C...Sample the five kinematical variables (for qqgg preweighted in y34).
55513 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
55514 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
55515 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
55516 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
55517 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
55519 CP=COS(PARU(1)*PYR(0))
55522 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
55523 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
55524 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
55526 Y12=1D0-Y134-Y23-Y24
55527 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
55531 C...Calculate matrix elements for qqgg or qqqq process.
55536 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
55537 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
55538 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
55539 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
55540 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
55541 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
55542 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
55543 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
55544 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
55545 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
55546 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
55547 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
55548 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
55549 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
55550 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
55551 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
55552 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
55553 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
55554 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
55555 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
55556 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
55557 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
55558 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
55559 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
55560 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
55561 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
55562 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
55563 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
55564 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
55565 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
55566 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
55567 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
55568 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
55569 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
55570 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
55571 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
55572 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
55573 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
55574 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
55575 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
55576 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
55579 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
55580 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
55581 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
55582 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
55583 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
55584 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
55585 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
55586 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
55587 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
55588 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
55589 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
55590 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
55591 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
55592 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
55593 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
55594 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
55595 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
55596 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
55599 C...Permutations of momenta in matrix element. Weighting.
55600 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
55611 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
55622 IF(IC.LE.3) GOTO 120
55623 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
55626 C...qqgg events: string configuration and event type.
55628 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
55629 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
55630 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
55631 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
55632 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
55633 IF(ID.EQ.2) GOTO 130
55634 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
55635 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
55636 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
55637 IF(ID.EQ.2) GOTO 130
55640 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
55641 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
55644 C...Mass cuts. Kinematical variables out.
55645 IF(Y12.LE.CUT+QME) NJET=2
55646 IF(NJET.EQ.2) GOTO 150
55647 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
55648 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
55649 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
55651 X12=(1D0-Q12)*Y13+Q12*Y23
55653 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
55655 C...qqbarqqbar events: string configuration, choose new flavour.
55658 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
55659 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
55660 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
55661 IF(WTR.LT.WTD(4)) ID=4
55662 IF(ID.GE.2) GOTO 130
55665 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
55666 140 KFLN=1+INT(5D0*PYR(0))
55667 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
55668 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
55669 IF(KFLN.GT.MSTJ(104)) NJET=2
55671 QMEN=(2D0*PMQN/ECM)**2
55673 C...Mass cuts. Kinematical variables out.
55674 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
55675 IF(NJET.EQ.2) GOTO 150
55676 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
55677 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
55678 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
55679 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
55680 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
55681 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
55684 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
55686 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
55687 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
55688 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
55690 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
55695 C*********************************************************************
55698 C...Gives the angular orientation of events.
55700 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
55702 C...Double precision and integer declarations.
55703 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55704 IMPLICIT INTEGER(I-N)
55705 INTEGER PYK,PYCHGE,PYCOMP
55707 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55708 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55709 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55710 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55712 C...Charge. Factors depending on polarization for QED case.
55714 POLL=1D0-PARJ(131)*PARJ(132)
55715 POLD=PARJ(132)-PARJ(131)
55716 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
55722 C...Factors depending on flavour, energy and polarization for QFD case.
55724 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
55725 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
55726 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
55728 VE=4D0*PARU(102)-1D0
55730 VF=AF-4D0*QF*PARU(102)
55731 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
55732 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
55733 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
55734 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
55735 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
55736 & SFW*SFF**2*(VE**2-AE**2))
55737 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
55741 C...Mass factor. Differential cross-sections for two-jet events.
55744 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
55745 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
55747 SIGU=4D0*SQRT(1D0-QME)
55748 SIGL=2D0*QME*SQRT(1D0-QME)
55754 C...Kinematical variables. Reduce four-jet event to three-jet one.
55757 X1=2D0*P(NC+1,4)/ECM
55758 X2=2D0*P(NC+3,4)/ECM
55760 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
55761 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
55762 X1=2D0*P(NC+1,4)/ECMR
55763 X2=2D0*P(NC+4,4)/ECMR
55766 C...Differential cross-sections for three-jet (or reduced four-jet).
55767 XQ=(1D0-X1)/(1D0-X2)
55768 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
55769 ST12=SQRT(1D0-CT12**2)
55770 IF(MSTJ(109).NE.1) THEN
55771 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
55772 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
55773 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
55774 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
55776 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
55777 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
55778 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
55779 SIGA=X2**2*ST12/SQ2
55780 SIGP=2D0*(X1**2-X2**2*CT12)
55782 C...Differential cross-sect for scalar gluons (no mass effects).
55786 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
55787 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
55788 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
55789 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
55790 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
55791 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
55792 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
55793 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
55794 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
55795 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
55796 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
55800 C...Upper bounds for differential cross-section.
55805 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
55806 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
55807 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
55808 &2D0*HF2A*ABS(SIGP)
55810 C...Generate angular orientation according to differential cross-sect.
55811 100 CHI=PARU(2)*PYR(0)
55812 CTHE=2D0*PYR(0)-1D0
55820 C2PHI=COS(2D0*(PHI-PARJ(134)))
55821 S2PHI=SIN(2D0*(PHI-PARJ(134)))
55822 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
55823 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
55824 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
55825 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
55826 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
55827 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
55828 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
55829 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
55834 C*********************************************************************
55837 C...Generates Upsilon and toponium decays into three gluons
55838 C...or two gluons and a photon.
55840 SUBROUTINE PYONIA(KFL,ECM)
55842 C...Double precision and integer declarations.
55843 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55844 IMPLICIT INTEGER(I-N)
55845 INTEGER PYK,PYCHGE,PYCOMP
55847 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55848 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55849 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55850 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55852 C...Printout. Check input parameters.
55853 IF(MSTU(12).GE.1) CALL PYLIST(0)
55854 IF(KFL.LT.0.OR.KFL.GT.8) THEN
55855 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
55856 IF(MSTU(21).GE.1) RETURN
55858 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
55859 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
55860 IF(MSTU(21).GE.1) RETURN
55863 C...Initial e+e- and onium state (optional).
55865 IF(MSTJ(115).GE.2) THEN
55867 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
55869 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
55873 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
55879 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
55885 C...Choose x1 and x2 according to matrix element.
55890 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
55891 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
55894 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
55895 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
55897 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
55898 MSTU(111)=MSTJ(108)
55899 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
55901 PARU(112)=PARJ(121)
55902 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
55904 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
55905 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
55908 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
55909 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
55911 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
55912 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
55915 ECMC=SQRT(1D0-X1)*ECM
55916 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
55921 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
55922 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
55923 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
55924 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
55926 IF(ECMC.LT.4D0*PARJ(127)) THEN
55930 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
55936 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
55939 C...Differential cross-sections. Upper limit for cross-section.
55940 IF(MSTJ(106).EQ.1) THEN
55942 HF1=1D0-PARJ(131)*PARJ(132)
55944 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
55945 ST13=SQRT(1D0-CT13**2)
55946 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
55947 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
55949 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
55950 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
55951 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
55953 C...Angular orientation of event.
55954 120 CHI=PARU(2)*PYR(0)
55955 CTHE=2D0*PYR(0)-1D0
55963 C2PHI=COS(2D0*(PHI-PARJ(134)))
55964 S2PHI=SIN(2D0*(PHI-PARJ(134)))
55965 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
55966 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
55967 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
55968 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
55969 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
55970 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
55971 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
55972 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
55975 C...Generate parton shower. Rearrange along strings and check.
55976 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
55977 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
55979 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
55980 IF(MSTJ(105).GE.0) MSTU(28)=0
55983 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
55986 C...Generate fragmentation. Information for PYTABU:
55987 IF(MSTJ(105).EQ.1) CALL PYEXEC
55988 MSTU(161)=110*KFLC+3
55994 C*********************************************************************
55997 C...Books a histogram.
55999 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
56001 C...Double precision declaration.
56002 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56003 IMPLICIT INTEGER(I-N)
56005 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56007 C...Local character variables.
56008 CHARACTER TITLE*(*), TITFX*60
56010 C...Check that input is sensible. Find initial address in memory.
56011 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
56012 &'(PYBOOK:) not allowed histogram number')
56013 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
56014 &'(PYBOOK:) not allowed number of bins')
56015 IF(XL.GE.XU) CALL PYERRM(28,
56016 &'(PYBOOK:) x limits in wrong order')
56018 IHIST(4)=IHIST(4)+28+NX
56019 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
56020 &'(PYBOOK:) out of histogram space')
56023 C...Store histogram size and reset contents.
56027 BIN(IS+4)=(XU-XL)/NX
56030 C...Store title by conversion to integer to double precision.
56033 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
56034 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
56040 C*********************************************************************
56043 C...Fills entry in histogram.
56045 SUBROUTINE PYFILL(ID,X,W)
56047 C...Double precision declaration.
56048 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56049 IMPLICIT INTEGER(I-N)
56051 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56054 C...Find initial address in memory. Increase number of entries.
56055 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
56056 &'(PYFILL:) not allowed histogram number')
56058 IF(IS.EQ.0) CALL PYERRM(28,
56059 &'(PYFILL:) filling unbooked histogram')
56060 BIN(IS+5)=BIN(IS+5)+1D0
56062 C...Find bin in x, including under/overflow, and fill.
56063 IF(X.LT.BIN(IS+2)) THEN
56064 BIN(IS+6)=BIN(IS+6)+W
56065 ELSEIF(X.GE.BIN(IS+3)) THEN
56066 BIN(IS+8)=BIN(IS+8)+W
56068 BIN(IS+7)=BIN(IS+7)+W
56069 IX=(X-BIN(IS+2))/BIN(IS+4)
56070 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
56071 BIN(IS+9+IX)=BIN(IS+9+IX)+W
56077 C*********************************************************************
56080 C...Multiplies histogram contents by factor.
56082 SUBROUTINE PYFACT(ID,F)
56084 C...Double precision declaration.
56085 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56086 IMPLICIT INTEGER(I-N)
56088 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56091 C...Find initial address in memory. Multiply all contents bins.
56092 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
56093 &'(PYFACT:) not allowed histogram number')
56095 IF(IS.EQ.0) CALL PYERRM(28,
56096 &'(PYFACT:) scaling unbooked histogram')
56097 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
56104 C*********************************************************************
56107 C...Performs operations between histograms.
56109 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
56111 C...Double precision declaration.
56112 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56113 IMPLICIT INTEGER(I-N)
56115 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56117 C...Character variable.
56120 C...Find initial addresses in memory, and histogram size.
56121 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
56122 &'(PYFACT:) not allowed histogram number')
56124 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
56125 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
56126 NX=NINT(BIN(IS3+1))
56127 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
56129 C...Update info on number of histogram entries.
56130 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
56131 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
56132 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
56133 BIN(IS3+5)=BIN(IS1+5)
56136 C...Operations on pair of histograms: addition, subtraction,
56137 C...multiplication, division.
56138 IF(OPER.EQ.'+') THEN
56140 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
56142 ELSEIF(OPER.EQ.'-') THEN
56144 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
56146 ELSEIF(OPER.EQ.'*') THEN
56148 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
56150 ELSEIF(OPER.EQ.'/') THEN
56153 IF(ABS(FA2).LE.1D-20) THEN
56156 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
56160 C...Operations on single histogram: multiplication+addition,
56161 C...square root+addition, logarithm+addition.
56162 ELSEIF(OPER.EQ.'A') THEN
56164 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
56166 ELSEIF(OPER.EQ.'S') THEN
56168 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
56170 ELSEIF(OPER.EQ.'L') THEN
56173 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
56174 & ZMIN=0.8D0*BIN(IS1+IX)
56177 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
56180 C...Operation on two or three histograms: average and
56181 C...standard deviation.
56182 ELSEIF(OPER.EQ.'M') THEN
56184 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
56187 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
56190 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
56193 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
56197 BIN(IS1+IX)=F1*BIN(IS1+IX)
56204 C*********************************************************************
56207 C...Prints and resets all histograms.
56211 C...Double precision declaration.
56212 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56213 IMPLICIT INTEGER(I-N)
56215 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56218 C...Loop over histograms, print and reset used ones.
56219 DO 100 ID=1,IHIST(1)
56221 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
56230 C*********************************************************************
56233 C...Prints a histogram (but does not reset it).
56235 SUBROUTINE PYPLOT(ID)
56237 C...Double precision declaration.
56238 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56239 IMPLICIT INTEGER(I-N)
56241 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56242 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56243 SAVE /PYDAT1/,/PYBINS/
56244 C...Local arrays and character variables.
56245 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
56246 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
56248 C...Steps in histogram scale. Character sequence.
56249 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
56250 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
56252 C...Find initial address in memory; skip if empty histogram.
56253 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
56256 IF(NINT(BIN(IS+5)).LE.0) THEN
56257 WRITE(MSTU(11),5000) ID
56261 C...Number of histogram lines and x bins.
56265 C...Extract title by conversion from double precision via integer.
56267 IEQ=NINT(BIN(IS+8+NX+IT))
56268 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
56269 & //CHAR(MOD(IEQ,256))
56272 C...Find time; print title.
56274 IF(IDATI(1).GT.0) THEN
56275 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
56277 WRITE(MSTU(11),5200) ID, TITLE
56280 C...Find minimum and maximum bin content.
56283 DO 110 IX=IS+10,IS+8+NX
56284 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
56285 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
56288 C...Determine scale and step size for y axis.
56289 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
56290 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
56291 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
56292 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
56293 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
56294 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
56297 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
56301 C...Convert bin contents to integer form; fractional fill in top row.
56303 CTA=ABS(BIN(IS+8+IX))/DY
56304 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
56305 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
56307 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
56308 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
56310 C...Print histogram row by row.
56311 DO 150 IR=IRMA,IRMI,-1
56312 IF(IR.EQ.0) GOTO 150
56315 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
56316 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
56318 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
56321 C...Print sign and value of bin contents.
56322 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
56325 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
56326 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
56328 WRITE(MSTU(11),5400) OUT
56331 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
56333 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
56336 C...Print sign and value of lower bin edge.
56337 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
56341 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
56342 & OUT(IX:IX)=CHA(11)
56343 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
56345 WRITE(MSTU(11),5600) OUT
56348 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
56350 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
56354 C...Calculate and print statistics.
56359 CTA=ABS(BIN(IS+8+IX))
56360 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
56363 CXXSUM=CXXSUM+CTA*X**2
56365 XMEAN=CXSUM/MAX(CSUM,1D-20)
56366 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
56367 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
56368 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
56370 C...Formats for output.
56371 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
56372 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
56374 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
56375 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
56376 5400 FORMAT(/8X,'Contents',3X,A100)
56377 5500 FORMAT(9X,'*10**',I2,3X,A100)
56378 5600 FORMAT(/8X,'Low edge',3X,A100)
56379 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
56380 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
56381 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
56386 C*********************************************************************
56389 C...Resets bin contents of a histogram.
56391 SUBROUTINE PYNULL(ID)
56393 C...Double precision declaration.
56394 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56395 IMPLICIT INTEGER(I-N)
56397 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56400 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
56403 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
56410 C*********************************************************************
56413 C...Dumps histogram contents on file for reading by other program.
56414 C...Can also read back own dump.
56416 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
56418 C...Double precision declaration.
56419 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56420 IMPLICIT INTEGER(I-N)
56422 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
56424 C...Local arrays and character variables.
56425 DIMENSION IHI(*),ISS(100),VAL(5)
56426 CHARACTER TITLE*60,FORMAT*13
56428 C...Dump all histograms that have been booked,
56429 C...including titles and ranges, one after the other.
56430 IF(MDUMP.EQ.1) THEN
56432 C...Loop over histograms and find which are wanted and booked.
56447 C...Write title, histogram size, filling statistics.
56450 IEQ=NINT(BIN(IS+8+NX+IT))
56451 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
56452 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
56454 WRITE(LFN,5100) ID,TITLE
56455 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
56456 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
56460 C...Write histogram contents, in groups of five.
56461 DO 120 IXG=1,(NX+4)/5
56465 VAL(IXV)=BIN(IS+8+IX)
56470 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
56473 C...Go to next histogram; finish.
56474 ELSEIF(NHI.GT.0) THEN
56475 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
56479 C...Read back in histograms dumped MDUMP=1.
56480 ELSEIF(MDUMP.EQ.2) THEN
56482 C...Read histogram number, title and range, and book.
56483 140 READ(LFN,5100,END=170) ID,TITLE
56484 READ(LFN,5200) NX,XL,XU
56485 CALL PYBOOK(ID,TITLE,NX,XL,XU)
56488 C...Read filling statistics.
56489 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
56490 BIN(IS+5)=DBLE(NENTRY)
56492 C...Read histogram contents, in groups of five.
56493 DO 160 IXG=1,(NX+4)/5
56494 READ(LFN,5400) (VAL(IXV),IXV=1,5)
56497 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
56501 C...Go to next histogram; finish.
56505 C...Write histogram contents in column format,
56506 C...convenient e.g. for GNUPLOT input.
56507 ELSEIF(MDUMP.EQ.3) THEN
56509 C...Find addresses to wanted histograms.
56523 IF(IS.NE.0.AND.NSS.LT.100) THEN
56526 ELSEIF(NSS.GE.100) THEN
56527 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
56528 ELSEIF(NHI.GT.0) THEN
56529 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
56533 C...Check that they have common number of x bins. Fix format.
56534 NX=NINT(BIN(ISS(1)+1))
56536 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
56537 CALL PYERRM(8,'(PYDUMP:) different number of bins')
56541 FORMAT='(1P,000E12.4)'
56542 WRITE(FORMAT(5:7),'(I3)') NSS+1
56544 C...Write histogram contents; first column x values.
56546 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
56547 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
56552 C...Formats for output.
56553 5100 FORMAT(I5,5X,A60)
56554 5200 FORMAT(I5,1P,2D12.4)
56555 5300 FORMAT(I12,1P,3D12.4)
56556 5400 FORMAT(1P,5D12.4)
56561 C*********************************************************************
56564 C...Dummy routine, which the user can replace in order to make cuts on
56565 C...the kinematics on the parton level before the matrix elements are
56566 C...evaluated and the event is generated. The cross-section estimates
56567 C...will automatically take these cuts into account, so the given
56568 C...values are for the allowed phase space region only. MCUT=0 means
56569 C...that the event has passed the cuts, MCUT=1 that it has failed.
56571 SUBROUTINE PYKCUT(MCUT)
56573 C...Double precision and integer declarations.
56574 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56575 IMPLICIT INTEGER(I-N)
56576 INTEGER PYK,PYCHGE,PYCOMP
56578 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56579 COMMON/PYINT1/MINT(400),VINT(400)
56580 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
56581 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
56583 C...Set default value (accepting event) for MCUT.
56586 C...Read out subprocess number.
56590 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
56594 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
56596 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
56598 C...Calculate x_1, x_2, x_F.
56599 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
56600 X1=SQRT(TAU)*EXP(YST)
56601 X2=SQRT(TAU)*EXP(-YST)
56603 X1=SQRT(TAUP)*EXP(YST)
56604 X2=SQRT(TAUP)*EXP(-YST)
56608 C...Calculate shat, that, uhat, p_T^2.
56614 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
56615 RPTS=4D0*VINT(71)**2/SHAT
56616 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
56619 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
56620 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
56621 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
56622 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
56624 C...Decisions by user to be put here.
56626 C...Stop program if this routine is ever called.
56627 C...You should not copy these lines to your own routine.
56628 WRITE(MSTU(11),5000)
56629 IF(PYR(0).LT.10D0) STOP
56631 C...Format for error printout.
56632 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
56633 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
56634 &1X,'Execution stopped!')
56639 C*********************************************************************
56642 C...Dummy routine, which the user can replace in order to multiply the
56643 C...standard PYTHIA differential cross-section by a process- and
56644 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
56645 C...to generation of weighted events, with weight 1/WTXS, while for
56646 C...MSTP(142)=2 it corresponds to a modification of the underlying
56649 SUBROUTINE PYEVWT(WTXS)
56651 C...Double precision and integer declarations.
56652 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56653 IMPLICIT INTEGER(I-N)
56654 INTEGER PYK,PYCHGE,PYCOMP
56656 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56657 COMMON/PYINT1/MINT(400),VINT(400)
56658 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
56659 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
56661 C...Set default weight for WTXS.
56664 C...Read out subprocess number.
56668 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
56672 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
56674 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
56676 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
56685 C...Modifications by user to be put here.
56687 C...Stop program if this routine is ever called.
56688 C...You should not copy these lines to your own routine.
56689 WRITE(MSTU(11),5000)
56690 IF(PYR(0).LT.10D0) STOP
56692 C...Format for error printout.
56693 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
56694 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
56695 &1X,'Execution stopped!')
56700 C*********************************************************************
56703 C...Dummy routine, to be replaced by a user implementing external
56704 C...processes. Is supposed to fill the HEPRUP commonblock with info
56705 C...on incoming beams and allowed processes.
56709 C...Double precision and integer declarations.
56710 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56711 IMPLICIT INTEGER(I-N)
56713 C...User process initialization commonblock.
56715 PARAMETER (MAXPUP=100)
56716 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
56717 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
56718 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
56719 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
56726 C*********************************************************************
56729 C...Dummy routine, to be replaced by a user implementing external
56730 C...processes. Depending on cross section model chosen, it either has
56731 C...to generate a process of the type IDPRUP requested, or pick a type
56732 C...itself and generate this event. The event is to be stored in the
56733 C...HEPEUP commonblock, including (often) an event weight.
56737 C...Double precision and integer declarations.
56738 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56739 IMPLICIT INTEGER(I-N)
56741 C...User process event common block.
56743 PARAMETER (MAXNUP=500)
56744 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
56745 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
56746 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
56747 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
56748 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
56754 C*********************************************************************
56757 C...Dummy routine, to be replaced by user, to handle the decay of a
56758 C...polarized tau lepton.
56760 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
56761 C...IORIG is the position where the mother of the tau is stored;
56762 C... is 0 when the mother is not stored.
56763 C...KFORIG is the flavour of the mother of the tau;
56764 C... is 0 when the mother is not known.
56765 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
56766 C... e.g. in B hadron semileptonic decays the W propagator
56767 C... is not explicitly stored but the W code is still unambiguous.
56769 C...NDECAY is the number of decay products in the current tau decay.
56770 C...These decay products should be added to the /PYJETS/ common block,
56771 C...in positions N+1 through N+NDECAY. For each product I you must
56772 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
56773 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
56775 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
56777 C...Double precision and integer declarations.
56778 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56779 IMPLICIT INTEGER(I-N)
56780 INTEGER PYK,PYCHGE,PYCOMP
56782 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56783 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56784 SAVE /PYJETS/,/PYDAT1/
56786 C...Stop program if this routine is ever called.
56787 C...You should not copy these lines to your own routine.
56788 NDECAY=ITAU+IORIG+KFORIG
56789 WRITE(MSTU(11),5000)
56790 IF(PYR(0).LT.10D0) STOP
56792 C...Format for error printout.
56793 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
56794 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
56795 &1X,'Execution stopped!')
56800 C*********************************************************************
56803 C...Finds current date and time.
56804 C...Since this task is not standardized in Fortran 77, the routine
56805 C...is dummy, to be replaced by the user. Examples are given for
56806 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
56807 C...you do not have access to suitable routines.
56809 SUBROUTINE PYTIME(IDATI)
56811 C...Double precision and integer declarations.
56812 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56813 IMPLICIT INTEGER(I-N)
56814 INTEGER PYK,PYCHGE,PYCOMP
56817 INTEGER IDATI(6),IDTEMP(3)
56819 C...Example 0: if you do not have suitable routines.
56824 C...Example 1: Fortran 90 routine.
56826 C CALL DATE_AND_TIME(VALUES=IVAL)
56834 C...Example 2: DEC Fortran 77. AIX.
56835 C CALL IDATE(IMON,IDAY,IYEAR)
56839 C CALL ITIME(IHOUR,IMIN,ISEC)
56844 C...Example 3: DEC Fortran, IRIX, IRIX64.
56845 C CALL IDATE(IMON,IDAY,IYEAR)
56853 C READ(ATIME(1:2),'(I2)') IHOUR
56854 C READ(ATIME(4:5),'(I2)') IMIN
56855 C READ(ATIME(7:8),'(I2)') ISEC
56860 C...Example 4: GNU LINUX libU77, SunOS.
56861 c CALL IDATE(IDTEMP)
56862 c IDATI(1)=IDTEMP(3)
56863 c IDATI(2)=IDTEMP(2)
56864 c IDATI(3)=IDTEMP(1)
56865 c CALL ITIME(IDTEMP)
56866 c IDATI(4)=IDTEMP(1)
56867 c IDATI(5)=IDTEMP(2)
56868 c IDATI(6)=IDTEMP(3)
56870 C...Common code to ensure right century.
56871 IDATI(1)=2000+MOD(IDATI(1),100)