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* Computing Division, Simulations Group **
20 C* Fermi National Accelerator Laboratory **
21 C* MS 234, Batavia, IL 60510, USA **
22 C* phone + 1 - 630 - 840 - 2556 **
23 C* E-mail mrenna@fnal.gov **
25 C* Baryon and lepton number violation parts by **
27 C* Department of Theoretical Physics **
29 C* Solvegatan 14A, S-223 62 Lund, Sweden **
30 C* phone +46 - 46 - 222 31 92 **
31 C* E-mail zeiler@thep.lu.se **
33 C* PYTHIA 7 efforts coordinated by **
35 C* Department of Theoretical Physics **
37 C* Solvegatan 14A, S-223 62 Lund, Sweden **
38 C* phone +46 - 46 - 222 77 80 **
39 C* E-mail leif@thep.lu.se **
41 C* Several parts are written by Hans-Uno Bengtsson **
42 C* PYSHOW is written together with Mats Bengtsson **
43 C* PYMAEL is written by Emanuel Norrbin **
44 C* advanced popcorn baryon production written by Patrik Eden **
45 C* code for virtual photons mainly written by Christer Friberg **
46 C* code for low-mass strings mainly written by Emanuel Norrbin **
47 C* Bose-Einstein code mainly written by Leif Lonnblad **
48 C* CTEQ parton distributions are by the CTEQ collaboration **
49 C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
50 C* SaS photon parton distributions together with Gerhard Schuler **
51 C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
52 C* MSSM Higgs mass calculation code by M. Carena, **
53 C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
54 C* PYGAUS adapted from CERN library (K.S. Kolbig) **
56 C* The latest program version and documentation is found on WWW **
57 C* http://www.thep.lu.se/~torbjorn/Pythia.html **
59 C* Copyright Torbjorn Sjostrand, Lund 2003 **
61 C*********************************************************************
62 C*********************************************************************
64 C List of subprograms in order of appearance, with main purpose *
65 C (S = subroutine, F = function, B = block data) *
67 C B PYDATA to contain all default values *
68 C S PYTEST to test the proper functioning of the package *
69 C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
71 C S PYINIT to administer the initialization procedure *
72 C S PYEVNT to administer the generation of an event *
73 C S PYSTAT to print cross-section and other information *
74 C S PYINRE to initialize treatment of resonances *
75 C S PYINBM to read in beam, target and frame choices *
76 C S PYINKI to initialize kinematics of incoming particles *
77 C S PYINPR to set up the selection of included processes *
78 C S PYXTOT to give total, elastic and diffractive cross-sect. *
79 C S PYMAXI to find differential cross-section maxima *
80 C S PYPILE to select multiplicity of pileup events *
81 C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
82 C S PYGAGA to handle lepton -> lepton + gamma branchings *
83 C S PYRAND to select subprocess and kinematics for event *
84 C S PYSCAT to set up kinematics and colour flow of event *
85 C S PYSSPA to simulate initial state spacelike showers *
86 C S PYMEMX auxiliary to PYSSPA for ME correction maximum *
87 C S PYMEWT auxiliary to PYSSPA for matrix element correction *
88 C S PYADSH to administrate sequential final-state showers *
89 C S PYRESD to perform resonance decays *
90 C S PYMULT to generate multiple interactions *
91 C S PYREMN to add on target remnants *
92 C S PYDIFF to set up kinematics for diffractive events *
93 C S PYDISG to set up kinematics, remnant and showers for DIS *
94 C S PYDOCU to compute cross-sections and handle documentation *
95 C S PYFRAM to perform boosts between different frames *
96 C S PYWIDT to calculate full and partial widths of resonances *
97 C S PYOFSH to calculate partial width into off-shell channels *
98 C S PYRECO to handle colour reconnection in W+W- events *
99 C S PYKLIM to calculate borders of allowed kinematical region *
100 C S PYKMAP to construct value of kinematical variable *
101 C S PYSIGH to calculate differential cross-sections *
102 C S PYPDFU to evaluate parton distributions *
103 C S PYPDFL to evaluate parton distributions at low x and Q^2 *
104 C S PYPDEL to evaluate electron parton distributions *
105 C S PYPDGA to evaluate photon parton distributions (generic) *
106 C S PYGGAM to evaluate photon parton distributions (SaS sets) *
107 C S PYGVMD to evaluate VMD part of photon parton distributions *
108 C S PYGANO to evaluate anomalous part of photon pdf's *
109 C S PYGBEH to evaluate Bethe-Heitler part of photon pdf's *
110 C S PYGDIR to evaluate direct contribution to photon pdf's *
111 C S PYPDPI to evaluate pion parton distributions *
112 C S PYPDPR to evaluate proton parton distributions *
113 C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
114 C S PYGRVL to evaluate the GRV 94L proton parton distributions *
115 C S PYGRVM to evaluate the GRV 94M proton parton distributions *
116 C S PYGRVD to evaluate the GRV 94D proton parton distributions *
117 C F PYGRVV auxiliary to the PYGRV* routines *
118 C F PYGRVW auxiliary to the PYGRV* routines *
119 C F PYGRVS auxiliary to the PYGRV* routines *
120 C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
121 C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
122 C S PYPDPO to evaluate old proton parton distributions *
123 C F PYHFTH to evaluate threshold factor for heavy flavour *
124 C S PYSPLI to find flavours left in hadron when one removed *
125 C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
126 C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
127 C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
128 C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
129 C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
131 C S PYMSIN to initialize the supersymmetry simulation *
132 C S PYAPPS to determine MSSM parameters from SUGRA input *
133 C S PYSUGI to determine MSSM parameters using ISASUSY *
134 C F PYRNMQ to determine running squark masses *
135 C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
136 C S PYINOM to calculate neutralino/chargino mass eigenstates *
137 C F PYRNM3 to determine running M3, gluino mass *
138 C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
139 C S PYHGGM to determine Higgs mass spectrum *
140 C S PYSUBH to determine Higgs masses in the MSSM *
141 C S PYPOLE to determine Higgs masses in the MSSM *
142 C S PYRGHM auxiliary to PYPOLE *
143 C S PYGFXX auxiliary to PYRGHM *
144 C F PYFINT auxiliary to PYPOLE *
145 C F PYFISB auxiliary to PYFINT *
146 C S PYSFDC to calculate sfermion decay partial widths *
147 C S PYGLUI to calculate gluino decay partial widths *
148 C S PYTBBN to calculate 3-body decay of gluino to neutralino *
149 C S PYTBBC to calculate 3-body decay of gluino to chargino *
150 C S PYNJDC to calculate neutralino decay partial widths *
151 C S PYCJDC to calculate chargino decay partial widths *
152 C F PYXXZ6 auxiliary for ino 3-body decays *
153 C F PYXXGA auxiliary for ino -> ino + gamma decay *
154 C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
155 C F PYX2XH auxiliary for ino -> ino + Higgs decay *
156 C S PYHEXT to calculate non-SM Higgs decay partial widths *
157 C F PYH2XX auxiliary for H -> ino + ino decay *
158 C F PYGAUS to perform Gaussian integration *
159 C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
160 C F PYSIMP to perform Simpson integration *
161 C F PYLAMF to evaluate the lambda kinematics function *
162 C S PYTBDY to perform 3-body decay of gauginos *
163 C S PYTECM to calculate techni_rho/omega masses *
164 C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
165 C S PYCMQR auxiliary to PYEICG *
166 C S PYCMQ2 auxiliary to PYEICG *
167 C S PYCDIV auxiliary to PYCMQR *
168 C S PYCSRT auxiliary to PYCMQR *
169 C S PYTHAG auxiliary to PYCMQR *
170 C S PYCBAL auxiliary to PYEICG *
171 C S PYCBA2 auxiliary to PYEICG *
172 C S PYCRTH auxiliary to PYEICG *
173 C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
174 C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
175 C S PYWIDX to calculate decay widths from within PYWIDT *
176 C S PYRVSF to calculate R-violating sfermion decay widths *
177 C S PYRVNE to calculate R-violating neutralino decay widths *
178 C S PYRVCH to calculate R-violating chargino decay widths *
179 C S PYRVGL to calculate R-violating gluino decay widths *
180 C F PYRVSB auxiliary to PYRVSF *
181 C S PYRVGW to calculate R-Violating 3-body widths *
182 C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
183 C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
184 C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
185 C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
186 C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
187 C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
188 C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
189 C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
190 C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
192 C S PY1ENT to fill one entry (= parton or particle) *
193 C S PY2ENT to fill two entries *
194 C S PY3ENT to fill three entries *
195 C S PY4ENT to fill four entries *
196 C S PY2FRM to interface to generic two-fermion generator *
197 C S PY4FRM to interface to generic four-fermion generator *
198 C S PY6FRM to interface to generic six-fermion generator *
199 C S PY4JET to generate a shower from a given 4-parton config *
200 C S PY4JTW to evaluate the weight od a shower history for above *
201 C S PY4JTS to set up the parton configuration for above *
202 C S PYJOIN to connect entries with colour flow information *
203 C S PYGIVE to fill (or query) commonblock variables *
204 C S PYEXEC to administrate fragmentation and decay chain *
205 C S PYPREP to rearrange showered partons along strings *
206 C S PYSTRF to do string fragmentation of jet system *
207 C S PYJURF to find boost to string junction rest frame *
208 C S PYINDF to do independent fragmentation of one or many jets *
209 C S PYDECY to do the decay of a particle *
210 C S PYDCYK to select parton and hadron flavours in decays *
211 C S PYKFDI to select parton and hadron flavours in fragm *
212 C S PYNMES to select number of popcorn mesons *
213 C S PYKFIN to calculate falvour prod. ratios from input params. *
214 C S PYPTDI to select transverse momenta in fragm *
215 C S PYZDIS to select longitudinal scaling variable in fragm *
216 C S PYSHOW to do timelike parton shower evolution *
217 C F PYMAEL auxiliary to PYSHOW, with gluon emission ME's *
218 C S PYBOEI to include Bose-Einstein effects (crudely) *
219 C S PYBESQ auxiliary to PYBOEI *
220 C F PYMASS to give the mass of a particle or parton *
221 C F PYMRUN to give the running MSbar mass of a quark *
222 C S PYNAME to give the name of a particle or parton *
223 C F PYCHGE to give three times the electric charge *
224 C F PYCOMP to compress standard KF flavour code to internal KC *
225 C S PYERRM to write error messages and abort faulty run *
226 C F PYALEM to give the alpha_electromagnetic value *
227 C F PYALPS to give the alpha_strong value *
228 C F PYANGL to give the angle from known x and y components *
229 C F PYR to provide a random number generator *
230 C S PYRGET to save the state of the random number generator *
231 C S PYRSET to set the state of the random number generator *
232 C S PYROBO to rotate and/or boost an event *
233 C S PYEDIT to remove unwanted entries from record *
234 C S PYLIST to list event record or particle data *
235 C S PYLOGO to write a logo *
236 C S PYUPDA to update particle data *
237 C F PYK to provide integer-valued event information *
238 C F PYP to provide real-valued event information *
239 C S PYSPHE to perform sphericity analysis *
240 C S PYTHRU to perform thrust analysis *
241 C S PYCLUS to perform three-dimensional cluster analysis *
242 C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
243 C S PYJMAS to give high and low jet mass of event *
244 C S PYFOWO to give Fox-Wolfram moments *
245 C S PYTABU to analyze events, with tabular output *
247 C S PYEEVT to administrate the generation of an e+e- event *
248 C S PYXTEE to give the total cross-section at given CM energy *
249 C S PYRADK to generate initial state photon radiation *
250 C S PYXKFL to select flavour of primary qqbar pair *
251 C S PYXJET to select (matrix element) jet multiplicity *
252 C S PYX3JT to select kinematics of three-jet event *
253 C S PYX4JT to select kinematics of four-jet event *
254 C S PYXDIF to select angular orientation of event *
255 C S PYONIA to perform generation of onium decay to gluons *
257 C S PYBOOK to book a histogram *
258 C S PYFILL to fill an entry in a histogram *
259 C S PYFACT to multiply histogram contents by a factor *
260 C S PYOPER to perform operations between histograms *
261 C S PYHIST to print and reset all histograms *
262 C S PYPLOT to print a single histogram *
263 C S PYNULL to reset contents of a single histogram *
264 C S PYDUMP to dump histogram contents onto a file *
266 C S PYKCUT dummy routine for user kinematical cuts *
267 C S PYEVWT dummy routine for weighting events *
268 C S UPINIT dummy routine to initialize user processes *
269 C S UPEVNT dummy routine to generate a user process event *
270 C S PDFSET dummy routine to be removed when using PDFLIB *
271 C S STRUCTM dummy routine to be removed when using PDFLIB *
272 C S STRUCTP dummy routine to be removed when using PDFLIB *
273 C S SUGRA dummy routine to be removed when linking with ISAJET *
274 C F VISAJE dummy functn. to be removed when linking with ISAJET *
275 C S PYTAUD dummy routine for interface to tau decay libraries *
276 C S PYTIME dummy routine for giving date and time *
278 C*********************************************************************
281 C...Default values for switches and parameters,
282 C...and particle, decay and process data.
286 C...Double precision and integer declarations.
287 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
288 IMPLICIT INTEGER(I-N)
289 C INTEGER PYK,PYCHGE,PYCOMP
291 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
292 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
293 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
294 COMMON/PYDAT4/CHAF(500,2)
296 COMMON/PYDATR/MRPY(6),RRPY(100)
297 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
298 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
299 COMMON/PYINT1/MINT(400),VINT(400)
300 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
301 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
302 COMMON/PYINT4/MWID(500),WIDS(500,5)
303 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
304 COMMON/PYINT6/PROC(0:500)
306 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
307 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
308 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
309 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
310 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
311 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
312 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
313 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
314 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
315 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYBINS/
317 C...PYDAT1, containing status codes and most parameters.
319 & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
320 1 6, 1, 1, 0, 0, 1, 0, 0, 0, 0,
321 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
322 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
323 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
324 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
325 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
327 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
328 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
330 DATA (PARU(I),I=1,100)/
331 & 3.141592653589793D0, 6.283185307179586D0,
332 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
333 1 0.001D0, 0.09D0, 0.01D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
334 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
335 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
336 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
337 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
338 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
340 DATA (PARU(I),I=101,200)/
341 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
342 & 0D0, 0D0, 0D0, 0D0, 0D0,
343 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
344 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
345 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
346 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
347 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
348 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
349 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
350 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
351 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
352 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
354 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
355 1 4, 2, 0, 1, 0, 2, 2, 10, 0, 0,
356 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
357 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
358 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
359 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
361 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
362 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
365 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
366 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
367 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
368 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
369 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
370 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
371 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
372 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
373 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
374 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
375 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
376 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
377 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
378 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
379 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
380 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
381 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
385 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
386 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
387 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
388 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
391 C...PYDAT2, with particle data and flavour treatment parameters.
392 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
393 &-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,
394 &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,
395 &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,
396 &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,
397 &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,
398 &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,
399 &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,
400 &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,
402 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
403 &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,
404 &-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,
405 &6*1,9*0,2,3*0,2,0,5*2,2*1,156*0/
406 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
407 &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,
408 &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,
409 &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/
410 DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
411 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
412 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
413 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
414 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
415 &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
416 &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
417 &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
418 &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
419 &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
420 &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
421 &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
422 &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
423 &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
424 &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
425 &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
426 &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
427 &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
428 &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
429 &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
430 DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
431 &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
432 &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
433 &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
434 &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
435 &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
436 &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
437 &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
438 &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
439 &9902110,9902210,139*0/
440 DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
441 &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
442 &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
443 &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
444 &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
445 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
446 &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
447 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
448 &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
449 &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
450 &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
451 &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
452 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
453 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
454 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
455 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
456 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
457 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
458 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
459 &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
460 DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
461 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
462 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
463 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
464 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
465 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
466 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
467 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
468 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
469 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
470 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
471 &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
472 &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,139*0D0/
473 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
474 &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
475 &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
476 &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
477 &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
478 &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
479 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
480 &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
481 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
482 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
483 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
484 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
485 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
486 &0.02911D0,0.01741D0,0.04536D0,0.09511D0,0.8686D0,0.62395D0,
487 &0.19192D0,123.27638D0,0.02296D0,0.18886D0,23.26819D0,2.86306D0,
488 &0D0,3.45903D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
489 &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
491 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
492 &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
493 &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
494 &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
495 &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
496 &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
497 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
498 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
499 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
500 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
501 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
502 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
503 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
504 &0.29108D0,0.17412D0,0.45362D0,0.95114D0,8.68604D0,6.23946D0,
505 &1.91923D0,450D0,0.22959D0,1.88863D0,232.68185D0,28.63059D0,0D0,
506 &34.59032D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
507 &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
508 &8.80013D0,7*0D0,139*0D0/
509 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
510 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
511 &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
512 &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
513 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
514 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
515 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
516 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,112*0D0,139*0D0/
518 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
519 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
520 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
521 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
522 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
523 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
524 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
525 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
526 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
527 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0,
528 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
529 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
530 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
532 4 0.2D0, 0.5D0, 8*0D0,
534 DATA ((VCKM(I,J),J=1,4),I=1,4)/
535 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
536 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
537 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
538 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
540 C...PYDAT3, with particle decay parameters and data.
541 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
542 &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,
543 &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,
544 &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/
545 DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
546 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
547 &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
548 &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
549 &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
550 &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
551 &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
552 &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
553 &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
554 &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
555 &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
556 &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
557 &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
558 &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
559 &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
560 &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
561 &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
562 &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
563 &3924,0,3960,0,3996,4004,4012,4020,4023,4047,4073,4097,4103,4110,
564 &4117,4124,4130,4136,4145,4149,4153,4156,4158,4178,4200,4222,4244/
565 DATA (MDCY(I,2),I= 352, 500)/4259,4271,4278,146*0/
566 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
567 &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,
568 &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,
569 &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,
570 &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,
571 &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,
572 &5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,9*2,11,14,45,24,45,24,
573 &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
574 &28,49,28,36,0,36,0,36,0,3*8,3,24,26,24,6,3*7,2*6,9,2*4,3,2,20,
575 &3*22,15,12,2*7,146*0/
576 DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
577 &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,
578 &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,85*1,
579 &2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,200*1,2*-1,2*1,-1,
580 &1249*1,2*-1,377*1,2*-1,1868*1,2*-1,6*1,2*-1,9*1,-1,3*1,-1,3*1,
581 &5*-1,3*1,-1,14*1,2*-1,6*1,2*-1,67*1,2*-1,6*1,2*-1,111*1,3716*0/
582 DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
583 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
584 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
585 &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
586 &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,
587 &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,
588 &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,
589 &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
590 &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,
591 &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,
592 &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,
593 &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,
594 &17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,5*0,2404*53,4*32,
595 &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,
596 &46*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0,9*32,3733*0/
597 DATA (BRAT(I) ,I= 1, 346)/43*0D0,0.00003D0,0.001765D0,
598 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
599 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
600 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
601 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
602 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
603 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
604 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
605 &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
606 &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
607 &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
608 &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
609 &0.108087D0,0D0,0.000001D0,0D0,0.000349D0,0.048707D0,0.768308D0,
610 &4*0D0,0.000227D0,0.064048D0,0D0,0.040621D0,0.002043D0,0.000615D0,
611 &0.006981D0,0.068099D0,62*0D0,0.145835D0,0.113276D0,0.145835D0,
612 &0.113271D0,0.145781D0,0.049002D0,2*0D0,0.032025D0,0.063642D0,
613 &0.032025D0,0.063642D0,0.032022D0,0.063642D0,8*0D0,0.251225D0,
614 &0.0129D0,0.000006D0,0D0,0.0129D0,0.250764D0,0.00038D0,0D0,
615 &0.000008D0,0.000465D0,0.215418D0,5*0D0,2*0.085312D0,0.08531D0,
616 &7*0D0,0.000049D0,0.000774D0,5*0D0,0.000074D0,0D0,0.000417D0/
617 DATA (BRAT(I) ,I= 347, 651)/0.000015D0,0.000061D0,0.30671D0,
618 &0.689011D0,0D0,0.002889D0,69*0D0,0.000001D0,0.000121D0,
619 &0.001924D0,4*0D0,0.000001D0,0.000184D0,0D0,0.003106D0,0.000015D0,
620 &0.000003D0,2*0D0,0.994646D0,66*0D0,0.000021D0,0.090135D0,2*0D0,
621 &0.000013D0,0.003714D0,0D0,0.906117D0,18*0D0,3*0.215119D0,
622 &0.214724D0,2*0D0,0.06996D0,0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,
623 &0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
624 &0.005D0,0.988D0,0.012D0,0.998739D0,0.00079D0,0.00038D0,
625 &0.000046D0,0.000045D0,2*0.34725D0,0.144D0,0.104D0,0.0245D0,
626 &2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0,2*0.1939D0,
627 &2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0,0.000123D0,
628 &0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0,0.049D0,0.0028D0,
629 &0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0,0.0049D0,0.0013D0,
630 &0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0,0.00083D0,
631 &2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0,2*0.0115D0,
632 &0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0,0.333D0,
633 &0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0,0.059D0,
634 &2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0,0.0482D0,
635 &0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0,0.168D0,0.084D0,
636 &0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0,0.437D0,0.208D0/
637 DATA (BRAT(I) ,I= 652, 823)/0.302D0,0.0302D0,0.0212D0,0.0016D0,
638 &0.48947D0,0.34D0,3*0.043D0,0.027D0,0.0126D0,0.0013D0,0.0003D0,
639 &0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,2*0.004D0,0.07D0,
640 &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,0.065D0,2*0.005D0,
641 &2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0,0.041D0,0.045D0,
642 &0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0,0.0006D0,0.0066D0,
643 &0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0,0.005D0,0.012D0,
644 &0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0,0.004D0,0.019D0,
645 &0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0,0.087D0,0.001D0,
646 &0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0,0.011D0,0.3D0,0.15D0,
647 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.034D0,0.027D0,
648 &2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0,2*0.002D0,
649 &2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0,3*0.021D0,
650 &0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0,0.0041D0,
651 &0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0,0.0018D0,
652 &0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0,0.0036D0,
653 &0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0,0.0077D0,
654 &0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0,0.017D0,
655 &0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0,0.08D0,
656 &0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,2*0.005D0/
657 DATA (BRAT(I) ,I= 824, 991)/2*0.02D0,0.03D0,2*0.005D0,0.015D0,
658 &0.037D0,0.028D0,0.079D0,0.095D0,0.052D0,0.0078D0,4*0.001D0,
659 &0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,0.0952D0,
660 &0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,0.8797D0,
661 &0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,
662 &0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
663 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
664 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
665 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
666 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
667 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
668 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
669 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,
670 &0.0008D0,0.0014D0,0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,
671 &0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,
672 &0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,
673 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,
674 &0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,
675 &0.0135D0,0.025D0,2*0.0002D0,0.0007D0,2*0.0004D0,0.0014D0,0.001D0,
676 &0.0009D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0/
677 DATA (BRAT(I) ,I= 992,1183)/1D0,2*0.3D0,2*0.2D0,0.047D0,0.122D0,
678 &0.006D0,0.012D0,0.035D0,0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,
679 &0.037D0,0.008D0,0.002D0,0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,
680 &0.042D0,0.014D0,0.042D0,0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,
681 &0.002D0,0.001D0,0.002D0,0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,
682 &0.0252D0,0.0248D0,0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,
683 &0.7743D0,0.029D0,0.22D0,0.78D0,1D0,0.331D0,0.663D0,0.006D0,
684 &0.663D0,0.331D0,0.006D0,1D0,0.999D0,0.001D0,0.88D0,2*0.06D0,
685 &0.639D0,0.358D0,0.002D0,0.001D0,1D0,0.88D0,2*0.06D0,0.516D0,
686 &0.483D0,0.001D0,0.88D0,2*0.06D0,0.9988D0,0.0001D0,0.0006D0,
687 &0.0004D0,0.0001D0,0.667D0,0.333D0,0.9954D0,0.0011D0,0.0035D0,
688 &0.333D0,0.667D0,0.676D0,0.234D0,0.085D0,0.005D0,2*1D0,0.018D0,
689 &2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.018D0,2*0.005D0,0.003D0,
690 &0.002D0,2*0.006D0,0.0066D0,0.025D0,0.016D0,0.0088D0,2*0.005D0,
691 &0.0058D0,0.005D0,0.0055D0,4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,
692 &0.002D0,2*0.003D0,3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,
693 &2*0.002D0,0.0013D0,0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,
694 &2*0.002D0,2*0.001D0,2*0.002D0,2*0.001D0,0.2432D0,0.057D0,
695 &2*0.035D0,0.15D0,2*0.075D0,0.03D0,2*0.015D0,2*0.08D0,0.76D0,
696 &0.08D0,4*1D0,2*0.08D0,0.76D0,0.08D0,1D0,2*0.5D0,1D0,2*0.5D0/
697 DATA (BRAT(I) ,I=1184,1377)/2*0.08D0,0.76D0,0.08D0,1D0,2*0.08D0,
698 &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,
699 &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,
700 &0.04D0,0.0077D0,0.02D0,0.0235D0,0.0285D0,0.0435D0,0.0011D0,
701 &0.0022D0,0.0044D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
702 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
703 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
704 &4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
705 &0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
706 &0.005D0,4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
707 &0.015D0,0.005D0,1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
708 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
709 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
710 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
711 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
712 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
713 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
714 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
715 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
716 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0/
717 DATA (BRAT(I) ,I=1378,1580)/0.015D0,0.005D0,2*0.105D0,0.04D0,
718 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
719 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
720 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
721 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
722 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
723 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
724 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
725 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,
726 &0.11D0,2*0.055D0,0.333D0,0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,
727 &0.14D0,0.313D0,0.157D0,0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,
728 &0.313D0,0.157D0,0.11D0,0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,
729 &4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,
730 &0.333D0,4*0.5D0,0.007D0,0.993D0,1D0,0.667D0,0.333D0,0.667D0,
731 &0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,
732 &1D0,4*0.5D0,3*0.146D0,3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,
733 &0.667D0,0.333D0,0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,
734 &0.333D0,2*0.5D0,0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,
735 &4*0.5D0,0.35D0,0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,
736 &0.027D0,0.001D0,0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0/
737 DATA (BRAT(I) ,I=1581,4149)/0.008D0,0.024D0,0.008D0,0.024D0,
738 &0.425D0,0.02D0,0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,
739 &0.017431D0,0.054048D0,0.857694D0,2*0D0,0.00025D0,0.070578D0,0D0,
740 &0.022748D0,0.026576D0,0.359486D0,0.561581D0,2*0D0,0.000104D0,
741 &0.029504D0,0.011185D0,0.034681D0,0.550354D0,2*0D0,0.00016D0,
742 &0.045287D0,0.358333D0,0.445781D0,0D0,0.554219D0,0.144051D0,
743 &2*0.351902D0,0D0,0.082107D0,0.029566D0,0.001511D0,0.000726D0,
744 &0.004518D0,0.006522D0,0.004518D0,0.006522D0,0.004513D0,3*0D0,
745 &0.002908D0,0.000973D0,0.002908D0,0.000973D0,0.002908D0,
746 &0.000973D0,2*0D0,0.143982D0,0.489888D0,0.1951D0,0D0,0.114302D0,
747 &0.008426D0,0.014868D0,0.000763D0,2*0D0,0.000763D0,0.01484D0,
748 &0.000003D0,2*0D0,0.000027D0,0.001945D0,5*0D0,3*0.00503D0,0D0,
749 &0.133776D0,0.003284D0,0.37169D0,0.006838D0,2*0.030954D0,
750 &0.00163D0,0D0,0.047224D0,0.073737D0,0.047224D0,0.073732D0,
751 &0.047179D0,3*0D0,0.034761D0,0.009166D0,0.034761D0,0.009166D0,
752 &0.034759D0,0.009166D0,2*0D0,4*0.009069D0,0.510147D0,0.453576D0,
753 &6*0D0,1D0,6*0D0,1D0,4*0.001128D0,0.571047D0,0.382288D0,
754 &0.042153D0,4*0.016597D0,0.93361D0,0D0,4*0.016597D0,0.93361D0,0D0,
755 &4*0.05515D0,0.34469D0,0D0,0.228998D0,0.164208D0,0.041503D0,
756 &0.850973D0,0.005411D0,0.045025D0,0.098591D0,0.849898D0/
757 DATA (BRAT(I) ,I=4150,4280)/0.021617D0,0.030018D0,0.098466D0,
758 &0.294448D0,0.10945D0,0.596102D0,0.389906D0,0.610094D0,3*0.0633D0,
759 &0.063299D0,0.063295D0,0.056281D0,2*0D0,6*0.020495D0,2*0D0,
760 &0.327919D0,0.04099D0,0.045236D0,0.090112D0,0.19874D0,0.010204D0,
761 &0.000003D0,0.010205D0,0.198356D0,0.000151D0,0.000006D0,
762 &0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,0.010205D0,
763 &0.198356D0,0.000151D0,0.000006D0,0.000367D0,0.081967D0,4*0D0,
764 &0.198776D0,0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,
765 &0.000006D0,0.000367D0,0.081893D0,0.198776D0,0.010206D0,
766 &0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,0.000367D0,
767 &0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0,0.010236D0,
768 &0.198928D0,0.000149D0,0.000006D0,0.000368D0,0.080733D0,
769 &0.199344D0,0.010234D0,0.000003D0,0.010236D0,0.198928D0,
770 &0.000149D0,0.000006D0,0.000368D0,0.080733D0,4*0D0,0.184738D0,
771 &0.104588D0,0.184738D0,0.104587D0,0.184731D0,0.09582D0,0.022902D0,
772 &0.008429D0,0.015602D0,0.022902D0,0.008429D0,0.015602D0,
773 &0.022902D0,0.008429D0,0.015602D0,0.28959D0,0.01487D0,0.000008D0,
774 &0.01487D0,0.289061D0,0.000492D0,0.000009D0,0.000536D0,0.27911D0,
775 &2*0.037151D0,0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,
776 &0.001805D0,0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0/
777 DATA (BRAT(I) ,I=4281,8000)/0.090428D0,0.001808D0,0.81372D0,0D0,
779 DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
780 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
781 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
782 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
783 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
784 &-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,
785 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
786 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
787 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
788 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
789 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
790 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
791 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
792 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
793 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
794 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
795 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
796 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
797 &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
798 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
799 DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
800 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
801 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
802 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
803 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
804 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
805 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
806 &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
807 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
808 &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
809 &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
810 &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
811 &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
812 &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
813 &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
814 &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
815 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
816 &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
817 &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
818 &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
819 DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
820 &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
821 &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
822 &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
823 &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
824 &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
825 &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
826 &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
827 &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
828 &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
829 &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
830 &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
831 &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
832 &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
833 &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
834 &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
835 &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
836 &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
837 &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
838 &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
839 DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
840 &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
841 &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
842 &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
843 &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
844 &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
845 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
846 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
847 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
848 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
849 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
850 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
851 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
852 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
853 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
854 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
855 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
856 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
857 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
858 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
859 DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
860 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
861 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
862 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
863 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
864 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
865 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
866 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
867 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
868 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
869 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
870 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
871 &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
872 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
873 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
874 &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
875 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
876 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
877 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
878 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
879 DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,
880 &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
881 &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
882 &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
883 &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
884 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
885 &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
886 &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
887 &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
888 &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
889 &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
890 &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
891 &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
892 &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
893 &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
894 &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
895 &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
896 &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
897 &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
898 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
899 DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,
900 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
901 &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
902 &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
903 &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
904 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
905 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
906 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
907 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
908 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
909 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
910 &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
911 &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
912 &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
913 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
914 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
915 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
916 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
917 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
918 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
919 DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
920 &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
921 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
922 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
923 &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
924 &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
925 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
926 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
927 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
928 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
929 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
930 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
931 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
932 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
933 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
934 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
935 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
936 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
937 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
938 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
939 DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
940 &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
941 &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
942 &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
943 &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
944 &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
945 &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
946 &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
947 &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
948 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
949 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
950 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
951 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
952 &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
953 &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
954 &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
955 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
956 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
957 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
958 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
959 DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,
960 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
961 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
962 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
963 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
964 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
965 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
966 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
967 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
968 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
969 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
970 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
971 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
972 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
973 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
974 &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
975 &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
976 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
977 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
978 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
979 DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,
980 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
981 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
982 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
983 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
984 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
985 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
986 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
987 &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
988 &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
989 &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
990 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
991 &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
992 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
993 &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
994 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
995 &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
996 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
997 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
998 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
999 DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,
1000 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
1001 &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1002 &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
1003 &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
1004 &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1005 &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1006 &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
1007 &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
1008 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
1009 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
1010 &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
1011 &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
1012 &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
1013 &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
1014 &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
1015 &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
1016 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
1017 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
1018 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
1019 DATA (KFDP(I,1),I=3783,4127)/1000039,1000024,1000037,1000022,
1020 &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
1021 &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1022 &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
1023 &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
1024 &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
1025 &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
1026 &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
1027 &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1028 &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1029 &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1030 &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1031 &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1032 &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
1033 &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
1034 &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
1035 &2*24,2*3000211,2*22,2*23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1036 &2*24,3*3000211,24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,22,
1037 &23,24,3000211,24,3000211,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1038 &1,2,3,4,5,6,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4/
1039 DATA (KFDP(I,1),I=4128,8000)/5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,
1040 &3100111,3200111,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1,2,3,4,
1041 &5,6,7,8,11,12,13,14,15,16,17,18,21,22,23,24,9*11,9*-11,2*11,
1042 &2*-11,9*13,9*-13,2*13,2*-13,9*15,9*-15,2*15,2*-15,1,2,3,4,5,6,11,
1043 &12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,
1044 &-15,3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3716*0/
1045 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,
1046 &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,
1047 &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,
1048 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1049 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1050 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1051 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1052 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1053 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1054 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1055 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1056 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1057 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1058 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1059 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1060 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1061 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1062 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1063 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1064 &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/
1065 DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1066 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1067 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1068 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1069 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1070 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1071 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1072 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1073 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1074 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1075 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1076 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1077 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1078 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1079 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1080 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1081 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1082 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1083 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1084 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1085 DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1086 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1087 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1088 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1089 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1090 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1091 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1092 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1093 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1094 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1095 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1096 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1097 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1098 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1099 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1100 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1101 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1102 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1103 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1104 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1105 DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1106 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1107 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1108 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1109 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1110 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1111 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1112 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1113 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1114 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1115 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1116 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1117 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1118 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1119 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1120 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1121 &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,
1122 &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,
1123 &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,
1124 &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/
1125 DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1126 &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,
1127 &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,
1128 &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,
1129 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1130 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1131 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1132 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1133 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1134 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1135 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1136 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1137 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1138 &1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,
1139 &-5,2,2*1,4*2,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,
1140 &2*-24,2*-37,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,
1141 &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,2*24,2*37,4,1,3,5,1,3,5,1,3,5,-3,
1142 &2*-5,5,2*6,4*5,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,
1143 &4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,2*5,4*6,2*24,2*37,6,4,-15,
1144 &16,1,3,5,1,3,5,1,3,5,-3,2*-5,11,2*12,4*11,2*-24,-37,13,15,11,15/
1145 DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1146 &1,3,5,12,2*11,4*12,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,
1147 &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1148 &5,1,3,5,1,3,5,14,2*13,4*14,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,
1149 &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1150 &13,15,1,3,5,1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15,
1151 &1,3,5,1,3,5,1,3,5,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,
1152 &5,-5,5,-6,6,-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,
1153 &1,-1,3,-3,5,-5,1,-1,3,-3,5,-5,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,
1154 &-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,
1155 &-1,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,
1156 &-6,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,
1157 &-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,
1158 &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1159 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1160 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1161 &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,-6,
1162 &6,-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,
1163 &5,-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,
1164 &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3/
1165 DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1166 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1167 &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1168 &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1169 &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1170 &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1171 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1172 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1173 &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,-6,
1174 &6,-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,
1175 &5,-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,
1176 &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,
1177 &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1178 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1179 &2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,
1180 &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1181 &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1182 &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1183 &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1184 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1185 DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1186 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1187 &2*4,-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,22,23,25,35,36,22,23,11,13,
1188 &15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,
1189 &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1190 &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1191 &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1192 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1193 &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1194 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1195 &-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,
1196 &-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,
1197 &-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,
1198 &-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,
1199 &-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,
1200 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1201 &16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,
1202 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1203 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1204 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1205 DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1206 &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1207 &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1208 &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1209 &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,-2,
1210 &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,-5,
1211 &5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,
1212 &4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,
1213 &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1214 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1215 &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1216 &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1217 &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1218 &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1219 &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1220 &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1221 &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1222 &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1223 &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1224 &-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,1,2*2,4*1,23,25,35,36,2*-24/
1225 DATA (KFDP(I,2),I=3670,4136)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1226 &6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,-5,2,2*1,4*2,23,25,35,
1227 &36,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,23,25,35,36,
1228 &2*-24,2*-37,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,
1229 &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,23,25,35,36,2*24,2*37,4,1,3,5,1,
1230 &3,5,1,3,5,-3,2*-5,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,1,3,5,1,3,
1231 &5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,
1232 &2*5,4*6,23,25,35,36,2*24,2*37,6,1,3,5,1,3,5,1,3,5,-3,2*-5,11,
1233 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1234 &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,
1235 &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,
1236 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1237 &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1238 &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-24,-3000211,-24,-3000211,
1239 &3000111,3000221,3000111,3000221,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,
1240 &-13,-14,-15,-16,-17,-18,23,3000111,23,3000111,22,3000221,2,4,6,8,
1241 &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,
1242 &2*-24,-3000211,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1243 &-17,-18,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,
1244 &21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,-1/
1245 DATA (KFDP(I,2),I=4137,8000)/-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1246 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1247 &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3,
1248 &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,
1249 &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16,
1250 &9900016,2,4,6,2,4,6,2,4,6,9900012,9900014,9900016,-11,-13,-15,
1251 &-13,2*-15,24,-11,-13,-15,-13,2*-15,9900024,3716*0/
1252 DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1253 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1254 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1255 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1256 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1257 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1258 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1259 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1260 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1261 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1262 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1263 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1264 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1265 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1266 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1267 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1268 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1269 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1270 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1271 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1272 DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1273 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1274 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1275 &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,
1276 &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,
1277 &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,
1278 &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,
1279 &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,
1280 &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,
1281 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1282 &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1283 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1284 &6,-2,2,-4,4,-6,6,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,
1285 &-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,5,
1286 &-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,5,
1287 &-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,
1288 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,
1289 &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1290 &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1291 &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1292 DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1293 &-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,5,
1294 &-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,
1295 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,
1296 &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1297 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1298 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1299 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1300 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1301 &-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,5,
1302 &-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,
1303 &-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,
1304 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
1305 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,3*0,12,14,16,2,4,0,12,14,16,2,
1306 &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1307 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1308 &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1309 &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,
1310 &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,
1311 &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/
1312 DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1313 &2*6,5,-5,3,-3,5,-5,1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,7*0,
1314 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1315 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1316 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1317 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1318 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1319 &-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,5,
1320 &-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,
1321 &-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,
1322 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
1323 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1324 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1325 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1326 &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1327 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1328 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1329 &-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,
1330 &-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,3,
1331 &-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,3/
1332 DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1333 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,
1334 &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1335 &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,
1336 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1337 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1338 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1339 &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,
1340 &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,
1341 &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,
1342 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,3,-3,5,-5,
1343 &1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,351*0,-5,169*0,2,4,6,2,
1344 &4,6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,
1345 &4,6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,
1346 &4,6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3757*0/
1347 DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1348 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1349 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1350 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1351 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1352 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1353 &-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,
1354 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1355 &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,
1356 &162*81,31*0,-211,111,6516*0/
1357 DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1358 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1359 &3*111,-211,111,7193*0/
1361 C...PYDAT4, with particle names (character strings).
1362 DATA (CHAF(I,1),I= 1, 100)/'d','u','s','c','b','t','b''','t''',
1363 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1364 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1365 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1366 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1367 &'junction',' ','system','cluster','string','indep.','CMshower',
1368 &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' '/
1369 DATA (CHAF(I,1),I= 101, 202)/'reggeon','pi0',
1370 &'rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega','f_2',
1371 &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1372 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1373 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1374 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1375 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1376 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1377 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1378 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1379 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1380 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1381 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1382 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1383 DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1384 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1385 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1386 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1387 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1388 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1389 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1390 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1391 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1392 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1393 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1394 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1395 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1396 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1397 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1398 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1399 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1400 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1401 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1402 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1403 DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1404 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1405 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1406 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1407 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1408 &'n_diffr0','p_diffr+',139*' '/
1409 DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1410 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1411 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1412 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1413 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1414 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1415 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1416 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1417 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1418 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1419 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1420 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1421 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1422 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1423 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1424 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1425 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1426 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1427 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1428 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1429 DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1430 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1431 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1432 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1433 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1434 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1435 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1436 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1437 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1438 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1439 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1440 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1441 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1442 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1443 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1444 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1445 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1446 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1447 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1448 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1449 DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1450 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1451 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1452 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',139*' '/
1454 C...PYDATR, with initial values for the random number generator.
1455 DATA MRPY/19780503,0,0,97,33,0/
1457 C...Default values for allowed processes and kinematics constraints.
1460 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1461 &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,
1464 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1465 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1466 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1467 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1468 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1469 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1470 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1471 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1472 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1473 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1474 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1475 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1476 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1477 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1478 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1479 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1482 C...Default values for main switches and parameters. Reset information.
1483 DATA (MSTP(I),I=1,100)/
1484 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1485 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1486 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1487 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1488 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1489 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1490 6 2, 3, 2, 2, 1, 5, 2, 1, 0, 0,
1491 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1492 8 1, 1, 100, 0, 0, 2, 0, 0, 0, 0,
1493 9 1, 3, 1, 3, 0, 0, 0, 0, 0, 0/
1494 DATA (MSTP(I),I=101,200)/
1495 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1496 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1497 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1498 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1499 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1500 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1501 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1502 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1503 8 6, 214, 2003, 01, 22, 0, 0, 0, 0, 0,
1504 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1505 DATA (PARP(I),I=1,100)/
1506 & 0.25D0, 10D0, 8*0D0,
1507 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1509 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
1510 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1512 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 1.0D0,1D-3,2*0D0,
1513 7 4.0D0, 0.25D0, 8*0D0,
1514 8 1.90D0, 1.90D0, 0.5D0, 0.2D0, 0.33D0,
1515 8 0.66D0, 0.7D0, 0.5D0, 1000D0, 0.16D0,
1516 9 1.0D0,0.40D0,5.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1517 DATA (PARP(I),I=101,200)/
1518 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1519 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1520 2 1.0D0, 0.4D0, 8*0D0,
1523 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1524 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1525 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1526 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1528 9 0.64D0, 5.0D0, 8*0D0/
1534 C...Constants for the generation of the various processes.
1535 DATA (ISET(I),I=1,100)/
1536 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1537 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1538 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1539 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1540 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1541 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1542 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1543 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1544 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1545 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1546 DATA (ISET(I),I=101,200)/
1547 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1548 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1549 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1550 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1551 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1552 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1553 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1554 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1555 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1556 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1557 DATA (ISET(I),I=201,300)/
1558 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1559 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1560 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1561 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1562 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1563 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1564 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1565 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1566 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1567 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1568 DATA (ISET(I),I=301,500)/
1570 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1571 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1572 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1573 7 2, 2, 2, 2, 2, 2, 2, -1, -1, -1,
1574 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1575 9 1, 1, 2, 2, 2, 5*-2,
1577 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1578 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1579 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1580 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1581 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1582 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1583 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1584 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1585 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1586 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1587 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1588 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1589 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1590 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1591 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1592 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1593 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1594 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1595 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1596 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1597 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1598 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1599 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1600 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1601 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1602 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1603 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1604 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1605 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1606 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1607 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1608 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1609 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1610 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1611 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1612 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1613 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1614 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1615 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1616 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1617 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1618 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1619 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1620 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1621 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1622 & 1000011, 1000011, 2000011, 2000011, 1000011,
1623 & 2000011, 1000013, 1000013, 2000013, 2000013,
1624 & 1000013, 2000013, 1000015, 1000015, 2000015,
1625 & 2000015, 1000015, 2000015, 1000011, 1000012,
1626 1 1000015, 1000016, 2000015, 1000016, 1000012,
1627 1 1000012, 1000016, 1000016, 0, 0,
1628 1 1000022, 1000022, 1000023, 1000023, 1000025,
1629 1 1000025, 1000035, 1000035, 1000022, 1000023,
1630 2 1000022, 1000025, 1000022, 1000035, 1000023,
1631 2 1000025, 1000023, 1000035, 1000025, 1000035,
1632 2 1000024, 1000024, 1000037, 1000037, 1000024,
1633 2 1000037, 1000022, 1000024, 1000023, 1000024,
1634 3 1000025, 1000024, 1000035, 1000024, 1000022,
1635 3 1000037, 1000023, 1000037, 1000025, 1000037,
1636 3 1000035, 1000037, 1000021, 1000022, 1000021,
1637 3 1000023, 1000021, 1000025, 1000021, 1000035/
1638 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1639 4 1000021, 1000024, 1000021, 1000037, 1000021,
1640 4 1000021, 1000021, 1000021, 0, 0,
1641 4 1000002, 1000022, 2000002, 1000022, 1000002,
1642 4 1000023, 2000002, 1000023, 1000002, 1000025,
1643 5 2000002, 1000025, 1000002, 1000035, 2000002,
1644 5 1000035, 1000001, 1000024, 2000005, 1000024,
1645 5 1000001, 1000037, 2000005, 1000037, 1000002,
1646 5 1000021, 2000002, 1000021, 0, 0,
1647 6 1000006, 1000006, 2000006, 2000006, 1000006,
1648 6 2000006, 1000006, 1000006, 2000006, 2000006,
1651 7 1000002, 1000002, 2000002, 2000002, 1000002,
1652 7 2000002, 1000002, 1000002, 2000002, 2000002,
1653 7 1000002, 2000002, 1000002, 1000002, 2000002,
1654 7 2000002, 1000002, 1000002, 2000002, 2000002/
1655 DATA ((KFPR(I,J),J=1,2),I=281,350)/
1656 8 1000005, 1000002, 2000005, 2000002, 1000005,
1657 8 2000002, 1000005, 1000002, 2000005, 2000002,
1658 8 1000005, 2000002, 1000005, 1000005, 2000005,
1659 8 2000005, 1000005, 1000005, 2000005, 2000005,
1660 9 1000005, 1000005, 2000005, 2000005, 1000005,
1661 9 2000005, 1000005, 1000021, 2000005, 1000021,
1662 9 1000005, 2000005, 37, 25, 37,
1663 9 35, 36, 25, 36, 35,
1665 4 9900041, 0, 9900042, 0, 9900041,
1666 4 11, 9900042, 11, 9900041, 13,
1667 4 9900042, 13, 9900041, 15, 9900042,
1668 4 15, 9900041, 9900041, 9900042, 9900042/
1669 DATA ((KFPR(I,J),J=1,2),I=351,500)/
1670 5 9900041, 0, 9900042, 0, 9900023,
1671 5 0, 9900024, 0, 0, 0,
1674 6 24, 24, 24, 3000211, 3000211,
1675 6 3000211, 22, 3000111, 22, 3000221,
1676 6 23, 3000111, 23, 3000221, 24,
1677 6 3000211, 0, 0, 24, 23,
1678 7 24, 3000111, 3000211, 23, 3000211,
1679 7 3000111, 22, 3000211, 23, 3000211,
1680 7 24, 3000111, 24, 3000221, 0,
1682 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1683 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1684 9 5000039, 0, 5000039, 0, 21,
1685 9 5000039, 0, 5000039, 21, 5000039,
1688 DATA COEF/10000*0D0/
1689 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1690 &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,
1691 &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,
1692 &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,
1693 &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,
1694 &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,
1695 &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,
1696 &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,
1697 &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,
1698 &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,
1699 &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/
1701 C...Treatment of resonances.
1702 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1703 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,146*0/
1705 C...Character constants: name of processes.
1706 DATA PROC(0)/ 'All included subprocesses '/
1707 DATA (PROC(I),I=1,20)/
1708 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1709 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1710 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1711 &' ', 'W+ + W- -> h0 ',
1712 &' ', 'f + f'' -> f + f'' (QFD) ',
1713 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1714 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1715 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1716 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1717 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1718 DATA (PROC(I),I=21,40)/
1719 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1720 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1721 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1722 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1723 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1724 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1725 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1726 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1727 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1728 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1729 DATA (PROC(I),I=41,60)/
1730 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1731 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1732 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1733 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1734 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1735 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1736 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1737 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1738 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1739 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1740 DATA (PROC(I),I=61,80)/
1741 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1742 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1743 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1744 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1745 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1746 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1747 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1748 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1749 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1750 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1751 DATA (PROC(I),I=81,100)/
1752 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1753 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1754 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1755 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1756 8'g + g -> chi_2c + g ', ' ',
1757 9'Elastic scattering ', 'Single diffractive (XB) ',
1758 9'Single diffractive (AX) ', 'Double diffractive ',
1759 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1761 9'q + gamma* -> q ', ' '/
1762 DATA (PROC(I),I=101,120)/
1763 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1764 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1765 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1766 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1767 &' ', 'f + fbar -> gamma + h0 ',
1768 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1769 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1770 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1771 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1773 DATA (PROC(I),I=121,140)/
1774 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1775 2'f + f'' -> f + f'' + h0 ',
1776 2'f + f'' -> f" + f"'' + h0 ',
1780 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1781 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1782 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1783 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1784 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1785 DATA (PROC(I),I=141,160)/
1786 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1787 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1788 4'q + l -> LQ ', 'e + gamma -> e* ',
1789 4'd + g -> d* ', 'u + g -> u* ',
1790 4'g + g -> eta_tc ', ' ',
1791 5'f + fbar -> H0 ', 'g + g -> H0 ',
1792 5'gamma + gamma -> H0 ', ' ',
1793 5' ', 'f + fbar -> A0 ',
1794 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1796 DATA (PROC(I),I=161,180)/
1797 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1798 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1799 6'f + fbar -> f'' + fbar'' (g/Z)',
1800 6'f +fbar'' -> f" + fbar"'' (W) ',
1801 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1802 6'q + qbar -> e + e* ', ' ',
1803 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1804 7'f + f'' -> f + f'' + H0 ',
1805 7'f + f'' -> f" + f"'' + H0 ',
1806 7' ', 'f + fbar -> Z0 + A0 ',
1807 7'f + fbar'' -> W+/- + A0 ',
1808 7'f + f'' -> f + f'' + A0 ',
1809 7'f + f'' -> f" + f"'' + A0 ',
1811 DATA (PROC(I),I=181,200)/
1812 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1813 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
1814 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
1815 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
1816 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
1817 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
1818 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
1819 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
1822 DATA (PROC(I),I=201,220)/
1823 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1824 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1825 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1826 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1827 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1828 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1829 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1830 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1831 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1832 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1833 DATA (PROC(I),I=221,240)/
1834 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1835 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1836 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1837 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1838 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1839 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1840 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1841 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1842 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1843 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1844 DATA (PROC(I),I=241,260)/
1845 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1846 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1847 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1848 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1849 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1850 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1851 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1852 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1853 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1854 5'qj + g -> ~qj_R + ~g ', ' '/
1855 DATA (PROC(I),I=261,300)/
1856 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1857 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1858 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1861 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1862 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1863 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1864 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1865 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
1866 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
1867 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
1868 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
1869 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
1870 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
1871 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
1872 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
1873 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
1874 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
1875 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
1876 DATA (PROC(I),I=301,340)/
1877 &'f + fbar -> H+ + H- ', 39*' '/
1878 DATA (PROC(I),I=341,380)/
1879 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
1880 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
1881 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
1882 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
1883 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
1884 5'f + f -> f'' + f'' + H_L++/-- ',
1885 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
1886 5'f + fbar'' -> W_R+/- ',5*' ',
1887 6' ', 'f + fbar -> W_L+ W_L- ',
1888 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
1889 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
1890 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
1891 6'f + fbar -> W+/- pi_T-/+ ', ' ',
1892 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
1893 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
1894 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
1895 7'f + fbar'' -> W+/- pi_T0 ',
1896 7'f + fbar'' -> W+/- pi_T0'' ',
1899 DATA (PROC(I),I=381,500)/
1900 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
1901 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
1902 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
1903 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
1905 9'f + fbar -> G* ', 'g + g -> G* ',
1906 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
1907 9'g + g -> g + G* ',' ',
1910 C...Cross sections and slope offsets.
1913 C...Supersymmetry switches and parameters.
1915 & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
1918 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
1919 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
1920 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
1922 C...Initial values for R-violating SUSY couplings.
1923 C...Should not be changed here. See PYMSIN.
1928 C...Technicolor switches and parameters
1930 & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1933 & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
1934 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
1935 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
1936 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
1937 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 4*0D0,
1940 C...Data for histogramming routines.
1941 DATA IHIST/1000,20000,55,1/
1946 C*********************************************************************
1949 C...A simple program (disguised as subroutine) to run at installation
1950 C...as a check that the program works as intended.
1952 SUBROUTINE PYTEST(MTEST)
1954 C...Double precision and integer declarations.
1955 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1956 IMPLICIT INTEGER(I-N)
1957 INTEGER PYK,PYCHGE,PYCOMP
1959 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1960 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1961 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1962 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
1963 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
1964 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
1965 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
1967 DIMENSION PSUM(5),PINI(6),PFIN(6)
1969 C...Save defaults for values that are changed.
1986 C...First part: loop over simple events to be generated.
1987 IF(MTEST.GE.1) CALL PYTABU(20)
1991 C...Reset parameter values. Switch on some nonstandard features.
2006 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
2008 C...Ten events each for some single jets configurations.
2012 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
2013 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
2014 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
2015 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
2016 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
2017 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
2019 C...Ten events each for some simple jet systems; string fragmentation.
2020 ELSEIF(IEV.LE.130) THEN
2022 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
2023 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
2024 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
2025 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
2026 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
2027 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
2028 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
2029 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
2030 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2032 C...Seventy events with independent fragmentation and momentum cons.
2033 ELSEIF(IEV.LE.200) THEN
2035 MSTJ(2)=1+MOD(IEV-131,4)
2036 MSTJ(3)=1+MOD((IEV-131)/4,4)
2037 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
2038 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
2039 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
2040 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2041 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
2042 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2044 C...A hundred events with random jets (check invariant mass).
2045 ELSEIF(IEV.LE.300) THEN
2052 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
2053 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
2054 EJET=5D0+20D0*PYR(0)
2055 THETA=ACOS(2D0*PYR(0)-1D0)
2057 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
2058 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
2059 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
2060 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
2062 PSUM(J)=PSUM(J)+P(I,J)
2065 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2066 & (PSUM(5)+PARJ(32))**2) GOTO 100
2068 C...Fifty e+e- continuum events with matrix elements.
2069 ELSEIF(IEV.LE.350) THEN
2073 C...Fifty e+e- continuum event with varying shower options.
2074 ELSEIF(IEV.LE.400) THEN
2075 MSTJ(42)=1+MOD(IEV,2)
2076 MSTJ(43)=1+MOD(IEV/2,4)
2077 MSTJ(44)=MOD(IEV/8,3)
2080 C...Fifty e+e- continuum events with coherent shower.
2081 ELSEIF(IEV.LE.450) THEN
2082 CALL PYEEVT(0,500D0)
2084 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2086 CALL PYONIA(5,9.46D0)
2089 C...Generate event. Find total momentum, energy and charge.
2100 C...Check conservation of energy, momentum and charge;
2101 C...usually exact, but only approximate for single jets.
2104 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2106 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2107 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2108 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2111 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2113 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2115 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2116 & (PFIN(J),J=1,4),PFIN(6)
2118 C...Check that all KF codes are known ones, and that partons/particles
2119 C...satisfy energy-momentum-mass relation. Store particle statistics.
2121 IF(K(I,1).GT.20) GOTO 170
2122 IF(PYCOMP(K(I,2)).EQ.0) THEN
2123 WRITE(MSTU(11),5100) I
2126 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2127 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2129 WRITE(MSTU(11),5200) I
2133 IF(MTEST.GE.1) CALL PYTABU(21)
2135 C...List all erroneous events and some normal ones.
2136 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2137 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2139 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2143 C...Stop execution if too many errors.
2144 IF(MERR.NE.0) NERR=NERR+1
2146 WRITE(MSTU(11),6300)
2152 C...Summarize result of run.
2153 IF(MTEST.GE.1) CALL PYTABU(22)
2155 C...Reset commonblock variables changed during run.
2172 C...Second part: complete events of various kinds.
2173 C...Common initial values. Loop over initiating conditions.
2174 MSTP(122)=MAX(0,MIN(2,MTEST))
2175 MDCY(PYCOMP(111),1)=0
2178 C...Reset process type, kinematics cuts, and the flags used.
2195 C...Prompt photon production at fixed target.
2198 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2202 CALL PYINIT('FIXT','pi+','p',PZSUM)
2204 C...QCD processes at ISR energies.
2205 ELSEIF(IPROC.EQ.2) THEN
2211 CALL PYINIT('CMS','p','p',PESUM)
2213 C...W production + multiple interactions at CERN Collider.
2214 ELSEIF(IPROC.EQ.3) THEN
2223 CALL PYINIT('CMS','p','pbar',PESUM)
2225 C...W/Z gauge boson pairs + pileup events at the Tevatron.
2226 ELSEIF(IPROC.EQ.4) THEN
2238 CALL PYINIT('CMS','p','pbar',PESUM)
2240 C...Higgs production at LHC.
2241 ELSEIF(IPROC.EQ.5) THEN
2253 CALL PYINIT('CMS','p','p',PESUM)
2255 C...Z' production at SSC.
2256 ELSEIF(IPROC.EQ.6) THEN
2265 CALL PYINIT('CMS','p','p',PESUM)
2267 C...W pair production at 1 TeV e+e- collider.
2268 ELSEIF(IPROC.EQ.7) THEN
2275 CALL PYINIT('CMS','e+','e-',PESUM)
2277 C...Deep inelastic scattering at a LEP+LHC ep collider.
2278 ELSEIF(IPROC.EQ.8) THEN
2291 CALL PYINIT('3MOM','p','e-',PESUM)
2294 C...Generate 20 events of each required type.
2298 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2300 C...Check conservation of energy/momentum/flavour.
2311 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2312 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2313 DEVQ=ABS(PFIN(6)-PINI(6))
2314 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2315 & DEVQ.GT.0.1D0) MERR=1
2316 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2317 & (PFIN(J),J=1,4),PFIN(6)
2319 C...Check that all KF codes are known ones, and that partons/particles
2320 C...satisfy energy-momentum-mass relation.
2322 IF(K(I,1).GT.20) GOTO 210
2323 IF(PYCOMP(K(I,2)).EQ.0) THEN
2324 WRITE(MSTU(11),5100) I
2327 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2329 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2330 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2331 WRITE(MSTU(11),5200) I
2336 C...Listing of erroneous events, and first event of each type.
2337 IF(MERR.GE.1) NERR=NERR+1
2339 WRITE(MSTU(11),6300)
2343 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2344 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2349 C...List statistics for each process type.
2350 IF(MTEST.GE.1) CALL PYSTAT(1)
2353 C...Summarize result of run.
2354 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2355 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2357 C...Format statements for output.
2358 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2359 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2360 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2361 &4(1X,F12.5),1X,F8.2)
2362 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2363 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2365 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2366 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2367 6400 FORMAT(5X,'Faulty event follows:')
2368 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2369 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2370 &5X,'This should not have happened!')
2375 C*********************************************************************
2378 C...Converts PYTHIA event record contents to or from
2379 C...the standard event record commonblock.
2381 SUBROUTINE PYHEPC(MCONV)
2383 C...Double precision and integer declarations.
2384 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2385 IMPLICIT INTEGER(I-N)
2386 INTEGER PYK,PYCHGE,PYCOMP
2388 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2389 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2390 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2391 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2392 C...HEPEVT commonblock.
2393 PARAMETER (NMXHEP=4000)
2394 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2395 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2396 DOUBLE PRECISION PHEP,VHEP
2399 C...Conversion from PYTHIA to standard, the easy part.
2402 IF(N.GT.NMXHEP) CALL PYERRM(8,
2403 & '(PYHEPC:) no more space in /HEPEVT/')
2407 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2408 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2409 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2410 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2414 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2428 C...Check if new event (from pileup).
2432 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2435 C...Fill in missing mother information.
2436 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2438 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0)
2445 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2448 IF(I1.GE.I) CALL PYERRM(8,
2449 & '(PYHEPC:) translation of inconsistent event history')
2450 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130
2452 IF(I1.LT.I.AND.KC.EQ.0) GOTO 130
2453 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130
2455 ELSEIF(K(I,2).EQ.94) THEN
2457 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2458 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2459 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2460 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2461 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2464 C...Fill in missing daughter information.
2465 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2466 DO 140 I1=JDAHEP(1,I),JDAHEP(2,I)
2467 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2471 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150
2473 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150
2474 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150
2475 IF(JDAHEP(1,I1).EQ.0) THEN
2482 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160
2483 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2486 C...Conversion from standard to PYTHIA, the easy part.
2488 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2489 & '(PYHEPC:) no more space in /PYJETS/')
2495 IF(ISTHEP(I).EQ.1) K(I,1)=1
2496 IF(ISTHEP(I).EQ.2) K(I,1)=11
2497 IF(ISTHEP(I).EQ.3) K(I,1)=21
2509 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2511 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2512 & PHEP(5,I)/PHEP(4,I)
2515 C...Fill in missing information on colour connection in jet systems.
2516 IF(ISTHEP(I).EQ.1) THEN
2519 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2520 IF(KQ.NE.0) NKQ=NKQ+1
2521 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2522 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2524 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2525 IF(K(I+1,2).EQ.21) K(I,1)=2
2529 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2530 & '(PYHEPC:) input parton configuration not colour singlet')
2535 C*********************************************************************
2538 C...Initializes the generation procedure; finds maxima of the
2539 C...differential cross-sections to be used for weighting.
2541 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2543 C...Double precision and integer declarations.
2544 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2545 IMPLICIT INTEGER(I-N)
2546 INTEGER PYK,PYCHGE,PYCOMP
2548 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2549 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2550 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2551 COMMON/PYDAT4/CHAF(500,2)
2553 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2554 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2555 COMMON/PYINT1/MINT(400),VINT(400)
2556 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2557 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2558 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2559 &/PYINT1/,/PYINT2/,/PYINT5/
2560 C...Local arrays and character variables.
2561 DIMENSION ALAMIN(20),NFIN(20)
2562 CHARACTER*(*) FRAME,BEAM,TARGET
2563 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2565 C...Interface to PDFLIB.
2566 COMMON/LW50512/QCDL4,QCDL5
2568 DOUBLE PRECISION VALUE(20),QCDL4,QCDL5
2569 CHARACTER*20 PARM(20)
2570 DATA VALUE/20*0D0/,PARM/20*' '/
2572 C...Data:Lambda and n_f values for parton distributions..
2573 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2574 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2576 DATA CHLH/'lepton','hadron'/
2578 C...Reset MINT and VINT arrays. Write headers.
2584 IF(MSTU(12).GE.1) CALL PYLIST(0)
2585 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2587 C...Call user process initialization routine.
2588 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2594 C...Maximum 4 generations; set maximum number of allowed flavours.
2595 MSTP(1)=MIN(4,MSTP(1))
2596 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2597 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2599 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2603 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2606 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2607 IPM=(5-ISIGN(1,I))/2
2609 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2610 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2612 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2617 C...Initialize parton distributions: PDFLIB.
2618 IF(MSTP(52).EQ.2) THEN
2622 VALUE(2)=MSTP(51)/1000
2624 VALUE(3)=MOD(MSTP(51),1000)
2627 CALL PDFSET_ALICE(PARM,VALUE)
2628 MINT(93)=1000000+MSTP(51)
2631 C...Choose Lambda value to use in alpha-strong.
2633 IF(MSTP(3).GE.2) THEN
2636 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2637 ALAM=ALAMIN(MSTP(51))
2639 ELSEIF(MSTP(52).EQ.2) THEN
2648 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2651 C...Initialize the SUSY generation: couplings, masses,
2652 C...decay modes, branching ratios, and so on.
2654 C...Initialize widths and partial widths for resonances.
2656 C...Set Z0 mass and width for e+e- routines.
2657 PARJ(123)=PMAS(23,1)
2658 PARJ(124)=PMAS(23,2)
2660 C...Identify beam and target particles and frame of process.
2664 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2665 IF(MINT(65).EQ.1) GOTO 170
2667 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2668 C...For e-gamma allow 2 alternatives.
2670 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2671 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2672 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2673 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2674 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2675 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2676 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2677 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2678 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2679 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
2680 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2681 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2682 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
2683 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
2684 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2685 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2686 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
2687 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
2690 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
2691 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
2692 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
2693 IF(MSTP(14).EQ.11) MINT(123)=0
2694 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
2695 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
2696 IF(MSTP(14).EQ.15) MINT(123)=2
2697 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
2698 IF(MSTP(14).EQ.19) MINT(123)=3
2699 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
2700 IF(MSTP(14).EQ.21) MINT(123)=0
2701 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
2702 IF(MSTP(14).EQ.24) MINT(123)=1
2703 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
2704 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
2705 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
2708 C...Set up kinematics of process.
2711 C...Set up kinematics for photons inside leptons.
2712 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
2714 C...Precalculate flavour selection weights.
2717 C...Loop over gamma-p or gamma-gamma alternatives.
2720 DO 160 IGA=1,MINT(121)
2724 C...Select partonic subprocesses to be included in the simulation.
2731 C...Count number of subprocesses on.
2734 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2735 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
2737 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2738 & MSUB(ISUB).EQ.1) THEN
2739 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2741 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2742 WRITE(MSTU(11),5300) ISUB
2744 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2745 WRITE(MSTU(11),5400) ISUB
2747 ELSEIF(MSUB(ISUB).EQ.1) THEN
2752 C...Stop or raise warning flag if no subprocesses on.
2753 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
2754 IF(MSTP(127).NE.1) THEN
2755 WRITE(MSTU(11),5500)
2758 WRITE(MSTU(11),5700)
2762 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2763 MSAV48=MSAV48+MINT(48)
2765 C...Reset variables for cross-section calculation.
2773 C...Find parametrized total cross-sections.
2777 C...Maxima of differential cross-sections.
2778 IF(MSTP(121).LE.1) CALL PYMAXI
2780 C...Initialize possibility of pileup events.
2781 IF(MINT(121).GT.1) MSTP(131)=0
2782 IF(MSTP(131).NE.0) CALL PYPILE(1)
2784 C...Initialize multiple interactions with variable impact parameter.
2785 IF(MINT(50).EQ.1) THEN
2786 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
2787 IF(MSTP(81).EQ.0.AND.CKIN(3).GT.PTMN) MSTP(82)=MIN(1,MSTP(82))
2788 IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2)
2792 C...Save results for gamma-p and gamma-gamma alternatives.
2793 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2796 C...Initialization finished.
2797 IF(MSAV48.EQ.0) THEN
2798 IF(MSTP(127).NE.1) THEN
2799 WRITE(MSTU(11),5500)
2802 WRITE(MSTU(11),5700)
2806 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2808 C...Formats for initialization information.
2809 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
2810 &'routines',1X,17('*'))
2811 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
2812 &'-',A6,' interactions.'/1X,'Execution stopped!')
2813 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
2814 &1X,'Execution stopped!')
2815 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
2816 &1X,'Execution stopped!')
2817 5500 FORMAT(1X,'Error: no subprocess switched on.'/
2818 &1X,'Execution stopped.')
2819 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
2821 5700 FORMAT(1X,'Error: no subprocess switched on.'/
2822 &1X,'Execution will stop if you try to generate events.')
2827 C*********************************************************************
2830 C...Administers the generation of a high-pT event via calls to
2831 C...a number of subroutines.
2835 C...Double precision and integer declarations.
2836 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2837 IMPLICIT INTEGER(I-N)
2838 INTEGER PYK,PYCHGE,PYCOMP
2840 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2842 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2843 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2844 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2845 COMMON/PYINT1/MINT(400),VINT(400)
2846 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2847 COMMON/PYINT4/MWID(500),WIDS(500,5)
2848 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2849 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,
2850 &/PYINT2/,/PYINT4/,/PYINT5/
2854 C...Stop if no subprocesses on.
2855 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
2856 WRITE(MSTU(11),5100)
2860 C...Initial values for some counters.
2871 C...If variable energies: redo incoming kinematics and cross-section.
2873 IF(MSTP(171).EQ.1) THEN
2875 IF(MSTI(61).EQ.1) THEN
2879 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
2883 C...Loop over number of pileup events; check space left.
2884 IF(MSTP(131).LE.0) THEN
2890 DO 250 IPILE=1,NPILE
2891 IF(MINT(84)+100.GE.MSTU(4)) THEN
2893 & '(PYEVNT:) no more space in PYJETS for pileup events')
2894 IF(MSTU(21).GE.1) GOTO 260
2898 C...Generate variables of hard scattering.
2902 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
2907 IF(MSTI(61).EQ.1) THEN
2911 IF(MINT(51).EQ.2) RETURN
2913 IF(MSTP(111).EQ.-1) GOTO 240
2915 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
2916 C...Hard scattering (including low-pT):
2917 C...reconstruct kinematics and colour flow of hard scattering.
2922 IF(MINT(51).EQ.1) GOTO 100
2925 IF(ISUB.EQ.95) GOTO 120
2927 C...Showering of initial state partons (optional).
2931 IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2)
2933 IF(MINT(51).EQ.1) GOTO 100
2935 C...Showering of final state partons (optional).
2938 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
2942 IF(ISET(ISUB).EQ.5) IPU4=-3
2944 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
2945 CALL PYSHOW(IPU3,IPU4,QMAX)
2946 ELSEIF(ISET(ISUB).EQ.11) THEN
2951 C...Decay of final state resonances.
2953 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
2954 IF(MINT(51).EQ.1) GOTO 100
2957 C...Multiple interactions.
2958 IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6)
2961 C...Hadron remnants and primordial kT.
2962 120 CALL PYREMN(IPU1,IPU2)
2963 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO 110
2964 IF(MINT(51).EQ.1) GOTO 100
2966 ELSEIF(ISUB.NE.99) THEN
2967 C...Diffractive and elastic scattering.
2971 C...DIS scattering (photon flux external).
2973 IF(MINT(51).EQ.1) GOTO 100
2976 C...Check that no odd resonance left undecayed.
2977 IF(MSTP(111).GE.1) THEN
2979 DO 130 I=MINT(84)+1,NFIX
2980 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
2981 & K(I,2).NE.22) THEN
2983 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
2985 IF(MINT(51).EQ.1) GOTO 100
2991 C...Boost hadronic subsystem to overall rest frame.
2992 C..(Only relevant when photon inside lepton beam.)
2993 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
2995 C...Recalculate energies from momenta and masses (if desired).
2996 IF(MSTP(113).GE.1) THEN
2997 DO 140 I=MINT(83)+1,N
2998 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
2999 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3004 C...Rearrange partons along strings, check invariant mass cuts.
3006 IF(MSTP(111).LE.0) MSTJ(14)=-1
3007 CALL PYPREP(MINT(84)+1)
3009 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3010 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3011 DO 170 I=MINT(84)+1,N
3012 IF(K(I,2).EQ.94) THEN
3013 DO 160 I1=I+1,MIN(N,I+10)
3014 IF(K(I1,3).EQ.I) THEN
3015 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3016 IF(K(I1,3).EQ.0) THEN
3017 DO 150 II=MINT(84)+1,I-1
3018 IF(K(II,2).EQ.K(I1,2)) THEN
3019 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3020 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3023 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3031 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3032 IF(MSTP(125).EQ.0) MINT(4)=0
3033 DO 190 I=MINT(83)+1,N
3034 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3036 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3037 IF(K(I1,3).EQ.I) K(I,5)=I1
3043 C...Introduce separators between sections in PYLIST event listing.
3044 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3047 ELSEIF(IPILE.EQ.1) THEN
3054 C...Go back to lab frame (needed for vertices, also in fragmentation).
3057 C...Set nonvanishing production vertex (optional).
3058 IF(MSTP(151).EQ.1) THEN
3060 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3061 & SIN(PARU(2)*PYR(0))
3063 DO 220 I=MINT(83)+1,N
3065 V(I,J)=V(I,J)+VTX(J)
3070 C...Perform hadronization (if desired).
3071 IF(MSTP(111).GE.1) THEN
3073 IF(MSTU(24).NE.0) GOTO 100
3075 IF(MSTP(113).GE.1) THEN
3077 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3078 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3081 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3083 C...Store event information and calculate Monte Carlo estimates of
3084 C...subprocess cross-sections.
3085 240 IF(IPILE.EQ.1) CALL PYDOCU
3087 C...Set counters for current pileup event and loop to next one.
3089 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3090 IF(MSTU70.LT.10) THEN
3095 MINT(84)=N+MSTP(126)
3096 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3099 C...Generic information on pileup events. Reconstruct missing history.
3100 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3104 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3108 C...Transform to the desired coordinate frame.
3109 260 CALL PYFRAM(MSTP(124))
3114 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3115 &1X,'Execution stopped.')
3120 C***********************************************************************
3123 C...Prints out information about cross-sections, decay widths, branching
3124 C...ratios, kinematical limits, status codes and parameter values.
3126 SUBROUTINE PYSTAT(MSTAT)
3128 C...Double precision and integer declarations.
3129 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3130 IMPLICIT INTEGER(I-N)
3131 INTEGER PYK,PYCHGE,PYCOMP
3132 C...Parameter statement to help give large particle numbers.
3133 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3134 &KEXCIT=4000000,KDIMEN=5000000)
3135 PARAMETER (EPS=1D-3)
3137 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3138 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3139 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3140 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3141 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3142 COMMON/PYINT1/MINT(400),VINT(400)
3143 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3144 COMMON/PYINT4/MWID(500),WIDS(500,5)
3145 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3146 COMMON/PYINT6/PROC(0:500)
3147 CHARACTER PROC*28, CHTMP*16
3148 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3149 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
3150 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
3151 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
3152 C...Local arrays, character variables and data.
3153 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
3154 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
3155 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
3156 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
3157 CHARACTER*24 CHD0, CHDC(10)
3158 CHARACTER*6 DNAME(3)
3160 &'VMD/hadron * VMD ','VMD/hadron * direct ',
3161 &'VMD/hadron * anomalous ','direct * direct ',
3162 &'direct * anomalous ','anomalous * anomalous '/
3163 DATA DISGA/'e * VMD','e * anomalous'/
3165 &'direct * direct ','direct * VMD ',
3166 &'direct * anomalous ','VMD * direct ',
3167 &'VMD * VMD ','VMD * anomalous ',
3168 &'anomalous * direct ','anomalous * VMD ',
3169 &'anomalous * anomalous ','DIS * VMD ',
3170 &'DIS * anomalous ','VMD * DIS ',
3171 &'anomalous * DIS '/
3173 &'direct * direct ','direct * resolved ',
3174 &'resolved * direct ','resolved * resolved '/
3176 &'direct * hadron ','resolved * hadron '/
3178 &'VMD * hadron ','direct * hadron ',
3179 &'anomalous * hadron ','DIS * hadron '/
3180 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
3181 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
3182 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
3183 &' y*_small ',' eta*_large ',' eta*_small ',
3184 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
3185 &' x_2 ',' x_F ',' cos(theta_hard) ',
3186 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
3187 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
3189 DATA DNAME /'q ','lepton','nu '/
3193 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
3194 WRITE(MSTU(11),5000)
3195 WRITE(MSTU(11),5100)
3196 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
3198 IF(MSUB(I).NE.1) GOTO 100
3199 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
3201 IF(MINT(121).GT.1) THEN
3202 WRITE(MSTU(11),5300)
3203 DO 110 IGA=1,MINT(121)
3205 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3206 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
3208 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3209 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
3211 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
3212 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
3214 ELSEIF(MINT(121).EQ.4) THEN
3215 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
3217 ELSEIF(MINT(121).EQ.2) THEN
3218 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
3221 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
3227 WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
3228 & MAX(1D0,DBLE(NGEN(0,2)))
3230 C...Decay widths and branching ratios.
3231 ELSEIF(MSTAT.EQ.2) THEN
3232 WRITE(MSTU(11),5500)
3233 WRITE(MSTU(11),5600)
3236 CALL PYNAME(KF,CHKF)
3239 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
3240 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
3241 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
3242 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
3243 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
3245 IF(MWID(KC).LE.0) GOTO 140
3246 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
3247 & KF/KSUSY1.EQ.2)) GOTO 140
3249 C...Off-shell branchings.
3252 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
3253 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
3254 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
3255 DO 120 J=1,MDCY(KC,3)
3258 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3259 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3261 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3262 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3263 CALL PYNAME(KFDP(IDC,1),CHD1)
3264 CALL PYNAME(KFDP(IDC,2),CHD2)
3265 IF(KFDP(IDC,3).EQ.0) THEN
3266 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3267 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3268 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3270 CALL PYNAME(KFDP(IDC,3),CHD3)
3271 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3272 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3273 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3276 C...On-shell decays.
3278 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
3280 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
3281 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
3282 & STATE(MDCY(KC,1)),BRFIN
3283 DO 130 J=1,MDCY(KC,3)
3286 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3287 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3289 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3290 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3292 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
3293 CALL PYNAME(KFDP(IDC,1),CHD1)
3294 CALL PYNAME(KFDP(IDC,2),CHD2)
3295 IF(KFDP(IDC,3).EQ.0) THEN
3296 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3297 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3298 & CHD2(1:10),WDTP(J),WDTP(J)/WDTP(0),
3299 & STATE(MDME(IDC,1)),BRFIN
3301 CALL PYNAME(KFDP(IDC,3),CHD3)
3302 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3303 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3304 & CHD2(1:10),CHD3(1:10),WDTP(J),WDTP(J)/WDTP(0),
3305 & STATE(MDME(IDC,1)),BRFIN
3310 WRITE(MSTU(11),6000)
3312 C...Allowed incoming partons/particles at hard interaction.
3313 ELSEIF(MSTAT.EQ.3) THEN
3314 WRITE(MSTU(11),6100)
3315 CALL PYNAME(MINT(11),CHAU)
3317 CALL PYNAME(MINT(12),CHAU)
3319 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
3323 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
3324 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
3326 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
3329 WRITE(MSTU(11),6400)
3331 C...User-defined limits on kinematical variables.
3332 ELSEIF(MSTAT.EQ.4) THEN
3333 WRITE(MSTU(11),6500)
3334 WRITE(MSTU(11),6600)
3336 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
3337 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
3338 PTHMIN=MAX(CKIN(3),CKIN(5))
3340 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
3341 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
3342 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
3344 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
3347 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
3348 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
3349 WRITE(MSTU(11),7000)
3351 C...Status codes and parameter values.
3352 ELSEIF(MSTAT.EQ.5) THEN
3353 WRITE(MSTU(11),7100)
3354 WRITE(MSTU(11),7200)
3356 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
3360 C...List of all processes implemented in the program.
3361 ELSEIF(MSTAT.EQ.6) THEN
3362 WRITE(MSTU(11),7400)
3363 WRITE(MSTU(11),7500)
3365 IF(ISET(I).LT.0) GOTO 180
3366 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
3368 WRITE(MSTU(11),7700)
3370 ELSEIF(MSTAT.EQ.7) THEN
3371 WRITE (MSTU(11),8000)
3377 KFSUSY=ILR*KSUSY1+KFSM
3380 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
3386 CALL PYNAME(KFSUSY,CHTMP)
3388 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
3389 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
3390 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
3392 DO 200 J=1,MDCY(KC,3)
3394 ID1=IABS(KFDP(IDC,1))
3395 ID2=IABS(KFDP(IDC,2))
3396 IF (KFDP(IDC,3).EQ.0) THEN
3397 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3398 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3399 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3400 NMODES(1)=NMODES(1)+1
3401 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3402 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3403 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3404 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
3405 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3406 NMODES(2)=NMODES(2)+1
3407 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3408 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3409 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3410 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3411 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3412 NMODES(3)=NMODES(3)+1
3413 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3414 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3420 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
3426 CALL PYNAME(KFSUSY,CHTMP)
3428 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
3429 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3431 DO 220 J=1,MDCY(KC,3)
3433 ID1=IABS(KFDP(IDC,1))
3434 ID2=IABS(KFDP(IDC,2))
3435 IF (KFDP(IDC,3).EQ.0) THEN
3436 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
3437 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3438 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3439 NMODES(1)=NMODES(1)+1
3440 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3441 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3442 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
3443 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3444 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3445 NMODES(2)=NMODES(2)+1
3446 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3447 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3453 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
3459 CALL PYNAME(KFSUSY,CHTMP)
3461 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
3462 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3464 DO 240 J=1,MDCY(KC,3)
3466 ID1=IABS(KFDP(IDC,1))
3467 ID2=IABS(KFDP(IDC,2))
3468 IF (KFDP(IDC,3).EQ.0) THEN
3469 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3470 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
3471 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3472 NMODES(1)=NMODES(1)+1
3473 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3474 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3476 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
3477 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3478 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3479 NMODES(2)=NMODES(2)+1
3480 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3481 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3486 C...SNEUTRINO DECAYS
3487 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
3494 CALL PYNAME(KFSUSY,CHTMP)
3496 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
3497 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3499 DO 260 J=1,MDCY(KC,3)
3501 ID1=IABS(KFDP(IDC,1))
3502 ID2=IABS(KFDP(IDC,2))
3503 IF (KFDP(IDC,3).EQ.0) THEN
3504 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
3505 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
3506 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3507 NMODES(1)=NMODES(1)+1
3508 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3509 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3511 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
3512 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3513 NMODES(2)=NMODES(2)+1
3514 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3515 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3516 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3521 IF (NRVDC.NE.0) THEN
3523 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
3524 NMODES(0)=NMODES(0)+NMODES(I)
3532 C...NEUTRALINO DECAYS
3533 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
3539 CALL PYNAME(KFSUSY,CHTMP)
3541 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
3542 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3543 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3544 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3546 DO 310 J=1,MDCY(KC,3)
3548 ID1=IABS(KFDP(IDC,1))
3549 ID2=IABS(KFDP(IDC,2))
3550 ID3=IABS(KFDP(IDC,3))
3551 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3552 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
3553 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
3554 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3555 NMODES(1)=NMODES(1)+1
3556 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3557 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3558 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3559 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
3560 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3561 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3562 NMODES(2)=NMODES(2)+1
3563 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3564 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3565 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3566 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
3567 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3568 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3569 NMODES(3)=NMODES(3)+1
3570 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3571 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3572 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3573 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
3574 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3575 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3576 NMODES(4)=NMODES(4)+1
3577 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3578 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3583 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
3589 CALL PYNAME(KFSUSY,CHTMP)
3591 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
3592 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
3593 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3594 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3595 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3597 DO 330 J=1,MDCY(KC,3)
3599 ID1=IABS(KFDP(IDC,1))
3600 ID2=IABS(KFDP(IDC,2))
3601 ID3=IABS(KFDP(IDC,3))
3602 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3603 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
3604 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
3605 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3606 NMODES(1)=NMODES(1)+1
3607 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3608 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3609 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3610 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
3611 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
3612 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3613 NMODES(1)=NMODES(1)+1
3614 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3615 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3616 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3617 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
3618 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
3619 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3620 NMODES(2)=NMODES(2)+1
3621 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3622 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3623 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3624 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3625 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
3626 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3627 NMODES(3)=NMODES(3)+1
3628 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3629 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3630 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3631 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3632 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3633 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3634 NMODES(3)=NMODES(3)+1
3635 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3636 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3637 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3638 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3639 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
3640 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3641 NMODES(4)=NMODES(4)+1
3642 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3643 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3644 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3645 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3646 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3647 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3648 NMODES(4)=NMODES(4)+1
3649 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3650 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3651 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3652 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3653 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3654 PBRAT(5)=PBRAT(5)+BRAT(IDC)
3655 NMODES(5)=NMODES(5)+1
3656 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3657 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3658 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
3659 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3660 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3661 PBRAT(5)=PBRAT(5)+BRAT(IDC)
3662 NMODES(5)=NMODES(5)+1
3663 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3664 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3669 IF (KFSM.EQ.21) THEN
3675 CALL PYNAME(KFSUSY,CHTMP)
3677 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3678 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3679 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3681 DO 350 J=1,MDCY(KC,3)
3683 ID1=IABS(KFDP(IDC,1))
3684 ID2=IABS(KFDP(IDC,2))
3685 ID3=IABS(KFDP(IDC,3))
3686 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3687 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
3688 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
3689 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3690 NMODES(1)=NMODES(1)+1
3691 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3692 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3693 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3694 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
3695 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3696 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3697 NMODES(2)=NMODES(2)+1
3698 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3699 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3700 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3701 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
3702 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3703 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3704 NMODES(3)=NMODES(3)+1
3705 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3706 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3711 IF (NRVDC.NE.0) THEN
3713 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
3714 NMODES(0)=NMODES(0)+NMODES(I)
3718 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
3720 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
3721 WRITE (MSTU(11),8500)
3725 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
3726 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
3730 WRITE (MSTU(11),8600)
3734 C...Formats for printouts.
3735 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
3736 &'Events and Cross-sections',1X,9('*'))
3737 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
3738 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
3739 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
3740 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
3741 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
3742 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
3744 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
3746 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
3747 &1X,'I',34X,'I',28X,'I',12X,'I')
3748 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
3749 &1X,'********* Fraction of events that fail fragmentation ',
3750 &'cuts =',1X,F8.5,' *********'/)
3751 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
3752 &'Ratios',1X,27('*'))
3753 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3754 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
3755 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
3756 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3758 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
3759 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
3760 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
3761 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
3762 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3763 &1P,D10.3,0P,1X,'I')
3764 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
3765 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3766 &1P,D10.3,0P,1X,'I')
3767 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
3768 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
3769 &'Particles at Hard Interaction',1X,7('*'))
3770 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
3771 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
3772 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
3773 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
3774 &78('=')/1X,'I',38X,'I',37X,'I')
3775 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
3776 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
3777 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
3778 &'Kinematical Variables',1X,12('*'))
3779 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
3780 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
3782 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
3783 &1X,'<',1X,1P,D10.3,0P,16X,'I')
3784 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
3785 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
3786 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
3787 &'Parameter Values',1X,12('*'))
3788 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
3790 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
3791 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
3793 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
3794 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
3795 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
3796 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
3797 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
3799 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
3800 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
3801 & ,'Mother --> Sum over final state flavours',4X,'I',2X
3802 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
3803 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
3804 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
3805 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
3806 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
3807 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
3809 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
3810 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
3811 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
3813 & 1X,'R-Violating couplings',1X/ 1X /
3815 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
3816 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
3817 & ,'I',15X,'I',15X,'I',15X,'I')
3818 8600 FORMAT(1X,55('='))
3819 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
3820 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
3825 C*********************************************************************
3828 C...Calculates full and effective widths of gauge bosons, stores
3829 C...masses and widths, rescales coefficients to be used for
3830 C...resonance production generation.
3834 C...Double precision and integer declarations.
3835 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3836 IMPLICIT INTEGER(I-N)
3837 INTEGER PYK,PYCHGE,PYCOMP
3838 C...Parameter statement to help give large particle numbers.
3839 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3840 &KEXCIT=4000000,KDIMEN=5000000)
3842 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3843 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3844 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3845 COMMON/PYDAT4/CHAF(500,2)
3847 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3848 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3849 COMMON/PYINT1/MINT(400),VINT(400)
3850 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3851 COMMON/PYINT4/MWID(500),WIDS(500,5)
3852 COMMON/PYINT6/PROC(0:500)
3854 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3855 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
3856 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
3857 C...Local arrays and data.
3858 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
3859 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
3861 C...Born level couplings in MSSM Higgs doublet sector.
3864 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
3866 IF(MSTP(4).EQ.2) THEN
3868 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
3872 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
3873 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
3875 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
3876 WRITE(MSTU(11),5000)
3879 PMAS(35,1)=SQRT(SQMHP)
3880 PMAS(36,1)=SQRT(SQMA)
3881 PMAS(37,1)=SQRT(SQMHC)
3882 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
3887 PARU(161)=-SIN(ALSU)/COS(BESU)
3888 PARU(162)=COS(ALSU)/SIN(BESU)
3890 PARU(164)=SIN(BESU-ALSU)
3892 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
3893 PARU(171)=COS(ALSU)/COS(BESU)
3894 PARU(172)=SIN(ALSU)/SIN(BESU)
3896 PARU(174)=COS(BESU-ALSU)
3898 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
3900 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
3901 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
3907 PARU(186)=COS(BESU-ALSU)
3908 PARU(187)=SIN(BESU-ALSU)
3912 PARU(195)=COS(BESU-ALSU)
3915 C...Reset effective widths of gauge bosons.
3922 C...Order resonances by increasing mass (except Z0 and W+/-).
3926 IF(KF.EQ.0) GOTO 140
3927 IF(MWID(KC).EQ.0) GOTO 140
3928 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
3929 IF(MSTP(1).LE.3) GOTO 140
3931 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
3932 IF(IMSS(1).LE.0) GOTO 140
3936 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
3937 DO 120 I1=NRES-1,1,-1
3938 IF(PMRES.GE.PMORD(I1)) GOTO 130
3939 KCORD(I1+1)=KCORD(I1)
3940 PMORD(I1+1)=PMORD(I1)
3946 C...Loop over possible resonances.
3951 C...Check that no fourth generation channels on by mistake.
3952 IF(MSTP(1).LE.3) THEN
3953 DO 150 J=1,MDCY(KC,3)
3955 KFA1=IABS(KFDP(IDC,1))
3956 KFA2=IABS(KFDP(IDC,2))
3957 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
3958 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
3963 C...Check that no supersymmetric channels on by mistake.
3964 IF(IMSS(1).LE.0) THEN
3965 DO 160 J=1,MDCY(KC,3)
3967 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
3968 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
3969 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
3974 C...Find mass and evaluate width.
3976 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
3977 IF(MWID(KC).EQ.3) MINT(63)=1
3978 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
3981 C...Evaluate suppression factors due to non-simulated channels.
3983 C...Protection against division by 0 since rho_21_tc is causing problem here
3984 IF (WDTP(0) .GT. 0.) THEN
3986 IF(KCHG(KC,3).EQ.0) THEN
3987 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
3988 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3989 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3990 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3995 IF(MWID(KC).EQ.3) MINT(63)=1
3996 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
3998 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
3999 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
4000 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
4001 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
4002 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
4003 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
4004 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
4005 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
4006 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
4007 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
4008 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
4009 & 2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
4013 C...Set resonance widths and branching ratios;
4014 C...also on/off switch for decays.
4015 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
4017 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
4018 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
4019 DO 170 J=1,MDCY(KC,3)
4022 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
4027 C...Flavours of leptoquark: redefine charge and name.
4028 KFLQQ=KFDP(MDCY(42,2),1)
4029 KFLQL=KFDP(MDCY(42,2),2)
4030 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
4031 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
4033 IF(IABS(KFLQL).EQ.13) LL=2
4034 IF(IABS(KFLQL).EQ.15) LL=3
4035 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
4036 &CHAF(IABS(KFLQL),1)(1:LL)//' '
4037 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
4039 C...Special cases in treatment of gamma*/Z0: redefine process name.
4040 IF(MSTP(43).EQ.1) THEN
4041 PROC(1)='f + fbar -> gamma*'
4042 PROC(15)='f + fbar -> g + gamma*'
4043 PROC(19)='f + fbar -> gamma + gamma*'
4044 PROC(30)='f + g -> f + gamma*'
4045 PROC(35)='f + gamma -> f + gamma*'
4046 ELSEIF(MSTP(43).EQ.2) THEN
4047 PROC(1)='f + fbar -> Z0'
4048 PROC(15)='f + fbar -> g + Z0'
4049 PROC(19)='f + fbar -> gamma + Z0'
4050 PROC(30)='f + g -> f + Z0'
4051 PROC(35)='f + gamma -> f + Z0'
4052 ELSEIF(MSTP(43).EQ.3) THEN
4053 PROC(1)='f + fbar -> gamma*/Z0'
4054 PROC(15)='f + fbar -> g + gamma*/Z0'
4055 PROC(19)='f + fbar -> gamma + gamma*/Z0'
4056 PROC(30)='f + g -> f + gamma*/Z0'
4057 PROC(35)='f + gamma -> f + gamma*/Z0'
4060 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
4061 IF(MSTP(44).EQ.1) THEN
4062 PROC(141)='f + fbar -> gamma*'
4063 ELSEIF(MSTP(44).EQ.2) THEN
4064 PROC(141)='f + fbar -> Z0'
4065 ELSEIF(MSTP(44).EQ.3) THEN
4066 PROC(141)='f + fbar -> Z''0'
4067 ELSEIF(MSTP(44).EQ.4) THEN
4068 PROC(141)='f + fbar -> gamma*/Z0'
4069 ELSEIF(MSTP(44).EQ.5) THEN
4070 PROC(141)='f + fbar -> gamma*/Z''0'
4071 ELSEIF(MSTP(44).EQ.6) THEN
4072 PROC(141)='f + fbar -> Z0/Z''0'
4073 ELSEIF(MSTP(44).EQ.7) THEN
4074 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
4077 C...Special cases in treatment of WW -> WW: redefine process name.
4078 IF(MSTP(45).EQ.1) THEN
4079 PROC(77)='W+ + W+ -> W+ + W+'
4080 ELSEIF(MSTP(45).EQ.2) THEN
4081 PROC(77)='W+ + W- -> W+ + W-'
4082 ELSEIF(MSTP(45).EQ.3) THEN
4083 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
4086 C...Format for error information.
4087 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
4088 &'combination'/1X,'Execution stopped!')
4093 C*********************************************************************
4096 C...Identifies the two incoming particles and the choice of frame.
4098 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
4100 C...Double precision and integer declarations.
4101 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4102 IMPLICIT INTEGER(I-N)
4103 INTEGER PYK,PYCHGE,PYCOMP
4105 C...User process initialization commonblock.
4107 PARAMETER (MAXPUP=100)
4108 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4109 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4110 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4111 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4116 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4117 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4118 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4119 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4120 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4121 COMMON/PYINT1/MINT(400),VINT(400)
4122 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
4124 C...Local arrays, character variables and data.
4125 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
4126 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
4127 DIMENSION LEN(3),KCDE(39),PM(2)
4128 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
4129 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
4130 DATA CHCDE/ 'e- ','e+ ','nu_e ',
4131 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
4132 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
4133 &'nu_taubar ','pi+ ','pi- ','n0 ',
4134 &'nbar0 ','p+ ','pbar- ','gamma ',
4135 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
4136 &'xi- ','xi0 ','omega- ','pi0 ',
4137 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
4138 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
4139 &'k+ ','k- ','ks0 ','kl0 '/
4140 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
4141 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
4142 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
4144 C...Store initial energy. Default frame.
4148 C...Special user process initialization; convert to normal input.
4149 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
4151 CALL PYNAME(IDBMUP(1),CHNAME)
4153 CALL PYNAME(IDBMUP(2),CHNAME)
4157 C...Convert character variables to lowercase and find their length.
4164 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
4166 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
4172 C...Fix up bar, underscore and charge in particle name (if needed).
4174 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
4176 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
4179 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
4181 CHIDNT(I)='nu_'//CHTEMP(3:7)
4182 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
4183 CHIDNT(I)(1:3)='n0 '
4184 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
4185 CHIDNT(I)(1:5)='nbar0'
4186 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
4187 CHIDNT(I)(1:3)='p+ '
4188 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
4189 & CHIDNT(I)(1:2).EQ.'p-') THEN
4190 CHIDNT(I)(1:5)='pbar-'
4191 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
4193 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
4194 CHIDNT(I)(1:7)='reggeon'
4195 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
4196 CHIDNT(I)(1:7)='pomeron'
4200 C...Identify free initialization.
4201 IF(CHCOM(1)(1:2).EQ.'no') THEN
4206 C...Identify incoming beam and target particles.
4209 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
4211 PM(I)=PYMASS(MINT(10+I))
4214 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
4215 CHTEMP=CHIDNT(I+1)(7:12)//' '
4217 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
4219 PM(I)=PYMASS(MINT(140+I))
4223 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
4224 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
4225 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
4227 C...Identify choice of frame and input energies.
4230 C...Events defined in the CM frame.
4231 IF(CHCOM(1)(1:2).EQ.'cm') THEN
4234 IF(MSTP(122).GE.1) THEN
4235 IF(CHCOM(2)(1:1).NE.'e') THEN
4236 LOFFS=(31-(LEN(2)+LEN(3)))/2
4237 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
4238 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4241 LOFFS=(30-(LEN(2)+LEN(3)))/2
4242 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
4243 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4246 WRITE(MSTU(11),5200) CHINIT
4247 WRITE(MSTU(11),5300) WIN
4250 C...Events defined in fixed target frame.
4251 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
4253 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
4254 IF(MSTP(122).GE.1) THEN
4255 LOFFS=(29-(LEN(2)+LEN(3)))/2
4256 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4257 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4258 & ' fixed target'//' '
4259 WRITE(MSTU(11),5200) CHINIT
4260 WRITE(MSTU(11),5400) WIN
4261 WRITE(MSTU(11),5500) SQRT(S)
4264 C...Frame defined by user three-vectors.
4265 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
4269 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4270 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4271 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4272 & (P(1,3)+P(2,3))**2
4273 IF(MSTP(122).GE.1) THEN
4274 LOFFS=(22-(LEN(2)+LEN(3)))/2
4275 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4276 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4277 & ' user configuration'//' '
4278 WRITE(MSTU(11),5200) CHINIT
4279 WRITE(MSTU(11),5600)
4280 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4281 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4282 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4285 C...Frame defined by user four-vectors.
4286 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
4288 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4289 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4290 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4291 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4292 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4293 & (P(1,3)+P(2,3))**2
4294 IF(MSTP(122).GE.1) THEN
4295 LOFFS=(22-(LEN(2)+LEN(3)))/2
4296 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4297 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4298 & ' user configuration'//' '
4299 WRITE(MSTU(11),5200) CHINIT
4300 WRITE(MSTU(11),5600)
4301 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4302 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4303 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4306 C...Frame defined by user five-vectors.
4307 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
4309 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4310 & (P(1,3)+P(2,3))**2
4311 IF(MSTP(122).GE.1) THEN
4312 LOFFS=(22-(LEN(2)+LEN(3)))/2
4313 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4314 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4315 & ' user configuration'//' '
4316 WRITE(MSTU(11),5200) CHINIT
4317 WRITE(MSTU(11),5600)
4318 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4319 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4320 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4323 C...Frame defined by HEPRUP common block.
4324 ELSEIF(MINT(111).EQ.11) THEN
4325 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
4326 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
4327 IF(MSTP(122).GE.1) THEN
4328 LOFFS=(22-(LEN(2)+LEN(3)))/2
4329 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4330 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4331 & ' user configuration'//' '
4332 WRITE(MSTU(11),5200) CHINIT
4333 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
4334 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4337 C...Unknown frame. Error for too low CM energy.
4339 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
4342 IF(S.LT.PARP(2)**2) THEN
4343 WRITE(MSTU(11),5900) SQRT(S)
4347 C...Formats for initialization and error information.
4348 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
4349 &1X,'Execution stopped!')
4350 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
4351 &1X,'Execution stopped!')
4352 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
4353 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
4354 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
4355 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
4356 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
4357 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
4358 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
4359 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
4360 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
4361 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
4362 &1X,'Execution stopped!')
4363 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
4364 &'generation.'/1X,'Execution stopped!')
4365 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
4366 &'GeV beam energies',13X,'I')
4371 C*********************************************************************
4374 C...Sets up kinematics, including rotations and boosts to/from CM frame.
4376 SUBROUTINE PYINKI(MODKI)
4378 C...Double precision and integer declarations.
4379 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4380 IMPLICIT INTEGER(I-N)
4381 INTEGER PYK,PYCHGE,PYCOMP
4383 C...User process initialization commonblock.
4385 PARAMETER (MAXPUP=100)
4386 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4387 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4388 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4389 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4394 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4395 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4396 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4397 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4398 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4399 COMMON/PYINT1/MINT(400),VINT(400)
4400 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
4402 C...Set initial flavour state.
4407 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
4410 C...Reset boost. Do kinematics for various cases.
4415 C...Set up kinematics for events defined in CM frame.
4416 IF(MINT(111).EQ.1) THEN
4418 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4422 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4423 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4428 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
4431 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4432 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
4434 C...Set up kinematics for fixed target events.
4435 ELSEIF(MINT(111).EQ.2) THEN
4437 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4440 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4441 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4447 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4450 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
4451 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
4452 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4454 C...Set up kinematics for events in user-defined frame.
4455 ELSEIF(MINT(111).EQ.3) THEN
4458 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4459 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4460 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4461 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4463 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4465 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4466 VINT(7)=PYANGL(P(1,1),P(1,2))
4467 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4468 VINT(6)=PYANGL(P(1,3),P(1,1))
4469 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4470 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
4472 C...Set up kinematics for events with user-defined four-vectors.
4473 ELSEIF(MINT(111).EQ.4) THEN
4474 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4475 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4476 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4477 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4479 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4481 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4482 VINT(7)=PYANGL(P(1,1),P(1,2))
4483 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4484 VINT(6)=PYANGL(P(1,3),P(1,1))
4485 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4486 S=(P(1,4)+P(2,4))**2
4488 C...Set up kinematics for events with user-defined five-vectors.
4489 ELSEIF(MINT(111).EQ.5) THEN
4491 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4493 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4494 VINT(7)=PYANGL(P(1,1),P(1,2))
4495 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4496 VINT(6)=PYANGL(P(1,3),P(1,1))
4497 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4498 S=(P(1,4)+P(2,4))**2
4500 C...Set up kinematics for events with external user processes.
4501 ELSEIF(MINT(111).EQ.11) THEN
4504 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4505 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4510 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
4511 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
4514 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
4515 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4516 S=(P(1,4)+P(2,4))**2
4519 C...Return or error for too low CM energy.
4520 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
4521 IF(MSTP(172).LE.1) THEN
4523 & '(PYINKI:) too low invariant mass in this event')
4530 C...Save information on incoming particles.
4533 IF(MINT(111).GE.4) THEN
4534 IF(MINT(141).EQ.0) THEN
4536 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
4540 IF(MINT(142).EQ.0) THEN
4542 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
4548 IF(MODKI.EQ.0) VINT(289)=S
4556 C...Store pT cut-off and related constants to be used in generation.
4557 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
4558 IF(MSTP(82).LE.1) THEN
4559 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4561 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4563 VINT(149)=4D0*PTMN**2/S
4569 C*********************************************************************
4572 C...Selects partonic subprocesses to be included in the simulation.
4576 C...Double precision and integer declarations.
4577 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4578 IMPLICIT INTEGER(I-N)
4579 INTEGER PYK,PYCHGE,PYCOMP
4581 C...User process initialization commonblock.
4583 PARAMETER (MAXPUP=100)
4584 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4585 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4586 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4587 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4591 C...Commonblocks and character variables.
4592 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4593 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4594 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4595 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4596 COMMON/PYINT1/MINT(400),VINT(400)
4597 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4598 COMMON/PYINT6/PROC(0:500)
4600 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
4604 C...Reset processes to be included.
4611 C...Set running pTmin scale.
4612 IF(MSTP(82).LE.1) THEN
4613 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4615 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4618 C...Begin by assuming incoming photon to enter subprocess.
4619 IF(MINT(11).EQ.22) MINT(15)=22
4620 IF(MINT(12).EQ.22) MINT(16)=22
4622 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
4623 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4625 MINT(123)=MINT(122)+1
4627 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
4629 C...Here also set a few parameters otherwise normally not touched.
4630 ELSEIF(MINT(121).GT.1) THEN
4632 C...Parton distributions dampened at small Q2; go to low energies,
4633 C...alpha_s <1; no minimum pT cut-off a priori.
4634 IF(MSTP(18).EQ.2) THEN
4642 C...Define pT cut-off parameters and whether run involves low-pT.
4646 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
4648 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
4649 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
4651 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
4652 IF(MSEL.EQ.2) IPTL=1
4654 C...Set up for p/gamma * gamma; real or virtual photons.
4655 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
4656 & MSTP(14).EQ.30)) THEN
4658 C...Set up for p/VMD * VMD.
4659 IF(MINT(122).EQ.1) THEN
4667 IF(IPTL.EQ.1) MSUB(95)=1
4674 IF(IPTL.EQ.1) CKIN(3)=0D0
4676 C...Set up for p/VMD * direct gamma.
4677 ELSEIF(MINT(122).EQ.2) THEN
4679 IF(MINT(121).EQ.6) MINT(123)=5
4684 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4686 C...Set up for p/VMD * anomalous gamma.
4687 ELSEIF(MINT(122).EQ.3) THEN
4689 IF(MINT(121).EQ.6) MINT(123)=7
4696 IF(IPTL.EQ.1) MSUB(95)=1
4703 IF(IPTL.EQ.1) CKIN(3)=0D0
4705 C...Set up for DIS * p.
4706 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
4707 & IABS(MINT(12)).GT.100)) THEN
4709 IF(IPTL.EQ.1) MSUB(99)=1
4711 C...Set up for direct * direct gamma (switch off leptons).
4712 ELSEIF(MINT(122).EQ.4) THEN
4718 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4719 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4721 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4723 C...Set up for direct * anomalous gamma.
4724 ELSEIF(MINT(122).EQ.5) THEN
4730 IF(IPTL.EQ.1) CKIN(3)=PTMANO
4732 C...Set up for anomalous * anomalous gamma.
4733 ELSEIF(MINT(122).EQ.6) THEN
4741 IF(IPTL.EQ.1) MSUB(95)=1
4748 IF(IPTL.EQ.1) CKIN(3)=0D0
4751 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
4752 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4754 C...Set up for direct * direct gamma (switch off leptons).
4755 IF(MINT(122).EQ.1) THEN
4761 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4762 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4764 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4766 C...Set up for direct * VMD and VMD * direct gamma.
4767 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
4773 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4775 C...Set up for direct * anomalous and anomalous * direct gamma.
4776 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
4782 IF(IPTL.EQ.1) CKIN(3)=PTMANO
4784 C...Set up for VMD*VMD.
4785 ELSEIF(MINT(122).EQ.5) THEN
4793 IF(IPTL.EQ.1) MSUB(95)=1
4800 IF(IPTL.EQ.1) CKIN(3)=0D0
4802 C...Set up for VMD * anomalous and anomalous * VMD gamma.
4803 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
4811 IF(IPTL.EQ.1) MSUB(95)=1
4818 IF(IPTL.EQ.1) CKIN(3)=0D0
4820 C...Set up for anomalous * anomalous gamma.
4821 ELSEIF(MINT(122).EQ.9) THEN
4829 IF(IPTL.EQ.1) MSUB(95)=1
4836 IF(IPTL.EQ.1) CKIN(3)=0D0
4838 C...Set up for DIS * VMD and VMD * DIS gamma.
4839 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
4841 IF(IPTL.EQ.1) MSUB(99)=1
4843 C...Set up for DIS * anomalous and anomalous * DIS gamma.
4844 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
4846 IF(IPTL.EQ.1) MSUB(99)=1
4849 C...Set up for gamma* * p; virtual photons = dir, res.
4850 ELSEIF(MINT(121).EQ.2) THEN
4852 C...Set up for direct * p.
4853 IF(MINT(122).EQ.1) THEN
4859 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4861 C...Set up for resolved * p.
4862 ELSEIF(MINT(122).EQ.2) THEN
4870 IF(IPTL.EQ.1) MSUB(95)=1
4877 IF(IPTL.EQ.1) CKIN(3)=0D0
4880 C...Set up for gamma* * gamma*; virtual photons = dir, res.
4881 ELSEIF(MINT(121).EQ.4) THEN
4883 C...Set up for direct * direct gamma (switch off leptons).
4884 IF(MINT(122).EQ.1) THEN
4890 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4891 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4893 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4895 C...Set up for direct * resolved and resolved * direct gamma.
4896 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
4902 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4904 C...Set up for resolved * resolved gamma.
4905 ELSEIF(MINT(122).EQ.4) THEN
4913 IF(IPTL.EQ.1) MSUB(95)=1
4920 IF(IPTL.EQ.1) CKIN(3)=0D0
4923 C...End of special set up for gamma-p and gamma-gamma.
4928 C...Flavour information for individual beams.
4931 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
4932 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
4933 MINT(44+I)=MINT(40+I)
4934 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
4935 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
4938 C...If two real gammas, whereof one direct, pick the first.
4939 C...For two virtual photons, keep requested order.
4940 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4941 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
4944 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
4945 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
4948 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
4949 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
4952 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
4953 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
4956 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
4957 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
4960 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
4963 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
4967 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
4968 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
4969 IF(MINT(11).EQ.22) THEN
4977 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
4978 & '(PYINPR:) unallowed MSTP(14) code for single photon')
4981 C...Flavour information on combination of incoming particles.
4982 MINT(43)=2*MINT(41)+MINT(42)-2
4984 IF(MINT(123).LE.0) THEN
4985 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
4986 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
4987 ELSEIF(MINT(123).LE.3) THEN
4988 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
4989 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
4990 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4994 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
4995 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
4996 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
4997 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
4999 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
5002 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
5003 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
5005 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
5007 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
5008 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
5009 & MINT(122).EQ.10) MINT(108)=2
5010 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
5011 & MINT(122).EQ.11) MINT(108)=3
5012 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
5013 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
5014 IF(MINT(122).GE.3) MINT(107)=1
5015 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
5016 ELSEIF(MINT(121).EQ.2) THEN
5017 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
5018 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
5020 IF(MINT(11).EQ.22) THEN
5022 IF(MINT(123).GE.4) MINT(107)=0
5023 IF(MINT(123).EQ.7) MINT(107)=2
5024 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
5025 IF(MSTP(14).EQ.28) MINT(107)=2
5026 IF(MSTP(14).EQ.29) MINT(107)=3
5027 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
5030 IF(MINT(12).EQ.22) THEN
5032 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
5033 IF(MINT(123).EQ.7) MINT(108)=3
5034 IF(MSTP(14).EQ.26) MINT(108)=2
5035 IF(MSTP(14).EQ.27) MINT(108)=3
5036 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
5037 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
5040 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
5041 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
5047 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
5048 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
5050 C...Select default processes according to incoming beams
5051 C...(already done for gamma-p and gamma-gamma with
5052 C...MSTP(14) = 10, 20, 25 or 30).
5053 IF(MINT(121).GT.1) THEN
5054 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
5056 IF(MINT(43).EQ.1) THEN
5057 C...Lepton + lepton -> gamma/Z0 or W.
5058 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
5059 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
5061 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
5062 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
5063 C...Unresolved photon + lepton: Compton scattering.
5067 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
5068 & .OR.MINT(12).EQ.22)) THEN
5069 C...DIS as pure gamma* + f -> f process.
5072 ELSEIF(MINT(43).LE.3) THEN
5073 C...Lepton + hadron: deep inelastic scattering.
5076 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
5077 & MINT(12).EQ.22) THEN
5078 C...Two unresolved photons: fermion pair production,
5079 C...exclude lepton pairs.
5083 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5084 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5087 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
5088 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
5089 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
5091 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
5092 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
5093 & MINT(12).EQ.22)) THEN
5094 C...Unresolved photon + hadron: photon-parton scattering.
5099 ELSEIF(MSEL.EQ.1) THEN
5100 C...High-pT QCD processes:
5109 IF(CKIN(3).LT.PTMN) MSUB(95)=1
5110 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
5113 C...All QCD processes:
5127 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
5128 C...Heavy quark production.
5132 DO 180 J=1,MIN(8,MDCY(21,3))
5133 MDME(MDCY(21,2)+J-1,1)=0
5135 MDME(MDCY(21,2)+MSEL-1,1)=1
5137 DO 190 J=1,MIN(12,MDCY(22,3))
5138 MDME(MDCY(22,2)+J-1,1)=0
5140 MDME(MDCY(22,2)+MSEL-1,1)=1
5142 ELSEIF(MSEL.EQ.10) THEN
5143 C...Prompt photon production:
5148 ELSEIF(MSEL.EQ.11) THEN
5149 C...Z0/gamma* production:
5152 ELSEIF(MSEL.EQ.12) THEN
5153 C...W+/- production:
5156 ELSEIF(MSEL.EQ.13) THEN
5161 ELSEIF(MSEL.EQ.14) THEN
5166 ELSEIF(MSEL.EQ.15) THEN
5167 C...Z0 & W+/- pair production:
5174 ELSEIF(MSEL.EQ.16) THEN
5182 ELSEIF(MSEL.EQ.17) THEN
5183 C...h0 & Z0 or W+/- pair production:
5187 ELSEIF(MSEL.EQ.18) THEN
5188 C...h0 production; interesting processes in e+e-.
5194 ELSEIF(MSEL.EQ.19) THEN
5195 C...h0, H0 and A0 production; interesting processes in e+e-.
5209 ELSEIF(MSEL.EQ.21) THEN
5213 ELSEIF(MSEL.EQ.22) THEN
5214 C...W'+/- production:
5217 ELSEIF(MSEL.EQ.23) THEN
5218 C...H+/- production:
5221 ELSEIF(MSEL.EQ.24) THEN
5225 ELSEIF(MSEL.EQ.25) THEN
5226 C...LQ (leptoquark) production.
5232 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
5233 C...Production of one heavy quark (W exchange):
5235 DO 200 J=1,MIN(8,MDCY(21,3))
5236 MDME(MDCY(21,2)+J-1,1)=0
5238 MDME(MDCY(21,2)+MSEL-31,1)=1
5240 CMRENNA++Define SUSY alternatives.
5241 ELSEIF(MSEL.EQ.39) THEN
5242 C...Turn on all SUSY processes.
5243 IF(MINT(43).EQ.4) THEN
5244 C...Hadron-hadron processes.
5246 IF(ISET(I).GE.0) MSUB(I)=1
5248 ELSEIF(MINT(43).EQ.1) THEN
5249 C...Lepton-lepton processes: QED production of squarks.
5266 ELSEIF(MSEL.EQ.40) THEN
5267 C...Gluinos and squarks.
5268 IF(MINT(43).EQ.4) THEN
5280 ELSEIF(MINT(43).EQ.1) THEN
5285 ELSEIF(MSEL.EQ.41) THEN
5286 C...Stop production.
5290 IF(MINT(43).EQ.4) THEN
5295 ELSEIF(MSEL.EQ.42) THEN
5296 C...Slepton production.
5300 IF(MINT(43).NE.4) THEN
5306 ELSEIF(MSEL.EQ.43) THEN
5307 C...Neutralino/Chargino + Gluino/Squark.
5308 IF(MINT(43).EQ.4) THEN
5317 ELSEIF(MSEL.EQ.44) THEN
5318 C...Neutralino/Chargino pair production.
5319 IF(MINT(43).EQ.4) THEN
5323 ELSEIF(MINT(43).EQ.1) THEN
5329 ELSEIF(MSEL.EQ.45) THEN
5330 C...Sbottom production.
5333 IF(MINT(43).EQ.4) THEN
5339 ELSEIF(MSEL.EQ.50) THEN
5340 C...Pair production of technipions and gauge bosons.
5344 IF(MINT(43).EQ.4) THEN
5350 ELSEIF(MSEL.EQ.51) THEN
5351 C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
5357 C...Find heaviest new quark flavour allowed in processes 81-84.
5359 DO 350 I=1,MIN(8,MDCY(21,3))
5361 IF(MDME(IDC,1).LE.0) GOTO 350
5364 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
5375 C...Find heaviest new fermion flavour allowed in process 85.
5377 DO 360 I=1,MIN(12,MDCY(22,3))
5379 IF(MDME(IDC,1).LE.0) GOTO 360
5382 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
5383 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
5388 C...Import relevant information on external user processes.
5389 IF(MINT(111).EQ.11) THEN
5392 C...Find next empty PYTHIA process number slot and enable it.
5394 IF(IPYPR.GT.500) CALL PYERRM(26,
5395 & '(PYINPR.) no more empty slots for user processes')
5396 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
5397 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
5399 C...Overwrite KFPR with references back to process number and ID.
5401 KFPR(IPYPR,2)=LPRUP(IUP)
5403 WRITE(CHIPR,'(I10)') LPRUP(IUP)
5406 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
5408 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
5409 C...Switch on process.
5417 C*********************************************************************
5420 C...Parametrizes total, elastic and diffractive cross-sections
5421 C...for different energies and beams. Donnachie-Landshoff for
5422 C...total and Schuler-Sjostrand for elastic and diffractive.
5423 C...Process code IPROC:
5430 C...= 7 : J/psi + p;
5431 C...= 11 : rho + rho;
5432 C...= 12 : rho + phi;
5433 C...= 13 : rho + J/psi;
5434 C...= 14 : phi + phi;
5435 C...= 15 : phi + J/psi;
5436 C...= 16 : J/psi + J/psi;
5437 C...= 21 : gamma + p (DL);
5438 C...= 22 : gamma + p (VDM).
5439 C...= 23 : gamma + pi (DL);
5440 C...= 24 : gamma + pi (VDM);
5441 C...= 25 : gamma + gamma (DL);
5442 C...= 26 : gamma + gamma (VDM).
5446 C...Double precision and integer declarations.
5447 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5448 IMPLICIT INTEGER(I-N)
5449 INTEGER PYK,PYCHGE,PYCOMP
5451 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5452 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5453 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5454 COMMON/PYINT1/MINT(400),VINT(400)
5455 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5456 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5457 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
5459 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
5460 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
5461 &CEFFD(10,9),SIGTMP(6,0:5)
5463 C...Common constants.
5464 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
5465 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
5468 C...Number of multiple processes to be evaluated (= 0 : undefined).
5469 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
5470 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
5471 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
5472 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
5473 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
5475 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
5476 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
5477 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
5479 C...Beam and target hadron class:
5480 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
5481 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
5482 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
5483 C...Characteristic class masses, slope parameters, beta = sqrt(X).
5484 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
5485 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
5486 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
5488 C...Fitting constants used in parametrizations of diffractive results.
5489 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5490 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5491 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
5492 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
5493 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
5494 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
5495 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
5496 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
5497 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
5498 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
5499 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
5500 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
5501 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
5502 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
5503 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
5504 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
5505 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
5506 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
5507 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
5508 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
5509 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
5510 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
5511 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
5512 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
5513 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
5514 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
5515 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
5516 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
5517 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
5519 C...Parameters. Combinations of the energy.
5528 C...Ratio of gamma/pi (for rescaling in parton distributions).
5529 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
5530 &(XPAR(5)*SEPS+YPAR(5)*SETA)
5532 IF(MINT(50).NE.1) RETURN
5534 C...Order flavours of incoming particles: KF1 < KF2.
5535 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
5544 ISGN12=ISIGN(1,MINT(11)*MINT(12))
5546 C...Find process number (for lookup tables).
5547 IF(KF1.GT.1000) THEN
5549 IF(ISGN12.LT.0) IPROC=2
5550 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
5552 IF(ISGN12.LT.0) IPROC=4
5553 IF(KF1.EQ.111) IPROC=5
5554 ELSEIF(KF1.GT.100) THEN
5556 ELSEIF(KF2.GT.1000) THEN
5558 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
5559 ELSEIF(KF2.GT.100) THEN
5561 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
5564 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
5567 C... Number of multiple processes to be stored; beam/target side.
5573 ELSEIF(NPR.EQ.6) THEN
5578 IF(MINT(101).EQ.4) N1=4
5580 IF(MINT(102).EQ.4) N2=4
5582 C...Do not do any more for user-set or undefined cross-sections.
5583 IF(MSTP(31).LE.0) RETURN
5584 IF(NPR.EQ.0) CALL PYERRM(26,
5585 &'(PYXTOT:) cross section for this process not yet implemented')
5587 C...Parameters. Combinations of the energy.
5596 C...Loop over multiple processes (for VDM).
5600 ELSEIF(NPR.EQ.3) THEN
5602 IF(KF2.LT.1000) IPR=I+10
5603 ELSEIF(NPR.EQ.6) THEN
5607 C...Evaluate hadron species, mass, slope contribution and fit number.
5617 C...Skip if energy too low relative to masses.
5621 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
5623 C...Total cross-section. Elastic slope parameter and cross-section.
5624 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
5625 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
5626 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
5628 C...Diffractive scattering A + B -> X + B.
5631 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
5632 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5633 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5634 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
5635 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
5636 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
5637 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
5639 C...Diffractive scattering A + B -> A + X.
5642 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
5643 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5644 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5645 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
5646 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
5647 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
5648 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
5650 C...Order single diffractive correctly.
5653 SIGTMP(I,2)=SIGTMP(I,3)
5657 C...Double diffractive scattering A + B -> X1 + X2.
5658 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
5659 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
5660 SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
5661 IF(YEFF.LE.0) SUM1=0D0
5662 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
5663 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
5664 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
5665 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
5667 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
5668 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
5669 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
5671 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
5672 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
5673 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
5674 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
5675 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
5677 C...Non-diffractive by unitarity.
5678 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
5682 C...Put temporary results in output array: only one process.
5683 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
5685 SIGT(0,0,J)=SIGTMP(1,J)
5688 C...Beam multiple processes.
5689 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
5690 IF(MINT(107).EQ.2) THEN
5691 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5693 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5694 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5696 IF(MSTP(20).GT.0) THEN
5697 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
5700 IF(MINT(107).EQ.2) THEN
5701 CONV=(AEM/PARP(160+I))*VINT(317)
5702 ELSEIF(VINT(154).GT.PARP(15)) THEN
5703 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5704 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5710 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
5714 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5717 C...Target multiple processes.
5718 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
5719 IF(MINT(108).EQ.2) THEN
5720 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5722 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5723 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5725 IF(MSTP(20).GT.0) THEN
5726 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
5729 IF(MINT(108).EQ.2) THEN
5730 CONV=(AEM/PARP(160+I))*VINT(317)
5731 ELSEIF(VINT(154).GT.PARP(15)) THEN
5732 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5733 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5739 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
5743 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
5746 C...Both beam and target multiple processes.
5748 IF(MINT(107).EQ.2) THEN
5749 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5751 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5752 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5754 IF(MINT(108).EQ.2) THEN
5755 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5757 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
5758 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5760 IF(MSTP(20).GT.0) THEN
5761 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
5762 & VINT(308)))**MSTP(20)
5766 IF(MINT(107).EQ.2) THEN
5767 CONV=(AEM/PARP(160+I1))*VINT(317)
5768 ELSEIF(VINT(154).GT.PARP(15)) THEN
5769 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
5770 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5774 IF(MINT(108).EQ.2) THEN
5775 CONV=CONV*(AEM/PARP(160+I2))
5776 ELSEIF(VINT(154).GT.PARP(15)) THEN
5777 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
5778 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
5784 ELSEIF(I2.LE.2) THEN
5786 ELSEIF(I1.EQ.I2) THEN
5793 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
5794 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
5800 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
5801 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
5803 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5807 C...Scale up uniformly for Donnachie-Landshoff parametrization.
5808 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
5809 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
5813 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
5822 C*********************************************************************
5825 C...Finds optimal set of coefficients for kinematical variable selection
5826 C...and the maximum of the part of the differential cross-section used
5827 C...in the event weighting.
5831 C...Double precision and integer declarations.
5832 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5833 IMPLICIT INTEGER(I-N)
5834 INTEGER PYK,PYCHGE,PYCOMP
5835 C...Parameter statement to help give large particle numbers.
5836 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5837 &KEXCIT=4000000,KDIMEN=5000000)
5839 C...User process initialization commonblock.
5841 PARAMETER (MAXPUP=100)
5842 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5843 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5844 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5845 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5850 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5851 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5852 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5853 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5854 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5855 COMMON/PYINT1/MINT(400),VINT(400)
5856 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5857 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
5858 COMMON/PYINT4/MWID(500),WIDS(500,5)
5859 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5860 COMMON/PYINT6/PROC(0:500)
5862 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5863 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
5864 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
5865 C...Local arrays, character variables and data.
5867 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
5868 &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
5869 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
5870 DATA CVAR/'tau ','tau''','y* ','cth '/
5873 C...Initial values and loop over subprocesses.
5882 C...Find maximum weight factors for photon flux.
5883 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
5884 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
5887 C...Select subprocess to study: skip cases not applicable.
5888 IF(ISET(ISUB).EQ.11) THEN
5889 IF(MSUB(ISUB).NE.1) GOTO 460
5890 C...User process intialization: cross section model dependent.
5891 IF(IABS(IDWTUP).EQ.1) THEN
5892 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5893 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5894 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
5896 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
5897 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
5898 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
5899 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5900 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5901 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
5903 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5904 & WTGAGA*XSEC(ISUB,1)
5907 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
5908 CALL PYSIGH(NCHN,SIGS)
5910 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5911 & WTGAGA*XSEC(ISUB,1)
5912 IF(MSUB(ISUB).NE.1) GOTO 460
5915 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
5916 CALL PYSIGH(NCHN,SIGS)
5918 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5919 & WTGAGA*XSEC(ISUB,1)
5920 IF(XSEC(ISUB,1).EQ.0D0) THEN
5926 ELSEIF(ISUB.EQ.96) THEN
5927 IF(MINT(50).EQ.0) GOTO 460
5928 IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
5930 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
5931 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
5932 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
5933 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
5934 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
5935 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
5937 IF(MSUB(ISUB).NE.1) GOTO 460
5940 IF(ISUB.EQ.96) ISTSB=2
5941 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
5943 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
5944 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
5946 C...Find resonances (explicit or implicit in cross-section).
5949 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
5951 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
5952 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
5954 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
5955 & .OR.ISUB.EQ.177) THEN
5957 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
5959 IF(MSTP(46).EQ.5) THEN
5962 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
5964 ELSEIF(ISUB.EQ.194) THEN
5966 ELSEIF(ISUB.EQ.195) THEN
5968 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
5970 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
5974 IF(CKMX.LE.0D0) CKMX=VINT(1)
5977 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
5978 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
5981 TAUR1=PMAS(KCR1,1)**2/VINT(2)
5982 IF(KFR1.EQ.KTECHN+113) THEN
5986 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
5993 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
5996 IF(ISUB.EQ.194) THEN
5998 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
6002 TAUR2=PMAS(KCR2,1)**2/VINT(2)
6003 IF(KFR2.EQ.KTECHN+223) THEN
6007 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
6008 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
6009 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
6010 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
6015 ELSEIF(KFR2.NE.0) THEN
6027 C...Find product masses and minimum pT of process.
6033 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
6037 IF(KFPR(ISUB,I).EQ.0) THEN
6038 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
6040 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
6041 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
6044 C...This prevents SUSY/t particles from becoming too light.
6046 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
6049 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
6050 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
6051 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
6052 & PMAS(PYCOMP(KFDP(IDC,2)),1)
6053 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
6054 & PMAS(PYCOMP(KFDP(IDC,3)),1)
6055 PMMN(I)=MIN(PMMN(I),PMSUM)
6058 ELSEIF(KFLW.EQ.6) THEN
6059 PMMN(I)=PMAS(24,1)+PMAS(5,1)
6066 CKIN(41)=MAX(PMMN(1),CKIN(41))
6067 CKIN(43)=MAX(PMMN(2),CKIN(43))
6068 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
6071 IF(MINT(51).EQ.1) THEN
6072 WRITE(MSTU(11),5100) ISUB
6079 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
6080 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
6081 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
6082 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6083 ELSEIF(ISUB.EQ.96) THEN
6084 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6090 C...Prepare for additional variable choices in 2 -> 3.
6093 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
6095 VINT(204)=PMAS(23,1)
6096 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
6097 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
6098 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
6099 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
6103 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
6104 NPTS(1)=2+2*MINT(72)
6105 IF(MINT(47).EQ.1) THEN
6106 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
6107 ELSEIF(MINT(47).GE.5) THEN
6108 IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
6111 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
6112 IF(MINT(47).GE.2) NPTS(2)=2
6113 IF(MINT(47).GE.5) NPTS(2)=3
6116 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
6118 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
6119 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
6122 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
6123 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
6125 C...Reset coefficients of cross-section weighting.
6141 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
6142 C...in grid of phase space points.
6148 IF(METAU.EQ.1) GOTO 150
6149 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
6150 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
6151 IF(MTAU.GT.2+2*MINT(72)) MTAU=7
6153 C...Special case when both resonances have same mass,
6154 C...as is often the case in process 194.
6155 IF(MINT(72).EQ.2) THEN
6156 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
6157 & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
6158 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
6160 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
6165 CALL PYKMAP(1,MTAU,RTAU)
6166 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
6169 IF(METAUP.EQ.1) GOTO 150
6170 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
6172 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
6173 CALL PYKMAP(4,MTAUP,0.5D0)
6175 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
6179 IF(MEYST.EQ.1) GOTO 150
6180 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
6181 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
6182 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
6183 CALL PYKMAP(2,MYST,0.5D0)
6187 IF(MECTH.EQ.1) GOTO 150
6188 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
6189 MCTH=1+MOD(ITRY-1,NPTS(4))
6190 CALL PYKMAP(3,MCTH,0.5D0)
6192 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
6194 C...Store position and limits.
6197 IF(MINT(51).EQ.1) GOTO 150
6200 MVARPT(NACC,2)=MTAUP
6204 VINTPT(NACC,J)=VINT(10+J)
6207 C...Normal case: calculate cross-section.
6209 CALL PYSIGH(NCHN,SIGS)
6215 C..2 -> 3: find highest value out of a number of tries.
6218 DO 140 IKIN3=1,MSTP(129)
6219 CALL PYKMAP(5,0,0D0)
6220 IF(MINT(51).EQ.1) GOTO 140
6221 CALL PYSIGH(NCHN,SIGTMP)
6226 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6230 C...Store cross-section.
6232 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6233 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
6234 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6237 WRITE(MSTU(11),5100) ISUB
6240 ELSEIF(SIGSAM.EQ.0D0) THEN
6241 WRITE(MSTU(11),5300) ISUB
6245 IF(ISUB.NE.96) NPOSI=NPOSI+1
6247 C...Calculate integrals in tau over maximal phase space limits.
6250 ATAU1=LOG(TAUMAX/TAUMIN)
6251 IF(NPTS(1).GE.2) THEN
6252 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
6254 IF(NPTS(1).GE.4) THEN
6255 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
6256 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
6259 IF(NPTS(1).GE.6) THEN
6260 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
6261 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
6264 IF(NPTS(1).GT.2+2*MINT(72)) THEN
6265 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
6268 C...Reset. Sum up cross-sections in points calculated.
6270 IF(NPTS(IVAR).EQ.1) GOTO 320
6271 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
6282 IBIN=MVARPT(IACC,IVAR)
6283 IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
6284 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
6285 NAREL(IBIN)=NAREL(IBIN)+1
6286 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
6288 C...Sum up tau cross-section pieces in points used.
6291 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6292 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
6294 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
6295 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
6296 & ((TAU-TAUR1)**2+GAMR1**2)
6299 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
6300 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
6301 & ((TAU-TAUR2)**2+GAMR2**2)
6303 IF(NBIN.GT.2+2*MINT(72)) THEN
6304 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
6305 & TAU/MAX(2D-10,1D0-TAU)
6308 C...Sum up tau' cross-section pieces in points used.
6309 ELSEIF(IVAR.EQ.2) THEN
6311 TAUP=VINTPT(IACC,16)
6312 TAUPMN=VINTPT(IACC,6)
6313 TAUPMX=VINTPT(IACC,26)
6314 ATAUP1=LOG(TAUPMX/TAUPMN)
6315 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
6316 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6317 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
6318 & (1D0-TAU/TAUP)**3/TAUP
6320 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
6321 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
6322 & TAUP/MAX(2D-10,1D0-TAUP)
6325 C...Sum up y* cross-section pieces in points used.
6326 ELSEIF(IVAR.EQ.3) THEN
6328 YSTMIN=VINTPT(IACC,2)
6329 YSTMAX=VINTPT(IACC,22)
6331 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
6333 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
6334 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
6335 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
6336 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
6337 IF(MINT(45).EQ.3) THEN
6338 TAUE=VINTPT(IACC,11)
6339 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6340 YST0=-0.5D0*LOG(TAUE)
6341 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
6342 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
6343 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
6344 & MAX(1D-10,1D0-EXP(YST-YST0))
6346 IF(MINT(46).EQ.3) THEN
6347 TAUE=VINTPT(IACC,11)
6348 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6349 YST0=-0.5D0*LOG(TAUE)
6350 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
6351 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
6352 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
6353 & MAX(1D-10,1D0-EXP(-YST-YST0))
6356 C...Sum up cos(theta-hat) cross-section pieces in points used.
6358 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
6360 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
6362 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
6365 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
6366 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
6367 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
6368 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
6370 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6371 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
6372 & MAX(RM34,RSQM-CTH)
6373 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
6374 & MAX(RM34,RSQM+CTH)
6375 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
6376 & MAX(RM34,RSQM-CTH)**2
6377 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
6378 & MAX(RM34,RSQM+CTH)**2
6382 C...Check that equation system solvable.
6383 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
6387 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
6388 & IRED=1,NBIN),WTREL(IBIN)
6389 IF(NAREL(IBIN).EQ.0) MSOLV=0
6390 WTRELS=WTRELS+WTREL(IBIN)
6392 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
6394 C...Solve to find relative importance of cross-section pieces.
6397 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
6399 DO 230 IRED=1,NBIN-1
6400 DO 220 IBIN=IRED+1,NBIN
6401 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
6405 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
6406 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
6407 DO 210 ICOE=IRED,NBIN
6408 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
6412 DO 250 IRED=NBIN,1,-1
6413 DO 240 ICOE=IRED+1,NBIN
6414 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
6416 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
6420 C...Share evenly if failure.
6421 260 IF(MSOLV.EQ.0) THEN
6425 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
6426 & WTREL(IBIN)/WTRELS)
6430 C...Normalize coefficients, with piece shared democratically.
6434 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
6435 COEFSU=COEFSU+COEFU(IBIN)
6436 WTRELS=WTRELS+WTRELN(IBIN)
6438 IF(COEFSU.GT.0D0) THEN
6440 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
6441 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
6445 COEFO(IBIN)=1D0/NBIN
6448 IF(IVAR.EQ.1) IOFF=0
6449 IF(IVAR.EQ.2) IOFF=17
6450 IF(IVAR.EQ.3) IOFF=7
6451 IF(IVAR.EQ.4) IOFF=12
6454 IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
6455 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
6456 COEF(ISUB,ICOF)=COEFO(IBIN)
6458 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
6459 & (COEFO(IBIN),IBIN=1,NBIN)
6462 C...Find two most promising maxima among points previously determined.
6470 VINT(10+J)=VINTPT(IACC,J)
6473 CALL PYSIGH(NCHN,SIGS)
6480 DO 350 IKIN3=1,MSTP(129)
6481 CALL PYKMAP(5,0,0D0)
6482 IF(MINT(51).EQ.1) GOTO 350
6483 CALL PYSIGH(NCHN,SIGTMP)
6488 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6493 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
6496 DO 370 IMV=NMAX,1,-1
6498 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
6499 IACCMX(IMV+1)=IACCMX(IMV)
6500 SIGSMX(IMV+1)=SIGSMX(IMV)
6503 380 IACCMX(IIN)=IACC
6505 IF(NMAX.LE.1) NMAX=NMAX+1
6509 C...Read out starting position for search.
6510 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
6515 MTAUP=MVARPT(IACC,2)
6523 C...Starting point and step size in parameter space.
6526 IF(NPTS(IVAR).EQ.1) GOTO 420
6527 IF(IVAR.EQ.1) VVAR=VTAU
6528 IF(IVAR.EQ.2) VVAR=VTAUP
6529 IF(IVAR.EQ.3) VVAR=VYST
6530 IF(IVAR.EQ.4) VVAR=VCTH
6531 IF(IVAR.EQ.1) MVAR=MTAU
6532 IF(IVAR.EQ.2) MVAR=MTAUP
6533 IF(IVAR.EQ.3) MVAR=MYST
6534 IF(IVAR.EQ.4) MVAR=MCTH
6535 IF(IRPT.EQ.1) VDEL=0.1D0
6536 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
6538 IF(IRPT.EQ.1) VMAR=0.02D0
6539 IF(IRPT.EQ.2) VMAR=0.002D0
6541 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
6544 C...Define new point in parameter space.
6548 ELSEIF(IMOV.EQ.1) THEN
6551 ELSEIF(IMOV.EQ.2) THEN
6554 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
6555 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
6561 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
6562 & VVAR-2D0*VDEL.GT.VMAR) THEN
6568 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
6582 C...Convert to relevant variables and find derived new limits.
6586 CALL PYKMAP(1,MTAU,VTAU)
6587 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
6589 IF(MINT(51).EQ.1) ILERR=1
6592 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
6594 IF(IVAR.EQ.2) VTAUP=VNEW
6595 CALL PYKMAP(4,MTAUP,VTAUP)
6597 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
6599 IF(MINT(51).EQ.1) ILERR=1
6601 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
6602 IF(IVAR.EQ.3) VYST=VNEW
6603 CALL PYKMAP(2,MYST,VYST)
6605 IF(MINT(51).EQ.1) ILERR=1
6607 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
6609 IF(IVAR.EQ.4) VCTH=VNEW
6610 CALL PYKMAP(3,MCTH,VCTH)
6612 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
6614 C...Evaluate cross-section. Save new maximum. Final maximum.
6617 ELSEIF(ISTSB.NE.5) THEN
6618 CALL PYSIGH(NCHN,SIGS)
6625 DO 400 IKIN3=1,MSTP(129)
6626 CALL PYKMAP(5,0,0D0)
6627 IF(MINT(51).EQ.1) GOTO 400
6628 CALL PYSIGH(NCHN,SIGTMP)
6633 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6637 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6638 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
6639 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6644 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
6645 XSEC(ISUB,1)=1.05D0*SIGSAM
6646 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
6647 & WTGAGA*XSEC(ISUB,1)
6649 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
6650 & PARP(174)*XSEC(ISUB,1)
6651 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
6655 C...Print summary table.
6656 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
6657 IF(MSTP(127).NE.1) THEN
6658 WRITE(MSTU(11),5900)
6661 WRITE(MSTU(11),6400)
6665 IF(MSTP(122).GE.1) THEN
6666 WRITE(MSTU(11),6000)
6667 WRITE(MSTU(11),6100)
6669 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
6670 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
6671 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
6672 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
6673 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
6674 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
6675 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
6676 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
6678 WRITE(MSTU(11),6300)
6681 C...Format statements for maximization results.
6682 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
6683 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
6684 &'cth',9X,'tau''',7X,'sigma')
6685 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
6686 &'phase space.'/1X,'Process switched off!')
6687 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
6688 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
6689 &'cross-section.'/1X,'Process switched off!')
6690 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
6691 5500 FORMAT(1X,1P,8D11.3)
6692 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
6693 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
6694 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
6695 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
6696 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
6697 &'cross-section.'/1X,'Execution stopped!')
6698 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
6699 &'cross-section maximum search',1X,8('*'))
6700 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
6701 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
6702 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
6703 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
6704 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
6705 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
6707 &1X,'Execution will stop if you try to generate events.')
6712 C*********************************************************************
6715 C...Initializes multiplicity distribution and selects mutliplicity
6716 C...of pileup events, i.e. several events occuring at the same
6719 SUBROUTINE PYPILE(MPILE)
6721 C...Double precision and integer declarations.
6722 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6723 IMPLICIT INTEGER(I-N)
6724 INTEGER PYK,PYCHGE,PYCOMP
6726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6727 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6728 COMMON/PYINT1/MINT(400),VINT(400)
6729 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6730 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
6731 C...Local arrays and saved variables.
6732 DIMENSION WTI(0:200)
6733 SAVE IMIN,IMAX,WTI,WTS
6735 C...Sum of allowed cross-sections for pileup events.
6737 VINT(131)=SIGT(0,0,5)
6738 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
6739 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
6740 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
6741 IF(MSTP(133).LE.0) RETURN
6743 C...Initialize multiplicity distribution at maximum.
6744 XNAVE=VINT(131)*PARP(131)
6745 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
6746 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
6749 WTN=WTI(INAVE)*INAVE
6751 C...Find shape of multiplicity distribution below maximum.
6753 DO 100 I=INAVE-1,1,-1
6754 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
6755 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
6756 IF(WTI(I).LT.1D-6) GOTO 110
6762 C...Find shape of multiplicity distribution above maximum.
6764 DO 120 I=INAVE+1,200
6765 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
6766 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
6767 IF(WTI(I).LT.1D-6) GOTO 130
6774 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
6775 & WTS/(WTS+WTI(1)/XNAVE)
6776 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
6777 IF(MSTP(133).GE.2) VINT(134)=XNAVE
6779 C...Pick multiplicity of pileup events.
6781 IF(MSTP(133).LE.0) THEN
6782 MINT(81)=MAX(1,MSTP(134))
6788 IF(WTR.LE.0D0) GOTO 150
6794 C...Format statement for error message.
6795 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
6796 &'crossing too large, ',1P,D12.4)
6801 C*********************************************************************
6804 C...Saves and restores parameter and cross section values for the
6805 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
6806 C...Also makes random choice between alternatives.
6808 SUBROUTINE PYSAVE(ISAVE,IGA)
6810 C...Double precision and integer declarations.
6811 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6812 IMPLICIT INTEGER(I-N)
6813 INTEGER PYK,PYCHGE,PYCOMP
6815 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6816 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6817 COMMON/PYINT1/MINT(400),VINT(400)
6818 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6819 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6820 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6821 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
6822 C...Local arrays and saved variables.
6823 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
6824 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
6825 &INTCP(15,20),RECP(15,20)
6826 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
6828 C...Save list of subprocesses and cross-section information.
6832 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
6835 MSUBCP(IGA,ICP)=MSUB(I)
6837 COEFCP(IGA,ICP,J)=COEF(I,J)
6840 NGENCP(IGA,ICP,J)=NGEN(I,J)
6841 XSECCP(IGA,ICP,J)=XSEC(I,J)
6846 NGENCP(IGA,0,J)=NGEN(0,J)
6847 XSECCP(IGA,0,J)=XSEC(0,J)
6852 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
6857 C...Save various common process variables.
6859 INTCP(IGA,J)=MINT(40+J)
6861 INTCP(IGA,11)=MINT(101)
6862 INTCP(IGA,12)=MINT(102)
6863 INTCP(IGA,13)=MINT(107)
6864 INTCP(IGA,14)=MINT(108)
6865 INTCP(IGA,15)=MINT(123)
6867 RECP(IGA,2)=VINT(318)
6869 C...Save cross-section information only.
6870 ELSEIF(ISAVE.EQ.2) THEN
6871 DO 190 ICP=1,NCP(IGA)
6874 NGENCP(IGA,ICP,J)=NGEN(I,J)
6875 XSECCP(IGA,ICP,J)=XSEC(I,J)
6879 NGENCP(IGA,0,J)=NGEN(0,J)
6880 XSECCP(IGA,0,J)=XSEC(0,J)
6883 C...Choose between allowed alternatives.
6884 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
6887 DO 210 IG=1,MINT(121)
6888 XSUMCP=XSUMCP+XSECCP(IG,0,1)
6890 XSUMCP=XSUMCP*PYR(0)
6891 DO 220 IG=1,MINT(121)
6893 XSUMCP=XSUMCP-XSECCP(IG,0,1)
6894 IF(XSUMCP.LE.0D0) GOTO 230
6899 C...Restore cross-section information.
6903 DO 270 ICP=1,NCP(IGA)
6905 MSUB(I)=MSUBCP(IGA,ICP)
6907 COEF(I,J)=COEFCP(IGA,ICP,J)
6910 NGEN(I,J)=NGENCP(IGA,ICP,J)
6911 XSEC(I,J)=XSECCP(IGA,ICP,J)
6915 NGEN(0,J)=NGENCP(IGA,0,J)
6916 XSEC(0,J)=XSECCP(IGA,0,J)
6921 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
6926 C...Restore various common process variables.
6928 MINT(40+J)=INTCP(IGA,J)
6930 MINT(101)=INTCP(IGA,11)
6931 MINT(102)=INTCP(IGA,12)
6932 MINT(107)=INTCP(IGA,13)
6933 MINT(108)=INTCP(IGA,14)
6934 MINT(123)=INTCP(IGA,15)
6937 VINT(318)=RECP(IGA,2)
6939 C...Sum up cross-section info (for PYSTAT).
6940 ELSEIF(ISAVE.EQ.5) THEN
6951 DO 350 IG=1,MINT(121)
6952 DO 340 ICP=1,NCP(IG)
6954 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
6955 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
6956 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
6957 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
6959 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
6960 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
6961 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
6962 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
6969 C*********************************************************************
6972 C...For lepton beams it gives photon-hadron or photon-photon systems
6973 C...to be treated with the ordinary machinery and combines this with a
6974 C...description of the lepton -> lepton + photon branching.
6976 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
6978 C...Double precision and integer declarations.
6979 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6980 IMPLICIT INTEGER(I-N)
6981 INTEGER PYK,PYCHGE,PYCOMP
6983 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
6984 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6985 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6986 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6987 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6988 COMMON/PYINT1/MINT(400),VINT(400)
6989 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6990 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
6992 C...Local variables and data statement.
6993 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
6994 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
6995 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
6998 C...Initialize generation of photons inside leptons.
7001 C...Save quantities on incoming lepton system.
7005 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
7007 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
7008 PMC(3)=VINT(302)-PMS(1)-PMS(2)
7009 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
7011 C...Calculate range of x and Q2 values allowed in generation.
7013 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
7014 IF(MINT(140+I).NE.0) THEN
7015 XMIN(I)=MAX(CKIN(59+2*I),EPS)
7016 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
7018 YMIN=MAX(CKIN(71+2*I),EPS)
7019 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
7020 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
7021 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
7022 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
7023 THEMIN=MAX(CKIN(67+2*I),0D0)
7024 THEMAX=MIN(CKIN(68+2*I),PARU(1))
7025 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
7026 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
7027 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
7028 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
7029 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
7030 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
7031 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
7032 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
7033 C...W limits when lepton on one side only.
7034 IF(MINT(143-I).EQ.0) THEN
7035 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
7036 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
7037 & (CKIN(78)**2-PMS(3-I))/PMC(I))
7042 C...W limits when lepton on both sides.
7043 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7044 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
7045 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
7046 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
7047 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
7048 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
7049 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
7050 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
7051 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
7052 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
7054 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
7055 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
7059 C...Q2 and W values and photon flux weight factors for initialization.
7060 ELSEIF(IGAGA.EQ.2) THEN
7065 C...W value for photon on one or both sides, and for processes
7066 C...with gamma-gamma cross section peaked at small shat.
7067 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
7068 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
7069 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
7070 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
7071 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
7072 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
7073 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
7075 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
7076 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
7078 VINT(1)=SQRT(MAX(0D0,VINT(2)))
7080 C...Upper estimate of photon flux weight factor.
7081 C...Initialization Q2 scale. Flag incoming unresolved photon.
7084 IF(MINT(140+I).NE.0) THEN
7085 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
7086 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
7087 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
7089 Q2INIT=5D0+Q2MIN(3-I)
7090 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
7091 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
7092 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
7093 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
7094 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
7095 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
7097 ELSEIF(ISUB.EQ.140) THEN
7102 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
7103 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
7105 VINT(306+I)=VINT(2+I)**2
7110 C...Update pTmin and cross section information.
7111 IF(MSTP(82).LE.1) THEN
7112 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7114 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7116 VINT(149)=4D0*PTMN**2/VINT(2)
7121 C...Generate photons inside leptons and
7122 C...calculate photon flux weight factors.
7123 ELSEIF(IGAGA.EQ.3) THEN
7128 C...Generate phase space point and check against cuts.
7132 IF(MINT(140+I).NE.0) THEN
7134 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
7135 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
7136 C...Cuts on internal consistency in x and Q2.
7137 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
7138 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
7139 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
7140 C...Cuts on y and theta.
7141 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
7142 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
7143 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
7144 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
7145 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
7146 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
7147 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
7150 C...Phi angle isotropic. Reconstruct pT.
7151 PHI(I)=PARU(2)*PYR(0)
7152 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
7153 & PMS(I))*SIN(THETA(I))
7155 C...Store info on variables selected, for documentation purposes.
7156 VINT(2+I)=-SQRT(Q2(I))
7160 VINT(310+I)=THETA(I)
7171 C...Cut on W combines info from two sides.
7172 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7173 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
7174 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
7175 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
7176 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
7177 IF(W2.LT.W2MIN) GOTO 120
7178 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
7181 ELSEIF(MINT(141).NE.0) THEN
7182 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
7185 ELSEIF(MINT(142).NE.0) THEN
7186 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
7191 C...Store kinematics info for photon(s) in subsystem cm frame.
7196 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
7197 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
7198 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
7201 VINT(298)=-VINT(293)
7202 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
7203 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
7205 C...Assign weight for photon flux; different for transverse and
7206 C...longitudinal photons. Flag incoming unresolved photon.
7209 IF(MINT(140+I).NE.0) THEN
7210 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
7211 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
7212 IF(MSTP(16).EQ.0) THEN
7215 WTGAGA=WTGAGA*X(I)/Y(I)
7218 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
7219 WTGAGA=WTGAGA*(1D0-XY)
7220 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
7221 WTGAGA=WTGAGA*(1D0-XY)
7222 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
7223 WTGAGA=WTGAGA*(1D0-XY)
7225 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
7226 & PMS(I)*XY**2/Q2(I))
7228 IF(MINT(106+I).EQ.0) MINT(14+I)=22
7234 C...Update pTmin and cross section information.
7235 IF(MSTP(82).LE.1) THEN
7236 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7238 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7240 VINT(149)=4D0*PTMN**2/VINT(2)
7244 C...Reconstruct kinematics of photons inside leptons.
7245 ELSEIF(IGAGA.EQ.4) THEN
7247 C...Make place for incoming particles and scattered leptons.
7249 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
7250 MINT(4)=MINT(4)+MOVE
7251 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
7252 IF(K(I,1).EQ.21) THEN
7258 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7259 & K(I+MOVE,3)=K(I,3)+MOVE
7260 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
7261 & K(I+MOVE,4)=K(I,4)+MOVE
7262 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
7263 & K(I+MOVE,5)=K(I,5)+MOVE
7266 DO 170 I=MINT(84)+1,N
7267 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7268 & K(I,3)=K(I,3)+MOVE
7271 C...Fill in incoming particles.
7272 DO 190 I=MINT(83)+1,MINT(83)+MOVE
7281 IF(MINT(140+I).NE.0) THEN
7282 K(MINT(83)+I,2)=MINT(140+I)
7283 P(MINT(83)+I,5)=VINT(302+I)
7285 K(MINT(83)+I,2)=MINT(10+I)
7286 P(MINT(83)+I,5)=VINT(2+I)
7288 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
7289 & VINT(302))*(-1D0)**(I+1)
7290 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
7293 C...New mother-daughter relations in documentation section.
7294 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7295 K(MINT(83)+1,4)=MINT(83)+3
7296 K(MINT(83)+1,5)=MINT(83)+5
7297 K(MINT(83)+2,4)=MINT(83)+4
7298 K(MINT(83)+2,5)=MINT(83)+6
7299 K(MINT(83)+3,3)=MINT(83)+1
7300 K(MINT(83)+5,3)=MINT(83)+1
7301 K(MINT(83)+4,3)=MINT(83)+2
7302 K(MINT(83)+6,3)=MINT(83)+2
7303 ELSEIF(MINT(141).NE.0) THEN
7304 K(MINT(83)+1,4)=MINT(83)+3
7305 K(MINT(83)+1,5)=MINT(83)+4
7306 K(MINT(83)+2,4)=MINT(83)+5
7307 K(MINT(83)+3,3)=MINT(83)+1
7308 K(MINT(83)+4,3)=MINT(83)+1
7309 K(MINT(83)+5,3)=MINT(83)+2
7310 ELSEIF(MINT(142).NE.0) THEN
7311 K(MINT(83)+1,4)=MINT(83)+4
7312 K(MINT(83)+2,4)=MINT(83)+3
7313 K(MINT(83)+2,5)=MINT(83)+5
7314 K(MINT(83)+3,3)=MINT(83)+2
7315 K(MINT(83)+4,3)=MINT(83)+1
7316 K(MINT(83)+5,3)=MINT(83)+2
7319 C...Fill scattered lepton(s).
7321 IF(MINT(140+I).NE.0) THEN
7322 LSC=MINT(83)+MIN(I+2,MOVE)
7324 K(LSC,2)=MINT(140+I)
7325 P(LSC,1)=PT(I)*COS(PHI(I))
7326 P(LSC,2)=PT(I)*SIN(PHI(I))
7327 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
7328 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
7330 P(LSC,5)=VINT(302+I)
7334 C...Find incoming four-vectors to subprocess.
7336 IF(MINT(141).NE.0) THEN
7338 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
7342 P(N+1,J)=P(MINT(83)+1,J)
7346 IF(MINT(142).NE.0) THEN
7348 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
7352 P(N+2,J)=P(MINT(83)+2,J)
7356 C...Define boost and rotation between hadronic subsystem and
7357 C...collision rest frame; boost hadronic subsystem to this frame.
7359 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
7361 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
7362 BPHI=PYANGL(P(N+1,1),P(N+1,2))
7363 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
7364 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
7365 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
7368 C...Add on scattered leptons to final state.
7370 IF(MINT(140+I).NE.0) THEN
7371 LSC=MINT(83)+MIN(I+2,MOVE)
7387 C*********************************************************************
7390 C...Generates quantities characterizing the high-pT scattering at the
7391 C...parton level according to the matrix elements. Chooses incoming,
7392 C...reacting partons, their momentum fractions and one of the possible
7397 C...Double precision and integer declarations.
7398 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7399 IMPLICIT INTEGER(I-N)
7400 INTEGER PYK,PYCHGE,PYCOMP
7401 C...Parameter statement to help give large particle numbers.
7402 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7403 &KEXCIT=4000000,KDIMEN=5000000)
7405 C...User process initialization and event commonblocks.
7407 PARAMETER (MAXPUP=100)
7408 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7409 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7410 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7411 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7414 PARAMETER (MAXNUP=500)
7415 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
7416 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
7417 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
7418 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
7419 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
7420 SAVE /HEPRUP/,/HEPEUP/
7423 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7424 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7425 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7426 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7427 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7428 COMMON/PYINT1/MINT(400),VINT(400)
7429 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7430 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7431 COMMON/PYINT4/MWID(500),WIDS(500,5)
7432 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7433 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7434 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
7435 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7436 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/
7438 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
7440 C...Parameters and data used in elastic/diffractive treatment.
7441 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
7442 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
7444 C...Initial values, specifically for (first) semihard interaction.
7454 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
7462 C...Start by assuming incoming photon is entering subprocess.
7463 IF(MINT(11).EQ.22) THEN
7465 VINT(307)=VINT(3)**2
7467 IF(MINT(12).EQ.22) THEN
7469 VINT(308)=VINT(4)**2
7474 C...Choice of process type - first event of pileup.
7476 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
7477 ELSEIF(MINT(82).EQ.1) THEN
7479 C...For gamma-p or gamma-gamma first pick between alternatives.
7481 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
7484 C...For real gamma + gamma with different nature, flip at random.
7485 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
7486 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
7496 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
7499 C...Pick process type, possibly by user process machinery.
7500 C...(If the latter, also event will be picked here.)
7501 IF(MINT(111).EQ.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
7503 ELSEIF(MINT(111).EQ.11.AND.IABS(IDWTUP).GE.3) THEN
7507 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
7508 & ISUB.LT.500) GOTO 110
7510 RSUB=XSEC(0,1)*PYR(0)
7512 IF(MSUB(I).NE.1) GOTO 120
7515 IF(RSUB.LE.0D0) GOTO 130
7517 130 IF(ISUB.EQ.95) ISUB=96
7518 IF(ISUB.EQ.96) INMULT=1
7519 IF(ISET(ISUB).EQ.11) THEN
7525 C...Choice of inclusive process type - pileup events.
7526 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
7527 RSUB=VINT(131)*PYR(0)
7529 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
7530 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
7531 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
7532 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
7534 IF(ISUB.EQ.96) INMULT=1
7537 C...Choice of photon energy and flux factor inside lepton.
7538 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
7539 CALL PYGAGA(3,WTGAGA)
7540 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
7541 CKIN(3)=MAX(VINT(285),VINT(154))
7544 C...When necessary set direct/resolved photon by hand.
7545 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
7546 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
7547 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
7550 C...Restrict direct*resolved processes to pTmin >= Q,
7551 C...to avoid doublecounting with DIS.
7552 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
7553 IF(MINT(15).EQ.22) THEN
7554 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
7556 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
7561 C...Set up for multiple interactions.
7562 IF(INMULT.EQ.1) CALL PYMULT(2)
7564 C...Loopback point for minimum bias in photon physics.
7567 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
7568 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
7569 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
7570 &NGEN(97,1)=NGEN(97,1)+MINT(143)
7574 C...Random choice of flavour for some SUSY processes.
7575 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
7576 C...~e_L ~nu_e or ~mu_L ~nu_mu.
7577 IF(ISUB.EQ.210) THEN
7578 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
7579 KFPR(ISUB,2)=KFPR(ISUB,1)+1
7580 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
7581 ELSEIF(ISUB.EQ.213) THEN
7582 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
7583 KFPR(ISUB,2)=KFPR(ISUB,1)
7584 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
7585 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
7586 IF(ISUB.GE.258) THEN
7591 IF(MOD(ISUB,2).EQ.0) THEN
7592 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
7594 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
7596 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7597 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
7598 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
7601 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
7604 ELSEIF(PYR(0).LT.0.5D0) THEN
7611 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
7612 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
7613 C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
7614 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
7615 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
7616 KFPR(ISUB,2)=KFPR(ISUB,1)
7617 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
7618 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
7619 KFPR(ISUB,2)=KFPR(ISUB,1)
7620 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7621 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
7622 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
7625 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
7628 ELSEIF(PYR(0).LT.0.5D0) THEN
7635 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
7640 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
7644 C...Find resonances (explicit or implicit in cross-section).
7647 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7649 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
7650 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7652 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
7655 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7657 IF(MSTP(46).EQ.5) THEN
7660 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7662 ELSEIF(ISUB.EQ.194) THEN
7664 ELSEIF(ISUB.EQ.195) THEN
7666 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
7668 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
7672 IF(CKMX.LE.0D0) CKMX=VINT(1)
7675 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7676 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7679 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7680 IF(KFR1.EQ.KTECHN+113) THEN
7684 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7690 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
7693 IF(ISUB.EQ.194) THEN
7695 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
7699 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7700 IF(KFR2.EQ.KTECHN+223) THEN
7704 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7705 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7706 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
7707 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7712 ELSEIF(KFR2.NE.0) THEN
7723 C...Find product masses and minimum pT of process,
7724 C...optionally with broadening according to a truncated Breit-Wigner.
7729 IF(MINT(82).GE.2) VINT(71)=0D0
7731 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7735 IF(KFPR(ISUB,I).EQ.0) THEN
7736 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7738 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7741 C...This prevents SUSY/t particles from becoming too light.
7743 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7746 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7747 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7748 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7749 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7750 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7751 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7752 PMMN(I)=MIN(PMMN(I),PMSUM)
7755 ELSEIF(KFLW.EQ.6) THEN
7756 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7763 CKIN(41)=MAX(PMMN(1),CKIN(41))
7764 CKIN(43)=MAX(PMMN(2),CKIN(43))
7765 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7768 IF(MINT(51).EQ.1) THEN
7769 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7779 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
7780 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7783 C...Prepare for additional variable choices in 2 -> 3.
7786 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7788 VINT(204)=PMAS(23,1)
7789 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7790 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7791 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
7792 & ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
7796 C...Select incoming VDM particle (rho/omega/phi/J/psi).
7797 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
7798 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
7799 VRN=PYR(0)*SIGT(0,0,5)
7800 IF(MINT(101).LE.1) THEN
7807 IF(MINT(102).LE.1) THEN
7818 VRN=VRN-SIGT(I1,I2,5)
7819 IF(VRN.LE.0D0) GOTO 190
7822 190 IF(MINT(101).GE.2) MINT(103)=KFV1
7823 IF(MINT(102).GE.2) MINT(104)=KFV2
7827 C...Elastic scattering or single or double diffractive scattering.
7829 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
7834 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
7836 VRN=PYR(0)*SIGT(0,0,JJ)
7837 IF(MINT(101).LE.1) THEN
7844 IF(MINT(102).LE.1) THEN
7855 VRN=VRN-SIGT(I1,I2,JJ)
7856 IF(VRN.LE.0D0) GOTO 220
7859 220 IF(MINT(101).GE.2) THEN
7863 IF(MINT(102).GE.2) THEN
7871 C...Select mass for GVMD states (rejecting previous assignment).
7873 Q1S=4D0*VINT(154)**2
7877 IF(MINT(106+JT).EQ.3) THEN
7879 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
7880 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
7881 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
7882 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
7885 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
7886 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
7891 C...Side/sides of diffractive system.
7894 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
7895 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
7897 C...Find masses of particles and minimal masses of diffractive states.
7900 VINT(68+JT)=PDIF(JT)
7901 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
7908 SMRES1=(PMM(1)+PMRC)**2
7909 SMRES2=(PMM(2)+PMRC)**2
7911 C...Find elastic slope and lower limit diffractive slope.
7912 IHA=MAX(2,IABS(MINT(103))/110)
7914 IHB=MAX(2,IABS(MINT(104))/110)
7917 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
7918 ELSEIF(ISUB.EQ.92) THEN
7919 BMN=MAX(2D0,2D0*BHAD(IHB))
7920 ELSEIF(ISUB.EQ.93) THEN
7921 BMN=MAX(2D0,2D0*BHAD(IHA))
7922 ELSEIF(ISUB.EQ.94) THEN
7926 C...Determine maximum possible t range and coefficient of generation.
7927 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
7928 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7929 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7930 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7931 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7932 & (SQM1*SQM4-SQM2*SQM3)/SH
7933 THL=-0.5D0*(THA+THB)
7935 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
7937 C...Select diffractive mass/masses according to dm^2/m^2.
7941 IF(MINT(16+JT).EQ.0) THEN
7945 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
7946 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
7952 C..Additional mass factors, including resonance enhancement.
7953 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
7954 IF(LOOP3.LT.100) GOTO 260
7958 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
7959 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7960 ELSEIF(ISUB.EQ.93) THEN
7961 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
7962 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7963 ELSEIF(ISUB.EQ.94) THEN
7964 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
7965 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
7966 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
7967 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
7970 C...Select t according to exp(Bmn*t) and correct to right slope.
7971 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
7974 BADD=2D0*ALP*LOG(SH/SQM3)
7975 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
7976 ELSEIF(ISUB.EQ.93) THEN
7977 BADD=2D0*ALP*LOG(SH/SQM4)
7978 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
7979 ELSEIF(ISUB.EQ.94) THEN
7980 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
7982 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
7985 C...Check whether m^2 and t choices are consistent.
7986 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7987 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7988 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7989 IF(THB.LE.1D-8) GOTO 260
7990 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7991 & (SQM1*SQM4-SQM2*SQM3)/SH
7992 THLM=-0.5D0*(THA+THB)
7994 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
7996 C...Information to output.
7999 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
8001 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
8004 VINT(283)=PMM(1)**2/4D0
8005 VINT(284)=PMM(2)**2/4D0
8007 C...Note: in the following, by In is meant the integral over the
8008 C...quantity multiplying coefficient cn.
8009 C...Choose tau according to h1(tau)/tau, where
8010 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
8011 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
8012 C...I1/I5*c5*1/(tau+tau_R') +
8013 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
8014 C...I1/I7*c7*tau/(1.-tau), and
8015 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
8016 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
8018 IF(MINT(51).NE.0) THEN
8019 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8028 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
8029 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
8030 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
8031 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
8033 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
8034 & COEF(ISUB,5)) MTAU=6
8035 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
8036 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
8037 CALL PYKMAP(1,MTAU,PYR(0))
8039 C...2 -> 3, 4 processes:
8040 C...Choose tau' according to h4(tau,tau')/tau', where
8041 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
8042 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
8043 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8045 IF(MINT(51).NE.0) THEN
8046 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8055 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
8056 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
8057 CALL PYKMAP(4,MTAUP,PYR(0))
8060 C...Choose y* according to h2(y*), where
8061 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
8062 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
8063 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
8064 C...and c1 + c2 + c3 + c4 + c5 = 1.
8066 IF(MINT(51).NE.0) THEN
8067 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8076 IF(RYST.GT.COEF(ISUB,8)) MYST=2
8077 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
8078 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
8079 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
8080 & COEF(ISUB,11)) MYST=5
8081 CALL PYKMAP(2,MYST,PYR(0))
8083 C...2 -> 2 processes:
8084 C...Choose cos(theta-hat) (cth) according to h3(cth), where
8085 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
8086 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
8087 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
8088 C...and c0 + c1 + c2 + c3 + c4 = 1.
8090 IF(MINT(51).NE.0) THEN
8091 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8098 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
8101 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
8102 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
8103 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
8104 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
8105 & COEF(ISUB,16)) MCTH=5
8106 CALL PYKMAP(3,MCTH,PYR(0))
8109 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
8111 CALL PYKMAP(5,0,0D0)
8112 IF(MINT(51).NE.0) THEN
8113 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8122 C...DIS as f + gamma* -> f process: set dummy values.
8123 ELSEIF(ISTSB.EQ.8) THEN
8130 C...Low-pT or multiple interactions (first semihard interaction).
8131 ELSEIF(ISTSB.EQ.9) THEN
8135 C...Study user-defined process: kinematics plus weight.
8136 ELSEIF(ISTSB.EQ.11) THEN
8137 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
8138 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
8143 IF(MINT(82).EQ.1) THEN
8144 NGEN(0,1)=NGEN(0,1)-1
8145 NGEN(ISUB,1)=NGEN(ISUB,1)-1
8147 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8151 C...Extract cross section event weight.
8152 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
8155 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
8157 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
8158 VINT(97)=SIGN(1D0,XWGTUP)
8160 VINT(97)=1D-9*XWGTUP
8163 C...Construct 'trivial' kinematical variables needed.
8166 VINT(41)=PUP(4,1)/EBMUP(1)
8167 VINT(42)=PUP(4,2)/EBMUP(2)
8168 VINT(21)=VINT(41)*VINT(42)
8169 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
8170 VINT(44)=VINT(21)*VINT(2)
8171 VINT(43)=SQRT(MAX(0D0,VINT(44)))
8173 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
8174 VINT(56)=VINT(55)**2
8178 C...Construct other kinematical variables needed (approximately).
8181 VINT(45)=-0.5D0*VINT(44)
8182 VINT(46)=-0.5D0*VINT(44)
8191 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
8192 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
8194 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
8195 & '(PYRAND:) unacceptable ISTUP code for particles')
8196 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
8197 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
8198 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
8201 VINT(47)=SQRT(VINT(48))
8204 C...Choose azimuthal angle.
8206 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
8208 C...Check against user cuts on kinematics at parton level.
8210 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
8211 IF(MINT(51).NE.0) THEN
8212 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8219 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
8221 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
8224 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8233 C...Calculate differential cross-section for different subprocesses.
8234 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
8236 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
8238 C...Multiply cross section by lepton -> photon flux factor.
8239 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
8242 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
8244 SIGLPT=WTGAGA*SIGLPT
8247 C...Multiply cross-section by user-defined weights.
8248 IF(MSTP(173).EQ.1) THEN
8251 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
8253 SIGLPT=PARP(173)*SIGLPT
8259 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
8260 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
8261 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
8264 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
8267 C...Calculations for Monte Carlo estimate of all cross-sections.
8268 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
8269 IF(MSTP(142).LE.1) THEN
8270 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8272 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
8274 ELSEIF(MINT(82).EQ.1) THEN
8275 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8277 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
8278 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
8280 C...Multiple interactions: store results of cross-section calculation.
8281 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
8286 C...Ratio of actual to maximum cross section.
8287 IF(ISTSB.NE.11) THEN
8288 VIOL=SIGSWT/XSEC(ISUB,1)
8289 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
8290 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
8291 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
8292 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
8293 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
8298 C...Check that weight not negative.
8299 IF(MSTP(123).LE.0) THEN
8300 IF(VIOL.LT.-1D-3) THEN
8301 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
8302 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8303 & VINT(22),VINT(23),VINT(26)
8307 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
8309 WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
8310 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8311 & VINT(22),VINT(23),VINT(26)
8315 C...Weighting using estimate of maximum of differential cross-section.
8316 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
8317 IF(VIOL.LT.PYR(0)) THEN
8318 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8319 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
8322 ELSEIF(MFAIL.EQ.0) THEN
8323 RATND=SIGLPT/XSEC(95,1)
8325 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
8326 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
8327 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
8328 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8332 IF(VIOL.LT.PYR(0)) THEN
8335 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
8336 IF(VIOL.LT.PYR(0)) THEN
8338 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8342 RATND=SIGLPT/XSEC(95,1)
8343 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
8345 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8349 IF(VIOL.LT.PYR(0)) THEN
8350 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8355 C...Check for possible violation of estimated maximum of differential
8356 C...cross-section used in weighting.
8357 IF(MSTP(123).LE.0) THEN
8358 IF(VIOL.GT.1D0) THEN
8359 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
8360 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8361 & VINT(22),VINT(23),VINT(26)
8364 ELSEIF(MSTP(123).EQ.1) THEN
8365 IF(VIOL.GT.VINT(108)) THEN
8367 IF(VIOL.GT.1.0001D0) THEN
8369 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8370 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8371 & VINT(22),VINT(23),VINT(26)
8374 ELSEIF(VIOL.GT.VINT(108)) THEN
8376 IF(VIOL.GT.1D0) THEN
8378 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8379 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
8381 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
8382 IF(KFPR(ISUB,1).LE.9) THEN
8383 WRITE(MSTU(11),5800) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8384 ELSEIF(KFPR(ISUB,1).LE.99) THEN
8385 WRITE(MSTU(11),5900) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8387 WRITE(MSTU(11),6000) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8390 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
8391 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
8392 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
8393 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
8394 & XSEC(0,1)=XSEC(0,1)+XDIF
8395 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8396 & VINT(22),VINT(23),VINT(26)
8398 WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
8399 ELSEIF(ISUB.LE.99) THEN
8400 WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
8402 WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
8409 C...Multiple interactions: choose impact parameter.
8411 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
8412 &MSTP(82).GE.3) THEN
8414 IF(VINT(150).LT.PYR(0)) THEN
8415 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8423 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
8424 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
8425 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
8426 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
8428 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
8430 C...Choose flavour of reacting partons (and subprocess).
8431 IF(ISTSB.GE.11) GOTO 320
8434 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
8435 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
8436 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
8437 &PYR(0).GT.RQQBAR)) THEN
8441 MINT(2)=ISIG(ICHN,3)
8442 RSIGS=RSIGS-SIGH(ICHN)
8443 IF(RSIGS.LE.0D0) GOTO 320
8446 C...Multiple interactions: choose qqbar preferentially at small pT.
8447 ELSEIF(ISUB.EQ.96) THEN
8450 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
8453 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
8456 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
8458 C...Low-pT: choose string drawing configuration.
8464 IF(RSIGS.GT.1D0) MINT(2)=2
8465 IF(RSIGS.GT.2D0) MINT(2)=3
8468 C...Reassign QCD process. Partons before initial state radiation.
8469 320 IF(MINT(2).GT.10) THEN
8471 MINT(2)=MOD(MINT(2),10)
8473 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
8484 C...Calculate x value of photon for parton inside photon inside e.
8489 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
8490 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
8491 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
8496 MINT(105)=MINT(102+JT)
8497 MINT(109)=MINT(106+JT)
8498 VINT(120)=VINT(2+JT)
8499 IF(MSTP(57).LE.1) THEN
8500 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
8502 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
8505 IF(MSTP(13).EQ.2) THEN
8506 Q2PMS=Q2HRD/PMAS(11,1)**2
8507 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
8510 XG=MIN(1D0-1D-10,XHRD/XE)
8511 IF(MSTP(57).LE.1) THEN
8512 CALL PYPDFU(22,XG,Q2HRD,XPQ)
8514 CALL PYPDFL(22,XG,Q2HRD,XPQ)
8516 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
8517 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
8518 IF(WT.LT.PYR(0)*WTMX) GOTO 330
8522 XSFX(JT,KFLS)=XPQ(KFLS)
8527 C...Pick scale where photon is resolved.
8531 IF(MINT(107).EQ.3) THEN
8532 IF(MSTP(66).EQ.1) THEN
8533 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
8534 ELSEIF(MSTP(66).EQ.2) THEN
8536 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8537 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8538 Q2INT=SQRT(Q0S*Q2EFF)
8539 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8540 ELSEIF(MSTP(66).EQ.3) THEN
8541 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
8542 ELSEIF(MSTP(66).GE.4) THEN
8543 PS=0.25D0*VINT(3)**2
8544 VINT(283)=(Q0S+PS)*(Q1S+PS)/
8545 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8549 IF(MINT(108).EQ.3) THEN
8550 IF(MSTP(66).EQ.1) THEN
8551 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
8552 ELSEIF(MSTP(66).EQ.2) THEN
8554 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8555 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8556 Q2INT=SQRT(Q0S*Q2EFF)
8557 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8558 ELSEIF(MSTP(66).EQ.3) THEN
8559 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
8560 ELSEIF(MSTP(66).GE.4) THEN
8561 PS=0.25D0*VINT(4)**2
8562 VINT(284)=(Q0S+PS)*(Q1S+PS)/
8563 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8566 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8568 C...Format statements for differential cross-section maximum violations.
8569 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
8570 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8571 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
8572 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
8573 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
8575 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
8576 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8577 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
8579 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
8580 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
8581 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
8582 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
8583 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
8584 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
8589 C*********************************************************************
8592 C...Finds outgoing flavours and event type; sets up the kinematics
8593 C...and colour flow of the hard scattering
8597 C...Double precision and integer declarations
8598 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8599 IMPLICIT INTEGER(I-N)
8600 INTEGER PYK,PYCHGE,PYCOMP
8601 C...Parameter statement to help give large particle numbers.
8602 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
8603 &KEXCIT=4000000,KDIMEN=5000000)
8605 C...User process event common block.
8607 PARAMETER (MAXNUP=500)
8608 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
8609 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
8610 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
8611 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
8612 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
8616 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8617 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8618 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8619 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
8620 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8621 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8622 COMMON/PYINT1/MINT(400),VINT(400)
8623 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8624 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8625 COMMON/PYINT4/MWID(500),WIDS(500,5)
8626 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8627 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
8628 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
8629 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
8630 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
8631 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,/PYTCSM/
8632 C...Local arrays and saved variables
8633 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
8634 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
8637 C...Read out process
8641 C...Restore information for low-pT processes
8642 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
8644 100 VINT(J)=VINTSV(J)
8647 C...Convert H' or A process into equivalent H one
8650 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
8653 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
8655 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
8656 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
8657 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
8658 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
8659 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
8660 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
8661 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
8662 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
8663 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
8664 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
8665 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
8666 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
8669 C...Choice of subprocess, number of documentation lines
8671 IF(ISUB.EQ.95) IDOC=8
8672 IF(ISET(ISUB).EQ.5) IDOC=9
8673 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
8675 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
8684 C...Reset K, P and V vectors. Store incoming particles
8685 DO 120 JT=1,MSTP(126)+100
8687 IF(I.GT.MSTU(4)) GOTO 120
8699 P(I,J)=VINT(285+5*JT+J)
8705 C...Store incoming partons in their CM-frame
8708 SHP=VINT(26)*VINT(2)
8711 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
8716 K(I,3)=MINT(83)+2+JT
8717 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
8721 C...Copy incoming partons to documentation lines
8733 C...Choose new quark/lepton flavour for relevant annihilation graphs
8734 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
8735 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
8737 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
8738 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
8739 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
8740 DO 190 I=1,MDCY(IGLGA,3)
8741 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
8742 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
8743 IF(RKFL.LE.0D0) GOTO 200
8746 IF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.2) THEN
8747 IF(KFLF.GE.4) GOTO 180
8748 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.4) THEN
8751 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385) THEN
8754 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
8755 & .AND.IABS(KFLF).GE.3) THEN
8756 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
8758 FACCIB=VINT(46)**2/RTCM(41)**4
8759 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
8760 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
8763 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
8764 IF(KFLF.EQ.5) GOTO 180
8765 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
8766 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
8767 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
8768 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
8772 C...Final state flavours and colour flow: default values
8779 KCS=ISIGN(1,MINT(15))
8781 IF(ISET(ISUB).EQ.11) THEN
8782 C...User-defined processes: find products
8785 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
8786 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
8787 MINT(21+IUP)=IDUP(IUP)
8788 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
8789 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
8790 ELSEIF(IDUP(IUP).EQ.0) THEN
8793 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
8797 ELSEIF(ISUB.LE.10) THEN
8799 C...f + fbar -> gamma*/Z0
8802 ELSEIF(ISUB.EQ.2) THEN
8803 C...f + fbar' -> W+/-
8804 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8805 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8806 KFRES=ISIGN(24,KCH1+KCH2)
8808 ELSEIF(ISUB.EQ.3) THEN
8809 C...f + fbar -> h0 (or H0, or A0)
8812 ELSEIF(ISUB.EQ.4) THEN
8813 C...gamma + W+/- -> W+/-
8815 ELSEIF(ISUB.EQ.5) THEN
8820 PMQ(1)=PYMASS(MINT(21))
8821 PMQ(2)=PYMASS(MINT(22))
8822 220 JT=INT(1.5D0+PYR(0))
8823 ZMIN=2D0*PMQ(JT)/SHPR
8824 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8825 & (SHPR*(SHPR-PMQ(3-JT)))
8826 ZMAX=MIN(1D0-XH,ZMAX)
8827 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8828 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8829 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
8830 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8831 IF(SQC1.LT.1D-8) GOTO 220
8833 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8834 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8835 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8836 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8837 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8838 IF(SQC1.LT.1D-8) GOTO 220
8840 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8841 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8842 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8845 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8846 & SQRT(1D0-CTHE(2)**2)*CPHI
8848 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8849 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8850 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8851 & PMQ(3-JT)**2/SHP))
8852 ZMIN=2D0*PMQ(3-JT)/SHPR
8853 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8854 ZMAX=MIN(1D0-XH,ZMAX)
8855 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
8859 ELSEIF(ISUB.EQ.6) THEN
8860 C...Z0 + W+/- -> W+/-
8862 ELSEIF(ISUB.EQ.7) THEN
8865 ELSEIF(ISUB.EQ.8) THEN
8872 RVCKM=VINT(180+I)*PYR(0)
8875 IPM=(5-ISIGN(1,I))/2
8877 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
8878 MINT(20+JT)=ISIGN(IB,I)
8879 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8880 IF(RVCKM.LE.0D0) GOTO 250
8883 IB=2*((IA+1)/2)-1+MOD(IA,2)
8884 MINT(20+JT)=ISIGN(IB,I)
8886 250 PMQ(JT)=PYMASS(MINT(20+JT))
8888 JT=INT(1.5D0+PYR(0))
8889 ZMIN=2D0*PMQ(JT)/SHPR
8890 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8891 & (SHPR*(SHPR-PMQ(3-JT)))
8892 ZMAX=MIN(1D0-XH,ZMAX)
8893 IF(ZMIN.GE.ZMAX) GOTO 230
8894 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8895 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8896 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
8897 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8898 IF(SQC1.LT.1D-8) GOTO 230
8900 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8901 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8902 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8903 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8904 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8905 IF(SQC1.LT.1D-8) GOTO 230
8907 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8908 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8909 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8912 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8913 & SQRT(1D0-CTHE(2)**2)*CPHI
8915 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8916 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8917 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8918 & PMQ(3-JT)**2/SHP))
8919 ZMIN=2D0*PMQ(3-JT)/SHPR
8920 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8921 ZMAX=MIN(1D0-XH,ZMAX)
8922 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
8926 ELSEIF(ISUB.EQ.10) THEN
8927 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
8928 IF(MINT(2).EQ.1) THEN
8931 C...W exchange: need to mix flavours according to CKM matrix
8936 RVCKM=VINT(180+I)*PYR(0)
8939 IPM=(5-ISIGN(1,I))/2
8941 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
8942 MINT(20+JT)=ISIGN(IB,I)
8943 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8944 IF(RVCKM.LE.0D0) GOTO 280
8947 IB=2*((IA+1)/2)-1+MOD(IA,2)
8948 MINT(20+JT)=ISIGN(IB,I)
8955 ELSEIF(ISUB.LE.20) THEN
8957 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
8959 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8961 ELSEIF(ISUB.EQ.12) THEN
8962 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
8963 MINT(21)=ISIGN(KFLF,MINT(15))
8967 ELSEIF(ISUB.EQ.13) THEN
8968 C...f + fbar -> g + g; th arbitrary
8973 ELSEIF(ISUB.EQ.14) THEN
8974 C...f + fbar -> g + gamma; th arbitrary
8975 IF(PYR(0).GT.0.5D0) JS=2
8980 ELSEIF(ISUB.EQ.15) THEN
8981 C...f + fbar -> g + Z0; th arbitrary
8982 IF(PYR(0).GT.0.5D0) JS=2
8987 ELSEIF(ISUB.EQ.16) THEN
8988 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8989 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8990 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8991 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8993 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8996 ELSEIF(ISUB.EQ.17) THEN
8997 C...f + fbar -> g + h0; th arbitrary
8998 IF(PYR(0).GT.0.5D0) JS=2
9003 ELSEIF(ISUB.EQ.18) THEN
9004 C...f + fbar -> gamma + gamma; th arbitrary
9008 ELSEIF(ISUB.EQ.19) THEN
9009 C...f + fbar -> gamma + Z0; th arbitrary
9010 IF(PYR(0).GT.0.5D0) JS=2
9014 ELSEIF(ISUB.EQ.20) THEN
9015 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
9016 C...(p(fbar')-p(W+))**2
9017 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9018 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9019 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
9021 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
9024 ELSEIF(ISUB.LE.30) THEN
9026 C...f + fbar -> gamma + h0; th arbitrary
9027 IF(PYR(0).GT.0.5D0) JS=2
9031 ELSEIF(ISUB.EQ.22) THEN
9032 C...f + fbar -> Z0 + Z0; th arbitrary
9036 ELSEIF(ISUB.EQ.23) THEN
9037 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
9038 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9039 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9040 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
9042 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
9044 ELSEIF(ISUB.EQ.24) THEN
9045 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
9046 IF(PYR(0).GT.0.5D0) JS=2
9050 ELSEIF(ISUB.EQ.25) THEN
9051 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
9052 MINT(21)=-ISIGN(24,MINT(15))
9055 ELSEIF(ISUB.EQ.26) THEN
9056 C...f + fbar' -> W+/- + h0 (or H0, or A0);
9057 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
9058 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9059 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9060 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
9061 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
9064 ELSEIF(ISUB.EQ.27) THEN
9065 C...f + fbar -> h0 + h0
9067 ELSEIF(ISUB.EQ.28) THEN
9068 C...f + g -> f + g; th = (p(f)-p(f))**2
9069 IF(MINT(15).EQ.21) JS=2
9071 IF(MINT(15).EQ.21) KCC=KCC+2
9072 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
9073 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
9075 ELSEIF(ISUB.EQ.29) THEN
9076 C...f + g -> f + gamma; th = (p(f)-p(f))**2
9077 IF(MINT(15).EQ.21) JS=2
9080 KCS=ISIGN(1,MINT(14+JS))
9082 ELSEIF(ISUB.EQ.30) THEN
9083 C...f + g -> f + Z0; th = (p(f)-p(f))**2
9084 IF(MINT(15).EQ.21) JS=2
9087 KCS=ISIGN(1,MINT(14+JS))
9090 ELSEIF(ISUB.LE.40) THEN
9092 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
9093 IF(MINT(15).EQ.21) JS=2
9096 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
9097 RVCKM=VINT(180+I)*PYR(0)
9100 IPM=(5-ISIGN(1,I))/2
9102 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
9103 MINT(20+JS)=ISIGN(IB,I)
9104 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9105 IF(RVCKM.LE.0D0) GOTO 300
9108 KCS=ISIGN(1,MINT(14+JS))
9110 ELSEIF(ISUB.EQ.32) THEN
9111 C...f + g -> f + h0; th = (p(f)-p(f))**2
9112 IF(MINT(15).EQ.21) JS=2
9115 KCS=ISIGN(1,MINT(14+JS))
9117 ELSEIF(ISUB.EQ.33) THEN
9118 C...f + gamma -> f + g; th=(p(f)-p(f))**2
9119 IF(MINT(15).EQ.22) JS=2
9122 KCS=ISIGN(1,MINT(14+JS))
9124 ELSEIF(ISUB.EQ.34) THEN
9125 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
9126 IF(MINT(15).EQ.22) JS=2
9128 KCS=ISIGN(1,MINT(14+JS))
9130 ELSEIF(ISUB.EQ.35) THEN
9131 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
9132 IF(MINT(15).EQ.22) JS=2
9136 ELSEIF(ISUB.EQ.36) THEN
9137 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
9138 IF(MINT(15).EQ.22) JS=2
9141 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
9143 RVCKM=VINT(180+I)*PYR(0)
9146 IPM=(5-ISIGN(1,I))/2
9148 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
9149 MINT(20+JS)=ISIGN(IB,I)
9150 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9151 IF(RVCKM.LE.0D0) GOTO 320
9154 IB=2*((IA+1)/2)-1+MOD(IA,2)
9155 MINT(20+JS)=ISIGN(IB,I)
9159 ELSEIF(ISUB.EQ.37) THEN
9160 C...f + gamma -> f + h0
9162 ELSEIF(ISUB.EQ.38) THEN
9165 ELSEIF(ISUB.EQ.39) THEN
9166 C...f + Z0 -> f + gamma
9168 ELSEIF(ISUB.EQ.40) THEN
9169 C...f + Z0 -> f + Z0
9172 ELSEIF(ISUB.LE.50) THEN
9174 C...f + Z0 -> f' + W+/-
9176 ELSEIF(ISUB.EQ.42) THEN
9177 C...f + Z0 -> f + h0
9179 ELSEIF(ISUB.EQ.43) THEN
9180 C...f + W+/- -> f' + g
9182 ELSEIF(ISUB.EQ.44) THEN
9183 C...f + W+/- -> f' + gamma
9185 ELSEIF(ISUB.EQ.45) THEN
9186 C...f + W+/- -> f' + Z0
9188 ELSEIF(ISUB.EQ.46) THEN
9189 C...f + W+/- -> f' + W+/-
9191 ELSEIF(ISUB.EQ.47) THEN
9192 C...f + W+/- -> f' + h0
9194 ELSEIF(ISUB.EQ.48) THEN
9197 ELSEIF(ISUB.EQ.49) THEN
9198 C...f + h0 -> f + gamma
9200 ELSEIF(ISUB.EQ.50) THEN
9201 C...f + h0 -> f + Z0
9204 ELSEIF(ISUB.LE.60) THEN
9206 C...f + h0 -> f' + W+/-
9208 ELSEIF(ISUB.EQ.52) THEN
9209 C...f + h0 -> f + h0
9211 ELSEIF(ISUB.EQ.53) THEN
9212 C...g + g -> f + fbar; th arbitrary
9213 KCS=(-1)**INT(1.5D0+PYR(0))
9214 MINT(21)=ISIGN(KFLF,KCS)
9218 ELSEIF(ISUB.EQ.54) THEN
9219 C...g + gamma -> f + fbar; th arbitrary
9220 KCS=(-1)**INT(1.5D0+PYR(0))
9221 MINT(21)=ISIGN(KFLF,KCS)
9224 IF(MINT(16).EQ.21) KCC=28
9226 ELSEIF(ISUB.EQ.55) THEN
9227 C...g + Z0 -> f + fbar
9229 ELSEIF(ISUB.EQ.56) THEN
9230 C...g + W+/- -> f + fbar'
9232 ELSEIF(ISUB.EQ.57) THEN
9233 C...g + h0 -> f + fbar
9235 ELSEIF(ISUB.EQ.58) THEN
9236 C...gamma + gamma -> f + fbar; th arbitrary
9237 KCS=(-1)**INT(1.5D0+PYR(0))
9238 MINT(21)=ISIGN(KFLF,KCS)
9242 ELSEIF(ISUB.EQ.59) THEN
9243 C...gamma + Z0 -> f + fbar
9245 ELSEIF(ISUB.EQ.60) THEN
9246 C...gamma + W+/- -> f + fbar'
9249 ELSEIF(ISUB.LE.70) THEN
9251 C...gamma + h0 -> f + fbar
9253 ELSEIF(ISUB.EQ.62) THEN
9254 C...Z0 + Z0 -> f + fbar
9256 ELSEIF(ISUB.EQ.63) THEN
9257 C...Z0 + W+/- -> f + fbar'
9259 ELSEIF(ISUB.EQ.64) THEN
9260 C...Z0 + h0 -> f + fbar
9262 ELSEIF(ISUB.EQ.65) THEN
9263 C...W+ + W- -> f + fbar
9265 ELSEIF(ISUB.EQ.66) THEN
9266 C...W+/- + h0 -> f + fbar'
9268 ELSEIF(ISUB.EQ.67) THEN
9269 C...h0 + h0 -> f + fbar
9271 ELSEIF(ISUB.EQ.68) THEN
9272 C...g + g -> g + g; th arbitrary
9274 KCS=(-1)**INT(1.5D0+PYR(0))
9276 ELSEIF(ISUB.EQ.69) THEN
9277 C...gamma + gamma -> W+ + W-; th arbitrary
9282 ELSEIF(ISUB.EQ.70) THEN
9283 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
9284 IF(MINT(15).EQ.22) MINT(21)=23
9285 IF(MINT(16).EQ.22) MINT(22)=23
9289 ELSEIF(ISUB.LE.80) THEN
9290 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
9291 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
9295 PMQ(1)=PYMASS(MINT(21))
9296 PMQ(2)=PYMASS(MINT(22))
9297 330 JT=INT(1.5D0+PYR(0))
9298 ZMIN=2D0*PMQ(JT)/SHPR
9299 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9300 & (SHPR*(SHPR-PMQ(3-JT)))
9301 ZMAX=MIN(1D0-XH,ZMAX)
9302 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9303 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9304 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
9305 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9306 IF(SQC1.LT.1D-8) GOTO 330
9308 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9309 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9310 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9311 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9312 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9313 IF(SQC1.LT.1D-8) GOTO 330
9315 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9316 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9317 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9320 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9321 & SQRT(1D0-CTHE(2)**2)*CPHI
9323 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9324 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9325 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9326 & PMQ(3-JT)**2/SHP))
9327 ZMIN=2D0*PMQ(3-JT)/SHPR
9328 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9329 ZMAX=MIN(1D0-XH,ZMAX)
9330 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
9333 ELSEIF(ISUB.EQ.73) THEN
9334 C...Z0 + W+/- -> Z0 + W+/-
9341 RVCKM=VINT(180+I)*PYR(0)
9344 IPM=(5-ISIGN(1,I))/2
9346 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
9347 MINT(20+JT)=ISIGN(IB,I)
9348 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9349 IF(RVCKM.LE.0D0) GOTO 360
9352 IB=2*((IA+1)/2)-1+MOD(IA,2)
9353 MINT(20+JT)=ISIGN(IB,I)
9355 360 PMQ(JT)=PYMASS(MINT(20+JT))
9356 MINT(23-JT)=MINT(17-JT)
9357 PMQ(3-JT)=PYMASS(MINT(23-JT))
9358 JT=INT(1.5D0+PYR(0))
9359 ZMIN=2D0*PMQ(JT)/SHPR
9360 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9361 & (SHPR*(SHPR-PMQ(3-JT)))
9362 ZMAX=MIN(1D0-XH,ZMAX)
9363 IF(ZMIN.GE.ZMAX) GOTO 340
9364 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9365 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9366 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
9367 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9368 IF(SQC1.LT.1D-8) GOTO 340
9370 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9371 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9372 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9373 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9374 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9375 IF(SQC1.LT.1D-8) GOTO 340
9377 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9378 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9379 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9382 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9383 & SQRT(1D0-CTHE(2)**2)*CPHI
9385 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9386 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9387 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9388 & PMQ(3-JT)**2/SHP))
9389 ZMIN=2D0*PMQ(3-JT)/SHPR
9390 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9391 ZMAX=MIN(1D0-XH,ZMAX)
9392 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
9395 ELSEIF(ISUB.EQ.74) THEN
9396 C...Z0 + h0 -> Z0 + h0
9398 ELSEIF(ISUB.EQ.75) THEN
9399 C...W+ + W- -> gamma + gamma
9401 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
9402 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
9408 RVCKM=VINT(180+I)*PYR(0)
9411 IPM=(5-ISIGN(1,I))/2
9413 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
9414 MINT(20+JT)=ISIGN(IB,I)
9415 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9416 IF(RVCKM.LE.0D0) GOTO 390
9419 IB=2*((IA+1)/2)-1+MOD(IA,2)
9420 MINT(20+JT)=ISIGN(IB,I)
9422 390 PMQ(JT)=PYMASS(MINT(20+JT))
9424 JT=INT(1.5D0+PYR(0))
9425 ZMIN=2D0*PMQ(JT)/SHPR
9426 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9427 & (SHPR*(SHPR-PMQ(3-JT)))
9428 ZMAX=MIN(1D0-XH,ZMAX)
9429 IF(ZMIN.GE.ZMAX) GOTO 370
9430 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9431 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9432 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
9433 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9434 IF(SQC1.LT.1D-8) GOTO 370
9436 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9437 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9438 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9439 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9440 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9441 IF(SQC1.LT.1D-8) GOTO 370
9443 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9444 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9445 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9448 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9449 & SQRT(1D0-CTHE(2)**2)*CPHI
9451 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9452 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9453 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9454 & PMQ(3-JT)**2/SHP))
9455 ZMIN=2D0*PMQ(3-JT)/SHPR
9456 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9457 ZMAX=MIN(1D0-XH,ZMAX)
9458 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
9461 ELSEIF(ISUB.EQ.78) THEN
9462 C...W+/- + h0 -> W+/- + h0
9464 ELSEIF(ISUB.EQ.79) THEN
9465 C...h0 + h0 -> h0 + h0
9467 ELSEIF(ISUB.EQ.80) THEN
9468 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
9469 IF(MINT(15).EQ.22) JS=2
9472 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
9474 MINT(20+JS)=ISIGN(IB,I)
9478 ELSEIF(ISUB.LE.90) THEN
9480 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
9481 MINT(21)=ISIGN(MINT(55),MINT(15))
9485 ELSEIF(ISUB.EQ.82) THEN
9486 C...g + g -> Q + Qbar; th arbitrary
9487 KCS=(-1)**INT(1.5D0+PYR(0))
9488 MINT(21)=ISIGN(MINT(55),KCS)
9492 ELSEIF(ISUB.EQ.83) THEN
9493 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
9495 IF(MINT(2).EQ.2) KFOLD=MINT(15)
9497 IF(KFAOLD.GT.10) THEN
9498 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
9500 RCKM=VINT(180+KFOLD)*PYR(0)
9501 IPM=(5-ISIGN(1,KFOLD))/2
9502 KFANEW=-MOD(KFAOLD+1,2)
9504 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
9505 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
9506 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
9507 & VCKM(KFAOLD/2,(KFANEW+1)/2)
9508 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
9509 & VCKM(KFANEW/2,(KFAOLD+1)/2)
9511 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
9513 IF(MINT(2).EQ.1) THEN
9514 MINT(21)=ISIGN(MINT(55),MINT(15))
9515 MINT(22)=ISIGN(KFANEW,MINT(16))
9517 MINT(21)=ISIGN(KFANEW,MINT(15))
9518 MINT(22)=ISIGN(MINT(55),MINT(16))
9523 ELSEIF(ISUB.EQ.84) THEN
9524 C...g + gamma -> Q + Qbar; th arbitary
9525 KCS=(-1)**INT(1.5D0+PYR(0))
9526 MINT(21)=ISIGN(MINT(55),KCS)
9529 IF(MINT(16).EQ.21) KCC=28
9531 ELSEIF(ISUB.EQ.85) THEN
9532 C...gamma + gamma -> F + Fbar; th arbitary
9533 KCS=(-1)**INT(1.5D0+PYR(0))
9534 MINT(21)=ISIGN(MINT(56),KCS)
9538 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
9539 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
9540 MINT(21)=KFPR(ISUB,1)
9541 MINT(22)=KFPR(ISUB,2)
9543 KCS=(-1)**INT(1.5D0+PYR(0))
9546 ELSEIF(ISUB.LE.100) THEN
9548 C...Low-pT ( = energyless g + g -> g + g)
9550 KCS=(-1)**INT(1.5D0+PYR(0))
9552 ELSEIF(ISUB.EQ.96) THEN
9553 C...Multiple interactions (should be reassigned to QCD process)
9556 ELSEIF(ISUB.LE.110) THEN
9557 IF(ISUB.EQ.101) THEN
9558 C...g + g -> gamma*/Z0
9562 ELSEIF(ISUB.EQ.102) THEN
9563 C...g + g -> h0 (or H0, or A0)
9567 ELSEIF(ISUB.EQ.103) THEN
9568 C...gamma + gamma -> h0 (or H0, or A0)
9572 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
9573 C...g + g -> chi_0c or chi_2c.
9577 ELSEIF(ISUB.EQ.106) THEN
9578 C...g + g -> J/Psi + gamma
9579 MINT(21)=KFPR(ISUB,1)
9580 MINT(22)=KFPR(ISUB,2)
9583 ELSEIF(ISUB.EQ.107) THEN
9584 C...g + gamma -> J/Psi + g
9585 MINT(21)=KFPR(ISUB,1)
9586 MINT(22)=KFPR(ISUB,2)
9588 IF(MINT(16).EQ.22) KCC=33
9590 ELSEIF(ISUB.EQ.108) THEN
9591 C...gamma + gamma -> J/Psi + gamma
9592 MINT(21)=KFPR(ISUB,1)
9593 MINT(22)=KFPR(ISUB,2)
9595 ELSEIF(ISUB.EQ.110) THEN
9596 C...f + fbar -> gamma + h0; th arbitrary
9597 IF(PYR(0).GT.0.5D0) JS=2
9602 ELSEIF(ISUB.LE.120) THEN
9603 IF(ISUB.EQ.111) THEN
9604 C...f + fbar -> g + h0; th arbitrary
9605 IF(PYR(0).GT.0.5D0) JS=2
9610 ELSEIF(ISUB.EQ.112) THEN
9611 C...f + g -> f + h0; th = (p(f) - p(f))**2
9612 IF(MINT(15).EQ.21) JS=2
9615 KCS=ISIGN(1,MINT(14+JS))
9617 ELSEIF(ISUB.EQ.113) THEN
9618 C...g + g -> g + h0; th arbitrary
9619 IF(PYR(0).GT.0.5D0) JS=2
9622 KCS=(-1)**INT(1.5D0+PYR(0))
9624 ELSEIF(ISUB.EQ.114) THEN
9625 C...g + g -> gamma + gamma; th arbitrary
9626 IF(PYR(0).GT.0.5D0) JS=2
9631 ELSEIF(ISUB.EQ.115) THEN
9632 C...g + g -> g + gamma; th arbitrary
9633 IF(PYR(0).GT.0.5D0) JS=2
9636 KCS=(-1)**INT(1.5D0+PYR(0))
9638 ELSEIF(ISUB.EQ.116) THEN
9639 C...g + g -> gamma + Z0
9641 ELSEIF(ISUB.EQ.117) THEN
9642 C...g + g -> Z0 + Z0
9644 ELSEIF(ISUB.EQ.118) THEN
9645 C...g + g -> W+ + W-
9648 ELSEIF(ISUB.LE.140) THEN
9649 IF(ISUB.EQ.121) THEN
9650 C...g + g -> Q + Qbar + h0
9651 KCS=(-1)**INT(1.5D0+PYR(0))
9652 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
9654 KCC=11+INT(0.5D0+PYR(0))
9657 ELSEIF(ISUB.EQ.122) THEN
9658 C...q + qbar -> Q + Qbar + h0
9659 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
9664 ELSEIF(ISUB.EQ.123) THEN
9665 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
9670 ELSEIF(ISUB.EQ.124) THEN
9671 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
9677 RVCKM=VINT(180+I)*PYR(0)
9680 IPM=(5-ISIGN(1,I))/2
9682 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
9683 MINT(20+JT)=ISIGN(IB,I)
9684 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9685 IF(RVCKM.LE.0D0) GOTO 430
9688 IB=2*((IA+1)/2)-1+MOD(IA,2)
9689 MINT(20+JT)=ISIGN(IB,I)
9695 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
9696 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
9697 IF(MINT(15).EQ.22) JS=2
9700 KCS=ISIGN(1,MINT(14+JS))
9702 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
9703 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
9704 IF(MINT(15).EQ.22) JS=2
9706 KCS=ISIGN(1,MINT(14+JS))
9708 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
9709 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
9710 KCS=(-1)**INT(1.5D0+PYR(0))
9711 MINT(21)=ISIGN(KFLF,KCS)
9714 IF(MINT(16).EQ.21) KCC=28
9716 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
9717 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
9718 KCS=(-1)**INT(1.5D0+PYR(0))
9719 MINT(21)=ISIGN(KFLF,KCS)
9725 ELSEIF(ISUB.LE.160) THEN
9726 IF(ISUB.EQ.141) THEN
9727 C...f + fbar -> gamma*/Z0/Z'0
9730 ELSEIF(ISUB.EQ.142) THEN
9731 C...f + fbar' -> W'+/-
9732 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9733 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9734 KFRES=ISIGN(34,KCH1+KCH2)
9736 ELSEIF(ISUB.EQ.143) THEN
9737 C...f + fbar' -> H+/-
9738 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9739 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9740 KFRES=ISIGN(37,KCH1+KCH2)
9742 ELSEIF(ISUB.EQ.144) THEN
9744 KFRES=ISIGN(41,MINT(15)+MINT(16))
9746 ELSEIF(ISUB.EQ.145) THEN
9747 C...q + l -> LQ (leptoquark)
9748 IF(IABS(MINT(16)).LE.8) JS=2
9749 KFRES=ISIGN(42,MINT(14+JS))
9751 KCS=ISIGN(1,MINT(14+JS))
9753 ELSEIF(ISUB.EQ.146) THEN
9754 C...e + gamma -> e* (excited lepton)
9755 IF(MINT(15).EQ.22) JS=2
9756 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9759 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
9760 C...q + g -> q* (excited quark)
9761 IF(MINT(15).EQ.21) JS=2
9762 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9764 KCS=ISIGN(1,MINT(14+JS))
9766 ELSEIF(ISUB.EQ.149) THEN
9770 KCS=(-1)**INT(1.5D0+PYR(0))
9773 ELSEIF(ISUB.LE.200) THEN
9774 IF(ISUB.EQ.161) THEN
9775 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
9776 IF(MINT(15).EQ.21) JS=2
9779 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
9780 IB=IA+MOD(IA,2)-MOD(IA+1,2)
9781 MINT(20+JS)=ISIGN(IB,I)
9783 KCS=ISIGN(1,MINT(14+JS))
9785 ELSEIF(ISUB.EQ.162) THEN
9786 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
9787 IF(MINT(15).EQ.21) JS=2
9788 MINT(20+JS)=ISIGN(42,MINT(14+JS))
9789 KFLQL=KFDP(MDCY(42,2),2)
9790 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
9792 KCS=ISIGN(1,MINT(14+JS))
9794 ELSEIF(ISUB.EQ.163) THEN
9795 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
9796 KCS=(-1)**INT(1.5D0+PYR(0))
9797 MINT(21)=ISIGN(42,KCS)
9801 ELSEIF(ISUB.EQ.164) THEN
9802 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
9803 MINT(21)=ISIGN(42,MINT(15))
9807 ELSEIF(ISUB.EQ.165) THEN
9808 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
9809 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9812 ELSEIF(ISUB.EQ.166) THEN
9813 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9814 IF(MOD(MINT(15),2).EQ.0) THEN
9815 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9816 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9818 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9819 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9822 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
9823 C...q + q' -> q" + q* (excited quark)
9825 KFQEXC=MOD(KFQSTR,KEXCIT)
9827 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9828 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
9829 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9833 ELSEIF(ISUB.EQ.169) THEN
9834 C...q + qbar -> e + e* (excited lepton)
9836 KFQEXC=MOD(KFQSTR,KEXCIT)
9838 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9839 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9842 ELSEIF(ISUB.EQ.191) THEN
9843 C...f + fbar -> rho_tc0.
9846 ELSEIF(ISUB.EQ.192) THEN
9847 C...f + fbar' -> rho_tc+/-
9848 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9849 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9850 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
9852 ELSEIF(ISUB.EQ.193) THEN
9853 C...f + fbar -> omega_tc0.
9856 ELSEIF(ISUB.EQ.194) THEN
9857 C...f + fbar -> f' + fbar' via mixture of s-channel
9858 C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
9859 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9862 ELSEIF(ISUB.EQ.195) THEN
9863 C...f + fbar' -> f'' + fbar''' via s-channel
9864 C...rho_tc+ th=(p(f)-p(f'))**2
9865 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9866 IF(MOD(MINT(15),2).EQ.0) THEN
9867 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9868 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9870 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9871 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9876 ELSEIF(ISUB.LE.215) THEN
9877 IF(ISUB.EQ.201) THEN
9878 C...f + fbar -> ~e_L + ~e_Lbar
9879 MINT(21)=ISIGN(KSUSY1+11,KCS)
9882 ELSEIF(ISUB.EQ.202) THEN
9883 C...f + fbar -> ~e_R + ~e_Rbar
9884 MINT(21)=ISIGN(KSUSY2+11,KCS)
9887 ELSEIF(ISUB.EQ.203) THEN
9888 C...f + fbar -> ~e_L + ~e_Rbar
9889 IF(MINT(15).LT.0) JS=2
9890 IF(MINT(2).EQ.1) THEN
9891 MINT(20+JS)=KFPR(ISUB,1)
9892 MINT(23-JS)=-KFPR(ISUB,2)
9894 MINT(20+JS)=-KFPR(ISUB,1)
9895 MINT(23-JS)=KFPR(ISUB,2)
9898 ELSEIF(ISUB.EQ.204) THEN
9899 C...f + fbar -> ~mu_L + ~mu_Lbar
9900 MINT(21)=ISIGN(KSUSY1+13,KCS)
9903 ELSEIF(ISUB.EQ.205) THEN
9904 C...f + fbar -> ~mu_R + ~mu_Rbar
9905 MINT(21)=ISIGN(KSUSY2+13,KCS)
9908 ELSEIF(ISUB.EQ.206) THEN
9909 C...f + fbar -> ~mu_L + ~mu_Rbar
9910 IF(MINT(15).LT.0) JS=2
9911 IF(MINT(2).EQ.1) THEN
9912 MINT(20+JS)=KFPR(ISUB,1)
9913 MINT(23-JS)=-KFPR(ISUB,2)
9915 MINT(20+JS)=-KFPR(ISUB,1)
9916 MINT(23-JS)=KFPR(ISUB,2)
9919 ELSEIF(ISUB.EQ.207) THEN
9920 C...f + fbar -> ~tau_1 + ~tau_1bar
9921 MINT(21)=ISIGN(KSUSY1+15,KCS)
9924 ELSEIF(ISUB.EQ.208) THEN
9925 C...f + fbar -> ~tau_2 + ~tau_2bar
9926 MINT(21)=ISIGN(KSUSY2+15,KCS)
9929 ELSEIF(ISUB.EQ.209) THEN
9930 C...f + fbar -> ~tau_1 + ~tau_2bar
9931 IF(MINT(15).LT.0) JS=2
9932 IF(MINT(2).EQ.1) THEN
9933 MINT(20+JS)=KFPR(ISUB,1)
9934 MINT(23-JS)=-KFPR(ISUB,2)
9936 MINT(20+JS)=-KFPR(ISUB,1)
9937 MINT(23-JS)=KFPR(ISUB,2)
9940 ELSEIF(ISUB.EQ.210) THEN
9941 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
9942 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9943 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9944 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
9945 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
9947 ELSEIF(ISUB.EQ.211) THEN
9948 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
9949 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9950 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9951 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
9952 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9954 ELSEIF(ISUB.EQ.212) THEN
9955 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
9956 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9957 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9958 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
9959 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9961 ELSEIF(ISUB.EQ.213) THEN
9962 C...f + fbar -> ~nul + ~nulbar
9963 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9966 ELSEIF(ISUB.EQ.214) THEN
9967 C...f + fbar -> ~nutau + ~nutaubar
9968 MINT(21)=ISIGN(KSUSY1+16,KCS)
9972 ELSEIF(ISUB.LE.225) THEN
9973 IF(ISUB.EQ.216) THEN
9974 C...f + fbar -> ~chi01 + ~chi01
9978 ELSEIF(ISUB.EQ.217) THEN
9979 C...f + fbar -> ~chi02 + ~chi02
9983 ELSEIF(ISUB.EQ.218 ) THEN
9984 C...f + fbar -> ~chi03 + ~chi03
9988 ELSEIF(ISUB.EQ.219 ) THEN
9989 C...f + fbar -> ~chi04 + ~chi04
9993 ELSEIF(ISUB.EQ.220 ) THEN
9994 C...f + fbar -> ~chi01 + ~chi02
9995 IF(MINT(15).LT.0) JS=2
9996 C IF(PYR(0).GT.0.5D0) JS=2
9997 MINT(20+JS)=KSUSY1+22
9998 MINT(23-JS)=KSUSY1+23
10000 ELSEIF(ISUB.EQ.221 ) THEN
10001 C...f + fbar -> ~chi01 + ~chi03
10002 IF(MINT(15).LT.0) JS=2
10003 C IF(PYR(0).GT.0.5D0) JS=2
10004 MINT(20+JS)=KSUSY1+22
10005 MINT(23-JS)=KSUSY1+25
10007 ELSEIF(ISUB.EQ.222) THEN
10008 C...f + fbar -> ~chi01 + ~chi04
10009 IF(MINT(15).LT.0) JS=2
10010 C IF(PYR(0).GT.0.5D0) JS=2
10011 MINT(20+JS)=KSUSY1+22
10012 MINT(23-JS)=KSUSY1+35
10014 ELSEIF(ISUB.EQ.223) THEN
10015 C...f + fbar -> ~chi02 + ~chi03
10016 IF(MINT(15).LT.0) JS=2
10017 C IF(PYR(0).GT.0.5D0) JS=2
10018 MINT(20+JS)=KSUSY1+23
10019 MINT(23-JS)=KSUSY1+25
10021 ELSEIF(ISUB.EQ.224) THEN
10022 C...f + fbar -> ~chi02 + ~chi04
10023 IF(MINT(15).LT.0) JS=2
10024 C IF(PYR(0).GT.0.5D0) JS=2
10025 MINT(20+JS)=KSUSY1+23
10026 MINT(23-JS)=KSUSY1+35
10028 ELSEIF(ISUB.EQ.225) THEN
10029 C...f + fbar -> ~chi03 + ~chi04
10030 IF(MINT(15).LT.0) JS=2
10031 C IF(PYR(0).GT.0.5D0) JS=2
10032 MINT(20+JS)=KSUSY1+25
10033 MINT(23-JS)=KSUSY1+35
10036 ELSEIF(ISUB.LE.236) THEN
10037 IF(ISUB.EQ.226) THEN
10038 C...f + fbar -> ~chi+-1 + ~chi-+1
10039 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
10040 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10041 MINT(21)=ISIGN(KSUSY1+24,KCH1)
10044 ELSEIF(ISUB.EQ.227) THEN
10045 C...f + fbar -> ~chi+-2 + ~chi-+2
10046 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10047 MINT(21)=ISIGN(KSUSY1+37,KCH1)
10050 ELSEIF(ISUB.EQ.228) THEN
10051 C...f + fbar -> ~chi+-1 + ~chi-+2
10052 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
10053 C...js=1 if pyr<.5, js=2 if pyr>.5
10054 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
10055 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
10056 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
10057 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
10058 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10060 IF(MINT(2).EQ.1) THEN
10061 MINT(21)= ISIGN(KSUSY1+24,KCH1)
10062 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
10063 c IF(KCH2.EQ.0) JS=2
10065 MINT(21)= ISIGN(KSUSY1+37,KCH1)
10066 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
10068 c IF(KCH2.EQ.1) JS=2
10071 ELSEIF(ISUB.EQ.229) THEN
10072 C...q + qbar' -> ~chi01 + ~chi+-1
10073 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
10074 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10075 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10077 IF(MOD(MINT(15),2).EQ.0) JS=2
10078 MINT(20+JS)=KSUSY1+22
10079 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10081 ELSEIF(ISUB.EQ.230) THEN
10082 C...q + qbar' -> ~chi02 + ~chi+-1
10083 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10084 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10085 IF(MOD(MINT(15),2).EQ.0) JS=2
10086 MINT(20+JS)=KSUSY1+23
10087 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10089 ELSEIF(ISUB.EQ.231) THEN
10090 C...q + qbar' -> ~chi03 + ~chi+-1
10091 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10092 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10093 IF(MOD(MINT(15),2).EQ.0) JS=2
10094 MINT(20+JS)=KSUSY1+25
10095 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10097 ELSEIF(ISUB.EQ.232) THEN
10098 C...q + qbar' -> ~chi04 + ~chi+-1
10099 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10100 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10101 IF(MOD(MINT(15),2).EQ.0) JS=2
10102 MINT(20+JS)=KSUSY1+35
10103 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10105 ELSEIF(ISUB.EQ.233) THEN
10106 C...q + qbar' -> ~chi01 + ~chi+-2
10107 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10108 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10109 IF(MOD(MINT(15),2).EQ.0) JS=2
10110 MINT(20+JS)=KSUSY1+22
10111 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10113 ELSEIF(ISUB.EQ.234) THEN
10114 C...q + qbar' -> ~chi02 + ~chi+-2
10115 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10116 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10117 IF(MOD(MINT(15),2).EQ.0) JS=2
10118 MINT(20+JS)=KSUSY1+23
10119 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10121 ELSEIF(ISUB.EQ.235) THEN
10122 C...q + qbar' -> ~chi03 + ~chi+-2
10123 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10124 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10125 IF(MOD(MINT(15),2).EQ.0) JS=2
10126 MINT(20+JS)=KSUSY1+25
10127 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10129 ELSEIF(ISUB.EQ.236) THEN
10130 C...q + qbar' -> ~chi04 + ~chi+-2
10131 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10132 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10133 IF(MOD(MINT(15),2).EQ.0) JS=2
10134 MINT(20+JS)=KSUSY1+35
10135 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10138 ELSEIF(ISUB.LE.245) THEN
10139 IF(ISUB.EQ.237) THEN
10140 C...q + qbar -> ~chi01 + ~g
10142 IF(PYR(0).GT.0.5D0) JS=2
10143 MINT(20+JS)=KSUSY1+21
10144 MINT(23-JS)=KSUSY1+22
10147 ELSEIF(ISUB.EQ.238) THEN
10148 C...q + qbar -> ~chi02 + ~g
10150 IF(PYR(0).GT.0.5D0) JS=2
10151 MINT(20+JS)=KSUSY1+21
10152 MINT(23-JS)=KSUSY1+23
10155 ELSEIF(ISUB.EQ.239) THEN
10156 C...q + qbar -> ~chi03 + ~g
10158 IF(PYR(0).GT.0.5D0) JS=2
10159 MINT(20+JS)=KSUSY1+21
10160 MINT(23-JS)=KSUSY1+25
10163 ELSEIF(ISUB.EQ.240) THEN
10164 C...q + qbar -> ~chi04 + ~g
10166 IF(PYR(0).GT.0.5D0) JS=2
10167 MINT(20+JS)=KSUSY1+21
10168 MINT(23-JS)=KSUSY1+35
10171 ELSEIF(ISUB.EQ.241) THEN
10172 C...q + qbar' -> ~chi+-1 + ~g
10173 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10174 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10175 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10176 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10177 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10178 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10179 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10181 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10182 MINT(20+JS)=KSUSY1+21
10183 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10186 ELSEIF(ISUB.EQ.242) THEN
10187 C...q + qbar' -> ~chi+-2 + ~g
10188 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10189 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10190 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10191 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10192 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10193 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10194 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10196 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10197 MINT(20+JS)=KSUSY1+21
10198 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10201 ELSEIF(ISUB.EQ.243) THEN
10202 C...q + qbar -> ~g + ~g ; th arbitrary
10207 ELSEIF(ISUB.EQ.244) THEN
10208 C...g + g -> ~g + ~g ; th arbitrary
10210 KCS=(-1)**INT(1.5D0+PYR(0))
10215 ELSEIF(ISUB.LE.260) THEN
10216 IF(ISUB.EQ.246) THEN
10217 C...qj + g -> ~qj_L + ~chi01
10218 IF(MINT(15).EQ.21) JS=2
10221 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10222 MINT(23-JS)=KSUSY1+22
10224 KCS=ISIGN(1,MINT(14+JS))
10226 ELSEIF(ISUB.EQ.247) THEN
10227 C...qj + g -> ~qj_R + ~chi01
10228 IF(MINT(15).EQ.21) JS=2
10231 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10232 MINT(23-JS)=KSUSY1+22
10234 KCS=ISIGN(1,MINT(14+JS))
10236 ELSEIF(ISUB.EQ.248) THEN
10237 C...qj + g -> ~qj_L + ~chi02
10238 IF(MINT(15).EQ.21) JS=2
10241 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10242 MINT(23-JS)=KSUSY1+23
10244 KCS=ISIGN(1,MINT(14+JS))
10246 ELSEIF(ISUB.EQ.249) THEN
10247 C...qj + g -> ~qj_R + ~chi02
10248 IF(MINT(15).EQ.21) JS=2
10251 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10252 MINT(23-JS)=KSUSY1+23
10254 KCS=ISIGN(1,MINT(14+JS))
10256 ELSEIF(ISUB.EQ.250) THEN
10257 C...qj + g -> ~qj_L + ~chi03
10258 IF(MINT(15).EQ.21) JS=2
10261 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10262 MINT(23-JS)=KSUSY1+25
10264 KCS=ISIGN(1,MINT(14+JS))
10266 ELSEIF(ISUB.EQ.251) THEN
10267 C...qj + g -> ~qj_R + ~chi03
10268 IF(MINT(15).EQ.21) JS=2
10271 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10272 MINT(23-JS)=KSUSY1+25
10274 KCS=ISIGN(1,MINT(14+JS))
10276 ELSEIF(ISUB.EQ.252) THEN
10277 C...qj + g -> ~qj_L + ~chi04
10278 IF(MINT(15).EQ.21) JS=2
10281 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10282 MINT(23-JS)=KSUSY1+35
10284 KCS=ISIGN(1,MINT(14+JS))
10286 ELSEIF(ISUB.EQ.253) THEN
10287 C...qj + g -> ~qj_R + ~chi04
10288 IF(MINT(15).EQ.21) JS=2
10291 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10292 MINT(23-JS)=KSUSY1+35
10294 KCS=ISIGN(1,MINT(14+JS))
10296 ELSEIF(ISUB.EQ.254) THEN
10297 C...qj + g -> ~qk_L + ~chi+-1
10298 IF(MINT(15).EQ.21) JS=2
10301 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10302 IB=-IA+INT((IA+1)/2)*4-1
10303 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10305 KCS=ISIGN(1,MINT(14+JS))
10307 ELSEIF(ISUB.EQ.255) THEN
10308 C...qj + g -> ~qk_L + ~chi+-1
10309 IF(MINT(15).EQ.21) JS=2
10312 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10313 IB=-IA+INT((IA+1)/2)*4-1
10314 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10316 KCS=ISIGN(1,MINT(14+JS))
10318 ELSEIF(ISUB.EQ.256) THEN
10319 C...qj + g -> ~qk_L + ~chi+-2
10320 IF(MINT(15).EQ.21) JS=2
10323 IB=-IA+INT((IA+1)/2)*4-1
10324 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10325 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10327 KCS=ISIGN(1,MINT(14+JS))
10329 ELSEIF(ISUB.EQ.257) THEN
10330 C...qj + g -> ~qk_R + ~chi+-2
10331 IF(MINT(15).EQ.21) JS=2
10334 IB=-IA+INT((IA+1)/2)*4-1
10335 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10336 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10338 KCS=ISIGN(1,MINT(14+JS))
10340 ELSEIF(ISUB.EQ.258) THEN
10341 C...qj + g -> ~qj_L + ~g
10342 IF(MINT(15).EQ.21) JS=2
10345 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10346 MINT(23-JS)=KSUSY1+21
10348 IF(JS.EQ.2) KCC=KCC+2
10351 ELSEIF(ISUB.EQ.259) THEN
10352 C...qj + g -> ~qj_R + ~g
10353 IF(MINT(15).EQ.21) JS=2
10356 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10357 MINT(23-JS)=KSUSY1+21
10359 IF(JS.EQ.2) KCC=KCC+2
10363 ELSEIF(ISUB.LE.270) THEN
10364 IF(ISUB.EQ.261) THEN
10365 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
10367 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10368 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10370 C...Correct color combination
10371 IF(MINT(43).EQ.4) KCC=4
10373 ELSEIF(ISUB.EQ.262) THEN
10374 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
10376 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10377 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10379 C...Correct color combination
10380 IF(MINT(43).EQ.4) KCC=4
10382 ELSEIF(ISUB.EQ.263) THEN
10383 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
10384 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
10385 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
10386 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10387 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
10390 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
10391 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
10393 C...Correct color combination
10394 IF(MINT(43).EQ.4) KCC=4
10396 ELSEIF(ISUB.EQ.264) THEN
10397 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
10398 KCS=(-1)**INT(1.5D0+PYR(0))
10399 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10403 ELSEIF(ISUB.EQ.265) THEN
10404 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
10405 KCS=(-1)**INT(1.5D0+PYR(0))
10406 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10411 ELSEIF(ISUB.LE.296) THEN
10412 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
10413 C...qi + qj -> ~qi_L + ~qj_L
10415 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10416 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10417 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10419 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
10420 C...qi + qj -> ~qi_R + ~qj_R
10422 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10423 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10424 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10426 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
10427 C...qi + qj -> ~qi_L + ~qj_R
10428 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10429 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10431 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10433 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
10434 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
10435 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10436 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10438 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10440 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
10441 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10442 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10443 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10445 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10447 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
10448 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10449 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10450 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10452 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10454 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
10455 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
10457 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10458 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10460 IF(MINT(43).EQ.4) KCC=4
10462 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
10463 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
10465 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10466 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10468 IF(MINT(43).EQ.4) KCC=4
10470 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
10471 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
10473 KCS=(-1)**INT(1.5D0+PYR(0))
10474 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10478 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
10479 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
10480 KCS=(-1)**INT(1.5D0+PYR(0))
10481 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10485 ELSEIF(ISUB.EQ.294) THEN
10486 C...qj + g -> ~qj_L + ~g
10487 IF(MINT(15).EQ.21) JS=2
10490 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10491 MINT(23-JS)=KSUSY1+21
10493 IF(JS.EQ.2) KCC=KCC+2
10496 ELSEIF(ISUB.EQ.295) THEN
10497 C...qj + g -> ~qj_R + ~g
10498 IF(MINT(15).EQ.21) JS=2
10501 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10502 MINT(23-JS)=KSUSY1+21
10504 IF(JS.EQ.2) KCC=KCC+2
10508 ELSEIF(ISUB.LE.340) THEN
10510 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
10511 C...q + qbar' -> H+ + H0
10512 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10513 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10514 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10515 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
10516 MINT(23-JS)=KFPR(ISUB,2)
10517 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
10518 C...f + fbar -> A0 + H0; th arbitrary
10519 IF(PYR(0).GT.0.5D0) JS=2
10520 MINT(20+JS)=KFPR(ISUB,1)
10521 MINT(23-JS)=KFPR(ISUB,2)
10522 ELSEIF(ISUB.EQ.301) THEN
10523 C...f + fbar -> H+ H-
10524 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10529 ELSEIF(ISUB.LE.360) THEN
10531 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
10532 C...l + l -> H_L++/--, H_R++/--
10533 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10534 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10535 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10537 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
10538 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
10539 IF(MINT(15).EQ.22) JS=2
10540 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
10541 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
10544 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
10545 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
10546 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
10549 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
10550 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
10551 C...as inner process).
10556 RVCKM=VINT(180+I)*PYR(0)
10559 IPM=(5-ISIGN(1,I))/2
10561 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
10562 MINT(20+JT)=ISIGN(IB,I)
10563 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10564 IF(RVCKM.LE.0D0) GOTO 450
10567 IB=2*((IA+1)/2)-1+MOD(IA,2)
10568 MINT(20+JT)=ISIGN(IB,I)
10572 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
10573 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
10575 ELSEIF(ISUB.EQ.353) THEN
10576 C...f + fbar -> Z_R0
10579 ELSEIF(ISUB.EQ.354) THEN
10580 C...f + fbar' -> W+/-
10581 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10582 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10583 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10587 ELSEIF(ISUB.LE.380) THEN
10589 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
10590 C...f + fbar -> charged+ charged- technicolor
10591 KSW=(-1)**INT(1.5D0+PYR(0))
10592 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
10593 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
10595 ELSEIF(ISUB.LE.367) THEN
10596 C...f + fbar -> neutral neutral technicolor
10597 MINT(21)=KFPR(ISUB,1)
10598 MINT(22)=KFPR(ISUB,2)
10600 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375) THEN
10601 C...f + fbar' -> neutral charged technicolor
10604 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10605 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10606 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10607 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10608 MINT(20+JS)=KFPR(ISUB,IN)
10610 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
10611 C...f + fbar' -> charged neutral technicolor
10614 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10615 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10616 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10617 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10618 MINT(23-JS)=KFPR(ISUB,IN)
10621 ELSEIF(ISUB.LE.400) THEN
10622 IF(ISUB.EQ.381) THEN
10623 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
10625 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10627 ELSEIF(ISUB.EQ.382) THEN
10628 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
10629 MINT(21)=ISIGN(KFLF,MINT(15))
10633 ELSEIF(ISUB.EQ.383) THEN
10634 C...f + fbar -> g + g; th arbitrary, TC extensions
10639 ELSEIF(ISUB.EQ.384) THEN
10640 C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
10641 IF(MINT(15).EQ.21) JS=2
10643 IF(MINT(15).EQ.21) KCC=KCC+2
10644 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10645 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10647 ELSEIF(ISUB.EQ.385) THEN
10648 C...g + g -> f + fbar; th arbitrary, TC extensions
10649 KCS=(-1)**INT(1.5D0+PYR(0))
10650 MINT(21)=ISIGN(KFLF,KCS)
10654 ELSEIF(ISUB.EQ.386) THEN
10655 C...g + g -> g + g; th arbitrary, TC extensions
10657 KCS=(-1)**INT(1.5D0+PYR(0))
10659 ELSEIF(ISUB.EQ.387) THEN
10660 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
10661 MINT(21)=ISIGN(MINT(55),MINT(15))
10665 ELSEIF(ISUB.EQ.388) THEN
10666 C...g + g -> Q + Qbar; th arbitrary, TC extensions
10667 KCS=(-1)**INT(1.5D0+PYR(0))
10668 MINT(21)=ISIGN(MINT(55),KCS)
10672 ELSEIF(ISUB.EQ.391) THEN
10673 C...f + fbar -> G*.
10676 ELSEIF(ISUB.EQ.392) THEN
10681 ELSEIF(ISUB.EQ.393) THEN
10682 C...q + qbar -> g + G*; th arbitrary.
10683 IF(PYR(0).GT.0.5D0) JS=2
10684 MINT(20+JS)=KFPR(ISUB,1)
10685 MINT(23-JS)=KFPR(ISUB,2)
10688 ELSEIF(ISUB.EQ.394) THEN
10689 C...q + g -> q + G*; th = (p(f) - p(f))**2
10690 IF(MINT(15).EQ.21) JS=2
10691 MINT(23-JS)=KFPR(ISUB,2)
10693 KCS=ISIGN(1,MINT(14+JS))
10695 ELSEIF(ISUB.EQ.395) THEN
10696 C...g + g -> G* + g; th arbitrary.
10697 IF(PYR(0).GT.0.5D0) JS=2
10698 MINT(23-JS)=KFPR(ISUB,2)
10703 IF(ISET(ISUB).EQ.11) THEN
10704 C...Store documentation for user-defined processes
10705 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
10706 KUPPO(1)=MINT(83)+5
10707 KUPPO(2)=MINT(83)+6
10711 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
10720 IF(IDUP(IUP).EQ.0) K(I,2)=90
10722 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
10730 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
10733 C...Store final state partons for user-defined processes
10738 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
10740 IF(IDUP(IUP).EQ.0) K(N,2)=90
10741 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
10744 K(N,3)=MINT(84)+MOTHUP(1,IUP)
10753 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
10755 C...Arrange colour flow for user-defined processes
10759 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
10760 IF(K(I1,1).EQ.1) K(I1,1)=3
10761 IF(K(I1,1).EQ.11) K(I1,1)=14
10762 C...Find a not yet considered colour/anticolour line.
10764 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
10767 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
10771 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
10772 C...Find all others belonging to same line.
10775 DO 520 IUP2=IUP1+1,NUP
10778 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
10779 IF(ISDE2.EQ.ISDE1) THEN
10780 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
10781 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
10783 ELSEIF(I4.NE.0) THEN
10784 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
10785 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
10787 ELSEIF(IUP2.LE.2) THEN
10788 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
10789 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
10792 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
10793 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
10803 ELSEIF(IDOC.EQ.7) THEN
10804 C...Resonance not decaying; store kinematics
10819 C...Special cases: colour flow in coloured resonances
10820 KCRES=PYCOMP(KFRES)
10821 IF(KCHG(KCRES,2).NE.0) THEN
10825 IF(KCS.EQ.-1) JC=3-J
10826 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
10827 & MINT(84)+ICOL(KCC,1,JC)
10828 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
10829 & MINT(84)+ICOL(KCC,2,JC)
10830 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
10831 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
10840 ELSEIF(IDOC.EQ.8) THEN
10841 C...2 -> 2 processes: store outgoing partons in their CM-frame
10844 KCA=PYCOMP(MINT(20+JT))
10846 IF(KCHG(KCA,2).NE.0) K(I,1)=3
10848 K(I,3)=MINT(83)+IDOC+JT-2
10850 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
10851 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10853 P(I,5)=PYMASS(K(I,2))
10855 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
10856 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
10858 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
10859 KFA1=IABS(MINT(21))
10860 KFA2=IABS(MINT(22))
10861 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
10869 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
10870 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
10871 P(IPU4,4)=SHR-P(IPU3,4)
10872 P(IPU4,3)=-P(IPU3,3)
10877 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
10878 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
10880 ELSEIF(IDOC.EQ.9) THEN
10881 C...2 -> 3 processes: store outgoing partons in their CM frame
10884 KCA=PYCOMP(MINT(20+JT))
10886 IF(KCHG(KCA,2).NE.0) K(I,1)=3
10888 K(I,3)=MINT(83)+IDOC+JT-3
10889 IF(IABS(K(I,2)).LE.22) THEN
10890 P(I,5)=PYMASS(K(I,2))
10892 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10894 PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
10895 P(I,1)=PT*COS(VINT(198+5*JT))
10896 P(I,2)=PT*SIN(VINT(198+5*JT))
10900 K(IPU5,3)=MINT(83)+IDOC
10902 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10903 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10904 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
10905 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
10906 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
10908 P(IPU5,3)=PMT3*SINH(VINT(211))
10909 P(IPU5,4)=PMT3*COSH(VINT(211))
10910 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
10911 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
10912 IF(SQL12.LE.0D0) THEN
10916 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
10917 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
10918 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
10919 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
10920 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
10926 ELSEIF(IDOC.EQ.11) THEN
10927 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
10928 PHI(1)=PARU(2)*PYR(0)
10933 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10935 K(I,3)=MINT(83)+IDOC+JT-2
10936 P(I,5)=PYMASS(K(I,2))
10937 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
10941 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10942 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10943 P(I,1)=PTABS*COS(PHI(JT))
10944 P(I,2)=PTABS*SIN(PHI(JT))
10945 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10946 P(I,4)=0.5D0*SHPR*Z(JT)
10950 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
10954 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
10955 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
10956 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
10963 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10964 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10965 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
10966 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
10975 ELSEIF(IDOC.EQ.12) THEN
10976 C...Z0 and W+/- scattering: store bosons and outgoing partons
10977 PHI(1)=PARU(2)*PYR(0)
10979 JTRAN=INT(1.5D0+PYR(0))
10983 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10985 K(I,3)=MINT(83)+IDOC+JT-2
10986 P(I,5)=PYMASS(K(I,2))
10987 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
10988 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10989 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10990 P(I,1)=PTABS*COS(PHI(JT))
10991 P(I,2)=PTABS*SIN(PHI(JT))
10992 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10993 P(I,4)=0.5D0*SHPR*Z(JT)
10996 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
10999 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
11004 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
11005 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
11006 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
11009 K(IPU,2)=KFPR(ISUB,JT)
11010 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
11011 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
11012 K(IPU,3)=MINT(83)+8+JT
11013 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
11014 P(IPU,5)=PYMASS(K(IPU,2))
11016 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
11018 MINT(22+JT)=K(IPU,2)
11020 C...Find rotation and boost for hard scattering subsystem
11023 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
11024 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
11025 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
11026 GAMCM=(P(I1,4)+P(I2,4))/SHR
11027 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
11028 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
11029 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
11030 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
11031 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
11032 PHICM=PYANGL(PX,PY)
11033 C...Store hard scattering subsystem. Rotate and boost it
11034 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
11036 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
11038 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
11039 PHIWZ=VINT(24)-PHICM
11040 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
11041 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
11042 P(IPU5,3)=PABS*CTHWZ
11043 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
11044 P(IPU6,1)=-P(IPU5,1)
11045 P(IPU6,2)=-P(IPU5,2)
11046 P(IPU6,3)=-P(IPU5,3)
11047 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
11048 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
11060 MINT(8)=MINT(83)+10
11063 IF(ISET(ISUB).EQ.11) THEN
11064 ELSEIF(IDOC.GE.8) THEN
11065 C...Store colour connection indices
11068 IF(KCS.EQ.-1) JC=3-J
11069 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
11070 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
11071 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
11072 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
11073 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
11074 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
11075 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
11076 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
11079 C...Copy outgoing partons to documentation lines
11081 IF(IDOC.EQ.9) IMAX=3
11083 I1=MINT(83)+IDOC-IMAX+I
11087 IF(IDOC.LE.9) K(I1,3)=0
11088 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
11094 ELSEIF(IDOC.EQ.9) THEN
11095 C...Store colour connection indices
11098 IF(KCS.EQ.-1) JC=3-J
11099 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
11100 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
11101 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
11102 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
11103 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
11104 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
11105 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
11106 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
11107 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
11108 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
11111 C...Copy outgoing partons to documentation lines
11113 I1=MINT(83)+IDOC-3+I
11124 C...Low-pT events: remove gluons used for string drawing purposes
11125 IF(ISUB.EQ.95) THEN
11126 K(IPU3,1)=K(IPU3,1)+10
11127 K(IPU4,1)=K(IPU4,1)+10
11132 DO 710 I=MINT(83)+5,MINT(83)+8
11142 C*********************************************************************
11145 C...Generates spacelike parton showers.
11147 SUBROUTINE PYSSPA(IPU1,IPU2)
11149 C...Double precision and integer declarations.
11150 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11151 IMPLICIT INTEGER(I-N)
11152 INTEGER PYK,PYCHGE,PYCOMP
11154 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11155 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11156 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
11157 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
11158 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11159 COMMON/PYINT1/MINT(400),VINT(400)
11160 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
11161 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
11162 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
11164 C...Local arrays and data.
11165 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
11166 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
11167 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
11168 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
11169 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
11172 C...Read out basic information; set global Q^2 scale.
11177 IF(ISET(ISUB).EQ.2) Q2MX=MIN(VINT(2),PARP(67)*VINT(56))
11180 C...Define which processes ME corrections have been implemented for.
11182 IF(MSTP(68).EQ.1) THEN
11183 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
11184 & ISUB.EQ.144) MECOR=1
11185 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
11188 C...Initialize QCD evolution and check phase space.
11192 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
11195 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11196 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11197 Q2INT=SQRT(Q0S*Q2EFF)
11198 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
11199 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
11200 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
11202 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
11205 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11206 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11207 Q2INT=SQRT(Q0S*Q2EFF)
11208 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
11209 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
11210 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
11217 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
11219 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
11220 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
11221 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
11222 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
11226 C...Initialize QED evolution and check phase space.
11230 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
11231 &SPME=PMAS(13,1)**2
11232 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
11233 &SPME=PMAS(15,1)**2
11234 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
11237 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
11239 TEMX=LOG(Q2MX/SPME)
11240 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
11242 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11247 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
11249 C...Loopback point in case of failure to reconstruct kinematics.
11253 IF(LOOP.GT.100) THEN
11259 C...Initial values: flavours, momenta, virtualities.
11262 KFBEAM(JT)=MINT(10+JT)
11263 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
11264 KFLS(JT)=MINT(14+JT)
11265 KFLS(JT+2)=KFLS(JT)
11267 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
11269 Q2S(JT)=FCQ2MX*Q2MX
11276 C...Calculate initial parton distribution weights.
11277 MINT(105)=MINT(102+JT)
11278 MINT(109)=MINT(106+JT)
11279 VINT(120)=VINT(2+JT)
11281 C.... Store side in MINT(124)
11284 IF(XS(JT).LT.1D0-XEE) THEN
11285 IF(MSTP(57).LE.1) THEN
11286 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11288 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11292 XFS(JT,KFL)=XFB(KFL)
11294 C...Special kinematics check for c/b quarks (that g -> c cbar or
11295 C...b bbar kinematically possible).
11296 KFLCB=IABS(KFLS(JT))
11297 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
11298 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
11305 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
11307 C...Find if interference with final state partons.
11309 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
11313 KCA=PYCOMP(IABS(KFLS(I)))
11314 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
11316 IF(KCFI(I).NE.0) THEN
11317 IF(I.EQ.1) IPFS=IPUS1
11318 IF(I.EQ.2) IPFS=IPUS2
11320 ICSI=MOD(K(IPFS,3+J),MSTU(5))
11321 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
11322 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
11324 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
11326 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
11331 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
11334 C...Pick up leg with highest virtuality.
11338 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
11339 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
11340 IF(MORE(JT).EQ.0) JT=3-JT
11345 XFB(KFL)=XFS(JT,KFL)
11350 C...Check if allowed to branch.
11352 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
11354 XEC=MAX(PARP(65)*DSHR/VINT(2),XB*(1D0/(1D0-PARP(66))-1D0))
11355 IF(XB.GE.1D0-2D0*XEC) MCEV=0
11358 IF(MINT(44+JT).EQ.3) THEN
11360 IF(XB.GE.1D0-2D0*XEE) MEEV=0
11361 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
11363 C***Currently kill QED shower for resolved photoproduction.
11364 IF(MINT(18+JT).EQ.1) MEEV=0
11365 C***Currently kill shower for W inside electron.
11366 IF(IABS(KFLB).EQ.24) THEN
11371 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
11373 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11378 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
11382 IF(MSTP(62).LE.1) THEN
11383 IF(ZS(JT).GT.0.99999D0) THEN
11386 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
11387 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
11388 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
11390 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11391 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11394 ALSDUM=PYALPS(FQ2C*Q2B)
11395 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
11397 B0=(33D0-2D0*MSTU(118))/6D0
11399 IF(MEEV.EQ.2) TEVEB=TEVCB
11403 C...Select side for interference with final state partons.
11404 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
11407 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
11409 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
11410 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
11411 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
11413 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
11417 C...Calculate preweighting factor for ME-corrected processes.
11418 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
11420 C...Calculate Altarelli-Parisi weights.
11426 C...q -> q (g or gamma emission), g -> q.
11427 IF(IABS(KFLB).LE.10) THEN
11428 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
11429 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
11431 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
11432 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
11434 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11435 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
11436 WTAPC(21)=WTGF*WTAPC(21)
11437 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11439 C...f -> f, gamma -> f.
11440 ELSEIF(IABS(KFLB).LE.20) THEN
11441 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
11442 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
11443 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
11444 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
11445 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11446 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11447 WTAPE(22)=WTGF*WTAPE(22)
11449 C...f -> g, g -> g.
11450 ELSEIF(KFLB.EQ.21) THEN
11451 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
11452 DO 180 KFL=1,MSTP(58)
11456 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
11457 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11458 DO 190 KFL=1,MSTP(58)
11459 WTAPC(KFL)=WTFG*WTAPC(KFL)
11460 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
11462 WTAPC(21)=WTGG*WTAPC(21)
11464 C...f -> gamma, W+, W-.
11465 ELSEIF(KFLB.EQ.22) THEN
11466 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
11469 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11470 WTAPE(11)=WTFG*WTAPE(11)
11471 WTAPE(-11)=WTFG*WTAPE(-11)
11473 ELSEIF(KFLB.EQ.24) THEN
11474 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11475 & (XEE*(XB+XEE)))/XB
11476 ELSEIF(KFLB.EQ.-24) THEN
11477 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11478 & (XEE*(XB+XEE)))/XB
11481 C...Calculate parton distribution weights and sum.
11484 IF(NTRY.GT.500) THEN
11490 XFBO=MAX(1D-10,XFB(KFLB))
11492 WTSF(KFL)=XFB(KFL)/XFBO
11493 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
11494 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
11496 WTSUMC=MAX(0.0001D0,WTSUMC)
11497 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
11499 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
11502 IF(NTRY2.GT.500) THEN
11507 IF(MSTP(64).LE.0) THEN
11508 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
11509 ELSEIF(MSTP(64).EQ.1) THEN
11510 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
11512 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
11516 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
11517 & (PARU(101)*FWTE*WTSUME*TEMX)))
11518 ELSEIF(MEEV.EQ.2) THEN
11519 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
11522 C...Translate t into Q2 scale; choose between QCD and QED evolution.
11523 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
11524 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
11525 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
11526 C...Ensure that Q2 is above threshold for charm/bottom.
11528 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11530 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
11531 Q2CB=1.1D0*PMAS(KFLCB,1)**2
11532 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11533 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
11536 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11538 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
11541 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11542 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11543 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
11544 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
11545 IF(Q2EB.GT.Q2MNE) MCE=2
11546 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
11547 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
11548 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
11549 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
11550 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
11551 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
11553 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
11554 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
11557 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
11558 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
11561 C...Evolution possibly ended. Update t values.
11565 ELSEIF(MCE.EQ.1) THEN
11568 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11569 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11573 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11576 C...Select flavour for branching parton.
11577 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
11578 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
11581 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
11582 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
11583 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
11584 IF(KFLA.EQ.25) THEN
11589 C...Choose z value and corrective weight.
11591 C...q -> q + g or q -> q + gamma.
11592 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
11593 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
11594 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
11595 WTZ=0.5D0*(1D0+Z**2)
11597 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
11598 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
11599 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
11600 C...f -> f + gamma.
11601 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11602 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
11603 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
11604 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
11606 Z=XB+XB*(XEE/(1D0-XEE))*
11607 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11609 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
11610 C...f -> gamma + f.
11611 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
11612 Z=XB+XB*(XEE/(1D0-XEE))*
11613 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11614 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
11616 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
11617 Z=XB+XB*(XEE/(1D0-XEE))*
11618 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11619 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
11620 & (Q2B/(Q2B+PMAS(24,1)**2))
11622 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
11623 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
11624 WTZ=1D0-2D0*Z*(1D0-Z)
11626 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11627 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
11628 WTZ=(1D0-Z*(1D0-Z))**2
11629 C...gamma -> f + fbar.
11630 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
11631 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
11632 WTZ=1D0-2D0*Z*(1D0-Z)
11634 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
11636 C...Option with resummation of soft gluon emission as effective z shift.
11638 IF(MSTP(65).GE.1) THEN
11640 IF(KFLB.NE.21) RSOFT=8D0/3D0
11641 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
11642 IF(Z.LE.XB) GOTO 220
11645 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
11646 IF(MSTP(64).GE.2) THEN
11647 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
11648 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
11649 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
11650 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
11654 C...Remove kinematically impossible branchings.
11655 UHAT=Q2B-DSH*(1D0-Z)/Z
11656 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
11658 C...Select phi angle of branching at random.
11659 PHIBR=PARU(2)*PYR(0)
11661 C...Matrix-element corrections for some processes.
11662 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11663 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11664 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
11666 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
11667 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
11669 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
11670 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
11672 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11673 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
11678 C...Impose angular constraint in first branching from interference
11679 C...with final state partons.
11681 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
11682 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
11683 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
11684 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
11685 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
11686 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
11690 C...Option with angular ordering requirement.
11691 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
11692 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT(2))
11693 IF(THE2T.GT.THE2(JT)) GOTO 220
11697 C...Weighting with new parton distributions.
11698 MINT(105)=MINT(102+JT)
11699 MINT(109)=MINT(106+JT)
11700 VINT(120)=VINT(2+JT)
11702 C.... Store side in MINT(124)
11705 IF(MSTP(57).LE.1) THEN
11706 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
11708 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
11711 IF(XFBN.LT.1D-20) THEN
11712 IF(KFLA.EQ.KFLB) THEN
11718 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
11719 TEVCB=0.5D0*(TEVCBS+TEVCB)
11721 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
11722 TEVEB=0.5D0*(TEVEBS+TEVEB)
11734 C.... Store side in MINT(124)
11737 IF(MSTP(57).LE.1) THEN
11738 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
11740 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
11743 IF(XFAN.LT.1D-20) GOTO 200
11745 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
11747 C...Define two hard scatterers in their CM-frame.
11748 260 IF(N.EQ.NS+2) THEN
11750 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
11753 IF(JR.EQ.1) IPO=IPUS1
11754 IF(JR.EQ.2) IPO=IPUS2
11764 P(I,3)=DPLCM*(-1)**(JR+1)
11765 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
11766 P(I,5)=-SQRT(DQ2(JR))
11769 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
11770 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
11773 C...Find maximum allowed mass of timelike parton.
11774 ELSEIF(N.GT.NS+2) THEN
11779 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
11780 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
11781 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
11782 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
11783 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
11785 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
11786 & 1D-10*DPD(1)) IKIN=1
11787 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
11788 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
11789 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
11790 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
11792 C...Generate timelike parton shower (if required).
11799 C...f -> f + g (gamma).
11800 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
11802 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
11803 C...f -> g (gamma, W+-) + f.
11804 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
11806 IF(KFLS(JT+2).EQ.24) THEN
11808 ELSEIF(KFLS(JT+2).EQ.-24) THEN
11811 C...g (gamma) -> f + fbar, g + g.
11813 K(IT,2)=-KFLS(JT+2)
11814 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
11817 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
11818 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
11819 P(IT,5)=PYMASS(K(IT,2))
11820 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
11821 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
11824 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
11825 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
11826 IF(MSTP(63).EQ.1) THEN
11828 ELSEIF(MSTP(63).EQ.2) THEN
11829 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
11833 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11834 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
11835 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
11836 PARJ(85)=SQRT(MAX(0D0,DPT2))*
11837 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
11839 CALL PYSHOW(IT,0,SQRT(Q2TIM))
11842 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
11845 C...Reconstruct kinematics of branching: timelike parton shower.
11847 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11848 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
11849 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
11850 & (4D0*DSH*DPC(3)**2)
11851 IF(DPT2.LT.0D0) GOTO 100
11852 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
11853 & DSHR)/DPC(3)-DPC(3)
11855 P(IT,3)=DPB(1)*(-1)**(JT+1)
11856 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
11858 DPB(1)=SQRT(DPB(1)**2+DPT2)
11859 DPB(2)=SQRT(DPB(1)**2+DMS)
11861 DPB(4)=SQRT(DPB(3)**2+DMS)
11862 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
11864 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
11865 THE=PYANGL(P(IT,3),P(IT,1))
11866 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
11869 C...Reconstruct kinematics of branching: spacelike parton.
11878 P(N+1,3)=P(IT,3)+P(IS(JT),3)
11879 P(N+1,4)=P(IT,4)+P(IS(JT),4)
11880 P(N+1,5)=-SQRT(DQ2(3))
11882 C...Define colour flow of branching.
11887 C...f -> f + gamma (Z, W).
11888 IF(IABS(K(IT,2)).GE.22) THEN
11892 C...f -> gamma (Z, W) + f.
11893 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
11896 C...gamma -> q + qbar, g + g.
11897 ELSEIF(K(N+1,2).EQ.22) THEN
11903 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
11907 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
11910 C...qbar -> qbar + g.
11911 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
11914 C...qbar -> g + qbar.
11915 ELSEIF(K(N+1,2).LT.0) THEN
11918 C...g -> g + g; g -> q + qbar.
11919 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
11926 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
11927 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
11928 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
11929 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
11930 IF(ID1.NE.ID2) THEN
11931 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
11932 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
11935 IF(K(IT,1).EQ.1) THEN
11940 C...Boost to new CM-frame.
11941 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
11942 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
11943 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
11944 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
11945 IR=N+(JT-1)*(IS(1)-N)
11946 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
11950 C...Update kinematics variables.
11953 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THE2(JT)=THE2T
11956 C...Save quantities; loop back.
11960 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
11961 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
11962 KFLS(JT+2)=KFLS(JT)
11967 XFS(JT,KFL)=XFA(KFL)
11976 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
11977 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
11978 IF(MSTU(21).GE.1) N=NS
11979 IF(MSTU(21).GE.1) RETURN
11981 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
11983 C...Boost hard scattering partons to frame of shower initiators.
11985 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
11991 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
11992 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
11993 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
11994 CALL PYROBO(MINT(83)+5,NS,0D0,-ROBO(2),0D0,0D0,0D0)
11995 CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
11998 C...Store user information. Reset Lambda value.
11999 K(IPU1,3)=MINT(83)+3
12000 K(IPU2,3)=MINT(83)+4
12002 MINT(12+JT)=KFLS(JT)
12003 VINT(140+JT)=XS(JT)
12004 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
12011 C*********************************************************************
12014 C...Generates maximum ME weight in some initial-state showers.
12015 C...Inparameter MECOR: kind of hard scattering process
12016 C...Outparameter WTFF: maximum weight for fermion -> fermion
12017 C... WTGF: maximum weight for gluon/photon -> fermion
12018 C... WTFG: maximum weight for fermion -> gluon/photon
12019 C... WTGG: maximum weight for gluon -> gluon
12021 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
12023 C...Double precision and integer declarations.
12024 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12025 IMPLICIT INTEGER(I-N)
12026 INTEGER PYK,PYCHGE,PYCOMP
12028 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12029 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12030 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12031 COMMON/PYINT1/MINT(400),VINT(400)
12032 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12033 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
12035 C...Default maximum weight.
12041 C...Select maximum weight by process.
12042 IF(MECOR.EQ.1) THEN
12045 ELSEIF(MECOR.EQ.2) THEN
12053 C*********************************************************************
12056 C...Calculates actual ME weight in some initial-state showers.
12057 C...Inparameter MECOR: kind of hard scattering process
12058 C... IFLCB: flavour combination of branching,
12059 C... 1 for fermion -> fermion,
12060 C... 2 for gluon/photon -> fermion
12061 C... 3 for fermion -> gluon/photon,
12062 C... 4 for gluon -> gluon
12063 C... Q2: Q2 value of shower branching
12064 C... Z: Z value of branching
12065 C...In+outparameter PHIBR: azimuthal angle of branching
12066 C...Outparameter WTME: actual ME weight
12068 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
12070 C...Double precision and integer declarations.
12071 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12072 IMPLICIT INTEGER(I-N)
12073 INTEGER PYK,PYCHGE,PYCOMP
12075 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12076 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12077 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12078 COMMON/PYINT1/MINT(400),VINT(400)
12079 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12080 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
12082 C...Default output.
12085 C...Define kinematics of shower branching in Mandelstam variables.
12089 UH=Q2-SQM*(1D0-Z)/Z
12091 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
12092 IF(MECOR.EQ.1) THEN
12093 IF(IFLCB.EQ.1) THEN
12094 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
12095 ELSEIF(IFLCB.EQ.2) THEN
12096 WTME=(SH**2+UH**2+2D0*SQM*TH)/((SH-SQM)**2+SQM**2)
12099 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
12100 ELSEIF(MECOR.EQ.2) THEN
12101 IF(IFLCB.EQ.3) THEN
12102 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
12103 ELSEIF(IFLCB.EQ.4) THEN
12104 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
12111 C*********************************************************************
12114 C...Administers the generation of successive final-state showers
12115 C...in external processes.
12117 SUBROUTINE PYADSH(NFIN)
12119 C...Double precision and integer declarations.
12120 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12121 IMPLICIT INTEGER(I-N)
12122 INTEGER PYK,PYCHGE,PYCOMP
12124 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12125 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12126 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12127 COMMON/PYINT1/MINT(400),VINT(400)
12128 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
12130 DIMENSION IBEG(100),KSAV(10,5),IORD(10),PSUM(4),BETA(3)
12132 C...Set primary vertex.
12134 V(MINT(83)+5,J)=0D0
12135 V(MINT(83)+6,J)=0D0
12136 V(MINT(84)+1,J)=0D0
12137 V(MINT(84)+2,J)=0D0
12140 C...Isolate systems of particles with the same mother.
12143 DO 140 I=MINT(84)+3,NFIN
12145 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
12152 C...Set production vertices.
12153 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
12160 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
12163 IF(MSTP(125).GE.1) THEN
12171 C...End loop over systems. Return if no showers to be performed.
12172 IBEG(NSYS+1)=NFIN+1
12173 IF(MSTP(71).LE.0) RETURN
12175 C...Loop through systems of particles; check that sensible size.
12177 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
12178 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
12179 ELSEIF(NSIZ.LE.1) THEN
12180 CALL PYERRM(2,'(PYADSH:) only one particle in system')
12181 ELSEIF(NSIZ.GT.7) THEN
12182 CALL PYERRM(2,'(PYADSH:) more than seven particles in system')
12185 C...Save status codes and daughters of showering pair; reset them.
12192 IF(K(I,1).GT.10) THEN
12194 IF(KSAV(II,1).EQ.14) K(I,1)=3
12196 IF(KSAV(II,1).LE.10) THEN
12197 ELSEIF(K(I,1).EQ.1) THEN
12203 KSAV(II,4)=MOD(K(I,4),MSTU(5))
12204 KSAV(II,5)=MOD(K(I,5),MSTU(5))
12205 K(I,4)=K(I,4)-KSAV(II,4)
12206 K(I,5)=K(I,5)-KSAV(II,5)
12209 PSUM(J)=PSUM(J)+P(I,J)
12213 C...Perform shower.
12214 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
12216 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
12219 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
12221 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
12224 C...Look up showered copies of original showering particles.
12228 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
12229 ELSEIF(K(I,1).EQ.11) THEN
12230 180 IMV=MOD(K(IMV,4),MSTU(5))
12231 IF(K(IMV,1).EQ.11) GOTO 180
12233 KDA1=MOD(K(I,4),MSTU(5))
12234 KDA2=MOD(K(I,5),MSTU(5))
12236 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
12239 KDA1=MOD(K(I3,4),MSTU(5))
12240 KDA2=MOD(K(I3,5),MSTU(5))
12245 C...Restore daughter info of original partons to showered copies.
12246 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
12247 IF(KSAV(II,1).LE.10) THEN
12248 ELSEIF(K(I,1).EQ.1) THEN
12249 K(IMV,4)=KSAV(II,4)
12250 K(IMV,5)=KSAV(II,5)
12252 K(IMV,4)=K(IMV,4)+KSAV(II,4)
12253 K(IMV,5)=K(IMV,5)+KSAV(II,5)
12256 C...Reset mother info of existing daughters to showered copies.
12257 DO 200 I3=IBEG(ISYS+1),NFIN
12258 IF(K(I3,3).EQ.I) K(I3,3)=IMV
12259 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
12260 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
12261 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
12265 C...Boost all original daughters to new frame of showered copy.
12268 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
12270 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
12272 BETA(J)=FAC*BETA(J)
12274 DO 240 I3=IBEG(ISYS+1),NFIN
12277 IF(MSTP(128).LE.0) THEN
12278 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 230
12279 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
12280 & CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
12282 IF(IMO.EQ.IMV) THEN
12283 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
12284 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
12292 C...End of loop over showering systems
12299 C*********************************************************************
12302 C...Allows resonances to decay (including parton showers for hadronic
12305 SUBROUTINE PYRESD(IRES)
12307 C...Double precision and integer declarations.
12308 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12309 IMPLICIT INTEGER(I-N)
12310 INTEGER PYK,PYCHGE,PYCOMP
12311 C...Parameter statement to help give large particle numbers.
12312 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
12313 &KEXCIT=4000000,KDIMEN=5000000)
12315 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12316 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12317 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12318 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
12319 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12320 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12321 COMMON/PYINT1/MINT(400),VINT(400)
12322 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12323 COMMON/PYINT4/MWID(500),WIDS(500,5)
12324 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
12325 &/PYINT1/,/PYINT2/,/PYINT4/
12326 C...Local arrays and complex and character variables.
12327 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
12328 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
12329 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
12330 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
12332 COMPLEX FGK,HA(6,6),HC(6,6)
12334 CHARACTER CODE*9,MASS*9
12336 C...The F, Xi and Xj functions of Gunion and Kunszt
12337 C...(Phys. Rev. D33, 665, plus errata from the authors).
12338 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
12339 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
12340 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
12341 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
12342 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
12343 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
12344 &2D0*(D34/D56+D56/D34))
12346 C...Some general constants.
12349 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
12353 GMMZ=PMAS(23,1)*PMAS(23,2)
12355 GMMW=PMAS(24,1)*PMAS(24,2)
12358 C...Boost and rotate to rest frame of incoming partons,
12359 C...to get proper amount of smearing of decay angles.
12363 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
12364 BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
12365 BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
12366 BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
12367 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
12368 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
12369 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
12370 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
12371 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
12374 C...Reset original resonance configuration.
12379 C...Define initial one, two or three objects for subprocess.
12383 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12384 IREF(1,1)=MINT(84)+2+ISET(ISUB)
12385 IREF(1,4)=MINT(83)+6+ISET(ISUB)
12387 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
12388 IREF(1,1)=MINT(84)+1+ISET(ISUB)
12389 IREF(1,2)=MINT(84)+2+ISET(ISUB)
12390 IREF(1,4)=MINT(83)+5+ISET(ISUB)
12391 IREF(1,5)=MINT(83)+6+ISET(ISUB)
12393 ELSEIF(ISET(ISUB).EQ.5) THEN
12394 IREF(1,1)=MINT(84)+3
12395 IREF(1,2)=MINT(84)+4
12396 IREF(1,3)=MINT(84)+5
12397 IREF(1,4)=MINT(83)+7
12398 IREF(1,5)=MINT(83)+8
12399 IREF(1,6)=MINT(83)+9
12403 C...Define original resonance for odd cases.
12406 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
12408 IF(IHDEC.EQ.1) ISUB=3
12410 IREF(1,4)=K(IRES,3)
12414 C...Check if initial resonance has been moved (in resonance + jet).
12416 IF(IREF(1,JT).GT.0) THEN
12417 IF(K(IREF(1,JT),1).GT.10) THEN
12418 KFA=IABS(K(IREF(1,JT),2))
12419 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
12420 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12421 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12422 DO 110 I=IREF(1,JT)+1,N
12423 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
12426 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12427 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12431 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
12432 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
12438 C.....Set decay vertex for initial resonances
12441 V(IREF(1,JT),I)=0D0
12445 C...Loop over decay history.
12451 IF(IREF(IP,2).EQ.0) JTMAX=1
12452 IF(IREF(IP,3).NE.0) JTMAX=3
12456 C...Check for Higgs which appears as decay product of user-process.
12459 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
12461 IF(IHDEC.EQ.1) ISUB=3
12464 C...Start treatment of one, two or three resonances in parallel.
12476 C...Check whether particle can/is allowed to decay.
12477 IF(ID.EQ.0) GOTO 310
12480 IF(MWID(KCA).EQ.0) GOTO 310
12481 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 310
12482 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
12483 & KFA.EQ.18) IT4=IT4+1
12484 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
12485 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
12487 C...Choose lifetime and determine decay vertex.
12488 IF(K(ID,1).EQ.5) THEN
12490 ELSEIF(K(ID,1).NE.4) THEN
12491 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
12494 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
12497 C...Determine whether decay allowed or not.
12499 IF(MSTJ(22).EQ.2) THEN
12500 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
12501 ELSEIF(MSTJ(22).EQ.3) THEN
12502 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
12503 ELSEIF(MSTJ(22).EQ.4) THEN
12504 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
12505 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
12507 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
12512 C...Info for selection of decay channel: sign, pairings.
12513 IF(KCHG(KCA,3).EQ.0) THEN
12516 IPM=(5-ISIGN(1,K(ID,2)))/2
12519 IF(JTMAX.EQ.2) THEN
12520 KFB=IABS(K(IREF(IP,3-JT),2))
12521 ELSEIF(JTMAX.EQ.3) THEN
12523 KFB=IABS(K(IREF(IP,JT2),2))
12524 IF(KFB.NE.KFA) THEN
12525 JT2=JT+2-3*((JT+1)/3)
12526 KFB=IABS(K(IREF(IP,JT2),2))
12530 C...Select decay channel.
12531 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
12532 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
12533 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
12534 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
12535 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
12536 IF(WDTE0S.LE.0D0) GOTO 310
12540 IDC=IDL+MDCY(KCA,2)-1
12541 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
12542 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
12543 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 180
12545 C...Read out flavours and colour charges of decay channel chosen.
12546 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
12547 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
12548 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
12549 KFC1A=PYCOMP(IABS(KFL1(JT)))
12550 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
12551 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
12552 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
12553 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
12554 KFC2A=PYCOMP(IABS(KFL2(JT)))
12555 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
12556 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
12557 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
12558 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
12560 IF(KFL3(JT).NE.0) THEN
12561 KFC3A=PYCOMP(IABS(KFL3(JT)))
12562 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
12563 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
12564 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
12567 C...Set/save further info on channel.
12569 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
12571 HGZ(JT,1)=VINT(111)
12572 HGZ(JT,2)=VINT(112)
12573 HGZ(JT,3)=VINT(114)
12576 C...Select masses; to begin with assume resonances narrow.
12581 KFLW=IABS(KFL1(JT))
12583 ELSEIF(I.EQ.2) THEN
12584 KFLW=IABS(KFL2(JT))
12586 ELSEIF(I.EQ.3) THEN
12587 IF(KFL3(JT).EQ.0) GOTO 200
12588 KFLW=IABS(KFL3(JT))
12591 P(N+I,5)=PMAS(KCW,1)
12593 C...This prevents SUSY/t particles from becoming too light.
12594 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
12595 PMMN(I)=PMAS(KCW,1)
12596 DO 190 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
12597 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
12598 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
12599 & PMAS(PYCOMP(KFDP(IDC,2)),1)
12600 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
12601 & PMAS(PYCOMP(KFDP(IDC,3)),1)
12602 PMMN(I)=MIN(PMMN(I),PMSUM)
12606 ELSEIF(KFLW.EQ.6) THEN
12607 PMMN(I)=PMAS(24,1)+PMAS(5,1)
12611 C...Check which two out of three are widest.
12614 PWID1=PMAS(KFC1A,2)
12615 PWID2=PMAS(KFC2A,2)
12616 KFLW1=IABS(KFL1(JT))
12617 KFLW2=IABS(KFL2(JT))
12618 IF(KFL3(JT).NE.0) THEN
12619 PWID3=PMAS(KFC3A,2)
12620 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
12623 KFLW1=IABS(KFL3(JT))
12624 ELSEIF(PWID3.GT.PWID2) THEN
12627 KFLW2=IABS(KFL3(JT))
12631 C...If all narrow then only check that masses consistent.
12632 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
12633 & PWID2.LT.PARP(41))) THEN
12635 C....Handle near degeneracy cases.
12636 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
12637 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12638 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
12639 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
12643 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12644 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
12647 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
12648 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
12653 C...For three wide resonances select narrower of three
12654 C...according to BW decoupled from rest.
12657 IF(KFL3(JT).NE.0) THEN
12658 IWID3=6-IWID1-IWID2
12659 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
12663 P(N+IWID3,5)=PYMASS(KFLW3)
12664 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 210
12665 PMTOT=PMTOT-P(N+IWID3,5)
12667 C...Select other two correlated within remaining phase space.
12671 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
12672 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
12673 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12678 CKIN(49)=PMMN(IWID1)
12679 CKIN(50)=PMMN(IWID2)
12680 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12685 IF(MINT(51).EQ.1) GOTO 700
12688 C...Begin fill decay products, with colour flow for coloured objects.
12694 C...1) Three-body decays of SUSY particles (plus special case top).
12695 IF(KFL3(JT).NE.0) THEN
12711 C...Set colour flow for t -> W + b + Z.
12715 IF(KCQM(JT).EQ.-1) ISID=5
12717 K(ID,ISID)=K(ID,ISID)+IDAU
12718 K(IDAU,ISID)=MSTU(5)*ID
12720 C...Set colour flow in three-body decays - programmed as special cases.
12721 ELSEIF(KFC2A.LE.6) THEN
12725 IF(KFL2(JT).LT.0) ISID=5
12726 K(N+2,ISID)=MSTU(5)*(N+3)
12727 K(N+3,9-ISID)=MSTU(5)*(N+2)
12729 IF(KFL1(JT).EQ.KSUSY1+21) THEN
12734 IF(KFL2(JT).LT.0) ISID=5
12735 K(N+1,ISID)=MSTU(5)*(N+2)
12736 K(N+1,9-ISID)=MSTU(5)*(N+3)
12737 K(N+2,ISID)=MSTU(5)*(N+1)
12738 K(N+3,9-ISID)=MSTU(5)*(N+1)
12740 IF(KFA.EQ.KSUSY1+21) THEN
12744 IF(KFL2(JT).LT.0) ISID=5
12745 K(ID,ISID)=K(ID,ISID)+(N+2)
12746 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
12747 K(N+2,ISID)=MSTU(5)*ID
12748 K(N+3,9-ISID)=MSTU(5)*ID
12752 IF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
12753 & IABS(KCQ2(JT)).EQ.1) THEN
12757 IF(KFL2(JT).LT.0) ISID=5
12758 K(N+2,ISID)=MSTU(5)*(N+3)
12759 K(N+3,9-ISID)=MSTU(5)*(N+2)
12762 C...Set colour flow in three-body decays with baryon number violation.
12763 C...Neutralino and chargino decays first.
12764 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
12765 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
12766 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
12767 K(N+4,4)=ITJUNC(JT)*MSTU(5)
12768 C...Insert junction to keep track of colours.
12769 IF(KCQ1(JT).NE.0) K(N+1,1)=3
12770 IF(KCQ2(JT).NE.0) K(N+2,1)=3
12771 IF(KCQ3(JT).NE.0) K(N+3,1)=3
12772 C...Set special junction codes:
12776 C...Order decay products by invariant mass. (will be used in PYSTRF).
12777 PM12=P(N+1,4)*P(N+2,4)-P(N+1,1)*P(N+2,1)-P(N+1,2)*P(N+2,2)-
12778 & P(N+1,3)*P(N+2,3)
12779 PM13=P(N+1,4)*P(N+3,4)-P(N+1,1)*P(N+3,1)-P(N+1,2)*P(N+3,2)-
12780 & P(N+1,3)*P(N+3,3)
12781 PM23=P(N+2,4)*P(N+3,4)-P(N+2,1)*P(N+3,1)-P(N+2,2)*P(N+3,2)-
12782 & P(N+2,3)*P(N+3,3)
12783 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
12784 K(N+4,4)=N+3+K(N+4,4)
12785 K(N+4,5)=N+1+MSTU(5)*(N+2)
12786 ELSEIF(PM13.LT.PM23) THEN
12787 K(N+4,4)=N+2+K(N+4,4)
12788 K(N+4,5)=N+1+MSTU(5)*(N+3)
12790 K(N+4,4)=N+1+K(N+4,4)
12791 K(N+4,5)=N+2+MSTU(5)*(N+3)
12797 C...Connect daughters to junction.
12801 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
12803 C...Particle counter should be stepped up one extra for junction.
12807 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
12808 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
12809 K(N+4,4)=ITJUNC(JT)*MSTU(5)
12810 C...Insert junction to keep track of colours.
12811 IF(KCQ1(JT).NE.0) K(N+1,1)=3
12812 IF(KCQ2(JT).NE.0) K(N+2,1)=3
12813 IF(KCQ3(JT).NE.0) K(N+3,1)=3
12824 C...Start by connecting all daughters to junction.
12825 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
12826 C...Only consider colour topologies with off shell resonances.
12827 RMQ1=PMAS(PYCOMP(K(II,2)),1)
12828 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
12829 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
12830 IF (RMGLU-RMQ1.LT.RMRES) THEN
12831 C...Calculate propagators for each colour topology.
12832 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
12833 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
12834 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
12838 CTMSUM=CTMSUM+CTM2(II-N)
12840 CTMSUM=PYR(0)*CTMSUM
12841 C...Select colour topology J, with most off shell least likely.
12844 CTMSUM=CTMSUM-CTM2(J)
12845 IF (CTMSUM.GT.0D0) GOTO 280
12846 C...The lucky winner gets its colour (anti-colour) directly from gluino.
12847 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
12848 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
12849 C...The other gluino colour is connected to junction
12850 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
12852 K(N+4,4)=K(N+4,4)+ID
12853 C...Lastly, connect junction to remaining daughters.
12854 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
12855 C...Particle counter should be stepped up one extra for junction.
12859 C...Update particle counter.
12862 C...2) Everything else two-body decay.
12864 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
12865 C...First set colour flow as if mother colour singlet.
12866 IF(KCQ1(JT).NE.0) THEN
12868 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
12869 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
12871 IF(KCQ2(JT).NE.0) THEN
12873 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
12874 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
12876 C...Then redirect colour flow if mother (anti)triplet.
12877 IF(KCQM(JT).EQ.0) THEN
12878 ELSEIF(KCQM(JT).NE.2) THEN
12880 IF(KCQM(JT).EQ.-1) ISID=5
12882 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
12883 K(ID,ISID)=K(ID,ISID)+IDAU
12884 K(IDAU,ISID)=MSTU(5)*ID
12885 C...Then redirect colour flow if mother octet.
12886 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
12888 IF(KCQ1(JT).EQ.0) IDAU=N
12889 K(ID,4)=K(ID,4)+IDAU
12890 K(ID,5)=K(ID,5)+IDAU
12891 K(IDAU,4)=MSTU(5)*ID
12892 K(IDAU,5)=MSTU(5)*ID
12895 IF(KCQ1(JT).EQ.-1) ISID=5
12896 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
12897 K(ID,ISID)=K(ID,ISID)+(N-1)
12898 K(ID,9-ISID)=K(ID,9-ISID)+N
12899 K(N-1,ISID)=MSTU(5)*ID
12900 K(N,9-ISID)=MSTU(5)*ID
12903 C...Insert junction
12904 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
12906 C...~q* mother: type 3 junction. ~q mother: type 4.
12907 ITJUNC(JT)=(7+KCQM(JT))/2
12908 C...Specify junction KF and set colour flow from junction
12912 C...Junction type encoded together with mother:
12913 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
12914 K(N,5)=N-1+MSTU(5)*(N-2)
12915 C...Zero P and V for junction (V filled later)
12920 C...Set colour flow from mother to junction
12921 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
12922 C...Set colour flow from daughters to junction
12926 C...(Anti-)colour mother is junction.
12927 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
12932 C...End loop over resonances for daughter flavour and mass selection.
12934 310 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
12936 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
12937 & KFL1(JT).EQ.0) THEN
12938 WRITE(CODE,'(I9)') K(ID,2)
12939 WRITE(MASS,'(F9.3)') P(ID,5)
12940 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
12941 & CODE//' with mass'//MASS)
12947 C...Check for allowed combinations. Skip if no decays.
12948 IF(JTMAX.EQ.1) THEN
12949 IF(KDCY(1).EQ.0) GOTO 690
12950 ELSEIF(JTMAX.EQ.2) THEN
12951 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 690
12952 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12953 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12954 ELSEIF(JTMAX.EQ.3) THEN
12955 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 690
12956 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12957 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12958 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12959 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12960 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12961 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12964 C...Special case: matrix element option for Z0 decay to quarks.
12965 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
12966 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
12968 C...Check consistency of MSTJ options set.
12969 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
12971 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
12974 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
12976 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
12981 C...Select alpha_strong behaviour.
12984 MSTU(111)=MSTJ(108)
12985 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
12987 PARU(112)=PARJ(121)
12988 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
12990 C...Find axial fraction in total cross section for scalar gluon model.
12992 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
12993 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
12994 POLL=1D0-PARJ(131)*PARJ(132)
12995 SFF=1D0/(16D0*XW*XW1)
12996 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
12997 & (PARJ(123)*PARJ(124))**2)
12998 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
13000 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
13001 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
13002 & (PARJ(132)-PARJ(131)))
13005 QF=KCHG(KFLC,1)/3D0
13007 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
13008 & 1D0-(2D0*PMQ/P(ID,5))**2))
13009 VF=SIGN(1D0,QF)-4D0*QF*XW
13010 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
13011 & VF**2*HF1W)+VQ**3*HF1W
13012 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
13015 C...Choice of jet configuration.
13016 CALL PYXJET(P(ID,5),NJET,CUT)
13021 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
13022 ELSEIF(NJET.EQ.3) THEN
13023 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
13028 C...Fill jet configuration; return if incorrect kinematics.
13030 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
13031 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
13032 ELSEIF(NJET.EQ.2) THEN
13033 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
13034 ELSEIF(NJET.EQ.3) THEN
13035 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
13036 ELSEIF(KFLN.EQ.21) THEN
13037 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
13040 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
13043 IF(MSTU(24).NE.0) THEN
13050 C...Angular orientation according to matrix element.
13051 IF(MSTJ(106).EQ.1) THEN
13052 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
13053 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
13055 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
13056 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
13059 C...Boost partons to Z0 rest frame.
13060 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
13061 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
13063 C...Mark decayed resonance and add documentation lines,
13065 IDOC=MINT(83)+MINT(4)
13067 I1=MINT(83)+MINT(4)+1
13069 IF(MSTP(128).GE.1) K(I,3)=ID
13070 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
13081 C...Generate parton shower.
13082 IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
13084 C... End special case for Z0: skip ahead.
13090 C...Order incoming partons and outgoing resonances.
13091 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
13094 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
13095 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
13096 & ILIN(1)=2*MINT(84)+3-ILIN(1)
13097 ILIN(2)=2*MINT(84)+3-ILIN(1)
13099 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
13103 IF(K(IREF(IP,1),2).EQ.23) IORD=2
13104 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
13105 IAKIPD=IABS(K(IREF(IP,IORD),2))
13106 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
13107 IF(KDCY(IORD).EQ.0) IORD=3-IORD
13109 C...Order decay products of resonances.
13110 DO 350 JT=IORD,3-IORD,3-2*IORD
13111 IF(KDCY(JT).EQ.0) THEN
13112 ILIN(IMAX+1)=NSD(JT)
13114 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
13115 ILIN(IMAX+1)=N+2*JT-1
13116 ILIN(IMAX+2)=N+2*JT
13118 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
13119 K(N+2*JT,2)=K(NSD(JT)+2,2)
13121 ILIN(IMAX+1)=N+2*JT
13123 ILIN(IMAX+2)=N+2*JT-1
13125 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
13126 K(N+2*JT,2)=K(NSD(JT)+2,2)
13130 C...Find charge, isospin, left- and righthanded couplings.
13135 KFA=IABS(K(ILIN(I),2))
13136 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 370
13137 COUP(I,1)=KCHG(KFA,1)/3D0
13138 COUP(I,2)=(-1)**MOD(KFA,2)
13139 COUP(I,4)=-2D0*COUP(I,1)*XWV
13140 COUP(I,3)=COUP(I,2)+COUP(I,4)
13143 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
13144 IF(ISUB.EQ.22) THEN
13147 IF(I.EQ.5) I1=3-IORD
13150 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
13151 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
13152 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
13157 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
13158 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
13159 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
13160 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
13162 IF(COWT12.LT.PYR(0)*COMX12) GOTO 160
13166 C...Select angular orientation type - Z'/W' only.
13168 IF(ISUB.EQ.141) THEN
13169 IF(PYR(0).LT.PARU(130)) MZPWP=1
13171 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
13172 IAKIR=IABS(K(IREF(2,2),2))
13173 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
13174 IF(IAKIR.LE.20) MZPWP=2
13176 IF(IP.GE.3) MZPWP=2
13177 ELSEIF(ISUB.EQ.142) THEN
13178 IF(PYR(0).LT.PARU(136)) MZPWP=1
13180 IAKIR=IABS(K(IREF(2,2),2))
13181 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
13182 IF(IAKIR.LE.20) MZPWP=2
13184 IF(IP.GE.3) MZPWP=2
13187 C...Select random angles (begin of weighting procedure).
13188 410 DO 420 JT=1,JTMAX
13189 IF(KDCY(JT).EQ.0) GOTO 420
13190 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
13191 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
13192 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
13195 CTHE(JT)=2D0*PYR(0)-1D0
13196 PHI(JT)=PARU(2)*PYR(0)
13200 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
13201 C...Construct massless four-vectors.
13210 IF(KDCY(JT).EQ.0) GOTO 450
13212 P(N+2*JT-1,3)=0.5D0*P(ID,5)
13213 P(N+2*JT-1,4)=0.5D0*P(ID,5)
13214 P(N+2*JT,3)=-0.5D0*P(ID,5)
13215 P(N+2*JT,4)=0.5D0*P(ID,5)
13216 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
13217 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
13220 C...Store incoming and outgoing momenta, with random rotation to
13221 C...avoid accidental zeroes in HA expressions.
13225 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
13226 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
13227 P(N+4+I,5)=P(ILIN(I),5)
13229 P(N+4+I,J)=P(ILIN(I),J)
13232 480 THERR=ACOS(2D0*PYR(0)-1D0)
13233 PHIRR=PARU(2)*PYR(0)
13234 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
13236 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2)
13244 C...Calculate internal products.
13245 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
13246 & ISUB.EQ.142) THEN
13247 DO 520 I1=IMIN,IMAX-1
13248 DO 510 I2=I1+1,IMAX
13249 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
13250 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
13251 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
13252 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
13253 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
13254 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
13255 HC(I1,I2)=CONJG(HA(I1,I2))
13256 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
13257 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
13258 HA(I2,I1)=-HA(I1,I2)
13259 HC(I2,I1)=-HC(I1,I2)
13264 C...Calculate four-products.
13271 DO 560 I1=IMIN,IMAX-1
13272 DO 550 I2=I1+1,IMAX
13273 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
13274 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
13275 PKK(I2,I1)=PKK(I1,I2)
13281 KFAGM=IABS(IREF(IP,7))
13282 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
13283 C...Isotropic decay selected by user.
13287 ELSEIF(JTMAX.EQ.3) THEN
13288 C...Isotropic decay when three mother particles.
13292 ELSEIF(IT4.GE.1) THEN
13293 C... Isotropic decay t -> b + W etc for 4th generation q and l.
13297 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
13298 & IREF(IP,7).EQ.36) THEN
13299 C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
13300 C...CP-odd case added by Kari Ertresvag Myklevoll.
13301 IF(IP.EQ.1) WTMAX=SH**2
13302 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
13303 KFA=IABS(K(IREF(IP,1),2))
13305 KFLF1A=IABS(KFL1(1))
13306 EF1=KCHG(KFLF1A,1)/3D0
13307 AF1=SIGN(1D0,EF1+0.1D0)
13308 VF1=AF1-4D0*EF1*XWV
13309 KFLF2A=IABS(KFL1(2))
13310 EF2=KCHG(KFLF2A,1)/3D0
13311 AF2=SIGN(1D0,EF2+0.1D0)
13312 VF2=AF2-4D0*EF2*XWV
13313 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)
13314 & *(VF2**2+AF2**2))
13315 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
13318 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
13319 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
13322 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
13323 & -2*PKK(3,4)*PKK(5,6)
13324 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
13325 & (PKK(3,4)*PKK(5,6))
13326 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
13327 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
13329 ELSEIF(KFA.EQ.24) THEN
13330 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
13333 WT=16D0*PKK(3,5)*PKK(4,6)
13336 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
13337 & -2*PKK(3,4)*PKK(5,6)
13338 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
13339 & (PKK(3,4)*PKK(5,6))
13340 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
13341 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
13347 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
13348 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
13350 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
13352 IF(MOD(KFAGM,2).EQ.0) THEN
13360 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
13361 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
13362 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
13363 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
13365 ELSEIF(ISUB.EQ.1) THEN
13366 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
13367 EI=KCHG(IABS(MINT(15)),1)/3D0
13368 AI=SIGN(1D0,EI+0.1D0)
13370 EF=KCHG(IABS(KFL1(1)),1)/3D0
13371 AF=SIGN(1D0,EF+0.1D0)
13374 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
13375 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13376 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
13377 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13378 & (VI**2+AI**2)*VINT(114)*VF**2)
13379 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
13380 & 4D0*VI*AI*VINT(114)*VF*AF)
13381 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13382 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13383 WTMAX=2D0*(WT1+ABS(WT3))
13385 ELSEIF(ISUB.EQ.2) THEN
13386 C...Angular weight for W+/- -> 2 quarks/leptons.
13387 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
13388 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
13389 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13390 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13393 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
13394 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
13395 C...-> gluon/gamma + 2 quarks/leptons.
13396 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13397 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13398 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13399 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13400 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13401 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13402 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13403 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13404 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13405 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13406 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13407 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13408 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
13409 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
13410 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13411 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
13413 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
13414 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
13415 C...-> gluon/gamma + 2 quarks/leptons.
13416 WT=PKK(1,3)**2+PKK(2,4)**2
13417 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
13419 ELSEIF(ISUB.EQ.22) THEN
13420 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
13421 S34=P(IREF(IP,IORD),5)**2
13422 S56=P(IREF(IP,3-IORD),5)**2
13423 TI=PKK(1,3)+PKK(1,4)+S34
13424 UI=PKK(1,5)+PKK(1,6)+S56
13427 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
13428 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
13429 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
13430 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
13431 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
13432 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
13433 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
13434 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
13437 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
13438 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
13439 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
13440 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
13441 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
13442 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
13443 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
13446 ELSEIF(ISUB.EQ.23) THEN
13447 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
13448 D34=P(IREF(IP,IORD),5)**2
13449 D56=P(IREF(IP,3-IORD),5)**2
13450 DT=PKK(1,3)+PKK(1,4)+D34
13451 DU=PKK(1,5)+PKK(1,6)+D56
13452 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
13453 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13454 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13455 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
13457 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
13458 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
13459 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
13460 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13461 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
13462 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
13464 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
13465 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
13466 C...(or H0, or A0).
13467 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
13468 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
13469 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
13470 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
13471 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13473 ELSEIF(ISUB.EQ.25) THEN
13474 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
13475 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
13476 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
13477 D34=P(IREF(IP,IORD),5)**2
13478 D56=P(IREF(IP,3-IORD),5)**2
13479 DT=PKK(1,3)+PKK(1,4)+D34
13480 DU=PKK(1,5)+PKK(1,6)+D56
13481 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
13482 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
13483 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
13484 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
13485 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
13486 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
13487 & REAL(CBWW)*FGK(1,2,5,6,3,4))
13488 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13489 IF(MSTP(50).LE.0) THEN
13490 WT=FGK135**2+(CCWW*FGK253)**2
13491 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
13492 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
13495 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
13496 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
13497 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
13498 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
13501 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
13502 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
13503 C...(or H0, or A0).
13504 WT=PKK(1,3)*PKK(2,4)
13505 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13507 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
13508 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
13509 C...-> f + 2 quarks/leptons.
13510 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13511 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13512 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13513 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13514 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13515 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13516 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13517 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13518 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13519 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13520 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13521 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13522 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
13523 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
13524 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
13525 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
13526 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13527 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
13529 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
13530 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
13531 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
13532 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
13533 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
13535 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
13537 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
13538 WT=16D0*PKK(3,5)*PKK(4,6)
13541 ELSEIF(ISUB.EQ.110) THEN
13542 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
13546 ELSEIF(ISUB.EQ.141) THEN
13547 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13548 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
13549 C...Couplings of incoming flavour.
13550 KFAI=IABS(MINT(15))
13551 EI=KCHG(KFAI,1)/3D0
13552 AI=SIGN(1D0,EI+0.1D0)
13555 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
13556 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
13557 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
13558 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
13559 VPI=PARU(119+2*KFAIC)
13560 API=PARU(120+2*KFAIC)
13561 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
13562 VPI=PARJ(178+2*KFAIC)
13563 API=PARJ(179+2*KFAIC)
13565 VPI=PARJ(186+2*KFAIC)
13566 API=PARJ(187+2*KFAIC)
13568 C...Couplings of final flavour.
13570 EF=KCHG(KFAF,1)/3D0
13571 AF=SIGN(1D0,EF+0.1D0)
13574 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
13575 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
13576 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
13577 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
13578 VPF=PARU(119+2*KFAFC)
13579 APF=PARU(120+2*KFAFC)
13580 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
13581 VPF=PARJ(178+2*KFAFC)
13582 APF=PARJ(179+2*KFAFC)
13584 VPF=PARJ(186+2*KFAFC)
13585 APF=PARJ(187+2*KFAFC)
13587 C...Asymmetry and weight.
13588 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
13589 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
13590 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
13591 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13592 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
13593 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
13594 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
13595 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13596 WTMAX=2D0+ABS(ASYM)
13597 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
13598 C...Angular weight for f + fbar -> Z' -> W+ + W-.
13599 RM1=P(NSD(1)+1,5)**2/SH
13600 RM2=P(NSD(1)+2,5)**2/SH
13601 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13602 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13603 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13605 WT=CFLAT+CCOS2*CTHE(1)**2
13606 WTMAX=CFLAT+MAX(0D0,CCOS2)
13607 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
13608 & IABS(KFL1(1)).EQ.37)) THEN
13609 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
13612 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13613 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
13614 RM1=P(NSD(1)+1,5)**2/SH
13615 RM2=P(NSD(1)+2,5)**2/SH
13616 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13617 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13618 WTMAX=1D0+FLAM2/(8D0*RM1)
13619 ELSEIF(MZPWP.EQ.0) THEN
13620 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13621 C...(W:s like if intermediate Z).
13622 D34=P(IREF(IP,IORD),5)**2
13623 D56=P(IREF(IP,3-IORD),5)**2
13624 DT=PKK(1,3)+PKK(1,4)+D34
13625 DU=PKK(1,5)+PKK(1,6)+D56
13626 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13627 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13628 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
13629 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
13630 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13631 ELSEIF(MZPWP.EQ.1) THEN
13632 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13633 C...(W:s approximately longitudinal, like if intermediate H).
13634 WT=16D0*PKK(3,5)*PKK(4,6)
13637 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
13638 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
13643 ELSEIF(ISUB.EQ.142) THEN
13644 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13645 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
13646 KFAI=IABS(MINT(15))
13648 IF(KFAI.GT.10) KFAIC=2
13649 VI=PARU(129+2*KFAIC)
13650 AI=PARU(130+2*KFAIC)
13653 IF(KFAF.GT.10) KFAFC=2
13654 VF=PARU(129+2*KFAFC)
13655 AF=PARU(130+2*KFAFC)
13656 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
13657 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13658 WTMAX=2D0+ABS(ASYM)
13659 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
13660 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
13661 RM1=P(NSD(1)+1,5)**2/SH
13662 RM2=P(NSD(1)+2,5)**2/SH
13663 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13664 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13665 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13667 WT=CFLAT+CCOS2*CTHE(1)**2
13668 WTMAX=CFLAT+MAX(0D0,CCOS2)
13669 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13670 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
13671 RM1=P(NSD(1)+1,5)**2/SH
13672 RM2=P(NSD(1)+2,5)**2/SH
13673 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13674 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13675 WTMAX=1D0+FLAM2/(8D0*RM1)
13676 ELSEIF(MZPWP.EQ.0) THEN
13677 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13678 C...(W/Z like if intermediate W).
13679 D34=P(IREF(IP,IORD),5)**2
13680 D56=P(IREF(IP,3-IORD),5)**2
13681 DT=PKK(1,3)+PKK(1,4)+D34
13682 DU=PKK(1,5)+PKK(1,6)+D56
13683 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13684 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
13685 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13686 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
13687 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13688 ELSEIF(MZPWP.EQ.1) THEN
13689 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13690 C...(W/Z approximately longitudinal, like if intermediate H).
13691 WT=16D0*PKK(3,5)*PKK(4,6)
13694 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
13695 C...t + bbar -> t + W + bbar.
13700 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
13702 C...Isotropic decay of leptoquarks (assumed spin 0).
13706 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
13707 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
13709 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
13710 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
13711 WT=1D0+SIDE*CTHE(1)
13713 ELSEIF(IP.EQ.1) THEN
13715 RM1=P(NSD(1)+1,5)**2/SH
13716 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13717 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13719 C...W/Z decay assumed isotropic, since not known.
13724 ELSEIF(ISUB.EQ.149) THEN
13725 C...Isotropic decay of techni-eta.
13729 ELSEIF(ISUB.EQ.191) THEN
13730 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13731 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
13732 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
13735 ELSEIF(IP.EQ.1) THEN
13736 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
13737 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13738 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
13739 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13740 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13741 KFAI=IABS(MINT(15))
13742 EI=KCHG(KFAI,1)/3D0
13743 AI=SIGN(1D0,EI+0.1D0)
13747 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
13748 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
13750 EF=KCHG(KFAF,1)/3D0
13751 AF=SIGN(1D0,EF+0.1D0)
13755 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
13756 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
13757 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
13758 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
13759 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
13760 WTMAX=4D0*MAX(ASAME,AFLIP)
13762 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
13767 ELSEIF(ISUB.EQ.192) THEN
13768 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13769 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
13770 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
13773 ELSEIF(IP.EQ.1) THEN
13774 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
13775 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13779 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
13784 ELSEIF(ISUB.EQ.193) THEN
13785 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13786 C...Angular weight for f + fbar -> omega_tc0 ->
13787 C...gamma pi_tc0 or Z0 pi_tc0.
13790 ELSEIF(IP.EQ.1) THEN
13791 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
13792 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13793 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13794 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13795 KFAI=IABS(MINT(15))
13796 EI=KCHG(KFAI,1)/3D0
13797 AI=SIGN(1D0,EI+0.1D0)
13801 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
13802 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
13804 EF=KCHG(KFAF,1)/3D0
13805 AF=SIGN(1D0,EF+0.1D0)
13809 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
13810 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
13811 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
13812 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
13813 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
13814 WTMAX=4D0*MAX(BSAME,BFLIP)
13816 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
13821 ELSEIF(ISUB.EQ.353) THEN
13822 C...Angular weight for Z_R0 -> 2 quarks/leptons.
13823 EI=KCHG(IABS(MINT(15)),1)/3D0
13824 AI=SIGN(1D0,EI+0.1D0)
13826 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
13827 AF=SIGN(1D0,EF+0.1D0)
13829 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
13830 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
13831 WT2=RMF*(VI**2+AI**2)*VF**2
13832 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
13833 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13834 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13835 WTMAX=2D0*(WT1+ABS(WT3))
13837 ELSEIF(ISUB.EQ.354) THEN
13838 C...Angular weight for W_R+/- -> 2 quarks/leptons.
13839 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
13840 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
13841 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13842 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13845 ELSEIF(ISUB.EQ.391) THEN
13846 C...Angular weight for f + fbar -> G* -> f + fbar
13847 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13848 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
13850 C...Other G* decays not yet implemented angular distributions.
13856 ELSEIF(ISUB.EQ.392) THEN
13857 C...Angular weight for g + g -> G* -> f + fbar
13858 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13861 C...Other G* decays not yet implemented angular distributions.
13867 C...Obtain correct angular distribution by rejection techniques.
13872 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
13874 C...Construct massive four-vectors using angles chosen.
13875 570 DO 670 JT=1,JTMAX
13876 IF(KDCY(JT).EQ.0) GOTO 670
13881 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
13883 IF(KFL3(JT).EQ.0) THEN
13884 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
13885 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13888 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
13889 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13894 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
13896 C...Fill in position of decay vertex.
13897 DO 610 I=NSD(JT)+1,N0
13906 C...Mark decayed resonances; trace history.
13910 IF(KCQM(JT).NE.0) THEN
13911 C...Do not kill colour flow through coloured resonance!
13915 C...If 3-body or 2-body with junction:
13916 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
13917 C...If 3-body with junction:
13918 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
13921 C...Add documentation lines.
13922 ISUBRG=MAX(1,MIN(500,MINT(1)))
13923 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
13924 IDOC=MINT(83)+MINT(4)
13927 IF(KFL3(JT).NE.0) IHI=IHI+1
13928 DO 630 I=NSD(JT)+1,IHI
13930 I1=MINT(83)+MINT(4)+1
13932 IF(MSTP(128).GE.1) K(I,3)=ID
13933 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
13937 K(I1,3)=IREF(IP,JT+3)
13946 C...If 3-body or 2-body with junction:
13947 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
13948 C...If 3-body with junction:
13949 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
13952 C...Do showering of two or three objects.
13954 IF(MSTP(71).GE.1) THEN
13955 IF(KFL3(JT).EQ.0) THEN
13956 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
13958 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
13962 IF(JT.EQ.1) NAFT1=N
13964 C...Check if decay products moved by shower.
13968 IF(NSHAFT.GT.NSHBEF) THEN
13969 IF(K(NSD1,1).GT.10) THEN
13970 DO 640 I=NSHBEF+1,NSHAFT
13971 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
13974 IF(K(NSD2,1).GT.10) THEN
13975 DO 650 I=NSHBEF+1,NSHAFT
13976 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
13977 & I.NE.NSD1) NSD2=I
13980 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
13981 DO 660 I=NSHBEF+1,NSHAFT
13982 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
13983 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
13988 C...Store decay products for further treatment.
13993 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
13997 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
13998 IREF(NP,7)=K(IREF(IP,JT),2)
13999 IREF(NP,8)=IREF(IP,JT)
14002 C...Fill information for 2 -> 1 -> 2.
14003 680 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
14004 MINT(7)=MINT(83)+6+2*ISET(ISUB)
14005 MINT(8)=MINT(83)+7+2*ISET(ISUB)
14011 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
14012 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
14013 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
14014 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
14015 VINT(47)=SQRT(VINT(48))
14018 C...Possibility of colour rearrangement in W+W- events.
14019 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
14020 IAKF1=IABS(KFL1(1))
14021 IAKF2=IABS(KFL1(2))
14022 IAKF3=IABS(KFL2(1))
14023 IAKF4=IABS(KFL2(2))
14024 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
14025 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
14026 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
14029 C...Loop back if needed.
14030 690 IF(IP.LT.NP) GOTO 150
14032 C...Boost back to standard frame.
14033 700 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
14039 C*********************************************************************
14042 C...Initializes treatment of multiple interactions, selects kinematics
14043 C...of hardest interaction if low-pT physics included in run, and
14044 C...generates all non-hardest interactions.
14046 SUBROUTINE PYMULT(MMUL)
14048 C...Double precision and integer declarations.
14049 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14050 IMPLICIT INTEGER(I-N)
14051 INTEGER PYK,PYCHGE,PYCOMP
14053 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14054 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14055 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14056 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
14057 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14058 COMMON/PYINT1/MINT(400),VINT(400)
14059 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14060 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
14061 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
14062 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
14063 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
14064 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
14065 C...Local arrays and saved variables.
14066 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
14067 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
14069 C...Initialization of multiple interaction treatment.
14071 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
14079 C...Loop over phase space points: xT2 choice in 20 bins.
14082 NMUL(IXT2)=MSTP(83)
14084 DO 110 ITRY=1,MSTP(83)
14085 RSCA=0.05D0*((21-IXT2)-PYR(0))
14086 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
14087 XT2=MAX(0.01D0*VINT(149),XT2)
14090 C...Choose tau and y*. Calculate cos(theta-hat).
14091 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14092 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14093 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14095 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14101 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14102 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14103 CALL PYKMAP(2,MYST,PYR(0))
14104 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14106 C...Calculate differential cross-section.
14107 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
14108 CALL PYSIGH(NCHN,SIGS)
14109 SIGM(IXT2)=SIGM(IXT2)+SIGS
14111 SIGSUM=SIGSUM+SIGM(IXT2)
14113 SIGSUM=SIGSUM/(20D0*MSTP(83))
14115 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
14116 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
14117 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
14118 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
14119 PARP(82)=0.9D0*PARP(82)
14120 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
14124 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
14125 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
14127 C...Start iteration to find k factor.
14128 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
14136 130 IF(IIT.EQ.0) THEN
14138 ELSEIF(IIT.EQ.1) THEN
14141 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
14144 C...Evaluate overlap integrals.
14145 IF(MSTP(82).EQ.2) THEN
14146 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
14149 IF(MSTP(82).EQ.3) DELTAB=0.02D0
14150 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
14155 IF(MSTP(82).EQ.3) THEN
14156 OV=EXP(-B**2)/PARU(2)
14159 OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
14160 & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
14161 & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
14162 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
14164 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
14165 SP=SP+PARU(2)*B*DELTAB*PACC
14166 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
14167 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
14169 YK=PARU(1)*XK*SO/SP
14171 C...Continue iteration until convergence.
14181 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
14183 C...Store some results for subsequent use.
14188 C...Initialize iteration in xT2 for hardest interaction.
14189 ELSEIF(MMUL.EQ.2) THEN
14190 IF(MSTP(82).LE.0) THEN
14191 ELSEIF(MSTP(82).EQ.1) THEN
14193 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
14194 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
14195 & VINT(317)/(VINT(318)*VINT(320))
14196 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
14197 ELSEIF(MSTP(82).EQ.2) THEN
14199 XT2FAC=VINT(146)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
14200 & VINT(149)*(1D0+VINT(149))
14202 XC2=4D0*CKIN(3)**2/VINT(2)
14203 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
14206 ELSEIF(MMUL.EQ.3) THEN
14207 C...Low-pT or multiple interactions (first semihard interaction):
14208 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
14209 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
14211 IF(MSTP(82).LE.0) THEN
14213 ELSEIF(MSTP(82).EQ.1) THEN
14214 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
14215 ELSEIF(MSTP(82).EQ.2) THEN
14216 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
14217 & VINT(149)))).GT.PYR(0)) XT2=1D0
14218 IF(XT2.GE.1D0) THEN
14219 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
14220 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
14223 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
14224 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
14227 XT2=MAX(0.01D0*VINT(149),XT2)
14229 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
14230 & PYR(0)*(1D0-XC2))-VINT(149)
14231 XT2=MAX(0.01D0*VINT(149),XT2)
14235 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
14236 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
14237 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
14238 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
14241 VINT(21)=0.01D0*VINT(149)
14244 VINT(25)=0.01D0*VINT(149)
14247 C...Multiple interactions (first semihard interaction).
14248 C...Choose tau and y*. Calculate cos(theta-hat).
14249 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14250 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14251 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14253 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14259 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14260 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14261 CALL PYKMAP(2,MYST,PYR(0))
14262 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14264 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
14266 C...Store results of cross-section calculation.
14267 ELSEIF(MMUL.EQ.4) THEN
14270 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
14271 IF(ISET(ISUB).EQ.2)
14272 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
14273 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
14274 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
14275 & (XTS+VINT(149))))
14276 IRBIN=INT(1D0+20D0*RBIN)
14277 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
14278 NMUL(IRBIN)=NMUL(IRBIN)+1
14279 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
14282 C...Choose impact parameter.
14283 ELSEIF(MMUL.EQ.5) THEN
14285 150 IF(MSTP(82).EQ.3) THEN
14286 VINT(148)=PYR(0)/(PARU(2)*VINT(147))
14290 IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
14292 ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
14293 B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
14295 B2=-CQ2*LOG(PYR(0))
14297 VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
14298 & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
14299 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
14302 C...Multiple interactions (variable impact parameter) : reject with
14303 C...probability exp(-overlap*cross-section above pT/normalization).
14304 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
14305 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
14306 DO 160 IBIN=IRBIN+1,20
14307 RNCOR=RNCOR+NMUL(IBIN)
14308 SIGCOR=SIGCOR+SIGM(IBIN)
14310 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
14311 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
14312 VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
14313 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
14314 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
14315 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
14316 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
14317 IF(VINT(150).LT.PYR(0)) GOTO 150
14321 C...Generate additional multiple semihard interactions.
14322 ELSEIF(MMUL.EQ.6) THEN
14332 C...Reconstruct strings in hard scattering.
14334 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
14335 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
14337 DO 190 I=MINT(84)+1,NMAX
14338 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
14339 IF(KCS.EQ.0) GOTO 190
14341 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 180
14342 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 180
14344 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
14346 IST=MOD(K(I,J+1),MSTU(5))
14348 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 180
14349 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 180
14351 IF(J.EQ.1.OR.J.EQ.4) THEN
14361 C...Set up starting values for iteration in xT2.
14362 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
14363 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
14364 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
14365 & ISUBSV.NE.96)) THEN
14366 XT2=(1D0-VINT(141))*(1D0-VINT(142))
14369 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
14370 IF(ISET(ISUBSV).EQ.2)
14371 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
14372 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
14374 IF(MSTP(82).LE.1) THEN
14375 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
14376 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
14377 & VINT(317)/(VINT(318)*VINT(320))
14378 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
14380 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
14381 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
14385 VINT(143)=1D0-VINT(141)
14386 VINT(144)=1D0-VINT(142)
14388 C...Iterate downwards in xT2.
14389 200 IF(MSTP(82).LE.1) THEN
14390 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
14391 IF(XT2.LT.VINT(149)) GOTO 250
14393 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 250
14394 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
14395 & LOG(PYR(0)))-VINT(149)
14396 IF(XT2.LE.0D0) GOTO 250
14397 XT2=MAX(0.01D0*VINT(149),XT2)
14401 C...Choose tau and y*. Calculate cos(theta-hat).
14402 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14403 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14404 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14406 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14412 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14413 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14414 CALL PYKMAP(2,MYST,PYR(0))
14415 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14417 C...Check that x not used up. Accept or reject kinematical variables.
14418 X1M=SQRT(TAU)*EXP(VINT(22))
14419 X2M=SQRT(TAU)*EXP(-VINT(22))
14420 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 200
14421 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
14422 CALL PYSIGH(NCHN,SIGS)
14423 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
14424 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 200
14426 C...Reset K, P and V vectors. Select some variables.
14435 PT=0.5D0*VINT(1)*SQRT(XT2)
14439 C...Add first parton to event record.
14442 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
14443 & 1+INT((2D0+PARJ(2))*PYR(0))
14444 P(N+1,1)=PT*COS(PHI)
14445 P(N+1,2)=PT*SIN(PHI)
14446 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
14447 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
14450 C...Add second parton to event record.
14453 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
14456 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
14457 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
14460 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
14461 C....Choose relevant string pieces to place gluons on.
14467 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
14468 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
14469 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
14470 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
14471 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
14479 C....Colour flow adjustments, new string pieces.
14480 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
14481 & MOD(K(IST1,4),MSTU(5))
14482 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
14483 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
14484 K(I,5)=MSTU(5)*IST1
14485 K(I,4)=MSTU(5)*IST2
14486 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
14487 & MOD(K(IST2,5),MSTU(5))
14488 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
14489 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
14492 KSTR(NSTR+1,2)=IST2
14496 C...String drawing and colour flow for gluon loop.
14497 ELSEIF(K(N+1,2).EQ.21) THEN
14498 K(N+1,4)=MSTU(5)*(N+2)
14499 K(N+1,5)=MSTU(5)*(N+2)
14500 K(N+2,4)=MSTU(5)*(N+1)
14501 K(N+2,5)=MSTU(5)*(N+1)
14508 C...String drawing and colour flow for qqbar pair.
14510 K(N+1,4)=MSTU(5)*(N+2)
14511 K(N+2,5)=MSTU(5)*(N+1)
14517 C...Update remaining energy; iterate.
14519 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14520 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
14521 IF(MSTU(21).GE.1) RETURN
14523 MINT(31)=MINT(31)+1
14524 VINT(151)=VINT(151)+VINT(41)
14525 VINT(152)=VINT(152)+VINT(42)
14526 VINT(143)=VINT(143)-VINT(41)
14527 VINT(144)=VINT(144)-VINT(42)
14528 IF(MINT(31).LT.240) GOTO 200
14536 C...Format statements for printout.
14537 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
14538 &'actions for MSTP(82) =',I2,' ******')
14539 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14540 &D9.2,' mb: rejected')
14541 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14542 &D9.2,' mb: accepted')
14547 C*********************************************************************
14550 C...Adds on target remnants (one or two from each side) and
14551 C...includes primordial kT for hadron beams.
14553 SUBROUTINE PYREMN(IPU1,IPU2)
14555 C...Double precision and integer declarations.
14556 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14557 IMPLICIT INTEGER(I-N)
14558 INTEGER PYK,PYCHGE,PYCOMP
14560 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14561 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14562 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14563 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14564 COMMON/PYINT1/MINT(400),VINT(400)
14565 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
14567 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
14568 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
14570 C...Find event type and remaining energy.
14573 IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
14574 VINT(143)=1D0-VINT(141)
14575 VINT(144)=1D0-VINT(142)
14578 C...Define initial partons.
14583 IF(JT.EQ.1) IPU=IPU1
14584 IF(JT.EQ.2) IPU=IPU2
14591 IF(MINT(47).EQ.1) THEN
14595 ELSEIF(ISUB.EQ.95) THEN
14600 C...No primordial kT, or chosen according to truncated Gaussian or
14601 C...exponential, or (for photon) predetermined or power law.
14602 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
14603 IF(MSTP(91).LE.0) THEN
14605 ELSEIF(MSTP(91).EQ.1) THEN
14606 PT=PARP(91)*SQRT(-LOG(PYR(0)))
14610 PT=-PARP(92)*LOG(RPT1*RPT2)
14612 IF(PT.GT.PARP(93)) GOTO 120
14613 ELSEIF(MINT(106+JT).EQ.3) THEN
14614 PTA=SQRT(VINT(282+JT))
14616 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
14617 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
14618 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
14621 PTB=-PARP(99)*LOG(RPT1*RPT2)
14623 IF(PTB.GT.PARP(100)) GOTO 120
14624 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
14625 PT=PT*0.8D0**MINT(57)
14626 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
14627 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
14628 IF(MSTP(93).LE.0) THEN
14630 ELSEIF(MSTP(93).EQ.1) THEN
14631 PT=PARP(99)*SQRT(-LOG(PYR(0)))
14632 ELSEIF(MSTP(93).EQ.2) THEN
14635 PT=-PARP(99)*LOG(RPT1*RPT2)
14636 ELSEIF(MSTP(93).EQ.3) THEN
14639 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
14643 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
14644 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
14646 IF(PT.GT.PARP(100)) GOTO 120
14654 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14657 IF(MINT(47).EQ.1) RETURN
14659 C...Kinematics construction for initial partons.
14662 IF(ISUB.EQ.95) THEN
14666 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
14667 & (P(I1,2)+P(I2,2))**2
14668 SHR=SQRT(MAX(0D0,SHS))
14669 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
14670 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
14671 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
14672 P(I2,4)=SHR-P(I1,4)
14675 C...Transform partons to overall CM-frame.
14676 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
14677 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
14678 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
14679 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
14680 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
14681 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
14682 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
14683 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
14684 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
14685 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
14686 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
14689 C...Optionally fix up x and Q2 definitions for leptoproduction.
14691 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
14692 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
14693 IF(IDISXQ.EQ.1) THEN
14695 C...Find where incoming and outgoing leptons/partons are sitting.
14697 IF(MINT(42).EQ.1) LESD=2
14698 LPIN=MINT(83)+3-LESD
14700 LQIN=MINT(84)+3-LESD
14701 LEOUT=MINT(84)+2+LESD
14702 LQOUT=MINT(84)+5-LESD
14703 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
14704 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
14706 DO 140 I=MINT(84)+5,N
14707 IF(K(I,2).EQ.94) THEN
14714 IF(LESD.EQ.1) LQBG=IPU2
14716 C...Calculate actual and wanted momentum transfer.
14719 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
14720 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
14721 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
14722 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
14723 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
14724 P(N+1,1)=FAC*P(LEOUT,1)
14725 P(N+1,2)=FAC*P(LEOUT,2)
14726 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
14727 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
14728 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
14731 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
14732 QNEW(J)=P(LEIN,J)-P(N+1,J)
14735 C...Boost outgoing electron and daughters.
14736 IF(LSCMS.EQ.0) THEN
14738 P(LEOUT,J)=P(N+1,J)
14742 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
14744 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
14746 DBE(J)=PINV*P(N+2,J)
14750 190 IORIG=K(IORIG,3)
14751 IF(IORIG.GT.LEOUT) GOTO 190
14752 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
14753 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
14757 C...Copy shower initiator and all outgoing partons.
14761 P(NCOP,J)=P(LQBG,J)
14763 DO 240 I=MINT(84)+1,N
14765 IF(K(I,1).GT.10) GOTO 240
14766 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
14770 220 IORIG=K(IORIG,3)
14771 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
14773 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
14786 C...Calculate relative rescaling factors.
14790 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
14793 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
14796 C...Transfer extra three-momentum of current.
14799 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
14801 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14804 C...Iterate change of initiator momentum to get energy right.
14807 PEEX=-P(N+1,4)-QNEW(4)
14808 PEMV=-P(N+1,3)/P(N+1,4)
14811 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
14813 IF(ABS(PEMV).LT.1D-10) THEN
14815 MINT(57)=MINT(57)+1
14819 P(N+1,3)=P(N+1,3)+PZCH
14820 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)
14822 P(I,3)=P(I,3)+V(I,1)*PZCH
14823 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14825 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
14827 C...Modify momenta in event record.
14828 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
14829 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
14830 IF(ABS(HBE).GE.1D0) THEN
14832 MINT(57)=MINT(57)+1
14836 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
14845 C...Check minimum invariant mass of remnant system(s).
14846 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
14847 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
14848 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
14849 PMIN(0)=SQRT(PMS(0))
14851 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
14852 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
14854 IF(MINT(44+JT).EQ.1) GOTO 340
14855 MINT(105)=MINT(102+JT)
14856 MINT(109)=MINT(106+JT)
14857 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
14858 IF(MINT(51).NE.0) THEN
14859 MINT(57)=MINT(57)+1
14862 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
14863 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
14864 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
14865 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
14866 & P(MINT(83)+JT+2,2)**2)
14868 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
14869 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
14872 MINT(57)=MINT(57)+1
14876 C...Loop over two remnants; skip if none there.
14880 IF(MINT(44+JT).EQ.1) GOTO 410
14881 IF(JT.EQ.1) IPU=IPU1
14882 IF(JT.EQ.2) IPU=IPU2
14884 C...Store first remnant parton.
14896 P(I,5)=PYMASS(K(I,2))
14898 C...First parton colour connections and kinematics.
14899 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
14902 K(I,4)=MSTU(5)*IPU+IPU
14903 K(I,5)=MSTU(5)*IPU+IPU
14904 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14905 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14906 ELSEIF(KCOL.NE.0) THEN
14908 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
14910 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14912 IF(KFLCH(JT).EQ.0) THEN
14913 P(I,1)=-P(MINT(83)+JT+2,1)
14914 P(I,2)=-P(MINT(83)+JT+2,2)
14915 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14916 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
14920 C...When extra remnant parton or hadron: store extra remnant.
14932 P(I,5)=PYMASS(K(I,2))
14934 C...Find parton colour connections of extra remnant.
14935 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
14938 K(I,4)=MSTU(5)*IPU+IPU
14939 K(I,5)=MSTU(5)*IPU+IPU
14940 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14941 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14942 ELSEIF(KCOL.NE.0) THEN
14944 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
14946 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14949 C...Relative transverse momentum when two remnants.
14952 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
14953 IF(IABS(MINT(10+JT)).LT.20) THEN
14957 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
14958 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
14960 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
14961 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
14962 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
14963 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14965 C...Meson or baryon; photon as meson. For splitup below.
14967 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
14969 C***Relative distribution for electron into two electrons. Temporary!
14970 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
14974 C...Relative distribution of electron energy into electron plus parton.
14975 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
14978 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
14980 C...Relative distribution of energy for particle into two jets.
14981 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
14982 CHIK=PARP(92+2*IMB)
14983 IF(MSTP(92).LE.1) THEN
14984 IF(IMB.EQ.1) CHI(JT)=PYR(0)
14985 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
14986 ELSEIF(MSTP(92).EQ.2) THEN
14987 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
14988 ELSEIF(MSTP(92).EQ.3) THEN
14989 CUT=2D0*0.3D0/VINT(1)
14990 380 CHI(JT)=PYR(0)**2
14991 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
14992 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
14993 ELSEIF(MSTP(92).EQ.4) THEN
14994 CUT=2D0*0.3D0/VINT(1)
14995 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
14996 390 CHIR=CUT*CUTR**PYR(0)
14997 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
14998 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
15000 CUT=2D0*0.3D0/VINT(1)
15001 CUTA=CUT**(1D0-PARP(98))
15002 CUTB=(1D0+CUT)**(1D0-PARP(98))
15003 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
15004 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
15005 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
15008 C...Relative distribution of energy for particle into jet plus particle.
15010 IF(MSTP(94).LE.1) THEN
15011 IF(IMB.EQ.1) CHI(JT)=PYR(0)
15012 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
15013 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
15014 ELSEIF(MSTP(94).EQ.2) THEN
15015 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
15016 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
15017 ELSEIF(MSTP(94).EQ.3) THEN
15018 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
15021 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
15026 C...Construct total transverse mass; reject if too large.
15027 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
15028 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
15029 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
15030 IF(LOOP.LT.100) THEN
15034 MINT(57)=MINT(57)+1
15038 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
15039 VINT(158+JT)=CHI(JT)
15041 C...Subdivide longitudinal momentum according to value selected above.
15042 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
15043 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
15044 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
15045 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
15046 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
15051 C...Check if longitudinal boosts needed - if so pick two systems.
15052 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
15053 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
15054 IF(PDEV.LE.1D-6*VINT(1)) RETURN
15055 IF(ISN(1).EQ.0) THEN
15058 ELSEIF(ISN(2).EQ.0) THEN
15061 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
15064 ELSEIF(VINT(143).GT.0.2D0) THEN
15067 ELSEIF(VINT(144).GT.0.2D0) THEN
15070 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
15079 C...E+-pL wanted for system to be modified.
15080 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
15084 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
15085 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
15088 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
15089 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
15090 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
15091 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
15095 DO 450 I=MINT(84)+1,NS
15096 IF(K(I,1).GT.10) GOTO 450
15099 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
15101 IF(IORIG.GT.LPIN) GOTO 430
15102 IF(INCL.EQ.0) GOTO 450
15104 PSYS(0,J)=PSYS(0,J)+P(I,J)
15107 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
15108 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
15109 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
15112 C...Construct longitudinal boosts.
15116 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
15117 IF(DSQLAM.LE.1D-6*DPMTB) THEN
15119 MINT(57)=MINT(57)+1
15122 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
15123 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
15124 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
15125 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
15126 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
15127 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
15128 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
15130 C...Perform longitudinal boosts.
15131 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
15133 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
15134 ELSEIF(IR.EQ.1) THEN
15135 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
15136 ELSEIF(IDISXQ.EQ.1) THEN
15140 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
15142 IF(IORIG.GT.LPIN) GOTO 460
15143 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
15146 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
15148 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
15150 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
15151 ELSEIF(IL.EQ.2) THEN
15152 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
15153 ELSEIF(IDISXQ.EQ.1) THEN
15157 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
15159 IF(IORIG.GT.LPIN) GOTO 480
15160 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
15163 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
15166 C...Final check that energy-momentum conservation worked.
15169 DO 500 I=MINT(84)+1,N
15170 IF(K(I,1).GT.10) GOTO 500
15174 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
15175 IF(PDEV.GT.1D-4*VINT(1)) THEN
15177 MINT(57)=MINT(57)+1
15181 C...Calculate rotation and boost from overall CM frame to
15182 C...hadronic CM frame in leptoproduction.
15184 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
15187 IF(MINT(42).EQ.1) LESD=2
15188 LPIN=MINT(83)+3-LESD
15190 C...Sum upp momenta of everything not lepton or photon to define boost.
15195 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
15196 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
15197 IF(K(I,2).EQ.22) GOTO 530
15199 PSUM(J)=PSUM(J)+P(I,J)
15202 VINT(223)=-PSUM(1)/PSUM(4)
15203 VINT(224)=-PSUM(2)/PSUM(4)
15204 VINT(225)=-PSUM(3)/PSUM(4)
15206 C...Boost incoming hadron to hadronic CM frame to determine rotations.
15212 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
15213 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
15214 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
15216 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
15218 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
15225 C*********************************************************************
15228 C...Handles diffractive and elastic scattering.
15232 C...Double precision and integer declarations.
15233 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15234 IMPLICIT INTEGER(I-N)
15235 INTEGER PYK,PYCHGE,PYCOMP
15237 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15238 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15239 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15240 COMMON/PYINT1/MINT(400),VINT(400)
15241 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
15243 C...Reset K, P and V vectors. Store incoming particles.
15244 DO 110 JT=1,MSTP(126)+10
15264 P(I,J)=VINT(285+5*JT+J)
15269 C...Subprocess; kinematics.
15270 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
15271 PZ=SQRT(SQLAM)/(2D0*VINT(1))
15274 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
15277 C...Elastically scattered particle. (Except elastic GVMD states.)
15278 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
15279 & MINT(106+JT).NE.3)) THEN
15284 P(N,3)=PZ*(-1)**(JT+1)
15286 P(N,5)=SQRT(VINT(62+JT))
15288 C...Decay rho from elastic scattering of gamma with sin**2(theta)
15289 C...distribution of decay products (in rho rest frame).
15290 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
15292 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
15296 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
15297 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
15298 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
15299 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
15300 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
15301 140 CTHE=2D0*PYR(0)-1D0
15302 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
15303 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
15305 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
15308 C...Diffracted particle: low-mass system to two particles.
15309 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
15315 PMMAS=SQRT(VINT(62+JT))
15318 IF(NTRY.LT.20) THEN
15319 MINT(105)=MINT(102+JT)
15320 MINT(109)=MINT(106+JT)
15321 CALL PYSPLI(KFH,21,KFL1,KFL2)
15322 CALL PYKFDI(KFL1,0,KFL3,KF1)
15323 IF(KF1.EQ.0) GOTO 150
15324 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
15325 IF(KF2.EQ.0) GOTO 150
15332 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
15337 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
15338 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
15341 P(N-1,4)=SQRT(PM1**2+PZP**2)
15342 P(N,4)=SQRT(PM2**2+PZP**2)
15343 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
15345 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
15346 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
15348 C...Diffracted particle: valence quark kicked out.
15349 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
15356 MINT(105)=MINT(102+JT)
15357 MINT(109)=MINT(106+JT)
15358 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
15359 P(N-1,5)=PYMASS(K(N-1,2))
15360 P(N,5)=PYMASS(K(N,2))
15361 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
15362 & 4D0*P(N-1,5)**2*P(N,5)**2
15363 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
15364 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
15365 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
15366 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
15367 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
15369 C...Diffracted particle: gluon kicked out.
15378 MINT(105)=MINT(102+JT)
15379 MINT(109)=MINT(106+JT)
15380 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
15382 P(N-2,5)=PYMASS(K(N-2,2))
15384 P(N,5)=PYMASS(K(N,2))
15385 C...Energy distribution for particle into two jets.
15387 IF(MOD(KFH/1000,10).NE.0) IMB=2
15388 CHIK=PARP(92+2*IMB)
15389 IF(MSTP(92).LE.1) THEN
15390 IF(IMB.EQ.1) CHI=PYR(0)
15391 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15392 ELSEIF(MSTP(92).EQ.2) THEN
15393 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
15394 ELSEIF(MSTP(92).EQ.3) THEN
15395 CUT=2D0*0.3D0/VINT(1)
15397 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
15399 ELSEIF(MSTP(92).EQ.4) THEN
15400 CUT=2D0*0.3D0/VINT(1)
15401 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
15402 180 CHIR=CUT*CUTR**PYR(0)
15403 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
15404 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
15406 CUT=2D0*0.3D0/VINT(1)
15407 CUTA=CUT**(1D0-PARP(98))
15408 CUTB=(1D0+CUT)**(1D0-PARP(98))
15409 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
15410 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
15411 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
15413 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
15414 & VINT(62+JT)) GOTO 160
15415 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
15416 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
15417 & (2D0*VINT(62+JT))
15418 PEI=SQRT(PZI**2+SQM)
15419 PQQP=(1D0-CHI)*(PEI+PZI)
15420 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
15421 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
15422 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
15423 P(N-1,3)=P(N-1,4)*(-1)**JT
15424 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
15425 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
15428 C...Documentation lines.
15430 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
15431 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
15432 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
15434 P(I+2,3)=PZ*(-1)**(JT+1)
15436 P(I+2,5)=SQRT(VINT(62+JT))
15439 C...Rotate outgoing partons/particles using cos(theta).
15440 IF(VINT(23).LT.0.9D0) THEN
15441 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
15443 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
15449 C*********************************************************************
15452 C...Set up a DIS process as gamma* + f -> f, with beam remnant
15453 C...and showering added consecutively. Photon flux by the PYGAGA
15454 C...routine (if at all).
15458 C...Double precision and integer declarations.
15459 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15460 IMPLICIT INTEGER(I-N)
15461 INTEGER PYK,PYCHGE,PYCOMP
15462 C...Parameter statement to help give large particle numbers.
15463 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
15464 &KEXCIT=4000000,KDIMEN=5000000)
15466 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15467 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15468 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15469 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15470 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15471 COMMON/PYINT1/MINT(400),VINT(400)
15472 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
15476 C...Choice of subprocess, number of documentation lines
15484 IF(MINT(107).EQ.4) ISIDE=2
15486 C...Reset K, P and V vectors. Store incoming particles
15487 DO 110 JT=1,MSTP(126)+20
15500 P(I,J)=VINT(285+5*JT+J)
15505 C...Store incoming partons in hadronic CM-frame
15510 K(I,3)=MINT(83)+2+JT
15512 IF(MINT(15).EQ.22) THEN
15513 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
15514 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
15515 P(MINT(84)+1,5)=-SQRT(VINT(307))
15516 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
15517 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
15521 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
15522 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
15523 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
15524 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
15525 P(MINT(84)+1,5)=-SQRT(VINT(308))
15529 SIDESG=(-1D0)**(ISIDE-1)
15531 C...Copy incoming partons to documentation lines.
15542 C...Second copy for partons before ISR shower, since no such.
15552 C...Define initial partons.
15555 IF(NTRY.GT.100) THEN
15560 C...Scattered quark in hadronic CM frame.
15565 P(IPU3,5)=PYMASS(KFRES)
15566 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
15567 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
15571 K(I,3)=MINT(83)+4+ISIDE
15579 C...No primordial kT, or chosen according to truncated Gaussian or
15580 C...exponential, or (for photon) predetermined or power law.
15581 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
15582 IF(MSTP(91).LE.0) THEN
15584 ELSEIF(MSTP(91).EQ.1) THEN
15585 PT=PARP(91)*SQRT(-LOG(PYR(0)))
15589 PT=-PARP(92)*LOG(RPT1*RPT2)
15591 IF(PT.GT.PARP(93)) GOTO 190
15592 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
15593 PTA=SQRT(VINT(282+ISIDE))
15595 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
15596 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
15597 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
15600 PTB=-PARP(99)*LOG(RPT1*RPT2)
15602 IF(PTB.GT.PARP(100)) GOTO 190
15603 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
15604 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
15605 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
15606 IF(MSTP(93).LE.0) THEN
15608 ELSEIF(MSTP(93).EQ.1) THEN
15609 PT=PARP(99)*SQRT(-LOG(PYR(0)))
15610 ELSEIF(MSTP(93).EQ.2) THEN
15613 PT=-PARP(99)*LOG(RPT1*RPT2)
15614 ELSEIF(MSTP(93).EQ.3) THEN
15617 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
15621 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
15622 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
15624 IF(PT.GT.PARP(100)) GOTO 190
15630 P(IPU3,1)=PT*COS(PHI)
15631 P(IPU3,2)=PT*SIN(PHI)
15632 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
15633 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
15634 PCP=P(IPU3,4)+ABS(P(IPU3,3))
15636 C...Find one or two beam remnants.
15637 MINT(105)=MINT(102+ISIDE)
15638 MINT(109)=MINT(106+ISIDE)
15639 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
15640 IF(MINT(51).NE.0) THEN
15645 C...Store first remnant parton, with colour info and kinematics.
15649 K(I,3)=MINT(83)+ISIDE
15650 P(I,5)=PYMASS(K(I,2))
15651 KCOL=KCHG(PYCOMP(KFLSP),2)
15654 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
15655 K(I,KFLS+3)=MSTU(5)*IPU3
15656 K(IPU3,6-KFLS)=MSTU(5)*I
15659 IF(KFLCH.EQ.0) THEN
15662 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15664 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
15665 PRP=P(I,4)+ABS(P(I,3))
15667 C...When extra remnant parton or hadron: store extra remnant.
15672 K(I,3)=MINT(83)+ISIDE
15673 P(I,5)=PYMASS(K(I,2))
15674 KCOL=KCHG(PYCOMP(KFLCH),2)
15677 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
15678 K(I,KFLS+3)=MSTU(5)*IPU3
15679 K(IPU3,6-KFLS)=MSTU(5)*I
15683 C...Relative transverse momentum when two remnants.
15686 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
15687 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
15688 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
15689 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
15690 P(I,1)=-P(IPU3,1)-P(I-1,1)
15691 P(I,2)=-P(IPU3,2)-P(I-1,2)
15692 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15694 C...Relative distribution of energy for particle into jet plus particle.
15696 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
15697 IF(MSTP(94).LE.1) THEN
15698 IF(IMB.EQ.1) CHI=PYR(0)
15699 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15700 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15701 ELSEIF(MSTP(94).EQ.2) THEN
15702 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
15703 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15704 ELSEIF(MSTP(94).EQ.3) THEN
15705 CALL PYZDIS(1,0,PMS(4),ZZ)
15708 CALL PYZDIS(1000,0,PMS(4),ZZ)
15712 C...Construct total transverse mass; reject if too large.
15713 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
15714 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
15715 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
15716 IF(LOOP.LT.10) GOTO 200
15719 VINT(158+ISIDE)=CHI
15721 C...Subdivide longitudinal momentum according to value selected above.
15722 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
15724 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
15725 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
15727 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
15728 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
15732 C...Boost current and remnant systems to correct frame.
15733 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
15734 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
15735 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
15737 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
15739 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
15740 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
15741 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
15742 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
15744 C...Let current quark shower; recoil but no showering by colour partner.
15745 QMAX=2D0*SQRT(VINT(309-ISIDE))
15750 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
15757 C*********************************************************************
15760 C...Handles the documentation of the process in MSTI and PARI,
15761 C...and also computes cross-sections based on accumulated statistics.
15765 C...Double precision and integer declarations.
15766 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15767 IMPLICIT INTEGER(I-N)
15768 INTEGER PYK,PYCHGE,PYCOMP
15770 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15771 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15772 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15773 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15774 COMMON/PYINT1/MINT(400),VINT(400)
15775 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15776 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15777 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
15780 C...Calculate Monte Carlo estimates of cross-sections.
15782 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
15783 NGEN(0,3)=NGEN(0,3)+1
15786 IF(I.EQ.96.OR.I.EQ.97) THEN
15788 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
15789 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
15790 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
15791 & DBLE(NGEN(96,2)))
15792 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
15793 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
15794 & DBLE(NGEN(96,2)))
15795 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
15797 ELSEIF(NGEN(I,2).EQ.0) THEN
15798 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
15801 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
15804 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
15807 C...Rescale to known low-pT cross-section for standard QCD processes.
15808 IF(MSUB(95).EQ.1) THEN
15809 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
15810 & XSEC(68,3)+XSEC(95,3)
15811 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
15812 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
15814 XSEC(11,3)=FAC*XSEC(11,3)
15815 XSEC(12,3)=FAC*XSEC(12,3)
15816 XSEC(13,3)=FAC*XSEC(13,3)
15817 XSEC(28,3)=FAC*XSEC(28,3)
15818 XSEC(53,3)=FAC*XSEC(53,3)
15819 XSEC(68,3)=FAC*XSEC(68,3)
15820 XSEC(95,3)=FAC*XSEC(95,3)
15821 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
15825 C...Save information for gamma-p and gamma-gamma.
15826 IF(MINT(121).GT.1) THEN
15832 C...Reset information on hard interaction.
15838 C...Copy integer valued information from MINT into MSTI.
15842 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
15844 C...Store cross-section variables in PARI.
15846 PARI(2)=XSEC(0,3)/MINT(5)
15850 VINT(98)=VINT(98)+VINT(100)
15851 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
15853 C...Store kinematics variables in PARI.
15856 IF(ISUB.NE.95) THEN
15864 PARI(35)=PARI(33)-PARI(34)
15871 PARI(42)=2D0*VINT(47)/VINT(1)
15874 C...Store information on scattered partons in PARI.
15875 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
15878 PARI(36+IS)=P(I,3)/VINT(1)
15879 PARI(38+IS)=P(I,4)/VINT(1)
15880 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
15881 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15882 & SQRT(PR),1D20)),P(I,3))
15883 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
15884 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15885 & SQRT(PR),1D20)),P(I,3))
15886 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
15887 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
15888 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
15892 C...Store sum up transverse and longitudinal momenta.
15893 PARI(65)=2D0*PARI(17)
15894 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
15895 DO 150 I=MSTP(126)+1,N
15896 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
15897 PT=SQRT(P(I,1)**2+P(I,2)**2)
15898 PARI(69)=PARI(69)+PT
15899 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
15900 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
15912 C...Store various other pieces of information into PARI.
15920 C...Store information on lepton -> lepton + gamma in PYGAGA.
15923 PARI(101)=VINT(301)
15924 PARI(102)=VINT(302)
15926 PARI(I)=VINT(I+202)
15929 C...Set information for PYTABU.
15930 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
15933 ELSEIF(ISET(ISUB).EQ.5) THEN
15944 C*********************************************************************
15947 C...Performs transformations between different coordinate frames.
15949 SUBROUTINE PYFRAM(IFRAME)
15951 C...Double precision and integer declarations.
15952 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15953 IMPLICIT INTEGER(I-N)
15954 INTEGER PYK,PYCHGE,PYCOMP
15956 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15957 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15958 COMMON/PYINT1/MINT(400),VINT(400)
15959 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
15961 C...Check that transformation can and should be done.
15962 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
15963 &MINT(91).EQ.1)) THEN
15964 IF(IFRAME.EQ.MINT(6)) RETURN
15966 WRITE(MSTU(11),5000) IFRAME,MINT(6)
15970 IF(MINT(6).EQ.1) THEN
15971 C...Transform from fixed target or user specified frame to
15972 C...overall CM frame.
15973 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
15974 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
15975 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
15976 ELSEIF(MINT(6).EQ.3) THEN
15977 C...Transform from hadronic CM frame in DIS to overall CM frame.
15978 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
15982 IF(IFRAME.EQ.1) THEN
15983 C...Transform from overall CM frame to fixed target or user specified
15985 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
15986 ELSEIF(IFRAME.EQ.3) THEN
15987 C...Transform from overall CM frame to hadronic CM frame in DIS.
15988 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
15989 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
15990 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
15993 C...Set information about new frame.
15997 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
15998 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
16004 C*********************************************************************
16007 C...Calculates full and partial widths of resonances.
16009 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
16011 C...Double precision and integer declarations.
16012 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16013 IMPLICIT INTEGER(I-N)
16014 INTEGER PYK,PYCHGE,PYCOMP
16015 C...Parameter statement to help give large particle numbers.
16016 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16017 &KEXCIT=4000000,KDIMEN=5000000)
16019 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16020 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16021 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16022 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16023 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16024 COMMON/PYINT1/MINT(400),VINT(400)
16025 COMMON/PYINT4/MWID(500),WIDS(500,5)
16026 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
16027 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
16028 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
16029 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
16030 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
16031 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/
16032 C...Local arrays and saved variables.
16033 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
16034 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
16035 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
16036 SAVE MOFSV,WIDWSV,WID2SV
16037 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
16039 C...Compressed code and sign; mass.
16046 C...Reset width information.
16047 DO 110 I=0,MDCY(KC,3)
16054 C...Allow for fudge factor to rescale resonance width.
16056 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
16057 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
16058 IF(MSTP(110).EQ.KFLA) THEN
16060 ELSEIF(MSTP(110).EQ.-1) THEN
16061 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
16062 ELSEIF(MSTP(110).EQ.-2) THEN
16067 C...Not to be treated as a resonance: return.
16068 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
16077 C...Treatment as a resonance based on tabulated branching ratios.
16078 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
16079 C...Loop over possible decay channels; skip irrelevant ones.
16080 DO 120 I=1,MDCY(KC,3)
16082 IF(MDME(IDC,1).LT.0) GOTO 120
16084 C...Read out decay products and nominal masses.
16087 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
16091 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
16097 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
16101 C...Naive partial width and alternative threshold factors.
16102 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
16103 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
16104 & PM1+PM2+PM3.GE.SHR) THEN
16106 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
16107 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
16108 & 4D0*PM1**2*PM2**2))/SH
16109 ELSEIF(MDME(IDC,2).EQ.52) THEN
16110 PMA=MAX(PM1,PM2,PM3)
16111 PMC=MIN(PM1,PM2,PM3)
16112 PMB=PM1+PM2+PM3-PMA-PMC
16113 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
16118 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
16119 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
16120 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
16121 & ((SHR-PMA)**2-(PMB+PMC)**2)*
16122 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
16123 & ((1D0-PMBCN)*PMBCN*SH)
16124 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
16125 WDTP(I)=WDTP(I)*SQRT(
16126 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
16127 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
16128 ELSEIF(MDME(IDC,2).EQ.53) THEN
16129 PMA=MAX(PM1,PM2,PM3)
16130 PMC=MIN(PM1,PM2,PM3)
16131 PMB=PM1+PM2+PM3-PMA-PMC
16132 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
16137 FACACT=SQRT(MAX(0D0,
16138 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
16139 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
16140 & ((SHR-PMA)**2-(PMB+PMC)**2)*
16141 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
16142 & ((1D0-PMBCN)*PMBCN*SH)
16143 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
16147 PMBCN=PMBC**2/PMR**2
16148 FACNOM=SQRT(MAX(0D0,
16149 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
16150 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
16151 & ((PMR-PMA)**2-(PMB+PMC)**2)*
16152 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
16153 & ((1D0-PMBCN)*PMBCN*PMR**2)
16154 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
16156 WDTP(I)=FUDGE*WDTP(I)
16157 WDTP(0)=WDTP(0)+WDTP(I)
16159 C...Calculate secondary width (at most two identical/opposite).
16161 IF(MDME(IDC,1).GT.0) THEN
16162 IF(KFD2.EQ.KFD1) THEN
16163 IF(KCHG(KFC1,3).EQ.0) THEN
16165 ELSEIF(KFD1.GT.0) THEN
16171 WID2=WID2*WIDS(KFC3,2)
16172 ELSEIF(KFD3.LT.0) THEN
16173 WID2=WID2*WIDS(KFC3,3)
16175 ELSEIF(KFD2.EQ.-KFD1) THEN
16178 WID2=WID2*WIDS(KFC3,2)
16179 ELSEIF(KFD3.LT.0) THEN
16180 WID2=WID2*WIDS(KFC3,3)
16182 ELSEIF(KFD3.EQ.KFD1) THEN
16183 IF(KCHG(KFC1,3).EQ.0) THEN
16185 ELSEIF(KFD1.GT.0) THEN
16191 WID2=WID2*WIDS(KFC2,2)
16192 ELSEIF(KFD2.LT.0) THEN
16193 WID2=WID2*WIDS(KFC2,3)
16195 ELSEIF(KFD3.EQ.-KFD1) THEN
16198 WID2=WID2*WIDS(KFC2,2)
16199 ELSEIF(KFD2.LT.0) THEN
16200 WID2=WID2*WIDS(KFC2,3)
16202 ELSEIF(KFD3.EQ.KFD2) THEN
16203 IF(KCHG(KFC2,3).EQ.0) THEN
16205 ELSEIF(KFD2.GT.0) THEN
16211 WID2=WID2*WIDS(KFC1,2)
16212 ELSEIF(KFD1.LT.0) THEN
16213 WID2=WID2*WIDS(KFC1,3)
16215 ELSEIF(KFD3.EQ.-KFD2) THEN
16218 WID2=WID2*WIDS(KFC1,2)
16219 ELSEIF(KFD1.LT.0) THEN
16220 WID2=WID2*WIDS(KFC1,3)
16229 WID2=WID2*WIDS(KFC2,2)
16231 WID2=WID2*WIDS(KFC2,3)
16234 WID2=WID2*WIDS(KFC3,2)
16235 ELSEIF(KFD3.LT.0) THEN
16236 WID2=WID2*WIDS(KFC3,3)
16240 C...Store effective widths according to case.
16241 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16242 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16243 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16244 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16254 C...Here begins detailed dynamical calculation of resonance widths.
16255 C...Shared treatment of Higgs states.
16258 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
16263 C...Common electroweak and strong constants.
16266 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
16269 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
16271 RADC=1D0+AS/PARU(1)
16275 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16276 RADCT=1D0-2.5D0*AS/PARU(1)
16277 DO 140 I=1,MDCY(KC,3)
16279 IF(MDME(IDC,1).LT.0) GOTO 140
16280 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16281 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16282 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
16284 IF(I.GE.4.AND.I.LE.7) THEN
16285 C...t -> W + q; including approximate QCD correction factor.
16286 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
16287 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16288 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16291 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
16294 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
16296 ELSEIF(I.EQ.9) THEN
16298 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16299 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16301 IF(KFLR.LT.0) WID2=WIDS(37,3)
16303 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
16304 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
16307 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
16310 KFC1=PYCOMP(KFDP(IDC,1))
16311 KFC2=PYCOMP(KFDP(IDC,2))
16312 PMNCHI=PMAS(KFC1,1)
16313 PMSTOP=PMAS(KFC2,1)
16314 IF(SHR.GT.PMNCHI+PMSTOP) THEN
16317 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
16319 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
16320 AR=-ET*ZMIXC(IZ,1)*TANW
16321 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
16323 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
16324 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
16325 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
16326 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
16327 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
16328 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
16329 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
16331 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
16333 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
16336 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
16338 KFC1=PYCOMP(KFDP(IDC,1))
16339 KFC2=PYCOMP(KFDP(IDC,2))
16340 PMNCHI=PMAS(KFC1,1)
16341 PMSTOP=PMAS(KFC2,1)
16342 IF(SHR.GT.PMNCHI+PMSTOP) THEN
16345 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
16346 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
16347 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
16348 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
16350 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
16352 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
16355 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
16356 C...t -> ~gravitino + ~t
16358 KFC1=PYCOMP(KFDP(IDC,1))
16359 XMGR2=PMAS(KFC1,1)**2
16360 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
16361 KFC2=PYCOMP(KFDP(IDC,2))
16363 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
16366 WDTP(I)=FUDGE*WDTP(I)
16367 WDTP(0)=WDTP(0)+WDTP(I)
16368 IF(MDME(IDC,1).GT.0) THEN
16369 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16370 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16371 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16372 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16376 ELSEIF(KFLA.EQ.7) THEN
16378 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16379 DO 150 I=1,MDCY(KC,3)
16381 IF(MDME(IDC,1).LT.0) GOTO 150
16382 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16383 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16384 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
16386 IF(I.GE.4.AND.I.LE.7) THEN
16388 WDTP(I)=FAC*VCKM(I-3,4)*
16389 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16390 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16393 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
16394 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
16397 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
16398 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
16401 IF(KFLR.LT.0) WID2=WIDS(24,2)
16402 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16404 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16405 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16408 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
16411 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
16414 WDTP(I)=FUDGE*WDTP(I)
16415 WDTP(0)=WDTP(0)+WDTP(I)
16416 IF(MDME(IDC,1).GT.0) THEN
16417 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16418 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16419 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16420 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16424 ELSEIF(KFLA.EQ.8) THEN
16426 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16427 DO 160 I=1,MDCY(KC,3)
16429 IF(MDME(IDC,1).LT.0) GOTO 160
16430 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16431 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16432 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
16434 IF(I.GE.4.AND.I.LE.7) THEN
16436 WDTP(I)=FAC*VCKM(4,I-3)*
16437 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16438 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16441 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
16444 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
16446 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16448 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16449 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16452 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
16455 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
16458 WDTP(I)=FUDGE*WDTP(I)
16459 WDTP(0)=WDTP(0)+WDTP(I)
16460 IF(MDME(IDC,1).GT.0) THEN
16461 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16462 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16463 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16464 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16468 ELSEIF(KFLA.EQ.17) THEN
16470 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16471 DO 170 I=1,MDCY(KC,3)
16473 IF(MDME(IDC,1).LT.0) GOTO 170
16474 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16475 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16476 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
16479 C...tau' -> W + nu'_tau.
16480 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16481 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16484 WID2=WID2*WIDS(18,2)
16487 WID2=WID2*WIDS(18,3)
16489 ELSEIF(I.EQ.5) THEN
16490 C...tau' -> H + nu'_tau.
16491 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16492 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16495 WID2=WID2*WIDS(18,2)
16498 WID2=WID2*WIDS(18,3)
16501 WDTP(I)=FUDGE*WDTP(I)
16502 WDTP(0)=WDTP(0)+WDTP(I)
16503 IF(MDME(IDC,1).GT.0) THEN
16504 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16505 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16506 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16507 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16511 ELSEIF(KFLA.EQ.18) THEN
16512 C...nu'_tau neutrino.
16513 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16514 DO 180 I=1,MDCY(KC,3)
16516 IF(MDME(IDC,1).LT.0) GOTO 180
16517 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16518 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16519 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
16522 C...nu'_tau -> W + tau'.
16523 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16524 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16527 WID2=WID2*WIDS(17,2)
16530 WID2=WID2*WIDS(17,3)
16532 ELSEIF(I.EQ.3) THEN
16533 C...nu'_tau -> H + tau'.
16534 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16535 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16538 WID2=WID2*WIDS(17,2)
16541 WID2=WID2*WIDS(17,3)
16544 WDTP(I)=FUDGE*WDTP(I)
16545 WDTP(0)=WDTP(0)+WDTP(I)
16546 IF(MDME(IDC,1).GT.0) THEN
16547 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16548 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16549 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16550 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16554 ELSEIF(KFLA.EQ.21) THEN
16556 C***Note that widths are not given in dimensional quantities here.
16557 DO 190 I=1,MDCY(KC,3)
16559 IF(MDME(IDC,1).LT.0) GOTO 190
16560 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16561 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16562 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
16565 C...QCD -> q + qbar
16566 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16567 IF(I.EQ.6) WID2=WIDS(6,1)
16568 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16570 WDTP(I)=FUDGE*WDTP(I)
16571 WDTP(0)=WDTP(0)+WDTP(I)
16572 IF(MDME(IDC,1).GT.0) THEN
16573 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16574 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16575 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16576 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16580 ELSEIF(KFLA.EQ.22) THEN
16582 C***Note that widths are not given in dimensional quantities here.
16583 DO 200 I=1,MDCY(KC,3)
16585 IF(MDME(IDC,1).LT.0) GOTO 200
16586 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16587 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16588 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
16591 C...QED -> q + qbar.
16594 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16595 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16596 IF(I.EQ.6) WID2=WIDS(6,1)
16597 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16598 ELSEIF(I.LE.12) THEN
16599 C...QED -> l+ + l-.
16600 EF=KCHG(9+2*(I-8),1)/3D0
16601 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16602 IF(I.EQ.12) WID2=WIDS(17,1)
16604 WDTP(I)=FUDGE*WDTP(I)
16605 WDTP(0)=WDTP(0)+WDTP(I)
16606 IF(MDME(IDC,1).GT.0) THEN
16607 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16608 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16609 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16610 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16614 ELSEIF(KFLA.EQ.23) THEN
16617 XWC=1D0/(16D0*XW*XW1)
16618 FAC=(AEM*XWC/3D0)*SHR
16620 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
16625 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16627 IF(KFI.GT.20) KFI=IABS(MINT(16))
16633 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
16634 IF(MSTP(43).EQ.3) VINT(112)=
16635 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
16636 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16637 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
16639 DO 220 I=1,MDCY(KC,3)
16641 IF(MDME(IDC,1).LT.0) GOTO 220
16642 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16643 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16644 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
16649 AF=SIGN(1D0,EF+0.1D0)
16652 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16653 IF(I.EQ.6) WID2=WIDS(6,1)
16654 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16655 ELSEIF(I.LE.16) THEN
16656 C...Z0 -> l+ + l-, nu + nubar
16658 AF=SIGN(1D0,EF+0.1D0)
16661 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
16663 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16664 IF(ICASE.EQ.1) THEN
16665 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
16667 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16668 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
16669 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
16670 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
16671 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16672 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
16673 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16674 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
16676 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
16677 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
16678 IF(MDME(IDC,1).GT.0) THEN
16679 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
16680 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
16681 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16682 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
16683 & WDTE(I,MDME(IDC,1))
16684 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16685 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16687 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16688 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
16689 & VINT(111)+FGGF*WID2
16690 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
16691 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16692 & VINT(114)+FZZF*WID2
16696 IF(MINT(61).GE.1) ICASE=3-ICASE
16697 IF(ICASE.EQ.2) GOTO 210
16699 ELSEIF(KFLA.EQ.24) THEN
16701 FAC=(AEM/(24D0*XW))*SHR
16702 DO 230 I=1,MDCY(KC,3)
16704 IF(MDME(IDC,1).LT.0) GOTO 230
16705 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16706 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16707 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
16710 C...W+/- -> q + qbar'
16711 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
16713 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
16714 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
16715 IF(I.GE.13) WID2=WID2*WIDS(7,3)
16717 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
16718 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
16719 IF(I.GE.13) WID2=WID2*WIDS(7,2)
16721 ELSEIF(I.LE.20) THEN
16722 C...W+/- -> l+/- + nu
16725 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
16727 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
16730 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
16731 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16732 WDTP(I)=FUDGE*WDTP(I)
16733 WDTP(0)=WDTP(0)+WDTP(I)
16734 IF(MDME(IDC,1).GT.0) THEN
16735 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16736 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16737 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16738 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16742 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
16743 C...h0 (or H0, or A0):
16745 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
16746 DO 270 I=1,MDCY(KFHIGG,3)
16747 IDC=I+MDCY(KFHIGG,2)-1
16748 IF(MDME(IDC,1).LT.0) GOTO 270
16749 KFC1=PYCOMP(KFDP(IDC,1))
16750 KFC2=PYCOMP(KFDP(IDC,2))
16751 RM1=PMAS(KFC1,1)**2/SH
16752 RM2=PMAS(KFC2,1)**2/SH
16753 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
16759 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
16760 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
16761 C...A0 behaves like beta, ho and H0 like beta**3.
16762 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16763 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16764 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
16765 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
16766 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
16767 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
16768 IF(IHIGG.NE.3) THEN
16769 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
16770 & PARU(151+10*IHIGG))**2
16774 IF(I.EQ.6) WID2=WIDS(6,1)
16775 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16776 ELSEIF(I.LE.12) THEN
16778 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
16779 C...A0 behaves like beta, ho and H0 like beta**3.
16780 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16781 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
16782 & PARU(153+10*IHIGG)**2
16783 IF(I.EQ.12) WID2=WIDS(17,1)
16785 ELSEIF(I.EQ.13) THEN
16786 C...h0 -> g + g; quark loop contribution only
16789 DO 240 J=1,2*MSTP(1)
16790 EPS=(2D0*PMAS(J,1))**2/SH
16791 C...Loop integral; function of eps=4m^2/shat; different for A0.
16792 IF(EPS.LE.1D0) THEN
16793 IF(EPS.GT.1D-4) THEN
16795 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16797 RLN=LOG(4D0/EPS-2D0)
16799 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16800 PHIIM=0.5D0*PARU(1)*RLN
16802 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16805 IF(IHIGG.LE.2) THEN
16806 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16807 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
16809 ETAREJ=-0.5D0*EPS*PHIRE
16810 ETAIMJ=-0.5D0*EPS*PHIIM
16812 C...Couplings (=1 for standard model Higgs).
16813 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16814 IF(MOD(J,2).EQ.1) THEN
16815 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
16816 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
16818 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
16819 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
16825 ETA2=ETARE**2+ETAIM**2
16826 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
16828 ELSEIF(I.EQ.14) THEN
16829 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
16833 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16835 IF(J.LE.2*MSTP(1)) THEN
16837 EPS=(2D0*PMAS(J,1))**2/SH
16838 ELSEIF(J.LE.3*MSTP(1)) THEN
16839 JL=2*(J-2*MSTP(1))-1
16840 EJ=KCHG(10+JL,1)/3D0
16841 EPS=(2D0*PMAS(10+JL,1))**2/SH
16842 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16843 EPS=(2D0*PMAS(24,1))**2/SH
16845 EPS=(2D0*PMAS(37,1))**2/SH
16847 C...Loop integral; function of eps=4m^2/shat.
16848 IF(EPS.LE.1D0) THEN
16849 IF(EPS.GT.1D-4) THEN
16851 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16853 RLN=LOG(4D0/EPS-2D0)
16855 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16856 PHIIM=0.5D0*PARU(1)*RLN
16858 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16861 IF(J.LE.3*MSTP(1)) THEN
16862 C...Fermion loops: loop integral different for A0; charges.
16863 IF(IHIGG.LE.2) THEN
16864 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16865 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
16867 PHIPRE=-0.5D0*EPS*PHIRE
16868 PHIPIM=-0.5D0*EPS*PHIIM
16870 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16872 EJH=PARU(151+10*IHIGG)
16873 ELSEIF(J.LE.2*MSTP(1)) THEN
16875 EJH=PARU(152+10*IHIGG)
16878 EJH=PARU(153+10*IHIGG)
16880 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16881 ETAREJ=EJC*EJH*PHIPRE
16882 ETAIMJ=EJC*EJH*PHIPIM
16883 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16884 C...W loops: loop integral and charges.
16885 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
16886 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
16887 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16888 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16889 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16892 C...Charged H loops: loop integral and charges.
16893 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
16894 & PARU(158+10*IHIGG+2*(IHIGG/3))
16895 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
16896 ETAIMJ=-EPS**2*PHIIM*FACHHH
16901 ETA2=ETARE**2+ETAIM**2
16902 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
16904 ELSEIF(I.EQ.15) THEN
16905 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
16909 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16911 IF(J.LE.2*MSTP(1)) THEN
16913 AJ=SIGN(1D0,EJ+0.1D0)
16915 EPS=(2D0*PMAS(J,1))**2/SH
16916 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
16917 ELSEIF(J.LE.3*MSTP(1)) THEN
16918 JL=2*(J-2*MSTP(1))-1
16919 EJ=KCHG(10+JL,1)/3D0
16920 AJ=SIGN(1D0,EJ+0.1D0)
16922 EPS=(2D0*PMAS(10+JL,1))**2/SH
16923 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
16925 EPS=(2D0*PMAS(24,1))**2/SH
16926 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
16928 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
16929 IF(EPS.LE.1D0) THEN
16931 IF(EPS.GT.1D-4) THEN
16932 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16934 RLN=LOG(4D0/EPS-2D0)
16936 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16937 PHIIM=0.5D0*PARU(1)*RLN
16938 PSIRE=0.5D0*ROOT*RLN
16939 PSIIM=-0.5D0*ROOT*PARU(1)
16941 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16943 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
16946 IF(EPSP.LE.1D0) THEN
16947 ROOT=SQRT(1D0-EPSP)
16948 IF(EPSP.GT.1D-4) THEN
16949 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16951 RLN=LOG(4D0/EPSP-2D0)
16953 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
16954 PHIIMP=0.5D0*PARU(1)*RLN
16955 PSIREP=0.5D0*ROOT*RLN
16956 PSIIMP=-0.5D0*ROOT*PARU(1)
16958 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
16960 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
16963 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
16964 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
16965 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
16966 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
16967 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
16968 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
16969 IF(J.LE.3*MSTP(1)) THEN
16970 C...Fermion loops: loop integral different for A0; charges.
16971 IF(IHIGG.EQ.3) FXYRE=0D0
16972 IF(IHIGG.EQ.3) FXYIM=0D0
16973 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16975 EJH=PARU(151+10*IHIGG)
16976 ELSEIF(J.LE.2*MSTP(1)) THEN
16978 EJH=PARU(152+10*IHIGG)
16981 EJH=PARU(153+10*IHIGG)
16983 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16984 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
16985 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
16986 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16987 C...W loops: loop integral and charges.
16988 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
16989 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
16990 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
16991 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16992 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16993 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16996 C...Charged H loops: loop integral and charges.
16997 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
16998 & PARU(158+10*IHIGG+2*(IHIGG/3))
16999 ETAREJ=FACHHH*FXYRE
17000 ETAIMJ=FACHHH*FXYIM
17005 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
17006 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
17009 ELSEIF(I.LE.17) THEN
17010 C...h0 -> Z0 + Z0, W+ + W-
17011 PM1=PMAS(IABS(KFDP(IDC,1)),1)
17012 PG1=PMAS(IABS(KFDP(IDC,1)),2)
17013 IF(MINT(62).GE.1) THEN
17014 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
17015 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
17016 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
17017 MOFSV(IHIGG,I-15)=0
17018 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
17022 MOFSV(IHIGG,I-15)=1
17023 RMAS=SQRT(MAX(0D0,SH))
17024 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
17026 WIDWSV(IHIGG,I-15)=WIDW
17027 WID2SV(IHIGG,I-15)=WID2
17030 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
17031 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
17035 WIDW=WIDWSV(IHIGG,I-15)
17036 WID2=WID2SV(IHIGG,I-15)
17039 WDTP(I)=FAC*WIDW/(2D0*(18-I))
17040 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
17041 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
17042 & PARU(138+I+10*IHIGG)**2
17043 WID2=WID2*WIDS(7+I,1)
17045 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
17046 C...H0 -> Z0 + h0, A0-> Z0 + h0
17047 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
17048 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17049 IF(IHIGG.EQ.2) THEN
17050 WDTP(I)=WDTP(I)*PARU(179)**2
17051 ELSEIF(IHIGG.EQ.3) THEN
17052 WDTP(I)=WDTP(I)*PARU(186)**2
17054 WID2=WIDS(23,2)*WIDS(25,2)
17056 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
17057 C...H0 -> h0 + h0, A0-> h0 + h0
17058 WDTP(I)=FAC*0.25D0*
17059 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
17060 IF(IHIGG.EQ.2) THEN
17061 WDTP(I)=WDTP(I)*PARU(176)**2
17062 ELSEIF(IHIGG.EQ.3) THEN
17063 WDTP(I)=WDTP(I)*PARU(169)**2
17066 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
17067 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
17068 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
17069 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17070 & *PARU(195+IHIGG)**2
17072 WID2=WIDS(24,2)*WIDS(37,3)
17073 ELSEIF(I.EQ.21) THEN
17074 WID2=WIDS(24,3)*WIDS(37,2)
17077 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
17079 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
17080 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*0.0D0
17081 WID2=WIDS(36,2)*WIDS(23,2)
17083 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
17085 WDTP(I)=FAC*0.5D0*PARU(180)**2*
17086 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
17087 WID2=WIDS(25,2)*WIDS(36,2)
17089 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
17091 WDTP(I)=FAC*0.25D0*PARU(177)**2*
17092 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
17097 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
17100 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
17101 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
17102 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
17107 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
17109 IF(KFC2.EQ.KFC1) THEN
17113 IF(KFDP(IDC,1).LT.0) KSGN1=3
17115 IF(KFDP(IDC,2).LT.0) KSGN2=3
17116 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
17119 WDTP(I)=FUDGE*WDTP(I)
17120 WDTP(0)=WDTP(0)+WDTP(I)
17121 IF(MDME(IDC,1).GT.0) THEN
17122 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17123 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17124 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17125 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17129 ELSEIF(KFLA.EQ.32) THEN
17132 XWC=1D0/(16D0*XW*XW1)
17133 FAC=(AEM*XWC/3D0)*SHR
17136 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
17144 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17145 KFAI=IABS(MINT(15))
17146 EI=KCHG(KFAI,1)/3D0
17147 AI=SIGN(1D0,EI+0.1D0)
17150 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
17151 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
17152 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
17153 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
17154 VPI=PARU(119+2*KFAIC)
17155 API=PARU(120+2*KFAIC)
17156 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
17157 VPI=PARJ(178+2*KFAIC)
17158 API=PARJ(179+2*KFAIC)
17160 VPI=PARJ(186+2*KFAIC)
17161 API=PARJ(187+2*KFAIC)
17165 SQMZP=PMAS(32,1)**2
17167 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
17168 & MSTP(44).EQ.7) VINT(111)=1D0
17169 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
17170 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
17171 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
17172 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
17173 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
17174 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
17175 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
17176 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
17177 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
17178 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
17179 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
17181 DO 290 I=1,MDCY(KC,3)
17183 IF(MDME(IDC,1).LT.0) GOTO 290
17184 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17185 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17186 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
17190 C...Z'0 -> q + qbar
17192 AF=SIGN(1D0,EF+0.1D0)
17195 VPF=PARU(123-2*MOD(I,2))
17196 APF=PARU(124-2*MOD(I,2))
17197 ELSEIF(I.LE.4) THEN
17198 VPF=PARJ(182-2*MOD(I,2))
17199 APF=PARJ(183-2*MOD(I,2))
17201 VPF=PARJ(190-2*MOD(I,2))
17202 APF=PARJ(191-2*MOD(I,2))
17205 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
17206 & PYHFTH(SH,SH*RM1,1D0)
17207 IF(I.EQ.6) WID2=WIDS(6,1)
17208 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
17209 ELSEIF(I.LE.16) THEN
17210 C...Z'0 -> l+ + l-, nu + nubar
17212 AF=SIGN(1D0,EF+0.1D0)
17215 VPF=PARU(127-2*MOD(I,2))
17216 APF=PARU(128-2*MOD(I,2))
17217 ELSEIF(I.LE.12) THEN
17218 VPF=PARJ(186-2*MOD(I,2))
17219 APF=PARJ(187-2*MOD(I,2))
17221 VPF=PARJ(194-2*MOD(I,2))
17222 APF=PARJ(195-2*MOD(I,2))
17225 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
17227 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17228 IF(ICASE.EQ.1) THEN
17229 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
17230 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
17231 & APF**2*(1D0-4D0*RM1))*BE34
17232 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17233 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
17234 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
17235 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
17236 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
17237 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
17238 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
17239 ELSEIF(MINT(61).EQ.2) THEN
17240 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
17241 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17242 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
17243 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
17244 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
17246 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
17249 ELSEIF(I.EQ.17) THEN
17251 WDTPZP=PARU(129)**2*XW1**2*
17252 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17253 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17254 IF(ICASE.EQ.1) THEN
17257 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17258 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
17259 ELSEIF(MINT(61).EQ.2) THEN
17268 ELSEIF(I.EQ.18) THEN
17270 CZC=2D0*(1D0-2D0*XW)
17271 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
17272 IF(ICASE.EQ.1) THEN
17273 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
17274 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
17275 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17276 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
17277 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
17278 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
17279 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
17280 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
17281 ELSEIF(MINT(61).EQ.2) THEN
17283 FGZF=0.25D0*PARU(142)*CZC*BE34C
17284 FGZPF=0.25D0*PARU(143)*CZC*BE34C
17285 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
17286 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
17287 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
17290 ELSEIF(I.EQ.19) THEN
17291 C...Z'0 -> Z0 + gamma.
17292 ELSEIF(I.EQ.20) THEN
17294 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17295 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
17296 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
17297 IF(ICASE.EQ.1) THEN
17300 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17301 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
17302 ELSEIF(MINT(61).EQ.2) THEN
17310 WID2=WIDS(23,2)*WIDS(25,2)
17311 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
17312 C...Z' -> h0 + A0 or H0 + A0.
17313 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17321 IF(ICASE.EQ.1) THEN
17322 WDTPZ=CZAH**2*BE34C
17323 WDTP(I)=FAC*CZPAH**2*BE34C
17324 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17325 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
17326 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
17328 ELSEIF(MINT(61).EQ.2) THEN
17333 FZZPF=CZAH*CZPAH*BE34C
17334 FZPZPF=CZPAH**2*BE34C
17336 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
17337 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
17339 IF(ICASE.EQ.1) THEN
17340 VINT(117)=VINT(117)+FAC*WDTPZ
17341 WDTP(I)=FUDGE*WDTP(I)
17342 WDTP(0)=WDTP(0)+WDTP(I)
17344 IF(MDME(IDC,1).GT.0) THEN
17345 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
17346 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
17347 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17348 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
17349 & WDTE(I,MDME(IDC,1))
17350 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17351 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17353 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
17354 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
17355 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
17356 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
17358 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
17360 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
17361 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
17362 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
17364 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
17365 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
17369 IF(MINT(61).GE.1) ICASE=3-ICASE
17370 IF(ICASE.EQ.2) GOTO 280
17372 ELSEIF(KFLA.EQ.34) THEN
17374 FAC=(AEM/(24D0*XW))*SHR
17375 DO 300 I=1,MDCY(KC,3)
17377 IF(MDME(IDC,1).LT.0) GOTO 300
17378 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17379 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17380 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
17384 C...W'+/- -> q + qbar'
17385 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
17386 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
17388 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
17389 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
17390 IF(I.GE.13) WID2=WID2*WIDS(7,3)
17392 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
17393 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
17394 IF(I.GE.13) WID2=WID2*WIDS(7,2)
17396 ELSEIF(I.LE.20) THEN
17397 C...W'+/- -> l+/- + nu
17398 FCOF=PARU(133)**2+PARU(134)**2
17400 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17402 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17405 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
17406 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17407 ELSEIF(I.EQ.21) THEN
17408 C...W'+/- -> W+/- + Z0
17409 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
17410 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17411 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17412 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
17413 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
17414 ELSEIF(I.EQ.23) THEN
17415 C...W'+/- -> W+/- + h0
17416 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17417 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
17418 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17419 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17421 WDTP(I)=FUDGE*WDTP(I)
17422 WDTP(0)=WDTP(0)+WDTP(I)
17423 IF(MDME(IDC,1).GT.0) THEN
17424 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17425 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17426 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17427 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17431 ELSEIF(KFLA.EQ.37) THEN
17433 C IF(MSTP(49).EQ.0) THEN
17436 C SHFS=PMAS(37,1)**2
17438 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
17439 DO 310 I=1,MDCY(KC,3)
17441 IF(MDME(IDC,1).LT.0) GOTO 310
17442 KFC1=PYCOMP(KFDP(IDC,1))
17443 KFC2=PYCOMP(KFDP(IDC,2))
17444 RM1=PMAS(KFC1,1)**2/SH
17445 RM2=PMAS(KFC2,1)**2/SH
17446 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
17449 C...H+/- -> q + qbar'
17450 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
17451 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
17452 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
17453 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
17454 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17456 IF(I.EQ.3) WID2=WIDS(6,2)
17457 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
17459 IF(I.EQ.3) WID2=WIDS(6,3)
17460 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
17462 ELSEIF(I.LE.8) THEN
17463 C...H+/- -> l+/- + nu
17464 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
17465 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
17466 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17468 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
17470 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
17472 ELSEIF(I.EQ.9) THEN
17473 C...H+/- -> W+/- + h0.
17474 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
17475 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17476 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17477 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17481 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
17484 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
17485 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
17486 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
17491 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
17494 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
17496 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
17497 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
17499 WDTP(I)=FUDGE*WDTP(I)
17500 WDTP(0)=WDTP(0)+WDTP(I)
17501 IF(MDME(IDC,1).GT.0) THEN
17502 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17503 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17504 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17505 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17509 ELSEIF(KFLA.EQ.41) THEN
17511 FAC=(AEM/(12D0*XW))*SHR
17512 DO 320 I=1,MDCY(KC,3)
17514 IF(MDME(IDC,1).LT.0) GOTO 320
17515 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17516 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17517 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
17522 ELSEIF(I.LE.9) THEN
17526 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17527 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17529 IF(I.EQ.4) WID2=WIDS(6,3)
17530 IF(I.EQ.5) WID2=WIDS(7,3)
17531 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
17532 IF(I.EQ.9) WID2=WIDS(17,3)
17534 IF(I.EQ.4) WID2=WIDS(6,2)
17535 IF(I.EQ.5) WID2=WIDS(7,2)
17536 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
17537 IF(I.EQ.9) WID2=WIDS(17,2)
17539 WDTP(I)=FUDGE*WDTP(I)
17540 WDTP(0)=WDTP(0)+WDTP(I)
17541 IF(MDME(IDC,1).GT.0) THEN
17542 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17543 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17544 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17545 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17549 ELSEIF(KFLA.EQ.42) THEN
17550 C...LQ (leptoquark).
17551 FAC=(AEM/4D0)*PARU(151)*SHR
17552 DO 330 I=1,MDCY(KC,3)
17554 IF(MDME(IDC,1).LT.0) GOTO 330
17555 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17556 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17557 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
17558 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17560 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
17561 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
17562 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
17563 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
17564 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
17565 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
17566 WDTP(I)=FUDGE*WDTP(I)
17567 WDTP(0)=WDTP(0)+WDTP(I)
17568 IF(MDME(IDC,1).GT.0) THEN
17569 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17570 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17571 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17572 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17576 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
17577 C...Techni-pi0 and techni-pi0':
17578 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
17579 DO 340 I=1,MDCY(KC,3)
17581 IF(MDME(IDC,1).LT.0) GOTO 340
17582 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17583 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17586 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
17590 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
17591 & /(8D0*PARU(1))*SH*SHR
17592 IF(KFLA.EQ.KTECHN+111) THEN
17599 C...pi_tc -> f + fbar.
17601 IKA=IABS(KFDP(IDC,1))
17602 IF(IKA.LT.10) FCOF=3D0*RADC
17605 IF(IKA.GE.4.AND.IKA.LE.6) THEN
17606 FCOF=FCOF*RTCM(1+IKA)**2
17607 HM1=PYMRUN(KFDP(IDC,1),SH)
17608 HM2=PYMRUN(KFDP(IDC,2),SH)
17609 ELSEIF(IKA.EQ.15) THEN
17610 FCOF=FCOF*RTCM(8)**2
17612 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17613 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17615 WDTP(I)=FUDGE*WDTP(I)
17616 WDTP(0)=WDTP(0)+WDTP(I)
17617 IF(MDME(IDC,1).GT.0) THEN
17618 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17619 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17620 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17621 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17625 ELSEIF(KFLA.EQ.KTECHN+211) THEN
17627 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
17628 DO 350 I=1,MDCY(KC,3)
17630 IF(MDME(IDC,1).LT.0) GOTO 350
17631 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17632 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17634 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
17638 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
17640 C...pi_tc -> f + f'.
17642 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
17643 C...pi_tc+ -> W b b~
17644 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
17646 XMT2=PMAS(6,1)**2/SH
17647 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
17648 KFC3=PYCOMP(KFDP(IDC,3))
17649 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
17651 T0 = (1D0-CHECK**2)*
17652 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
17653 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
17654 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
17655 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
17656 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
17657 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
17666 IKA=IABS(KFDP(IDC,1))
17667 IF(IKA.LT.10) FCOF=3D0*RADC
17670 IF(I.GE.1.AND.I.LE.5) THEN
17672 FCOF=FCOF*RTCM(5)**2
17673 ELSEIF(I.LE.4) THEN
17674 FCOF=FCOF*RTCM(6)**2
17675 ELSEIF(I.EQ.5) THEN
17676 FCOF=FCOF*RTCM(7)**2
17678 HM1=PYMRUN(KFDP(IDC,1),SH)
17679 HM2=PYMRUN(KFDP(IDC,2),SH)
17680 ELSEIF(I.EQ.8) THEN
17681 FCOF=FCOF*RTCM(8)**2
17683 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17684 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17686 WDTP(I)=FUDGE*WDTP(I)
17687 WDTP(0)=WDTP(0)+WDTP(I)
17688 IF(MDME(IDC,1).GT.0) THEN
17689 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17690 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17691 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17692 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17696 ELSEIF(KFLA.EQ.KTECHN+331) THEN
17698 FAC=(SH/PARP(46)**2)*SHR
17699 DO 360 I=1,MDCY(KC,3)
17701 IF(MDME(IDC,1).LT.0) GOTO 360
17702 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17703 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17704 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
17707 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
17708 IF(I.EQ.2) WID2=WIDS(6,1)
17710 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
17712 WDTP(I)=FUDGE*WDTP(I)
17713 WDTP(0)=WDTP(0)+WDTP(I)
17714 IF(MDME(IDC,1).GT.0) THEN
17715 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17716 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17717 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17718 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17722 ELSEIF(KFLA.EQ.KTECHN+113) THEN
17724 ALPRHT=2.91D0*(3D0/ITCM(1))
17725 FAC=(ALPRHT/12D0)*SHR
17726 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
17730 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17732 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
17733 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17734 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17735 DO 370 I=1,MDCY(KC,3)
17737 IF(MDME(IDC,1).LT.0) GOTO 370
17738 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17739 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17740 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
17743 C...rho_tc0 -> W+ + W-.
17744 WDTP(I)=FAC*RTCM(3)**4*
17745 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17747 ELSEIF(I.EQ.2) THEN
17748 C...rho_tc0 -> W+ + pi_tc-.
17749 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17750 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17751 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17752 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17753 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
17754 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17755 ELSEIF(I.EQ.3) THEN
17756 C...rho_tc0 -> pi_tc+ + W-.
17757 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17758 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17759 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17760 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17761 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
17762 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
17763 ELSEIF(I.EQ.4) THEN
17764 C...rho_tc0 -> pi_tc+ + pi_tc-.
17765 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
17766 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17767 WID2=WIDS(PYCOMP(KTECHN+211),1)
17768 ELSEIF(I.EQ.5) THEN
17769 C...rho_tc0 -> gamma + pi_tc0
17770 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17771 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17773 WID2=WIDS(PYCOMP(KTECHN+111),2)
17774 ELSEIF(I.EQ.6) THEN
17775 C...rho_tc0 -> gamma + pi_tc0'
17776 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17777 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
17778 WID2=WIDS(PYCOMP(KTECHN+221),2)
17779 ELSEIF(I.EQ.7) THEN
17780 C...rho_tc0 -> Z0 + pi_tc0
17781 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17782 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17784 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17785 ELSEIF(I.EQ.8) THEN
17786 C...rho_tc0 -> Z0 + pi_tc0'
17787 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17788 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
17790 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17792 C...rho_tc0 -> f + fbar.
17797 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
17801 IF(IA.GE.17) WID2=WIDS(IA,1)
17804 AI=SIGN(1D0,EI+0.1D0)
17808 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
17809 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
17810 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
17811 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
17813 WDTP(I)=FUDGE*WDTP(I)
17814 WDTP(0)=WDTP(0)+WDTP(I)
17815 IF(MDME(IDC,1).GT.0) THEN
17816 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17817 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17818 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17819 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17823 ELSEIF(KFLA.EQ.KTECHN+213) THEN
17825 ALPRHT=2.91D0*(3D0/ITCM(1))
17826 FAC=(ALPRHT/12D0)*SHR
17830 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
17832 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
17833 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
17834 DO 380 I=1,MDCY(KC,3)
17836 IF(MDME(IDC,1).LT.0) GOTO 380
17837 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17838 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17839 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
17842 C...rho_tc+ -> W+ + Z0.
17843 WDTP(I)=FAC*RTCM(3)**4*
17844 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17846 WID2=WIDS(24,2)*WIDS(23,2)
17848 WID2=WIDS(24,3)*WIDS(23,2)
17850 ELSEIF(I.EQ.2) THEN
17851 C...rho_tc+ -> W+ + pi_tc0.
17852 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17853 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17854 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17855 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17856 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
17858 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
17860 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
17862 ELSEIF(I.EQ.3) THEN
17863 C...rho_tc+ -> pi_tc+ + Z0.
17864 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17865 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17866 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17867 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
17868 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
17869 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17870 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17873 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
17875 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
17877 ELSEIF(I.EQ.4) THEN
17878 C...rho_tc+ -> pi_tc+ + pi_tc0.
17879 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
17880 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17882 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
17884 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
17886 ELSEIF(I.EQ.5) THEN
17887 C...rho_tc+ -> pi_tc+ + gamma
17888 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17889 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17892 WID2=WIDS(PYCOMP(KTECHN+211),2)
17894 WID2=WIDS(PYCOMP(KTECHN+211),3)
17896 ELSEIF(I.EQ.6) THEN
17897 C...rho_tc+ -> W+ + pi_tc0'
17898 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17899 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
17901 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
17903 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
17906 C...rho_tc+ -> f + fbar'.
17910 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
17912 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
17913 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
17914 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
17916 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
17917 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
17918 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
17923 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17925 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17928 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17929 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17931 WDTP(I)=FUDGE*WDTP(I)
17932 WDTP(0)=WDTP(0)+WDTP(I)
17933 IF(MDME(IDC,1).GT.0) THEN
17934 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17935 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17936 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17937 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17941 ELSEIF(KFLA.EQ.KTECHN+223) THEN
17943 ALPRHT=2.91D0*(3D0/ITCM(1))
17944 FAC=(ALPRHT/12D0)*SHR
17945 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
17948 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17950 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17951 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17952 DO 390 I=1,MDCY(KC,3)
17954 IF(MDME(IDC,1).LT.0) GOTO 390
17955 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17956 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17957 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
17960 C...omega_tc0 -> gamma + pi_tc0.
17961 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
17962 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
17963 WID2=WIDS(PYCOMP(KTECHN+111),2)
17964 ELSEIF(I.EQ.2) THEN
17965 C...omega_tc0 -> Z0 + pi_tc0
17966 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17967 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
17969 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17970 ELSEIF(I.EQ.3) THEN
17971 C...omega_tc0 -> gamma + pi_tc0'
17972 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17973 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
17975 WID2=WIDS(PYCOMP(KTECHN+221),2)
17976 ELSEIF(I.EQ.4) THEN
17977 C...omega_tc0 -> Z0 + pi_tc0'
17978 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17979 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
17981 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17982 ELSEIF(I.EQ.5) THEN
17983 C...omega_tc0 -> W+ + pi_tc-
17984 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17985 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
17986 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
17987 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17988 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17989 ELSEIF(I.EQ.6) THEN
17990 C...omega_tc0 -> pi_tc+ + W-
17991 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17992 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
17993 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
17994 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17995 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
17996 ELSEIF(I.EQ.7) THEN
17997 C...omega_tc0 -> W+ + W-.
17998 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
17999 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
18001 ELSEIF(I.EQ.8) THEN
18002 C...omega_tc0 -> pi_tc+ + pi_tc-.
18003 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
18004 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
18005 WID2=WIDS(PYCOMP(KTECHN+211),1)
18007 C...omega_tc0 -> f + fbar.
18012 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
18016 IF(IA.GE.17) WID2=WIDS(IA,1)
18019 AI=SIGN(1D0,EI+0.1D0)
18021 VALI=-0.5D0*(VI+AI)
18022 VARI=-0.5D0*(VI-AI)
18023 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
18024 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
18025 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
18026 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
18028 WDTP(I)=FUDGE*WDTP(I)
18029 WDTP(0)=WDTP(0)+WDTP(I)
18030 IF(MDME(IDC,1).GT.0) THEN
18031 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18032 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18033 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18034 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18038 C.....V8 -> quark anti-quark
18039 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
18042 IF(ITCM(2).EQ.0) THEN
18044 ELSEIF(ITCM(2).EQ.1) THEN
18047 DO 400 I=1,MDCY(KC,3)
18049 IF(MDME(IDC,1).LT.0) GOTO 400
18050 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
18052 IF(RM1.GT.0.25D0) GOTO 400
18054 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
18059 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
18060 IF(I.EQ.6) WID2=WIDS(6,1)
18061 WDTP(I)=FUDGE*WDTP(I)
18062 WDTP(0)=WDTP(0)+WDTP(I)
18063 IF(MDME(IDC,1).GT.0) THEN
18064 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18065 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18066 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18067 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18071 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
18072 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
18074 DO 410 I=1,MDCY(KC,3)
18076 IF(MDME(IDC,1).LT.0) GOTO 410
18077 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18078 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18079 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
18083 IF(KFLA.EQ.KTECHN+100111) THEN
18088 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
18089 & /(2D0*PARU(1))*SH*SHR*CLEBG
18092 C...pi_tc -> f + fbar.
18093 IF(I.EQ.6) WID2=WIDS(6,1)
18095 IKA=IABS(KFDP(IDC,1))
18096 IF(IKA.LT.10) FCOF=3D0*RADC
18097 HM1=PYMRUN(KFDP(IDC,1),SH)
18098 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
18099 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18101 WDTP(I)=FUDGE*WDTP(I)
18102 WDTP(0)=WDTP(0)+WDTP(I)
18103 IF(MDME(IDC,1).GT.0) THEN
18104 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18105 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18106 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18107 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18111 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
18113 ALPRHT=2.91D0*(3D0/ITCM(1))
18115 SIN2T=2D0*TANT3/(TANT3**2+1D0)
18116 SINT3=TANT3/SQRT(TANT3**2+1D0)
18119 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
18120 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
18121 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
18122 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
18123 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
18125 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
18127 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
18129 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
18131 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
18132 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
18133 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
18134 IF(ITCM(2).EQ.0) THEN
18139 DO 420 I=1,MDCY(KC,3)
18140 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
18141 & KFLA.EQ.KTECHN+300113)) GOTO 420
18143 IF(MDME(IDC,1).LT.0) GOTO 420
18144 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18145 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18146 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
18149 IF(I.EQ.6) WID2=WIDS(6,1)
18151 IF(KFLA.EQ.KTECHN+200113) THEN
18154 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
18157 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
18162 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
18163 FMIX=1D0/TANT3/SIN2T
18167 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
18168 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
18169 ELSEIF(I.EQ.7) THEN
18170 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
18171 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
18172 PSH=SHR*(1D0-RM1)/2D0
18173 WDTP(I)=AS/9D0*PSH**3/RM82
18175 WDTP(I)=2D0*WDTP(I)*CSXPP**2
18176 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
18178 WDTP(I)=5D0*WDTP(I)
18179 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
18182 WDTP(I)=FUDGE*WDTP(I)
18183 WDTP(0)=WDTP(0)+WDTP(I)
18184 IF(MDME(IDC,1).GT.0) THEN
18185 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18186 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18187 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18188 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18192 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
18193 C...d* excited quark.
18194 FAC=(SH/RTCM(41)**2)*SHR
18195 DO 430 I=1,MDCY(KC,3)
18197 IF(MDME(IDC,1).LT.0) GOTO 430
18198 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18199 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18200 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
18204 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
18206 ELSEIF(I.EQ.2) THEN
18207 C...d* -> gamma + d.
18208 QF=-RTCM(43)/2D0+RTCM(44)/6D0
18209 WDTP(I)=FAC*AEM*QF**2/4D0
18211 ELSEIF(I.EQ.3) THEN
18213 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
18214 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18215 & (1D0-RM1)**2*(2D0+RM1)
18217 ELSEIF(I.EQ.4) THEN
18219 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18220 & (1D0-RM1)**2*(2D0+RM1)
18221 IF(KFLR.GT.0) WID2=WIDS(24,3)
18222 IF(KFLR.LT.0) WID2=WIDS(24,2)
18224 WDTP(I)=FUDGE*WDTP(I)
18225 WDTP(0)=WDTP(0)+WDTP(I)
18226 IF(MDME(IDC,1).GT.0) THEN
18227 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18228 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18229 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18230 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18234 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
18235 C...u* excited quark.
18236 FAC=(SH/RTCM(41)**2)*SHR
18237 DO 440 I=1,MDCY(KC,3)
18239 IF(MDME(IDC,1).LT.0) GOTO 440
18240 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18241 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18242 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
18246 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
18248 ELSEIF(I.EQ.2) THEN
18249 C...u* -> gamma + u.
18250 QF=RTCM(43)/2D0+RTCM(44)/6D0
18251 WDTP(I)=FAC*AEM*QF**2/4D0
18253 ELSEIF(I.EQ.3) THEN
18255 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
18256 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18257 & (1D0-RM1)**2*(2D0+RM1)
18259 ELSEIF(I.EQ.4) THEN
18261 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18262 & (1D0-RM1)**2*(2D0+RM1)
18263 IF(KFLR.GT.0) WID2=WIDS(24,2)
18264 IF(KFLR.LT.0) WID2=WIDS(24,3)
18266 WDTP(I)=FUDGE*WDTP(I)
18267 WDTP(0)=WDTP(0)+WDTP(I)
18268 IF(MDME(IDC,1).GT.0) THEN
18269 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18270 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18271 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18272 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18276 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
18277 C...e* excited lepton.
18278 FAC=(SH/RTCM(41)**2)*SHR
18279 DO 450 I=1,MDCY(KC,3)
18281 IF(MDME(IDC,1).LT.0) GOTO 450
18282 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18283 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18284 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
18287 C...e* -> gamma + e.
18288 QF=-RTCM(43)/2D0-RTCM(44)/2D0
18289 WDTP(I)=FAC*AEM*QF**2/4D0
18291 ELSEIF(I.EQ.2) THEN
18293 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
18294 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18295 & (1D0-RM1)**2*(2D0+RM1)
18297 ELSEIF(I.EQ.3) THEN
18299 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18300 & (1D0-RM1)**2*(2D0+RM1)
18301 IF(KFLR.GT.0) WID2=WIDS(24,3)
18302 IF(KFLR.LT.0) WID2=WIDS(24,2)
18304 WDTP(I)=FUDGE*WDTP(I)
18305 WDTP(0)=WDTP(0)+WDTP(I)
18306 IF(MDME(IDC,1).GT.0) THEN
18307 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18308 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18309 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18310 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18314 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
18315 C...nu*_e excited neutrino.
18316 FAC=(SH/RTCM(41)**2)*SHR
18317 DO 460 I=1,MDCY(KC,3)
18319 IF(MDME(IDC,1).LT.0) GOTO 460
18320 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18321 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18322 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
18325 C...nu*_e -> Z0 + nu*_e.
18326 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
18327 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18328 & (1D0-RM1)**2*(2D0+RM1)
18330 ELSEIF(I.EQ.2) THEN
18331 C...nu*_e -> W+ + e.
18332 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18333 & (1D0-RM1)**2*(2D0+RM1)
18334 IF(KFLR.GT.0) WID2=WIDS(24,2)
18335 IF(KFLR.LT.0) WID2=WIDS(24,3)
18337 WDTP(I)=FUDGE*WDTP(I)
18338 WDTP(0)=WDTP(0)+WDTP(I)
18339 IF(MDME(IDC,1).GT.0) THEN
18340 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18341 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18342 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18343 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18347 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
18348 C...G* (graviton resonance):
18349 FAC=(PARP(50)**2/PARU(1))*SHR
18350 DO 470 I=1,MDCY(KC,3)
18352 IF(MDME(IDC,1).LT.0) GOTO 470
18353 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18354 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18355 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
18360 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
18361 & PYHFTH(SH,SH*RM1,1D0)
18362 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
18363 & (1D0+8D0*RM1/3D0)/320D0
18364 IF(I.EQ.6) WID2=WIDS(6,1)
18365 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
18366 ELSEIF(I.LE.16) THEN
18367 C...G* -> l+ + l-, nu + nubar
18369 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
18370 & (1D0+8D0*RM1/3D0)/320D0
18371 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
18372 ELSEIF(I.EQ.17) THEN
18375 ELSEIF(I.EQ.18) THEN
18376 C...G* -> gamma + gamma.
18378 ELSEIF(I.EQ.19) THEN
18380 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
18381 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
18383 ELSEIF(I.EQ.20) THEN
18385 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
18386 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
18389 WDTP(I)=FUDGE*WDTP(I)
18390 WDTP(0)=WDTP(0)+WDTP(I)
18391 IF(MDME(IDC,1).GT.0) THEN
18392 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18393 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18394 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18395 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18399 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
18400 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
18401 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
18402 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
18403 DO 480 I=1,MDCY(KC,3)
18405 IF(MDME(IDC,1).LT.0) GOTO 480
18406 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
18407 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
18408 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
18409 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
18412 C...nu_lR -> l- qbar q'
18413 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18414 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18415 ELSEIF(I.LE.18) THEN
18416 C...nu_lR -> l+ q qbar'
18417 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
18418 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
18420 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
18422 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
18424 X=(PM1+PM2+PM3)/SHR
18425 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
18427 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
18428 WDTP(I)=FAC*FCOF*FX*FY
18429 WDTP(I)=FUDGE*WDTP(I)
18430 WDTP(0)=WDTP(0)+WDTP(I)
18431 IF(MDME(IDC,1).GT.0) THEN
18432 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18433 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18434 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18435 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18439 ELSEIF(KFLA.EQ.9900023) THEN
18441 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
18442 DO 490 I=1,MDCY(KC,3)
18444 IF(MDME(IDC,1).LT.0) GOTO 490
18445 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18446 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18447 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
18451 C...Z_R0 -> q + qbar
18453 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
18454 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
18456 IF(I.EQ.6) WID2=WIDS(6,1)
18457 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
18458 C...Z_R0 -> l+ + l-
18462 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
18463 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
18468 ELSEIF(I.LE.15) THEN
18469 C...Z0 -> nu_R + nu_R, assumed Majorana.
18473 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
18476 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
18477 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
18478 WDTP(I)=FUDGE*WDTP(I)
18479 WDTP(0)=WDTP(0)+WDTP(I)
18480 IF(MDME(IDC,1).GT.0) THEN
18481 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18482 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18483 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18484 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18488 ELSEIF(KFLA.EQ.9900024) THEN
18490 FAC=(AEM/(24D0*XW))*SHR
18491 DO 500 I=1,MDCY(KC,3)
18493 IF(MDME(IDC,1).LT.0) GOTO 500
18494 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18495 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18496 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
18499 C...W_R+/- -> q + qbar'
18500 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18502 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18504 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
18506 ELSEIF(I.LE.12) THEN
18507 C...W_R+/- -> l+/- + nu_R
18510 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
18511 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18512 WDTP(I)=FUDGE*WDTP(I)
18513 WDTP(0)=WDTP(0)+WDTP(I)
18514 IF(MDME(IDC,1).GT.0) THEN
18515 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18516 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18517 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18518 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18522 ELSEIF(KFLA.EQ.9900041) THEN
18524 FAC=(1D0/(8D0*PARU(1)))*SHR
18525 DO 510 I=1,MDCY(KC,3)
18527 IF(MDME(IDC,1).LT.0) GOTO 510
18528 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18529 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18530 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
18533 C...H_L++/-- -> l+/- + l'+/-
18534 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18535 & (IABS(KFDP(IDC,2))-9)/2)**2
18536 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18537 ELSEIF(I.EQ.7) THEN
18538 C...H_L++/-- -> W_L+/- + W_L+/-
18539 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
18540 & (3D0*RM1+0.25D0/RM1-1D0)
18541 WID2=WIDS(24,4+(1-KFLS)/2)
18544 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18545 WDTP(I)=FUDGE*WDTP(I)
18546 WDTP(0)=WDTP(0)+WDTP(I)
18547 IF(MDME(IDC,1).GT.0) THEN
18548 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18549 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18550 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18551 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18555 ELSEIF(KFLA.EQ.9900042) THEN
18557 FAC=(1D0/(8D0*PARU(1)))*SHR
18558 DO 520 I=1,MDCY(KC,3)
18560 IF(MDME(IDC,1).LT.0) GOTO 520
18561 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18562 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18563 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
18566 C...H_R++/-- -> l+/- + l'+/-
18567 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18568 & (IABS(KFDP(IDC,2))-9)/2)**2
18569 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18570 ELSEIF(I.EQ.7) THEN
18571 C...H_R++/-- -> W_R+/- + W_R+/-
18572 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
18573 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
18576 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18577 WDTP(I)=FUDGE*WDTP(I)
18578 WDTP(0)=WDTP(0)+WDTP(I)
18579 IF(MDME(IDC,1).GT.0) THEN
18580 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18581 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18582 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18583 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18594 C***********************************************************************
18597 C...Calculates partial width and differential cross-section maxima
18598 C...of channels/processes not allowed on mass-shell, and selects
18599 C...masses in such channels/processes.
18601 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
18603 C...Double precision and integer declarations.
18604 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18605 IMPLICIT INTEGER(I-N)
18606 INTEGER PYK,PYCHGE,PYCOMP
18608 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18609 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18610 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
18611 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
18612 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18613 COMMON/PYINT1/MINT(400),VINT(400)
18614 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
18615 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
18616 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
18619 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
18620 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
18621 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
18624 C...Find if particles equal, maximum mass, matrix elements, etc.
18630 IF(KFD(1).EQ.KFD(2)) MEQL=1
18632 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
18633 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
18639 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
18642 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
18643 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
18644 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
18645 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
18646 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
18647 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
18650 C...Find where Breit-Wigners are required, else select discrete masses.
18652 KFCA=PYCOMP(KFD(I))
18654 PMD(I)=PMAS(KFCA,1)
18655 PGD(I)=PMAS(KFCA,2)
18660 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
18663 RMG(I)=(PMG(I)/PMMX)**2
18669 C...Find allowed mass range and Breit-Wigner parameters.
18671 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
18673 PMU(I)=PMMX-PARP(42)
18674 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18675 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18676 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
18678 IF(MLM.EQ.2) ILM=3-I
18679 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
18680 IF(MBW(3-I).EQ.0) THEN
18681 PMU(I)=PMMX-PMD(3-I)
18683 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
18685 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
18686 & MIN(PMU(I),CKIN(NOFF+2*ILM))
18687 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18688 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18689 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18690 IF(MBW(I).EQ.1) THEN
18691 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18692 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18693 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18696 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
18698 IF(MLM.EQ.2) ILM=3-I
18699 PML(I)=MAX(CKIN(48+I),PARP(42))
18700 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
18701 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18702 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18703 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18704 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18705 IF(MBW(I).EQ.1) THEN
18706 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18707 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18708 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18713 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
18715 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
18720 C...Calculation of partial width of resonance.
18721 IF(MOFSH.EQ.1) THEN
18723 C..If only one integration, pick that to be the inner.
18724 IF(MBW(1).EQ.0) THEN
18730 ELSEIF(MBW(2).EQ.0) THEN
18734 C...Start outer loop of integration.
18735 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18736 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18737 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18743 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18744 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
18745 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
18749 C...Start inner loop of integration.
18751 PMU1=MIN(PMU(1),PMMX-PM2)
18752 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
18753 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18754 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18755 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
18763 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
18764 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
18767 C...Evaluate function value - inner loop.
18768 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18769 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
18770 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
18771 & RM2**2+10D0*RM1*RM2)
18772 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
18775 C...Go to next position in inner loop.
18781 ELSEIF(NPT1.LE.8) THEN
18783 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
18785 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18786 INX1(NPT1)=INX1(ISH1)
18789 ELSEIF(NPT1.LT.100) THEN
18792 IF(ISH1.GT.NPT1) ISH1=2
18793 IF(ISH1.EQ.ISN1) GOTO 160
18794 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
18795 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
18797 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18798 INX1(NPT1)=INX1(ISH1)
18803 C...Calculate integral over inner loop.
18806 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
18807 & (XPT1(INX1(IPT1))-XPT1(IPT1))
18809 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
18810 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18811 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
18814 C...Go to next position in outer loop.
18820 ELSEIF(NPT2.LE.8) THEN
18822 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
18824 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18825 INX2(NPT2)=INX2(ISH2)
18828 ELSEIF(NPT2.LT.100) THEN
18831 IF(ISH2.GT.NPT2) ISH2=2
18832 IF(ISH2.EQ.ISN2) GOTO 200
18833 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
18834 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
18836 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18837 INX2(NPT2)=INX2(ISH2)
18842 C...Calculate integral over outer loop.
18845 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
18846 & (XPT2(INX2(IPT2))-XPT2(IPT2))
18848 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
18849 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
18854 C...Save result; second integration for user-selected mass range.
18855 IF(LOOP.EQ.1) WIDW=FSUM2
18857 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
18858 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
18865 C...Select two decay product masses of a resonance.
18866 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
18868 IF(MBW(I).EQ.0) GOTO 230
18869 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
18871 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
18872 RMG(I)=(PMG(I)/PMMX)**2
18874 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18875 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
18877 C...Weight with matrix element (if none known, use beta factor).
18878 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
18880 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
18881 ELSEIF(MMED.EQ.2) THEN
18882 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
18883 & RMG(2)**2+10D0*RMG(1)*RMG(2))
18884 ELSEIF(MMED.EQ.3) THEN
18885 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
18889 IF(WTBE.LT.PYR(0)) GOTO 220
18893 C...Find suitable set of masses for initialization of 2 -> 2 processes.
18894 ELSEIF(MOFSH.EQ.3) THEN
18895 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
18896 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
18898 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
18900 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
18904 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
18905 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
18906 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
18911 C...Evaluate importance of excluded tails of Breit-Wigners.
18912 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18913 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18917 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
18921 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
18922 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
18924 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
18925 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
18926 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
18927 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
18929 C...Pick one particle to be the lighter (if improves efficiency).
18930 ELSEIF(MOFSH.EQ.4) THEN
18931 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18932 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18933 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
18935 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
18937 IF(MBW(I).EQ.0) GOTO 270
18939 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18941 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18943 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18944 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
18945 IF(RBR.LT.0.8D0) THEN
18946 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
18947 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
18948 ELSEIF(RBR.LT.0.9D0) THEN
18949 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
18950 ELSEIF(RBR.LT.1.5D0) THEN
18951 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
18953 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
18954 & (PMV**2-PML(I)**2))))
18957 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18958 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
18959 IF(MINT(48).EQ.1) THEN
18960 NGEN(0,1)=NGEN(0,1)+1
18961 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
18971 C...Give weight for selected mass distribution.
18974 IF(MBW(I).EQ.0) GOTO 280
18976 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18978 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18979 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
18980 & (PMD(I)*PGD(I))**2)/PARU(1)
18984 FI0=(ATV-ATL(I))/PARU(1)
18985 FI1=PMV**2-PML(I)**2
18986 FI2=2D0*LOG(PMV/PML(I))
18987 FI3=1D0/PML(I)**2-1D0/PMV**2
18988 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18989 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
18990 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
18993 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
18995 VINT(80)=VINT(80)*FI0
18997 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
19003 C***********************************************************************
19006 C...Handles the possibility of colour reconnection in W+W- events,
19007 C...Based on the main scenarios of the Sjostrand and Khoze study:
19008 C...I, II, II', intermediate and instantaneous; plus one model
19009 C...along the lines of the Gustafson and Hakkinen: GH.
19010 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
19011 C...is as if first resonance is W+ and second W-.
19013 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
19015 C...Double precision and integer declarations.
19016 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19017 IMPLICIT INTEGER(I-N)
19018 INTEGER PYK,PYCHGE,PYCOMP
19019 C...Parameter value; number of points in MC integration.
19020 PARAMETER (NPT=100)
19022 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19023 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19024 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19025 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19026 COMMON/PYINT1/MINT(400),VINT(400)
19027 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19029 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
19030 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
19031 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
19032 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
19033 &TMC(20),IJOIN(100)
19035 C...Functions to give four-product and to do determinants.
19036 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)
19037 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
19038 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
19039 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
19041 C...Only allow fraction of recoupling for GH, intermediate and
19043 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
19044 IF(PYR(0).GT.PARP(120)) RETURN
19048 C...Common part for scenarios I, II, II', and GH.
19049 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
19050 &MSTP(115).EQ.5) THEN
19052 C...Read out frequently-used parameters.
19056 IF(ISUB.EQ.22) PMW=PMAS(23,1)
19058 IF(ISUB.EQ.22) PGW=PMAS(23,2)
19065 C...Find range of decay products of the W's.
19066 C...Background: the W's are stored in IW1 and IW2.
19067 C...Their direct decay products in NSD1+1 through NSD1+4.
19068 C...Products after shower (if any) in NSD1+5 through NAFT1
19069 C...for first W and in NAFT1+1 through N for the second.
19070 IF(NAFT1.GT.NSD1+4) THEN
19077 IF(N.GT.NAFT1) THEN
19085 C...Rearrange parton shower products along strings.
19087 CALL PYPREP(NSD1+1)
19089 C...Find partons pointing back to W+ and W-; store them with quark
19090 C...end of string first.
19096 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
19097 IF(IABS(K(I,2)).GE.22) GOTO 120
19098 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
19099 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
19109 IF(K(I,1).EQ.1) ISGP=0
19110 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
19111 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
19121 IF(K(I,1).EQ.1) ISGM=0
19125 C...Boost to W+W- rest frame (not strictly needed).
19127 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
19129 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
19130 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
19131 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
19133 C...Select decay vertices of W+ and W-.
19134 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
19135 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
19136 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
19137 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
19140 XP(J)=TP*P(IW1,J)/P(IW1,4)
19141 XM(J)=TM*P(IW2,J)/P(IW2,4)
19144 C...Begin scenario I specifics.
19145 IF(MSTP(115).EQ.1) THEN
19147 C...Reconstruct velocity and direction of W+ string pieces.
19149 IF(K(INP(IIP),2).LT.0) GOTO 170
19152 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
19153 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
19157 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
19158 DIRP(IIP,J)=V1(J)-V2(J)
19160 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
19162 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
19164 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
19168 C...Reconstruct velocity and direction of W- string pieces.
19170 IF(K(INM(IIM),2).LT.0) GOTO 200
19173 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
19174 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
19178 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
19179 DIRM(IIM,J)=V1(J)-V2(J)
19181 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
19183 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
19185 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
19189 C...Loop over number of space-time points.
19194 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
19195 R=SQRT(-LOG(PYR(0)))
19197 X=BLOWR*RHAD*R*COS(PHI)
19198 Y=BLOWR*RHAD*R*SIN(PHI)
19199 R=SQRT(-LOG(PYR(0)))
19201 Z=BLOWR*RHAD*R*COS(PHI)
19202 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
19204 C...Reject impossible points. Weight for sample distribution.
19205 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
19206 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
19207 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
19209 C...Loop over W+ string pieces and find one with largest weight.
19217 IF(K(INP(IIP),2).LT.0) GOTO 220
19218 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
19219 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
19221 XB(J)=XD(J)+BEDG*BETP(IIP,J)
19223 XB(4)=BETP(IIP,4)*(XD(4)-BED)
19224 SR2=XB(1)**2+XB(2)**2+XB(3)**2
19225 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
19226 & DIRP(IIP,3)*XB(3))**2
19227 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
19229 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
19230 IF(WTP.GT.WTMAXP) THEN
19236 C...Loop over W- string pieces and find one with largest weight.
19244 IF(K(INM(IIM),2).LT.0) GOTO 240
19245 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
19246 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
19248 XB(J)=XD(J)+BEDG*BETM(IIM,J)
19250 XB(4)=BETM(IIM,4)*(XD(4)-BED)
19251 SR2=XB(1)**2+XB(2)**2+XB(3)**2
19252 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
19253 & DIRM(IIM,3)*XB(3))**2
19254 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
19256 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
19257 IF(WTM.GT.WTMAXM) THEN
19263 C...Result of integration.
19265 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
19266 WT=WTMAXP*WTMAXM/WTSMP
19274 RES=BLOWR**3*BLOWT*SUM/NPT
19276 C...Decide whether to reconnect and, if so, where.
19278 PREC=1D0-EXP(-FACT*RES)
19279 IF(PREC.GT.PYR(0)) THEN
19284 IF(RSUM.LE.0D0) GOTO 270
19290 C...Begin scenario II and II' specifics.
19291 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
19293 C...Loop through all string pieces, one from W+ and one from W-.
19297 IF(K(INP(IIP),2).LT.0) GOTO 340
19301 IF(K(INM(IIM),2).LT.0) GOTO 330
19305 C...Find endpoint velocity vectors.
19307 V1P(J)=P(I1P,J)/P(I1P,4)
19308 V2P(J)=P(I2P,J)/P(I2P,4)
19309 V1M(J)=P(I1M,J)/P(I1M,4)
19310 V2M(J)=P(I2M,J)/P(I2M,4)
19313 C...Define q matrix and find t.
19315 Q(1,J)=V2P(J)-V1P(J)
19316 Q(2,J)=-(V2M(J)-V1M(J))
19317 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
19318 Q(4,J)=V1P(J)-V1M(J)
19320 T=-DETER(1,2,3)/DETER(1,2,4)
19322 C...Find alpha and beta; i.e. coordinates of crossing point.
19325 S13=Q(3,1)+Q(4,1)*T
19328 S23=Q(3,2)+Q(4,2)*T
19329 DEN=S11*S22-S12*S21
19330 ALP=(S12*S23-S22*S13)/DEN
19331 BET=(S21*S13-S11*S23)/DEN
19333 C...Check if solution acceptable.
19335 IF(T.LT.GTMAX) IANSW=0
19336 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
19337 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
19339 C...Find point of crossing and check that not inconsistent.
19341 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
19342 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
19344 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
19345 & (XPP(3)-XMM(3))**2
19346 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
19347 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
19348 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
19350 C...Find string eigentimes at crossing.
19351 IF(IANSW.EQ.1) THEN
19352 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
19353 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
19354 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
19355 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
19361 C...Order crossings by time. End loop over crossings.
19362 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
19364 DO 310 I1=NCROSS,1,-1
19365 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
19385 C...Loop over crossings; find first (if any) acceptable one.
19387 IF(NCROSS.GE.1) THEN
19389 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
19390 IF(PNFRAG.GT.PYR(0)) THEN
19391 C...Scenario II: only compare with fragmentation time.
19392 IF(MSTP(115).EQ.2) THEN
19397 C...Scenario II': also require that string length decreases.
19405 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19406 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19407 IF(ELNEW.LT.ELOLD) THEN
19419 C...Begin scenario GH specifics.
19420 ELSEIF(MSTP(115).EQ.5) THEN
19422 C...Loop through all string pieces, one from W+ and one from W-.
19426 IF(K(INP(IIP),2).LT.0) GOTO 380
19430 IF(K(INM(IIM),2).LT.0) GOTO 370
19434 C...Look for largest decrease of (exponent of) Lambda measure.
19435 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19436 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19437 ELDIF=ELNEW/MAX(1D-10,ELOLD)
19438 IF(ELDIF.LT.ELMIN) THEN
19450 C...Common for scenarios I, II, II' and GH: reconnect strings.
19454 DO 390 IS=1,NNP+NNM
19458 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
19460 ELSEIF(IS.LE.IIP+NNM) THEN
19461 I=INM(IS-IIP-NNM+IIM)
19466 IF(K(I,2).LT.0) THEN
19467 CALL PYJOIN(NJOIN,IJOIN)
19472 C...Restore original event record if no reconnection.
19474 DO 400 I=NSD1+1,NOLD
19475 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
19476 K(I,4)=MOD(K(I,4),MSTU(5)**2)
19477 K(I,5)=MOD(K(I,5),MSTU(5)**2)
19486 C...Boost back system.
19487 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19488 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19489 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
19490 & BEWW(1),BEWW(2),BEWW(3))
19492 C...Common part for intermediate and instantaneous scenarios.
19493 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
19496 C...Remove old shower products and reset showering ones.
19498 DO 420 I=NSD1+1,NSD1+4
19500 K(I,4)=MOD(K(I,4),MSTU(5)**2)
19501 K(I,5)=MOD(K(I,5),MSTU(5)**2)
19504 C...Identify quark-antiquark pairs.
19508 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
19511 C...Reconnect strings.
19514 CALL PYJOIN(2,IJOIN)
19517 CALL PYJOIN(2,IJOIN)
19519 C...Do new parton showers in intermediate scenario.
19520 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
19523 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
19524 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
19527 C...Do new parton showers in instantaneous scenario.
19528 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
19529 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
19530 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
19531 PPM=SQRT(MAX(0D0,PPM2))
19532 CALL PYSHOW(IQ1,IQ4,PPM)
19533 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
19534 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
19535 PPM=SQRT(MAX(0D0,PPM2))
19536 CALL PYSHOW(IQ3,IQ2,PPM)
19543 C***********************************************************************
19546 C...Checks generated variables against pre-set kinematical limits;
19547 C...also calculates limits on variables used in generation.
19549 SUBROUTINE PYKLIM(ILIM)
19551 C...Double precision and integer declarations.
19552 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19553 IMPLICIT INTEGER(I-N)
19554 INTEGER PYK,PYCHGE,PYCOMP
19556 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19557 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19558 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19559 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19560 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19561 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19562 COMMON/PYINT1/MINT(400),VINT(400)
19563 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19564 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19567 C...Common kinematical expressions.
19571 IF(ISUB.EQ.96) GOTO 100
19575 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
19576 CKIN09=MAX(CKIN(9),CKIN(13))
19577 CKIN10=MIN(CKIN(10),CKIN(14))
19578 CKIN11=MAX(CKIN(11),CKIN(15))
19579 CKIN12=MIN(CKIN(12),CKIN(16))
19581 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
19582 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
19583 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
19584 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
19589 RM3=SQM3/(TAU*VINT(2))
19590 RM4=SQM4/(TAU*VINT(2))
19591 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19594 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
19595 &PTHMIN=MAX(CKIN(3),CKIN(5))
19598 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
19599 C...pre-set kinematical limits.
19604 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
19605 X1=SQRT(TAUE)*EXP(YST)
19606 X2=SQRT(TAUE)*EXP(-YST)
19608 IF(MINT(47).NE.1) THEN
19609 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
19610 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
19611 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
19612 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
19614 IF(MINT(45).NE.1) THEN
19615 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
19617 IF(MINT(46).NE.1) THEN
19618 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
19620 IF(MINT(45).EQ.2) THEN
19621 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19623 IF(MINT(46).EQ.2) THEN
19624 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19626 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
19627 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
19628 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
19629 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
19630 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
19631 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
19632 Y3=YST+0.5D0*LOG(EXPY3)
19633 Y4=YST+0.5D0*LOG(EXPY4)
19638 STH=SQRT(MAX(0D0,1D0-CTH**2))
19639 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
19640 & CTH)**2-4D0*RM3))
19641 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
19642 & CTH)**2-4D0*RM4))
19643 IF(STH.GE.1D-10) THEN
19644 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
19646 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
19648 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
19649 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
19650 ETALAR=MAX(ETA3,ETA4)
19651 ETASMA=MIN(ETA3,ETA4)
19653 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
19654 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
19655 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
19656 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
19658 RPTS=4D0*VINT(71)**2/SH
19659 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
19660 RM34=MAX(1D-20,2D0*RM3*RM4)
19661 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
19662 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
19663 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
19664 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
19665 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
19666 IF(PTH.LT.PTHMIN) MINT(51)=1
19667 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
19668 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
19669 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
19670 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
19671 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
19672 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
19673 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
19674 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
19675 IF(THA.LT.CKIN(35)) MINT(51)=1
19676 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
19677 IF(UHA.LT.CKIN(37)) MINT(51)=1
19678 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
19680 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
19681 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
19682 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
19685 C...Additional cuts on W2 (approximately) in DIS.
19686 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
19688 IF(IABS(MINT(12)).LT.20) XBJ=X1
19690 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
19691 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
19692 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
19695 ELSEIF(ILIM.EQ.1) THEN
19696 C...Calculate limits on tau
19697 C...0) due to definition
19700 C...1) due to limits on subsystem mass
19701 TAUMN1=CKIN(1)**2/VINT(2)
19703 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
19704 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
19705 TM3=SQRT(SQM3+PTHMIN**2)
19706 TM4=SQRT(SQM4+PTHMIN**2)
19708 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
19709 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
19711 C...3) due to limits on pT-hat and cos(theta-hat)
19712 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
19713 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
19715 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
19716 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
19717 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
19719 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
19720 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
19721 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
19722 C...4) due to limits on x1 and x2
19723 TAUMN4=CKIN(21)*CKIN(23)
19724 TAUMX4=CKIN(22)*CKIN(24)
19725 C...5) due to limits on xF
19727 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
19728 C...6) due to limits on that and uhat
19729 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
19731 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
19732 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
19734 C...Net effect of all separate limits.
19735 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
19736 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
19737 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19740 ELSEIF(MINT(47).EQ.5) THEN
19741 VINT(31)=MIN(VINT(31),1D0-2D-10)
19742 ELSEIF(MINT(47).GE.6) THEN
19743 VINT(31)=MIN(VINT(31),1D0-1D-10)
19745 IF(VINT(31).LE.VINT(11)) MINT(51)=1
19747 ELSEIF(ILIM.EQ.2) THEN
19748 C...Calculate limits on y*
19750 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
19752 C...0) due to kinematics
19755 C...1) due to explicit limits
19758 C...2) due to limits on x1
19759 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
19760 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
19761 C...3) due to limits on x2
19762 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
19763 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
19764 C...4) due to limits on xF
19765 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
19766 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
19767 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
19768 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
19769 C...5) due to simultaneous limits on y-large and y-small
19770 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
19771 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
19772 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
19773 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
19774 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
19775 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
19776 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
19778 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
19779 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
19780 RZMX=BE34*MIN(CKIN(28),CTHLIM)
19781 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
19782 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
19783 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
19784 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
19785 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
19786 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
19788 C...Net effect of all separate limits.
19789 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
19790 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
19791 IF(MINT(47).EQ.1) THEN
19794 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
19795 VINT(12)=(1D0-1D-9)*YSTMX0
19796 VINT(32)=(1D0+1D-9)*YSTMX0
19797 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
19798 VINT(12)=-(1D0+1D-9)*YSTMX0
19799 VINT(32)=-(1D0-1D-9)*YSTMX0
19800 ELSEIF(MINT(47).EQ.5) THEN
19801 YSTEE=LOG((1D0-1D-10)/TAURT)
19802 VINT(12)=MAX(VINT(12),-YSTEE)
19803 VINT(32)=MIN(VINT(32),YSTEE)
19805 IF(VINT(32).LE.VINT(12)) MINT(51)=1
19807 ELSEIF(ILIM.EQ.3) THEN
19808 C...Calculate limits on cos(theta-hat)
19810 C...0) due to definition
19815 C...1) due to explicit limits
19816 CTNMN1=MIN(0D0,CKIN(27))
19817 CTNMX1=MIN(0D0,CKIN(28))
19818 CTPMN1=MAX(0D0,CKIN(27))
19819 CTPMX1=MAX(0D0,CKIN(28))
19820 C...2) due to limits on pT-hat
19821 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
19825 IF(CKIN(4).GE.0D0) THEN
19826 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
19827 & (BE34**2*TAU*VINT(2))))
19830 C...3) due to limits on y-large and y-small
19831 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
19832 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
19833 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
19834 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
19835 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
19836 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
19837 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
19838 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
19839 C...4) due to limits on that
19845 IF(CKIN(35).GT.0D0) THEN
19846 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
19847 IF(CTLIM.GT.0D0) THEN
19854 IF(CKIN(36).GT.0D0) THEN
19855 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
19856 IF(CTLIM.LT.0D0) THEN
19863 C...5) due to limits on uhat
19868 IF(CKIN(37).GT.0D0) THEN
19869 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
19870 IF(CTLIM.LT.0D0) THEN
19877 IF(CKIN(38).GT.0D0) THEN
19878 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
19879 IF(CTLIM.GT.0D0) THEN
19887 C...Net effect of all separate limits.
19888 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
19889 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
19890 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
19891 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
19892 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
19894 ELSEIF(ILIM.EQ.4) THEN
19895 C...Calculate limits on tau'
19896 C...0) due to kinematics
19898 IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
19899 PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
19900 TAPMN0=(SQRT(TAU)+PQRAT)**2
19903 C...1) due to explicit limits
19904 TAPMN1=CKIN(31)**2/VINT(2)
19906 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
19908 C...Net effect of all separate limits.
19909 VINT(16)=MAX(TAPMN0,TAPMN1)
19910 VINT(36)=MIN(TAPMX0,TAPMX1)
19911 IF(MINT(47).EQ.1) THEN
19914 ELSEIF(MINT(47).EQ.5) THEN
19915 VINT(36)=MIN(VINT(36),1D0-2D-10)
19916 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
19917 VINT(36)=MIN(VINT(36),1D0-1D-10)
19919 IF(VINT(36).LE.VINT(16)) MINT(51)=1
19924 C...Special case for low-pT and multiple interactions:
19925 C...effective kinematical limits for tau, y*, cos(theta-hat).
19926 100 IF(ILIM.EQ.0) THEN
19927 ELSEIF(ILIM.EQ.1) THEN
19928 IF(MSTP(82).LE.1) THEN
19929 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19932 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
19935 ELSEIF(ILIM.EQ.2) THEN
19936 VINT(12)=0.5D0*LOG(VINT(21))
19938 ELSEIF(ILIM.EQ.3) THEN
19939 IF(MSTP(82).LE.1) THEN
19940 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19941 & (VINT(21)*VINT(2))
19943 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19944 & (VINT(21)*VINT(2))
19946 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
19955 C*********************************************************************
19958 C...Maps a uniform distribution into a distribution of a kinematical
19959 C...variable according to one of the possibilities allowed. It is
19960 C...assumed that kinematical limits have been set by a PYKLIM call.
19962 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
19964 C...Double precision and integer declarations.
19965 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19966 IMPLICIT INTEGER(I-N)
19967 INTEGER PYK,PYCHGE,PYCOMP
19969 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19970 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19971 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19972 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19973 COMMON/PYINT1/MINT(400),VINT(400)
19974 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19975 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
19977 C...Convert VVAR to tau variable.
19983 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
19986 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
19990 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19992 ELSEIF(MVAR.EQ.1) THEN
19993 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
19994 ELSEIF(MVAR.EQ.2) THEN
19995 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
19996 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
19997 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
19998 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
19999 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
20000 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
20001 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
20002 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
20003 ELSEIF(MINT(47).EQ.5) THEN
20004 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
20005 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
20006 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20008 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
20009 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
20010 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20012 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
20014 C...Convert VVAR to y* variable.
20015 ELSEIF(IVAR.EQ.2) THEN
20019 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
20020 IF(MINT(47).EQ.1) THEN
20022 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
20023 YST=-0.5D0*LOG(TAUE)
20024 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
20025 YST=0.5D0*LOG(TAUE)
20026 ELSEIF(MVAR.EQ.1) THEN
20027 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
20028 ELSEIF(MVAR.EQ.2) THEN
20029 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
20030 ELSEIF(MVAR.EQ.3) THEN
20031 AUPP=ATAN(EXP(YSTMAX))
20032 ALOW=ATAN(EXP(YSTMIN))
20033 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
20034 ELSEIF(MVAR.EQ.4) THEN
20035 YST0=-0.5D0*LOG(TAUE)
20036 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
20037 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
20038 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
20040 YST0=-0.5D0*LOG(TAUE)
20041 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
20042 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
20043 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
20045 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
20047 C...Convert VVAR to cos(theta-hat) variable.
20048 ELSEIF(IVAR.EQ.3) THEN
20049 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
20051 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
20052 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
20060 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20061 VCTN=VVAR*(ANEG+APOS)/ANEG
20062 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
20064 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20065 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
20067 ELSEIF(MVAR.EQ.2) THEN
20068 RMNMIN=MAX(RM34,RSQM-CTNMIN)
20069 RMNMAX=MAX(RM34,RSQM-CTNMAX)
20070 RMPMIN=MAX(RM34,RSQM-CTPMIN)
20071 RMPMAX=MAX(RM34,RSQM-CTPMAX)
20072 ANEG=LOG(RMNMIN/RMNMAX)
20073 APOS=LOG(RMPMIN/RMPMAX)
20074 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20075 VCTN=VVAR*(ANEG+APOS)/ANEG
20076 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
20078 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20079 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
20081 ELSEIF(MVAR.EQ.3) THEN
20082 RMNMIN=MAX(RM34,RSQM+CTNMIN)
20083 RMNMAX=MAX(RM34,RSQM+CTNMAX)
20084 RMPMIN=MAX(RM34,RSQM+CTPMIN)
20085 RMPMAX=MAX(RM34,RSQM+CTPMAX)
20086 ANEG=LOG(RMNMAX/RMNMIN)
20087 APOS=LOG(RMPMAX/RMPMIN)
20088 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20089 VCTN=VVAR*(ANEG+APOS)/ANEG
20090 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
20092 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20093 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
20095 ELSEIF(MVAR.EQ.4) THEN
20096 RMNMIN=MAX(RM34,RSQM-CTNMIN)
20097 RMNMAX=MAX(RM34,RSQM-CTNMAX)
20098 RMPMIN=MAX(RM34,RSQM-CTPMIN)
20099 RMPMAX=MAX(RM34,RSQM-CTPMAX)
20100 ANEG=1D0/RMNMAX-1D0/RMNMIN
20101 APOS=1D0/RMPMAX-1D0/RMPMIN
20102 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20103 VCTN=VVAR*(ANEG+APOS)/ANEG
20104 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
20106 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20107 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
20109 ELSEIF(MVAR.EQ.5) THEN
20110 RMNMIN=MAX(RM34,RSQM+CTNMIN)
20111 RMNMAX=MAX(RM34,RSQM+CTNMAX)
20112 RMPMIN=MAX(RM34,RSQM+CTPMIN)
20113 RMPMAX=MAX(RM34,RSQM+CTPMAX)
20114 ANEG=1D0/RMNMIN-1D0/RMNMAX
20115 APOS=1D0/RMPMIN-1D0/RMPMAX
20116 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20117 VCTN=VVAR*(ANEG+APOS)/ANEG
20118 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
20120 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20121 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
20124 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
20125 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
20128 C...Convert VVAR to tau' variable.
20129 ELSEIF(IVAR.EQ.4) THEN
20133 IF(MINT(47).EQ.1) THEN
20135 ELSEIF(MVAR.EQ.1) THEN
20136 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
20137 ELSEIF(MVAR.EQ.2) THEN
20138 AUPP=(1D0-TAU/TAUPMX)**4
20139 ALOW=(1D0-TAU/TAUPMN)**4
20140 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
20141 ELSEIF(MINT(47).EQ.5) THEN
20142 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
20143 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
20144 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20146 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
20147 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
20148 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20150 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
20152 C...Selection of extra variables needed in 2 -> 3 process:
20153 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
20154 C...Since no options are available, the functions of PYKLIM
20155 C...and PYKMAP are joint for these choices.
20156 ELSEIF(IVAR.EQ.5) THEN
20158 C...Read out total energy and particle masses.
20161 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
20162 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
20164 SHP=VINT(26)*VINT(2)
20168 PM3=SQRT(VINT(21))*VINT(1)
20169 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
20176 C...Specify coefficients of pT choice; upper and lower limits.
20177 IF(MPTPK.EQ.1) THEN
20185 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
20187 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
20189 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
20191 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
20194 C...Select transverse momenta according to
20195 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
20198 IF(HMX.LT.1.0001D0*HMN) THEN
20204 IF(RPT.LT.HWT1) THEN
20205 PTS1=PTSMN1+PYR(0)*HDE
20206 ELSEIF(RPT.LT.HWT1+HWT2) THEN
20207 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
20209 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
20211 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
20212 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
20215 IF(HMX.LT.1.0001D0*HMN) THEN
20221 IF(RPT.LT.HWT1) THEN
20222 PTS2=PTSMN2+PYR(0)*HDE
20223 ELSEIF(RPT.LT.HWT1+HWT2) THEN
20224 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
20226 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
20228 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
20229 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
20231 C...Select azimuthal angles and check pT choice.
20232 PHI1=PARU(2)*PYR(0)
20233 PHI2=PARU(2)*PYR(0)
20235 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
20236 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
20237 & CKIN(56)**2)) THEN
20242 C...Calculate transverse masses and check phase space not closed.
20249 PM12=(PMT1+PMT2)**2
20250 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
20255 C...Select rapidity for particle 3 and check phase space not closed.
20256 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
20257 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
20258 IF(Y3MAX.LT.1D-6) THEN
20262 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
20266 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
20269 PMS12=PE12**2-PZ12**2
20270 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
20271 IF(SQL12.LT.1D-6*SHP) THEN
20275 PMM1=PMS12+PMS1-PMS2
20276 PMM2=PMS12+PMS2-PMS1
20277 TFAC=-SHPR/(2D0*PMS12)
20278 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
20279 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
20280 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
20281 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
20283 C...Construct relative mirror weights and make choice.
20284 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
20288 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
20289 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
20291 WTP=WTPU/(WTPU+WTNU)
20292 WTN=WTNU/(WTPU+WTNU)
20294 IF(WTN.GT.PYR(0)) EPS=-1D0
20296 C...Store result of variable choice and associated weights.
20306 IF(EPS.GT.0D0) THEN
20315 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
20316 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
20317 VINT(219)=0.5D0*(PMS12-PTS3)
20324 C***********************************************************************
20327 C...Differential matrix elements for all included subprocesses
20328 C...Note that what is coded is (disregarding the COMFAC factor)
20329 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
20330 C...when d(sigma-hat) is given in the zero-width limit, the delta
20331 C...function in tau is replaced by a (modified) Breit-Wigner:
20332 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
20333 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
20334 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
20335 C...i.e., dimensionless quantities
20336 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
20337 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
20338 C...(2pi)^4 delta^4(P - sum p_i)
20339 C...COMFAC contains the factor pi/s (or equivalent) and
20340 C...the conversion factor from GeV^-2 to mb
20342 SUBROUTINE PYSIGH(NCHN,SIGS)
20344 C...Double precision and integer declarations
20345 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20346 IMPLICIT INTEGER(I-N)
20347 INTEGER PYK,PYCHGE,PYCOMP
20348 C...Parameter statement to help give large particle numbers.
20349 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
20350 &KEXCIT=4000000,KDIMEN=5000000)
20352 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20353 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20354 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20355 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20356 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20357 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20358 COMMON/PYINT1/MINT(400),VINT(400)
20359 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20360 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20361 COMMON/PYINT4/MWID(500),WIDS(500,5)
20362 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20363 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20364 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
20365 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
20366 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
20367 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
20368 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
20369 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
20370 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
20371 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
20372 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20373 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
20374 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYSGCM/
20375 C...Local arrays and complex variables
20376 DIMENSION X(2),XPQ(-25:25)
20378 C...Map of processes onto which routine to call
20379 C...in order to evaluate cross section:
20380 C...0 = not implemented;
20381 C...1 = standard QCD (including photons);
20382 C...2 = heavy flavours;
20384 C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
20386 C...6 = Technicolor;
20387 C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
20388 DIMENSION MAPPR(500)
20389 DATA (MAPPR(I),I=1,180)/
20390 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
20391 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
20392 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
20393 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
20394 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
20395 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
20396 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
20397 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
20398 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
20399 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
20400 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
20401 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
20402 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
20403 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
20404 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
20405 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
20406 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
20407 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
20408 DATA (MAPPR(I),I=181,500)/
20409 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
20410 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
20412 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
20414 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
20415 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
20416 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
20417 7 6, 6, 6, 6, 6, 6, 6, 0, 0, 0,
20418 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
20419 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
20422 C...Reset number of channels and cross-section
20426 C...Read process to consider.
20431 C...Read kinematical variables and limits
20449 C...Derive kinematical quantities
20451 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
20452 X(1)=SQRT(TAUE)*EXP(YST)
20453 X(2)=SQRT(TAUE)*EXP(-YST)
20454 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
20455 IF(X(1).GT.1D0-1D-7) RETURN
20456 ELSEIF(MINT(45).EQ.3) THEN
20457 X(1)=MIN(1D0-1.1D-10,X(1))
20459 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
20460 IF(X(2).GT.1D0-1D-7) RETURN
20461 ELSEIF(MINT(46).EQ.3) THEN
20462 X(2)=MIN(1D0-1.1D-10,X(2))
20464 SH=MAX(1D0,TAU*VINT(2))
20469 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
20470 RPTS=4D0*VINT(71)**2/SH
20471 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
20472 RM34=MAX(1D-20,2D0*RM3*RM4)
20474 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
20475 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
20476 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
20477 IF(ISTSB.EQ.0) THEN
20479 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
20480 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
20482 C...Kinematics with incoming masses tricky: now depends on how
20483 C...subprocess has been set up w.r.t. order of incoming partons.
20485 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
20487 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
20488 IF(ISUB.EQ.35) THEN
20492 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
20493 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
20494 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
20496 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
20498 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
20505 C...Choice of Q2 scale: hard, parton distributions, parton showers
20506 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
20508 ELSEIF(ISTSB.EQ.8) THEN
20509 IF(MINT(107).EQ.4) Q2=VINT(307)
20510 IF(MINT(108).EQ.4) Q2=VINT(308)
20511 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
20513 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
20515 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
20516 IF(MSTP(32).EQ.1) THEN
20517 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
20518 ELSEIF(MSTP(32).EQ.2) THEN
20519 Q2=SQPTH+0.5D0*(SQM3+SQM4)
20520 ELSEIF(MSTP(32).EQ.3) THEN
20522 ELSEIF(MSTP(32).EQ.4) THEN
20524 ELSEIF(MSTP(32).EQ.5) THEN
20526 ELSEIF(MSTP(32).EQ.6) THEN
20528 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
20530 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
20531 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
20532 & (SQPTH+0.5D0*(SQM3+SQM4))
20533 ELSEIF(MSTP(32).EQ.7) THEN
20534 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
20535 ELSEIF(MSTP(32).EQ.8) THEN
20536 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
20537 ELSEIF(MSTP(32).EQ.9) THEN
20538 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
20539 ELSEIF(MSTP(32).EQ.10) THEN
20542 IF(ISTSB.EQ.9) Q2=SQPTH
20543 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
20544 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
20547 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20549 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
20550 & ISUB.EQ.351) Q2SF=PMAS(24,1)**2
20551 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
20552 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
20553 & ISUB.EQ.186.OR.ISUB.EQ.187) THEN
20554 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
20555 IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
20556 IF(MSTP(39).EQ.3) Q2SF=SH
20557 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
20558 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
20563 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
20564 IF(MSTP(69).GE.2) Q2SF=VINT(2)
20565 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
20566 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20568 IF(MINT(43).EQ.3) XBJ=X(1)
20569 IF(MSTP(22).EQ.1) THEN
20571 ELSEIF(MSTP(22).EQ.2) THEN
20572 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
20573 ELSEIF(MSTP(22).EQ.3) THEN
20574 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
20576 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
20579 IF(MSTP(68).EQ.1.AND.(ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.
20580 &ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
20581 &ISUBSV.EQ.144.OR.ISUBSV.EQ.152.OR.ISUBSV.EQ.157)) THEN
20583 ELSEIF(MSTP(68).GE.2.AND.(ISUBSV.NE.11.AND.ISUBSV.NE.12.AND.
20584 &ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.ISUBSV.NE.53.AND.
20585 &ISUBSV.NE.68)) THEN
20589 C...Store derived kinematical quantities
20596 IF(ISTSB.NE.8) VINT(48)=SQPTH
20597 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
20598 VINT(50)=TAUP*VINT(2)
20599 VINT(49)=SQRT(MAX(0D0,VINT(50)))
20603 VINT(53)=SQRT(Q2SF)
20605 VINT(55)=SQRT(Q2PS)
20607 C...Calculate parton distributions
20608 IF(ISTSB.LE.0) GOTO 160
20609 IF(MINT(47).GE.2) THEN
20610 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
20612 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
20613 IF(ISUB.EQ.99) THEN
20614 IF(MINT(140+I).EQ.0) THEN
20615 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
20617 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
20622 MINT(105)=MINT(102+I)
20623 MINT(109)=MINT(106+I)
20624 VINT(120)=VINT(2+I)
20626 C.... Store side in MINT(124)
20629 IF(MSTP(57).LE.1) THEN
20630 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
20632 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
20635 XSFX(I,KFL)=XPQ(KFL)
20640 C...Calculate alpha_em, alpha_strong and K-factor
20643 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
20644 &1D0-(PMAS(24,1)/PMAS(23,1))**2
20646 XWC=1D0/(16D0*XW*XW1)
20648 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
20649 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
20652 IF(MSTP(33).EQ.1) THEN
20654 ELSEIF(MSTP(33).EQ.2) THEN
20656 FACA=PARP(32)/PARP(31)
20657 ELSEIF(MSTP(33).EQ.3) THEN
20659 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
20660 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
20667 C...Set flags for allowed reacting partons/leptons
20672 IF(MINT(44+I).EQ.1) THEN
20673 KFAC(I,MINT(10+I))=1
20674 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
20675 KFAC(I,MINT(10+I))=1
20681 KFAC(I,J)=KFIN(I,J)
20682 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
20683 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
20688 C...Lower and upper limit for fermion flavour loops
20694 IF(KFAC(1,-J).EQ.1) MMIN1=-J
20695 IF(KFAC(1,J).EQ.1) MMAX1=J
20696 IF(KFAC(2,-J).EQ.1) MMIN2=-J
20697 IF(KFAC(2,J).EQ.1) MMAX2=J
20699 MMINA=MIN(MMIN1,MMIN2)
20700 MMAXA=MAX(MMAX1,MMAX2)
20702 C...Common resonance mass and width combinations
20705 GMMZ=PMAS(23,1)*PMAS(23,2)
20706 GMMW=PMAS(24,1)*PMAS(24,2)
20708 C...Polarization factors...implemented so far for W+W-(25)
20709 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
20710 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
20711 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
20712 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
20714 C...Phase space integral in tau
20715 COMFAC=PARU(1)*PARU(5)/VINT(2)
20716 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
20717 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
20718 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
20719 ATAU1=LOG(TAUMAX/TAUMIN)
20720 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
20721 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
20722 IF(MINT(72).GE.1) THEN
20725 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
20727 IF(ATAUD.GT.1D-10) H1=H1+
20728 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
20729 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
20731 IF(ATAUD.GT.1D-10) H1=H1+
20732 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
20734 IF(MINT(72).EQ.2) THEN
20737 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
20739 IF(ATAUD.GT.1D-10) H1=H1+
20740 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
20741 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
20743 IF(ATAUD.GT.1D-10) H1=H1+
20744 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
20746 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20747 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
20748 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20749 & MAX(2D-10,1D0-TAU)
20750 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20751 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
20752 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20753 & MAX(1D-10,1D0-TAU)
20755 COMFAC=COMFAC*ATAU1/(TAU*H1)
20758 C...Phase space integral in y*
20759 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
20761 AYST0=YSTMAX-YSTMIN
20762 IF(AYST0.LT.1D-10) THEN
20765 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20767 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20768 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20769 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20770 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20771 IF(MINT(45).EQ.3) THEN
20772 YST0=-0.5D0*LOG(TAUE)
20773 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
20774 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
20775 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
20776 & MAX(1D-10,1D0-EXP(YST-YST0))
20778 IF(MINT(46).EQ.3) THEN
20779 YST0=-0.5D0*LOG(TAUE)
20780 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
20781 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
20782 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
20783 & MAX(1D-10,1D0-EXP(-YST-YST0))
20785 COMFAC=COMFAC*AYST0/H2
20789 C...2 -> 1 processes: reduction in angular part of phase space integral
20790 C...for case of decaying resonance
20791 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
20792 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
20793 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
20794 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
20795 & KFPR(ISUB,1).EQ.39) THEN
20796 COMFAC=COMFAC*0.5D0*ACTH0
20798 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
20799 & CTPMAX**3-CTPMIN**3)
20803 C...2 -> 2 processes: angular part of phase space integral
20804 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
20805 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
20806 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
20807 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
20808 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
20809 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
20810 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
20811 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
20812 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
20813 H3=COEF(ISUBSV,13)+
20814 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
20815 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
20816 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
20817 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
20818 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
20820 C...2 -> 2 processes: take into account final state Breit-Wigners
20821 COMFAC=COMFAC*VINT(80)
20824 C...2 -> 3, 4 processes: phace space integral in tau'
20825 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20826 ATAUP1=LOG(TAUPMX/TAUPMN)
20827 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
20828 H4=COEF(ISUBSV,18)+
20829 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
20830 IF(MINT(47).EQ.5) THEN
20831 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
20832 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
20833 ELSEIF(MINT(47).GE.6) THEN
20834 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
20835 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
20837 COMFAC=COMFAC*ATAUP1/H4
20840 C...2 -> 3, 4 processes: effective W/Z parton distributions
20841 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
20842 IF(1D0-TAU/TAUP.GT.1D-4) THEN
20843 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
20845 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
20850 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
20851 IF(ISTSB.EQ.5) THEN
20852 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
20853 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
20856 C...Phase space integral for low-pT and multiple interactions
20857 IF(ISTSB.EQ.9) THEN
20858 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
20859 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
20860 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
20861 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
20862 COMFAC=COMFAC*ATAU1/H1
20863 AYST0=YSTMAX-YSTMIN
20864 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20865 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20866 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20867 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20868 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20869 COMFAC=COMFAC*AYST0/H2
20870 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
20871 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
20872 C...introduced to make cross-section finite for xT2 -> 0
20873 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
20877 C...Real gamma + gamma: include factor 2 when different nature
20878 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
20879 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
20881 C...Extra factors to include the effects of
20882 C...longitudinal resolved photons (but not direct or DIS ones).
20884 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
20885 & MINT(106+ISDE).LE.3) THEN
20888 IF(MSTP(16).EQ.0) THEN
20889 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
20890 & XY=VINT(304+ISDE)
20892 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
20893 & XY=VINT(308+ISDE)
20895 Q2GA=VINT(306+ISDE)
20896 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
20897 & Q2GA.GT.0D0) THEN
20899 IF(MSTP(17).EQ.1) THEN
20900 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
20901 ELSEIF(MSTP(17).EQ.2) THEN
20902 REDUCE=4D0*Q2GA/(Q2+Q2GA)
20903 ELSEIF(MSTP(17).EQ.3) THEN
20904 PMVIRT=PMAS(PYCOMP(113),1)
20905 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20906 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
20907 PMVIRT=PMAS(PYCOMP(113),1)
20908 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20909 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
20910 PMVIRT=PMAS(PYCOMP(113),1)
20911 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20912 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
20913 PMVSMN=4D0*PARP(15)**2
20914 PMVSMX=4D0*VINT(154)**2
20915 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20916 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
20917 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
20918 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
20919 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
20920 PMVIRT=PMAS(PYCOMP(113),1)
20921 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20922 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
20923 PMVIRT=PMAS(PYCOMP(113),1)
20924 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20925 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
20926 PMVSMN=4D0*PARP(15)**2
20927 PMVSMX=4D0*VINT(154)**2
20928 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20929 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
20930 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
20933 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
20934 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
20935 & (1D0-2D0*BEAMAS**2/Q2GA))
20936 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
20941 COMFAC=COMFAC*VINT(314+ISDE)
20944 C...Evaluate cross sections - done in separate routines by kind
20945 C...of physics, to keep PYSIGH of sensible size.
20947 C...Standard QCD (including photons).
20948 CALL PYSGQC(NCHN,SIGS)
20949 ELSEIF(MAP.EQ.2) THEN
20950 C...Heavy flavours.
20951 CALL PYSGHF(NCHN,SIGS)
20952 ELSEIF(MAP.EQ.3) THEN
20954 CALL PYSGWZ(NCHN,SIGS)
20955 ELSEIF(MAP.EQ.4) THEN
20956 C...Higgs (2 doublets; including longitudinal W/Z scattering).
20957 CALL PYSGHG(NCHN,SIGS)
20958 ELSEIF(MAP.EQ.5) THEN
20960 CALL PYSGSU(NCHN,SIGS)
20961 ELSEIF(MAP.EQ.6) THEN
20963 CALL PYSGTC(NCHN,SIGS)
20964 ELSEIF(MAP.EQ.7) THEN
20965 C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
20966 CALL PYSGEX(NCHN,SIGS)
20969 C...Multiply with parton distributions
20970 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
20972 IF(MINT(45).GE.2) THEN
20974 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
20976 IF(MINT(46).GE.2) THEN
20978 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
20980 SIGS=SIGS+SIGH(ICHN)
20987 C*********************************************************************
20990 C...Subprocess cross sections for QCD processes,
20991 C...including photons.
20992 C...Auxiliary to PYSIGH.
20994 SUBROUTINE PYSGQC(NCHN,SIGS)
20996 C...Double precision and integer declarations
20997 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20998 IMPLICIT INTEGER(I-N)
20999 INTEGER PYK,PYCHGE,PYCOMP
21000 C...Parameter statement to help give large particle numbers.
21001 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
21002 &KEXCIT=4000000,KDIMEN=5000000)
21004 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21005 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21006 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
21007 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21008 COMMON/PYINT1/MINT(400),VINT(400)
21009 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
21010 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
21011 COMMON/PYINT4/MWID(500),WIDS(500,5)
21012 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
21013 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
21014 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
21015 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
21016 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
21017 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
21018 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
21020 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
21022 C...Differential cross section expressions.
21024 IF(ISUB.LE.20) THEN
21025 IF(ISUB.EQ.10) THEN
21026 C...f + f' -> f + f' (gamma/Z/W exchange)
21027 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
21028 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
21029 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
21030 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
21031 DO 110 I=MMIN1,MMAX1
21032 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
21034 DO 100 J=MMIN2,MMAX2
21035 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
21037 C...Electroweak couplings
21038 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
21039 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
21041 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
21042 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
21045 C...gamma/Z exchange, only gamma exchange, or only Z exchange
21046 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
21047 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
21048 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
21049 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
21050 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
21051 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21052 ELSEIF(MSTP(21).EQ.2) THEN
21053 FACNCF=FACGGF*EI**2*EJ**2
21055 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
21056 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21058 C...Extrafactor 2 for only one incoming neutrino spin state.
21059 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
21060 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
21068 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
21069 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
21070 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
21071 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
21072 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
21082 ELSEIF(ISUB.EQ.11) THEN
21083 C...f + f' -> f + f' (g exchange)
21084 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
21085 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
21086 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
21087 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
21088 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
21089 DO 130 I=MMIN1,MMAX1
21091 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
21092 DO 120 J=MMIN2,MMAX2
21094 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
21100 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
21102 SIGH(NCHN)=0.5D0*SIGH(NCHN)
21107 SIGH(NCHN)=0.5D0*FACQQ2
21112 ELSEIF(ISUB.EQ.12) THEN
21113 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
21114 CALL PYWIDT(21,SH,WDTP,WDTE)
21115 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
21116 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21117 DO 140 I=MMINA,MMAXA
21118 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21119 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
21127 ELSEIF(ISUB.EQ.13) THEN
21128 C...f + fbar -> g + g (q + qbar -> g + g only)
21129 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21131 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21133 DO 150 I=MMINA,MMAXA
21134 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21135 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
21140 SIGH(NCHN)=0.5D0*FACGG1
21145 SIGH(NCHN)=0.5D0*FACGG2
21148 ELSEIF(ISUB.EQ.14) THEN
21149 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
21150 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
21151 DO 160 I=MMINA,MMAXA
21152 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21153 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
21154 EI=KCHG(IABS(I),1)/3D0
21159 SIGH(NCHN)=FACGG*EI**2
21162 ELSEIF(ISUB.EQ.18) THEN
21163 C...f + fbar -> gamma + gamma
21164 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
21165 DO 170 I=MMINA,MMAXA
21166 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
21167 EI=KCHG(IABS(I),1)/3D0
21169 IF(IABS(I).LE.10) FCOI=FACA/3D0
21174 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
21178 ELSEIF(ISUB.LE.40) THEN
21179 IF(ISUB.EQ.28) THEN
21180 C...f + g -> f + g (q + g -> q + g only)
21181 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
21183 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
21185 DO 190 I=MMINA,MMAXA
21186 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
21188 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
21189 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
21192 ISIG(NCHN,3-ISDE)=21
21197 ISIG(NCHN,3-ISDE)=21
21203 ELSEIF(ISUB.EQ.29) THEN
21204 C...f + g -> f + gamma (q + g -> q + gamma only)
21205 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
21206 DO 210 I=MMINA,MMAXA
21207 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
21208 EI=KCHG(IABS(I),1)/3D0
21211 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
21212 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
21215 ISIG(NCHN,3-ISDE)=21
21221 ELSEIF(ISUB.EQ.33) THEN
21222 C...f + gamma -> f + g (q + gamma -> q + g only)
21223 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
21224 DO 230 I=MMINA,MMAXA
21225 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
21226 EI=KCHG(IABS(I),1)/3D0
21229 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
21230 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
21233 ISIG(NCHN,3-ISDE)=22
21239 ELSEIF(ISUB.EQ.34) THEN
21240 C...f + gamma -> f + gamma
21241 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
21242 DO 250 I=MMINA,MMAXA
21243 IF(I.EQ.0) GOTO 250
21244 EI=KCHG(IABS(I),1)/3D0
21247 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
21248 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
21251 ISIG(NCHN,3-ISDE)=22
21258 ELSEIF(ISUB.LE.80) THEN
21259 IF(ISUB.EQ.53) THEN
21260 C...g + g -> f + fbar (g + g -> q + qbar only)
21261 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
21263 C...Begin by d, u, s flavours.
21265 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
21266 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
21267 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
21268 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
21269 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
21270 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
21271 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21272 & UH2/SH2)*FLAVWT*FACA
21273 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21274 & TH2/SH2)*FLAVWT*FACA
21285 C...Next c and b flavours: modified that and uhat for fixed
21286 C...cos(theta-hat).
21288 SQMAVG=PMAS(IFL,1)**2
21289 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
21290 BE34=SQRT(1D0-4D0*SQMAVG/SH)
21291 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21292 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21293 THUHQ=THQ*UHQ-SQMAVG*SH
21294 IF(MSTP(34).EQ.0) THEN
21295 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
21296 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
21298 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21299 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
21300 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21301 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
21303 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
21304 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
21308 ISIG(NCHN,3)=1+2*(IFL-3)
21313 ISIG(NCHN,3)=2+2*(IFL-3)
21319 ELSEIF(ISUB.EQ.54) THEN
21320 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
21321 CALL PYWIDT(21,SH,WDTP,WDTE)
21323 DO 280 I=1,MIN(8,MDCY(21,3))
21325 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21328 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
21329 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
21336 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
21344 ELSEIF(ISUB.EQ.58) THEN
21345 C...gamma + gamma -> f + fbar
21346 CALL PYWIDT(22,SH,WDTP,WDTE)
21348 DO 290 I=1,MIN(12,MDCY(22,3))
21349 IF(I.LE.8) EF= KCHG(I,1)/3D0
21350 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
21351 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21354 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
21355 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
21363 ELSEIF(ISUB.EQ.68) THEN
21365 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
21366 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
21368 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
21370 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
21376 SIGH(NCHN)=0.5D0*FACGG1
21381 SIGH(NCHN)=0.5D0*FACGG2
21386 SIGH(NCHN)=0.5D0*FACGG3
21389 ELSEIF(ISUB.EQ.80) THEN
21390 C...q + gamma -> q' + pi+/-
21391 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
21392 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
21393 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
21394 DELSH=UH*SQRT(ASSH*Q2FPSH)
21395 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
21396 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
21397 DELUH=SH*SQRT(ASUH*Q2FPUH)
21398 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
21399 IF(I.EQ.0) GOTO 320
21400 EI=KCHG(IABS(I),1)/3D0
21401 EJ=SIGN(1D0-ABS(EI),EI)
21403 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
21404 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
21407 ISIG(NCHN,3-ISDE)=22
21409 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
21414 ELSEIF(ISUB.LE.100) THEN
21415 IF(ISUB.EQ.91) THEN
21416 C...Elastic scattering
21417 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
21419 ELSEIF(ISUB.EQ.92) THEN
21420 C...Single diffractive scattering (first side, i.e. XB)
21421 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
21423 ELSEIF(ISUB.EQ.93) THEN
21424 C...Single diffractive scattering (second side, i.e. AX)
21425 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
21427 ELSEIF(ISUB.EQ.94) THEN
21428 C...Double diffractive scattering
21429 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
21431 ELSEIF(ISUB.EQ.95) THEN
21432 C...Low-pT scattering
21433 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
21435 ELSEIF(ISUB.EQ.96) THEN
21436 C...Multiple interactions: sum of QCD processes
21437 CALL PYWIDT(21,SH,WDTP,WDTE)
21439 C...q + q' -> q + q'
21440 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
21441 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
21442 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
21443 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
21444 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
21445 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
21447 IF(I.EQ.0) GOTO 340
21449 IF(J.EQ.0) GOTO 330
21455 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
21457 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
21462 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
21467 C...q + qbar -> q' + qbar' or g + g
21468 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
21469 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
21470 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21472 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21475 IF(I.EQ.0) GOTO 350
21485 SIGH(NCHN)=0.5D0*FACGG1
21490 SIGH(NCHN)=0.5D0*FACGG2
21494 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
21496 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
21499 IF(I.EQ.0) GOTO 370
21503 ISIG(NCHN,3-ISDE)=21
21508 ISIG(NCHN,3-ISDE)=21
21514 C...g + g -> q + qbar (only d, u, s)
21517 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
21518 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
21519 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
21520 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
21521 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
21522 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
21523 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21524 & UH2/SH2)*FLAVWT*FACA
21525 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21526 & TH2/SH2)*FLAVWT*FACA
21538 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
21541 SQMAVG=PMAS(IFL,1)**2
21542 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
21543 BE34=SQRT(1D0-4D0*SQMAVG/SH)
21544 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21545 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21546 THUHQ=THQ*UHQ-SQMAVG*SH
21547 IF(MSTP(34).EQ.0) THEN
21548 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
21549 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
21551 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21552 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
21553 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21554 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
21556 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
21557 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
21561 ISIG(NCHN,3)=531+2*(IFL-3)
21566 ISIG(NCHN,3)=532+2*(IFL-3)
21572 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
21573 & 2D0*TH/SH+TH2/SH2)*FACA
21574 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
21575 & 2D0*SH/UH+SH2/UH2)*FACA
21576 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
21577 & 2D0*UH/TH+UH2/TH2)
21582 SIGH(NCHN)=0.5D0*FACGG1
21587 SIGH(NCHN)=0.5D0*FACGG2
21592 SIGH(NCHN)=0.5D0*FACGG3
21594 ELSEIF(ISUB.EQ.99) THEN
21595 C...f + gamma* -> f.
21596 IF(MINT(107).EQ.4) THEN
21605 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
21606 PM2RHO=PMAS(PYCOMP(113),1)**2
21607 IF(MSTP(19).EQ.0) THEN
21609 ELSEIF(MSTP(19).EQ.1) THEN
21610 COMFAC=COMFAC/(Q2GA+PM2RHO)
21611 ELSEIF(MSTP(19).EQ.2) THEN
21612 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
21614 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
21616 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
21617 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
21618 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
21619 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
21621 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
21623 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
21625 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
21626 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
21628 DO 390 I=MMINA,MMAXA
21629 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
21630 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
21631 EI=KCHG(IABS(I),1)/3D0
21634 ISIG(NCHN,3-ISDE)=22
21636 SIGH(NCHN)=COMFAC*EI**2
21641 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
21642 C...g + g -> gamma + gamma or g + g -> g + gamma
21657 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
21659 EI=KCHG(IABS(I),1)/3D0
21661 IF(ISUB.EQ.115) EIWT=EI
21666 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
21667 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
21670 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
21671 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
21672 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
21673 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
21679 CALL PYWAUX(1,EPSS,W1SR,W1SI)
21680 CALL PYWAUX(1,EPST,W1TR,W1TI)
21681 CALL PYWAUX(1,EPSU,W1UR,W1UI)
21682 CALL PYWAUX(2,EPSS,W2SR,W2SI)
21683 CALL PYWAUX(2,EPST,W2TR,W2TI)
21684 CALL PYWAUX(2,EPSU,W2UR,W2UI)
21685 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
21686 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
21687 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
21688 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
21689 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
21690 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
21691 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
21692 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
21693 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
21694 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
21695 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
21696 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
21697 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
21698 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
21699 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
21700 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
21701 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
21702 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
21703 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
21704 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
21705 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
21706 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
21707 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
21708 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
21709 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
21710 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
21711 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
21712 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
21713 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
21714 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
21715 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
21716 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
21717 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
21718 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
21719 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
21720 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
21721 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
21722 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
21723 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
21724 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
21725 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
21726 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
21727 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
21728 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
21729 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
21730 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
21731 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
21732 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
21733 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
21734 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
21735 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
21736 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
21737 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
21738 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
21739 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
21740 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
21742 A0STUR=A0STUR+EIWT*B0STUR
21743 A0STUI=A0STUI+EIWT*B0STUI
21744 A0TSUR=A0TSUR+EIWT*B0TSUR
21745 A0TSUI=A0TSUI+EIWT*B0TSUI
21746 A0UTSR=A0UTSR+EIWT*B0UTSR
21747 A0UTSI=A0UTSI+EIWT*B0UTSI
21748 A1STUR=A1STUR+EIWT*B1STUR
21749 A1STUI=A1STUI+EIWT*B1STUI
21750 A2STUR=A2STUR+EIWT*B2STUR
21751 A2STUI=A2STUI+EIWT*B2STUI
21753 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
21754 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
21755 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
21756 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
21757 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
21762 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
21763 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
21766 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
21767 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
21769 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
21771 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
21773 IF(ISUB.EQ.131) THEN
21774 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
21775 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
21777 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
21779 DO 430 I=MMINA,MMAXA
21780 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
21781 EI=KCHG(IABS(I),1)/3D0
21784 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
21785 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
21788 ISIG(NCHN,3-ISDE)=22
21794 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
21795 C...f + gamma*_(T,L) -> f + gamma
21797 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
21799 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
21801 IF(ISUB.EQ.133) THEN
21802 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
21803 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
21805 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
21807 DO 450 I=MMINA,MMAXA
21808 IF(I.EQ.0) GOTO 450
21809 EI=KCHG(IABS(I),1)/3D0
21812 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
21813 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
21816 ISIG(NCHN,3-ISDE)=22
21822 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
21823 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
21825 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
21827 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
21829 CALL PYWIDT(21,SH,WDTP,WDTE)
21831 DO 460 I=1,MIN(8,MDCY(21,3))
21833 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21836 IF(ISUB.EQ.135) THEN
21837 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
21838 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
21840 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
21842 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
21849 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
21857 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
21858 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
21860 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
21862 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
21863 CALL PYWIDT(22,SH,WDTP,WDTE)
21865 DO 470 I=1,MIN(12,MDCY(22,3))
21866 IF(I.LE.8) EF= KCHG(I,1)/3D0
21867 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
21868 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21871 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
21872 IF(ISUB.EQ.137) THEN
21873 FPARAM=-SH*(TH+UH)/DLAMB2
21874 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
21875 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
21876 & 2D0*PH1*PH2*FPARAM**2)
21877 ELSEIF(ISUB.EQ.138) THEN
21878 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
21879 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
21880 & 2D0*PH1**2*(TH-UH)**2)
21881 ELSEIF(ISUB.EQ.139) THEN
21882 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
21883 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
21884 & 2D0*PH2**2*(TH-UH)**2)
21886 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
21887 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
21889 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
21903 C*********************************************************************
21906 C...Subprocess cross sections for heavy flavour production,
21907 C...open and closed.
21908 C...Auxiliary to PYSIGH.
21910 SUBROUTINE PYSGHF(NCHN,SIGS)
21912 C...Double precision and integer declarations
21913 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21914 IMPLICIT INTEGER(I-N)
21915 INTEGER PYK,PYCHGE,PYCOMP
21916 C...Parameter statement to help give large particle numbers.
21917 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
21918 &KEXCIT=4000000,KDIMEN=5000000)
21920 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21921 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21922 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21923 COMMON/PYINT1/MINT(400),VINT(400)
21924 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
21925 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
21926 COMMON/PYINT4/MWID(500),WIDS(500,5)
21927 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
21928 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
21929 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
21930 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
21931 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
21934 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
21936 C...Differential cross section expressions.
21938 IF(ISUB.LE.100) THEN
21939 IF(ISUB.EQ.81) THEN
21940 C...q + qbar -> Q + Qbar
21941 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21942 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21943 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21944 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
21946 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
21948 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21949 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21951 DO 100 I=MMINA,MMAXA
21952 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21953 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
21961 ELSEIF(ISUB.EQ.82) THEN
21962 C...g + g -> Q + Qbar
21963 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21964 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21965 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21966 THUHQ=THQ*UHQ-SQMAVG*SH
21967 IF(MSTP(34).EQ.0) THEN
21968 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
21969 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
21971 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21972 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
21973 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21974 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
21976 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
21977 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
21978 IF(MSTP(35).GE.1) THEN
21979 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
21980 FACQQ1=FACQQ1*FATRE
21981 FACQQ2=FACQQ2*FATRE
21984 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21985 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21988 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
22001 ELSEIF(ISUB.EQ.83) THEN
22002 C...f + q -> f' + Q
22003 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
22004 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
22005 DO 130 I=MMIN1,MMAX1
22006 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
22007 DO 120 J=MMIN2,MMAX2
22008 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
22009 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
22010 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
22011 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
22017 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
22018 & (IABS(I)+1)/2)*VINT(180+J)
22019 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
22020 & (MINT(55)+1)/2)*VINT(180+J)
22023 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
22024 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22027 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
22028 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22031 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
22032 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
22034 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
22040 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
22041 & (IABS(J)+1)/2)*VINT(180+I)
22042 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
22043 & (MINT(55)+1)/2)*VINT(180+I)
22045 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
22046 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22049 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
22050 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22053 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
22054 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
22059 ELSEIF(ISUB.EQ.84) THEN
22060 C...g + gamma -> Q + Qbar
22061 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22062 THQ=-0.5D0*SH*(1D0-BE34*CTH)
22063 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
22064 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
22065 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
22067 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
22069 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
22070 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
22072 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
22079 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
22087 ELSEIF(ISUB.EQ.85) THEN
22088 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
22089 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22090 THQ=-0.5D0*SH*(1D0-BE34*CTH)
22091 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
22092 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
22093 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
22094 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
22095 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
22096 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
22097 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
22098 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
22100 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
22101 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
22102 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
22104 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
22112 ELSEIF(ISUB.EQ.86) THEN
22113 C...g + g -> J/Psi + g
22114 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
22115 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22116 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22117 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22125 ELSEIF(ISUB.EQ.87) THEN
22126 C...g + g -> chi_0c + g
22127 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
22128 QGTW=(SH*TH*UH)/SH**3
22130 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
22131 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
22132 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
22133 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
22134 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
22135 & (QGTW*(QGTW-RGTW*PGTW)**4)
22136 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22144 ELSEIF(ISUB.EQ.88) THEN
22145 C...g + g -> chi_1c + g
22146 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
22147 QGTW=(SH*TH*UH)/SH**3
22149 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
22150 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
22151 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
22152 & (QGTW-RGTW*PGTW)**4
22153 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22161 ELSEIF(ISUB.EQ.89) THEN
22162 C...g + g -> chi_2c + g
22163 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
22164 QGTW=(SH*TH*UH)/SH**3
22166 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
22167 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
22168 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
22169 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
22170 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
22171 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
22172 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22181 ELSEIF(ISUB.LE.200) THEN
22182 IF(ISUB.EQ.104) THEN
22183 C...g + g -> chi_c0.
22185 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
22186 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
22187 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
22188 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22196 ELSEIF(ISUB.EQ.105) THEN
22197 C...g + g -> chi_c2.
22199 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
22200 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
22201 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
22202 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22210 ELSEIF(ISUB.EQ.106) THEN
22211 C...g + g -> J/Psi + gamma.
22213 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
22214 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22215 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22216 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22224 ELSEIF(ISUB.EQ.107) THEN
22225 C...g + gamma -> J/Psi + g.
22227 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
22228 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22229 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22230 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
22237 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
22245 ELSEIF(ISUB.EQ.108) THEN
22246 C...gamma + gamma -> J/Psi + gamma.
22248 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
22249 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22250 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22251 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
22264 C*********************************************************************
22267 C...Subprocess cross sections for W/Z processes,
22268 C...except that longitudinal WW scattering is in Higgs sector.
22269 C...Auxiliary to PYSIGH.
22271 SUBROUTINE PYSGWZ(NCHN,SIGS)
22273 C...Double precision and integer declarations
22274 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22275 IMPLICIT INTEGER(I-N)
22276 INTEGER PYK,PYCHGE,PYCOMP
22277 C...Parameter statement to help give large particle numbers.
22278 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
22279 &KEXCIT=4000000,KDIMEN=5000000)
22281 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22282 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22283 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
22284 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
22285 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22286 COMMON/PYINT1/MINT(400),VINT(400)
22287 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
22288 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
22289 COMMON/PYINT4/MWID(500),WIDS(500,5)
22290 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
22291 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
22292 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
22293 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
22294 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
22295 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
22296 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
22297 C...Local arrays and complex numbers
22298 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
22300 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
22302 C...Differential cross section expressions.
22304 IF(ISUB.LE.20) THEN
22306 C...f + fbar -> gamma*/Z0
22308 CALL PYWIDT(23,SH,WDTP,WDTE)
22310 FACZ=4D0*COMFAC*3D0
22313 DO 100 I=MMINA,MMAXA
22314 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
22315 EI=KCHG(IABS(I),1)/3D0
22319 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
22321 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
22326 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
22327 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
22328 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
22329 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
22332 ELSEIF(ISUB.EQ.2) THEN
22333 C...f + fbar' -> W+/-
22334 CALL PYWIDT(24,SH,WDTP,WDTE)
22336 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
22337 HP=AEM/(24D0*XW)*SH
22338 DO 120 I=MMIN1,MMAX1
22339 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
22341 DO 110 J=MMIN2,MMAX2
22342 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
22344 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
22345 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22347 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22349 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
22354 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
22355 SIGH(NCHN)=HI*FACBW*HF
22359 ELSEIF(ISUB.EQ.15) THEN
22360 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
22361 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22362 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22366 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22367 DO 130 I=1,MIN(16,MDCY(23,3))
22369 IF(MDME(IDC,1).LT.0) GOTO 130
22371 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22375 AF=SIGN(1D0,EF+0.1D0)
22377 ELSEIF(I.LE.16) THEN
22379 AF=SIGN(1D0,EF+0.1D0)
22382 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22383 IF(4D0*RM1.LT.1D0) THEN
22385 IF(I.LE.8) FCOF=3D0*RADC4
22386 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22388 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22389 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22390 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22391 & AF**2*(1D0-4D0*RM1))*BE34
22395 C...Propagators: as simulated in PYOFSH and as desired
22396 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22400 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22402 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22403 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22404 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22405 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22406 C...Loop over flavours; consider full gamma/Z structure
22407 DO 140 I=MMINA,MMAXA
22408 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
22409 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
22410 EI=KCHG(IABS(I),1)/3D0
22417 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
22418 & (VI**2+AI**2)*HFZZ)/HBW4
22421 ELSEIF(ISUB.EQ.16) THEN
22422 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
22423 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22424 C...Propagators: as simulated in PYOFSH and as desired
22425 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22426 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22427 GMMWC=SQRT(SQM4)*WDTP(0)
22428 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22429 FACWG=FACWG*HBW4C/HBW4
22430 DO 160 I=MMIN1,MMAX1
22432 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
22433 DO 150 J=MMIN2,MMAX2
22435 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
22436 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
22437 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22438 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22439 FCKM=VCKM((IA+1)/2,(JA+1)/2)
22444 SIGH(NCHN)=FACWG*FCKM*WIDSC
22448 ELSEIF(ISUB.EQ.19) THEN
22449 C...f + fbar -> gamma + (gamma*/Z0)
22450 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22451 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22455 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22456 DO 170 I=1,MIN(16,MDCY(23,3))
22458 IF(MDME(IDC,1).LT.0) GOTO 170
22460 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22464 AF=SIGN(1D0,EF+0.1D0)
22466 ELSEIF(I.LE.16) THEN
22468 AF=SIGN(1D0,EF+0.1D0)
22471 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22472 IF(4D0*RM1.LT.1D0) THEN
22474 IF(I.LE.8) FCOF=3D0*RADC4
22475 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22477 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22478 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22479 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22480 & AF**2*(1D0-4D0*RM1))*BE34
22484 C...Propagators: as simulated in PYOFSH and as desired
22485 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22489 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22491 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22492 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22493 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22494 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22495 C...Loop over flavours; consider full gamma/Z structure
22496 DO 180 I=MMINA,MMAXA
22497 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
22498 EI=KCHG(IABS(I),1)/3D0
22502 IF(IABS(I).LE.10) FCOI=FACA/3D0
22507 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
22508 & (VI**2+AI**2)*HFZZ)/HBW4
22511 ELSEIF(ISUB.EQ.20) THEN
22512 C...f + fbar' -> gamma + W+/-
22513 FACGW=COMFAC*0.5D0*AEM**2/XW
22514 C...Propagators: as simulated in PYOFSH and as desired
22515 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22516 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22517 GMMWC=SQRT(SQM4)*WDTP(0)
22518 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22519 FACGW=FACGW*HBW4C/HBW4
22520 C...Anomalous couplings
22521 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22524 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
22525 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
22526 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
22527 & (4D0*SQMW))/(TH+UH)**2
22529 DO 200 I=MMIN1,MMAX1
22531 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
22532 DO 190 J=MMIN2,MMAX2
22534 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
22535 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
22536 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22538 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22539 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22541 FACWR=UH/(TH+UH)-1D0/3D0
22542 FCKM=VCKM((IA+1)/2,(JA+1)/2)
22549 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
22554 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
22559 ELSEIF(ISUB.LE.40) THEN
22560 IF(ISUB.EQ.22) THEN
22561 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
22562 C...Kinematics dependence
22563 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
22564 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
22565 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22571 RADC3=1D0+PYALPS(SQM3)/PARU(1)
22572 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22573 DO 230 I=1,MIN(16,MDCY(23,3))
22575 IF(MDME(IDC,1).LT.0) GOTO 230
22577 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
22578 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
22581 AF=SIGN(1D0,EF+0.1D0)
22583 ELSEIF(I.LE.16) THEN
22585 AF=SIGN(1D0,EF+0.1D0)
22588 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
22589 IF(4D0*RM1.LT.1D0) THEN
22591 IF(I.LE.8) FCOF=3D0*RADC3
22592 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22594 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22595 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22596 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
22597 & AF**2*(1D0-4D0*RM1))*BE34
22600 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22601 IF(4D0*RM1.LT.1D0) THEN
22603 IF(I.LE.8) FCOF=3D0*RADC4
22604 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22606 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22607 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22608 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
22609 & AF**2*(1D0-4D0*RM1))*BE34
22613 C...Propagators: as simulated in PYOFSH and as desired
22614 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
22615 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22619 CALL PYWIDT(23,SQM3,WDTP,WDTE)
22621 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22623 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
22624 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
22625 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
22630 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22632 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22634 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
22635 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
22636 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
22638 C...Loop over flavours; separate left- and right-handed couplings
22639 DO 270 I=MMINA,MMAXA
22640 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
22641 EI=KCHG(IABS(I),1)/3D0
22647 IF(IABS(I).LE.10) FCOI=FACA/3D0
22649 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
22650 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
22651 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
22652 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
22654 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
22655 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
22656 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
22657 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
22662 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
22665 ELSEIF(ISUB.EQ.23) THEN
22666 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
22667 FACZW=COMFAC*0.5D0*(AEM/XW)**2
22668 FACZW=FACZW*WIDS(23,2)
22669 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
22670 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
22671 DO 290 I=MMIN1,MMAX1
22673 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
22674 DO 280 J=MMIN2,MMAX2
22676 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
22677 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
22678 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22680 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22682 AI=SIGN(1D0,EI+0.1D0)
22685 AJ=SIGN(1D0,EJ+0.1D0)
22687 IF(VI+AI.GT.0) THEN
22696 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
22698 IF(IA.LE.10) FCOI=FACA/3D0
22703 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
22704 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
22705 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
22706 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
22707 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
22708 & WIDS(24,(5-KCHW)/2)
22709 C***Protect against slightly negative cross sections. (Reason yet to be
22710 C***sorted out. One possibility: addition of width to the W propagator.)
22711 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
22715 ELSEIF(ISUB.EQ.25) THEN
22716 C...f + fbar -> W+ + W-
22717 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
22719 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
22720 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
22721 CALL PYWIDT(24,SQM3,WDTP,WDTE)
22722 GMMW3=SQRT(SQM3)*WDTP(0)
22723 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
22724 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22725 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22726 GMMW4=SQRT(SQM4)*WDTP(0)
22727 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
22728 C...Kinematical functions
22729 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
22730 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
22731 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
22732 GT=THUH34+4D0*THUH/TH2
22733 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
22734 GU=THUH34+4D0*THUH/UH2
22735 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
22736 C...Common factors and couplings
22737 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
22738 FACWW=FACWW*WIDS(24,1)
22740 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
22741 CZZ=AEM**2/(32D0*XW**2)*HBWZC
22742 CNG=AEM**2/(4D0*XW)
22743 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
22744 CNN=AEM**2/(16D0*XW**2)
22745 C...Coulomb factor for W+W- pair
22746 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
22747 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
22748 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
22749 IF(COULE.LT.100D0*PMAS(24,2)) THEN
22750 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
22751 & PMAS(24,2)**2)-COULE))
22753 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
22755 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
22756 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
22757 & PMAS(24,2)**2)+COULE))
22759 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
22762 IF(MSTP(40).EQ.1) THEN
22763 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
22764 & MAX(1D-10,2D0*COULP*COULP1))
22765 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
22766 ELSEIF(MSTP(40).EQ.2) THEN
22767 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
22768 COULCP=DCMPLX(0D0,DBLE(COULP))
22769 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
22770 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
22771 & (4D0*COULCP)*LOG(COULCD)
22772 COULCS=DCMPLX(0D0,0D0)
22775 COULXX=(ISTP-0.5)/NSTP
22776 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
22777 & (1D0+COULXX/COULCD))
22779 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
22781 FACCOU=ABS(COULCR)**2
22782 ELSEIF(MSTP(40).EQ.3) THEN
22783 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
22784 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
22785 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
22787 ELSEIF(MSTP(40).EQ.4) THEN
22788 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
22794 C...Loop over allowed flavours
22795 DO 310 I=MMINA,MMAXA
22796 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
22797 EI=KCHG(IABS(I),1)/3D0
22798 AI=SIGN(1D0,EI+0.1D0)
22801 IF(IABS(I).LE.10) FCOI=FACA/3D0
22802 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
22804 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
22805 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
22807 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
22808 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
22811 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22812 BET=SQRT(1D0-4D0*XMW02/SH)
22813 GAT=1D0/SQRT(1D0-BET**2)
22815 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
22816 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
22817 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
22818 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
22819 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
22820 & (1D0-2D0*BET*CTH+BET**2))
22821 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
22822 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
22823 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
22824 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
22825 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
22826 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
22827 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
22834 SIGH(NCHN)=FACWW*FCOI*DSIGWW
22837 ELSEIF(ISUB.EQ.30) THEN
22838 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
22839 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
22841 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22845 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22846 DO 320 I=1,MIN(16,MDCY(23,3))
22848 IF(MDME(IDC,1).LT.0) GOTO 320
22850 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22854 AF=SIGN(1D0,EF+0.1D0)
22856 ELSEIF(I.LE.16) THEN
22858 AF=SIGN(1D0,EF+0.1D0)
22861 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22862 IF(4D0*RM1.LT.1D0) THEN
22864 IF(I.LE.8) FCOF=3D0*RADC4
22865 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22867 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22868 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22869 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22870 & AF**2*(1D0-4D0*RM1))*BE34
22874 C...Propagators: as simulated in PYOFSH and as desired
22875 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22879 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22881 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22882 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22883 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22884 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22885 C...Loop over flavours; consider full gamma/Z structure
22886 DO 340 I=MMINA,MMAXA
22887 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
22888 EI=KCHG(IABS(I),1)/3D0
22891 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
22892 & (VI**2+AI**2)*HFZZ)/HBW4
22894 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
22895 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
22898 ISIG(NCHN,3-ISDE)=21
22904 ELSEIF(ISUB.EQ.31) THEN
22905 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
22906 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
22907 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
22908 C...Propagators: as simulated in PYOFSH and as desired
22909 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22910 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22911 GMMWC=SQRT(SQM4)*WDTP(0)
22912 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22913 FACWQ=FACWQ*HBW4C/HBW4
22914 DO 360 I=MMINA,MMAXA
22915 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
22917 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22918 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22920 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
22921 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
22924 ISIG(NCHN,3-ISDE)=21
22926 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
22930 ELSEIF(ISUB.EQ.35) THEN
22931 C...f + gamma -> f + (gamma*/Z0)
22932 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
22933 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
22934 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
22935 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
22936 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
22937 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
22939 FZQN=SH2+UH2+2D0*SQM4*TH
22942 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
22943 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22947 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22948 DO 370 I=1,MIN(16,MDCY(23,3))
22950 IF(MDME(IDC,1).LT.0) GOTO 370
22952 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22956 AF=SIGN(1D0,EF+0.1D0)
22958 ELSEIF(I.LE.16) THEN
22960 AF=SIGN(1D0,EF+0.1D0)
22963 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22964 IF(4D0*RM1.LT.1D0) THEN
22966 IF(I.LE.8) FCOF=3D0*RADC4
22967 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22969 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22970 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22971 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22972 & AF**2*(1D0-4D0*RM1))*BE34
22976 C...Propagators: as simulated in PYOFSH and as desired
22977 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22981 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22983 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22984 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22985 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22986 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22987 C...Loop over flavours; consider full gamma/Z structure
22988 DO 390 I=MMINA,MMAXA
22989 IF(I.EQ.0) GOTO 390
22990 EI=KCHG(IABS(I),1)/3D0
22993 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
22994 & (VI**2+AI**2)*HFZZ)/HBW4
22995 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
22997 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
22998 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
23001 ISIG(NCHN,3-ISDE)=22
23003 SIGH(NCHN)=FACZQ*FZQN/FZQD
23007 ELSEIF(ISUB.EQ.36) THEN
23008 C...f + gamma -> f' + W+/-
23009 FWQ=COMFAC*AEM**2/(2D0*XW)*
23010 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
23011 C...Propagators: as simulated in PYOFSH and as desired
23012 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
23013 CALL PYWIDT(24,SQM4,WDTP,WDTE)
23014 GMMWC=SQRT(SQM4)*WDTP(0)
23015 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
23017 DO 410 I=MMINA,MMAXA
23018 IF(I.EQ.0) GOTO 410
23020 EIA=ABS(KCHG(IABS(I),1)/3D0)
23021 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
23022 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
23023 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
23025 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
23026 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
23029 ISIG(NCHN,3-ISDE)=22
23031 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
23036 ELSEIF(ISUB.LE.100) THEN
23037 IF(ISUB.EQ.69) THEN
23038 C...gamma + gamma -> W+ + W-
23039 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
23040 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
23041 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
23042 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
23043 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
23051 ELSEIF(ISUB.EQ.70) THEN
23052 C...gamma + W+/- -> Z0 + W+/-
23053 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
23054 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
23055 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
23056 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
23057 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
23058 DO 440 KCHW=1,-1,-2
23060 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
23063 ISIG(NCHN,3-ISDE)=24*KCHW
23065 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
23074 C*********************************************************************
23077 C...Subprocess cross sections for Higgs processes,
23078 C...except Higgs pairs in PYSGSU, but including WW scattering.
23079 C...Auxiliary to PYSIGH.
23081 SUBROUTINE PYSGHG(NCHN,SIGS)
23083 C...Double precision and integer declarations
23084 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23085 IMPLICIT INTEGER(I-N)
23086 INTEGER PYK,PYCHGE,PYCOMP
23087 C...Parameter statement to help give large particle numbers.
23088 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23089 &KEXCIT=4000000,KDIMEN=5000000)
23091 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23092 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23093 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23094 COMMON/PYINT1/MINT(400),VINT(400)
23095 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
23096 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
23097 COMMON/PYINT4/MWID(500),WIDS(500,5)
23098 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23099 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
23100 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
23101 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
23102 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
23103 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
23104 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
23105 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
23106 C...Local arrays and complex variables
23107 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
23108 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
23109 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
23111 C...Convert H or A process into equivalent h one
23114 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
23115 &ISUB.LE.190)) THEN
23117 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
23119 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
23120 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
23121 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
23122 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
23123 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
23124 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
23125 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
23126 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
23127 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
23128 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
23129 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
23130 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
23132 SQMH=PMAS(KFHIGG,1)**2
23133 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
23135 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23136 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
23137 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
23138 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
23139 IF(MSTP(46).LE.4) THEN
23140 HDTLH=LOG(PMAS(25,1)/PARP(44))
23141 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
23142 HDTNR=-1D0/18D0+HDTLH/6D0
23144 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
23145 HDTLQ=LOG(PARP(45)/PARP(44))
23146 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
23147 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
23150 C...Calculate lowest and next-to-lowest order partial wave amplitudes
23151 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
23155 HDTLS=LOG(SH/PARP(44)**2)
23156 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
23157 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
23158 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
23159 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
23160 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
23161 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
23162 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
23163 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
23165 C...Unitarize partial wave amplitudes with Pade or K-matrix method
23166 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
23167 A00U=A00L/(1D0-A004/A00L)
23168 A20U=A20L/(1D0-A204/A20L)
23169 A11U=A11L/(1D0-A114/A11L)
23171 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
23172 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
23173 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
23177 C...Differential cross section expressions.
23179 IF(ISUB.LE.60) THEN
23181 C...f + fbar -> h0 (or H0, or A0)
23182 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23184 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23185 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23187 HP=AEM/(8D0*XW)*SH/SQMW*SH
23188 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23189 DO 100 I=MMINA,MMAXA
23190 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
23192 RMQ=PYMRUN(IA,SH)**2/SH
23194 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
23195 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
23197 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
23198 IF(IA.GT.10) IKFI=3
23199 HI=HI*PARU(150+10*IHIGG+IKFI)**2
23200 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
23201 HI=HI/(1D0+RMSS(41))**2
23202 IF(IHIGG.NE.3) THEN
23203 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
23204 & PARU(151+10*IHIGG))**2
23212 SIGH(NCHN)=HI*FACBW*HF
23215 ELSEIF(ISUB.EQ.5) THEN
23217 CALL PYWIDT(25,SH,WDTP,WDTE)
23219 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23220 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
23221 HP=AEM/(8D0*XW)*SH/SQMW*SH
23222 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23224 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
23225 DO 120 I=MMIN1,MMAX1
23226 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
23227 DO 110 J=MMIN2,MMAX2
23228 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
23229 EI=KCHG(IABS(I),1)/3D0
23232 EJ=KCHG(IABS(J),1)/3D0
23239 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
23243 ELSEIF(ISUB.EQ.8) THEN
23245 CALL PYWIDT(25,SH,WDTP,WDTE)
23247 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23248 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
23249 HP=AEM/(8D0*XW)*SH/SQMW*SH
23250 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23252 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
23253 DO 140 I=MMIN1,MMAX1
23254 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
23255 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23256 DO 130 J=MMIN2,MMAX2
23257 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
23258 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23259 IF(EI*EJ.GT.0D0) GOTO 130
23264 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
23268 ELSEIF(ISUB.EQ.24) THEN
23269 C...f + fbar -> Z0 + h0 (or H0, or A0)
23270 C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
23271 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
23272 CALL PYWIDT(23,SQM3,WDTP,WDTE)
23273 GMMZ3=SQRT(SQM3)*WDTP(0)
23274 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
23275 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23276 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23277 GMMH4=SQRT(SQM4)*WDTP(0)
23278 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
23279 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
23280 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
23281 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
23282 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
23283 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
23284 & PARU(154+10*IHIGG)**2
23285 DO 150 I=MMINA,MMAXA
23286 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
23287 EI=KCHG(IABS(I),1)/3D0
23291 IF(IABS(I).LE.10) FCOI=FACA/3D0
23296 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
23299 ELSEIF(ISUB.EQ.26) THEN
23300 C...f + fbar' -> W+/- + h0 (or H0, or A0)
23301 C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
23302 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
23303 CALL PYWIDT(24,SQM3,WDTP,WDTE)
23304 GMMW3=SQRT(SQM3)*WDTP(0)
23305 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
23306 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23307 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23308 GMMH4=SQRT(SQM4)*WDTP(0)
23309 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
23310 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
23311 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
23312 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
23313 FACHW=FACHW*WIDS(KFHIGG,2)
23314 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
23315 & PARU(155+10*IHIGG)**2
23316 DO 170 I=MMIN1,MMAX1
23318 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
23319 DO 160 J=MMIN2,MMAX2
23321 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
23322 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
23323 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
23325 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
23327 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
23329 IF(IA.LE.10) FCOI=FACA/3D0
23334 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
23338 ELSEIF(ISUB.EQ.32) THEN
23339 C...f + g -> f + h0 (q + g -> q + h0 only)
23340 SQMHC=PMAS(25,1)**2
23341 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
23342 DO 190 I=MMINA,MMAXA
23344 IF(IA.NE.5) GOTO 190
23346 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
23347 & (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
23348 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
23351 FACHCQ=FHCQ*SQML/SQMW*
23352 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
23353 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
23354 & (SQMHC-SQMQ-SH)/SH)
23355 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
23357 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
23358 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 180
23361 ISIG(NCHN,3-ISDE)=21
23363 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
23368 ELSEIF(ISUB.LE.80) THEN
23369 IF(ISUB.EQ.71) THEN
23370 C...Z0 + Z0 -> Z0 + Z0
23371 IF(SH.LE.4.01D0*SQMZ) GOTO 220
23373 IF(MSTP(46).LE.2) THEN
23374 C...Exact scattering ME:s for on-mass-shell gauge bosons
23375 BE2=1D0-4D0*SQMZ/SH
23376 TH=-0.5D0*SH*BE2*(1D0-CTH)
23377 UH=-0.5D0*SH*BE2*(1D0+CTH)
23378 IF(MAX(TH,UH).GT.-1D0) GOTO 220
23379 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
23380 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23381 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23382 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
23383 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
23384 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
23385 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
23386 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
23387 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
23388 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
23389 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
23390 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
23391 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
23392 & (ASHIM+ATHIM+AUHIM)**2)
23393 IF(MSTP(46).EQ.2) FACZZ=0D0
23396 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23397 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
23398 & ABS(A00U+2D0*A20U)**2
23400 FACZZ=FACZZ*WIDS(23,1)
23402 DO 210 I=MMIN1,MMAX1
23403 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
23404 EI=KCHG(IABS(I),1)/3D0
23408 DO 200 J=MMIN2,MMAX2
23409 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
23410 EJ=KCHG(IABS(J),1)/3D0
23418 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
23423 ELSEIF(ISUB.EQ.72) THEN
23424 C...Z0 + Z0 -> W+ + W-
23425 IF(SH.LE.4.01D0*SQMZ) GOTO 250
23427 IF(MSTP(46).LE.2) THEN
23428 C...Exact scattering ME:s for on-mass-shell gauge bosons
23429 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
23431 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
23432 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
23433 IF(MAX(TH,UH).GT.-1D0) GOTO 250
23434 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
23435 & (1D0-2D0*SQMZ/SH)
23436 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23437 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23438 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
23439 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23440 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23441 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
23442 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23444 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
23445 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23446 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23447 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
23448 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23450 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
23452 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
23453 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
23454 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
23455 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
23456 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
23457 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
23458 & (ATWIM+AUWIM+A4IM)**2)
23461 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23462 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
23463 & ABS(A00U-A20U)**2
23465 FACWW=FACWW*WIDS(24,1)
23467 DO 240 I=MMIN1,MMAX1
23468 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
23469 EI=KCHG(IABS(I),1)/3D0
23473 DO 230 J=MMIN2,MMAX2
23474 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
23475 EJ=KCHG(IABS(J),1)/3D0
23483 SIGH(NCHN)=FACWW*AVI*AVJ
23488 ELSEIF(ISUB.EQ.73) THEN
23489 C...Z0 + W+/- -> Z0 + W+/-
23490 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
23492 IF(MSTP(46).LE.2) THEN
23493 C...Exact scattering ME:s for on-mass-shell gauge bosons
23494 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
23495 EP1=1D0-(SQMZ-SQMW)/SH
23496 EP2=1D0+(SQMZ-SQMW)/SH
23497 TH=-0.5D0*SH*BE2*(1D0-CTH)
23498 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
23499 IF(MAX(TH,UH).GT.-1D0) GOTO 280
23500 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
23501 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
23502 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
23503 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
23504 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
23505 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
23506 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
23508 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
23509 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
23510 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
23511 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
23512 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
23513 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
23514 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
23515 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
23516 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
23517 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
23518 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
23519 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
23521 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
23522 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
23524 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
23525 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
23526 IF(MSTP(46).LE.0) FACZW=0D0
23527 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
23528 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
23529 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
23530 & (ASWIM+AUWIM+A4IM)**2)
23533 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23534 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
23535 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
23537 FACZW=FACZW*WIDS(23,2)
23539 DO 270 I=MMIN1,MMAX1
23540 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
23541 EI=KCHG(IABS(I),1)/3D0
23545 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
23546 DO 260 J=MMIN2,MMAX2
23547 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
23548 EJ=KCHG(IABS(J),1)/3D0
23552 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
23557 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
23562 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
23567 ELSEIF(ISUB.EQ.75) THEN
23568 C...W+ + W- -> gamma + gamma
23570 ELSEIF(ISUB.EQ.76) THEN
23571 C...W+ + W- -> Z0 + Z0
23572 IF(SH.LE.4.01D0*SQMZ) GOTO 310
23574 IF(MSTP(46).LE.2) THEN
23575 C...Exact scattering ME:s for on-mass-shell gauge bosons
23576 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
23578 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
23579 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
23580 IF(MAX(TH,UH).GT.-1D0) GOTO 310
23581 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
23582 & (1D0-2D0*SQMZ/SH)
23583 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23584 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23585 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
23586 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23587 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23588 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
23589 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23591 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
23592 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23593 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23594 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
23595 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23597 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
23599 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
23601 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
23602 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
23603 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
23604 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
23605 & (ATWIM+AUWIM+A4IM)**2)
23608 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23609 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
23610 & ABS(A00U-A20U)**2
23612 FACZZ=FACZZ*WIDS(23,1)
23614 DO 300 I=MMIN1,MMAX1
23615 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
23616 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23617 DO 290 J=MMIN2,MMAX2
23618 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
23619 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23620 IF(EI*EJ.GT.0D0) GOTO 290
23625 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
23630 ELSEIF(ISUB.EQ.77) THEN
23631 C...W+/- + W+/- -> W+/- + W+/-
23632 IF(SH.LE.4.01D0*SQMW) GOTO 340
23634 IF(MSTP(46).LE.2) THEN
23635 C...Exact scattering ME:s for on-mass-shell gauge bosons
23636 BE2=1D0-4D0*SQMW/SH
23640 TH=-0.5D0*SH*BE2*(1D0-CTH)
23641 UH=-0.5D0*SH*BE2*(1D0+CTH)
23642 IF(MAX(TH,UH).GT.-1D0) GOTO 340
23644 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23645 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23647 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
23648 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
23650 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
23651 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
23652 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
23655 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
23657 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
23658 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
23659 ATGRE=0.5D0*XW*SH/TH*TGZANG
23661 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
23663 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
23664 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
23665 AUGRE=0.5D0*XW*SH/UH*UGZANG
23667 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
23669 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
23671 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
23673 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
23675 IF(MSTP(46).LE.0) THEN
23680 ELSEIF(MSTP(46).EQ.1) THEN
23681 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23682 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23683 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23684 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23686 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23687 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23688 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23689 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23691 AWWA2=AWWARE**2+AWWAIM**2
23692 AWWS2=AWWSRE**2+AWWSIM**2
23695 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23696 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
23697 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
23698 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
23701 DO 330 I=MMIN1,MMAX1
23702 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
23703 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23704 DO 320 J=MMIN2,MMAX2
23705 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
23706 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23707 IF(EI*EJ.LT.0D0) THEN
23709 IF(MSTP(45).EQ.1) GOTO 320
23710 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
23711 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
23714 IF(MSTP(45).EQ.2) GOTO 320
23715 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
23716 IF(MSTP(46).GE.3) FACWW=FWWS
23717 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
23718 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
23724 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
23725 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
23731 ELSEIF(ISUB.LE.120) THEN
23732 IF(ISUB.EQ.102) THEN
23733 C...g + g -> h0 (or H0, or A0)
23734 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23736 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23737 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23738 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23740 HI=SHR*WDTP(13)/32D0
23741 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
23746 SIGH(NCHN)=HI*FACBW*HF
23749 ELSEIF(ISUB.EQ.103) THEN
23750 C...gamma + gamma -> h0 (or H0, or A0)
23751 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23753 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23754 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23755 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23757 HI=SHR*WDTP(14)*2D0
23758 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
23763 SIGH(NCHN)=HI*FACBW*HF
23766 ELSEIF(ISUB.EQ.110) THEN
23767 C...f + fbar -> gamma + h0
23768 THUH=MAX(TH*UH,SH*CKIN(3)**2)
23769 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
23770 FACHG=FACHG*WIDS(KFHIGG,2)
23771 C...Calculate loop contributions for intermediate gamma* and Z0
23772 CIGTOT=DCMPLX(0D0,0D0)
23773 CIZTOT=DCMPLX(0D0,0D0)
23776 IF(J.LE.2*MSTP(1)) THEN
23779 AJ=SIGN(1D0,EJ+0.1D0)
23781 BALP=SQM4/(2D0*PMAS(J,1))**2
23782 BBET=SH/(2D0*PMAS(J,1))**2
23783 ELSEIF(J.LE.3*MSTP(1)) THEN
23785 JL=2*(J-2*MSTP(1))-1
23786 EJ=KCHG(10+JL,1)/3D0
23787 AJ=SIGN(1D0,EJ+0.1D0)
23789 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
23790 BBET=SH/(2D0*PMAS(10+JL,1))**2
23792 BALP=SQM4/(2D0*PMAS(24,1))**2
23793 BBET=SH/(2D0*PMAS(24,1))**2
23795 BABI=1D0/(BALP-BBET)
23796 IF(BALP.LT.1D0) THEN
23797 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
23800 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
23801 & -DBLE(0.5D0*PARU(1)))
23804 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
23805 IF(BBET.LT.1D0) THEN
23806 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
23809 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
23810 & -DBLE(0.5D0*PARU(1)))
23813 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
23814 IF(J.LE.3*MSTP(1)) THEN
23815 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
23816 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
23817 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
23818 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
23821 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
23822 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
23823 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
23824 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
23825 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
23826 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
23830 CIGTOT=CIGTOT/DBLE(SH)
23831 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
23832 C...Loop over initial flavours
23833 DO 380 I=MMINA,MMAXA
23834 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
23835 EI=KCHG(IABS(I),1)/3D0
23839 IF(IABS(I).LE.10) FCOI=FACA/3D0
23844 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
23845 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
23848 ELSEIF(ISUB.EQ.111) THEN
23849 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
23850 IF(MSTP(38).NE.0) THEN
23851 C...Simple case: only do gg <-> h exactly.
23852 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23853 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
23854 & (TH**2+UH**2)/(SH*SQM4)
23855 C...Propagators: as simulated in PYOFSH and as desired
23856 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23857 GMMHC=SQRT(SQM4)*WDTP(0)
23858 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23859 & ((SQM4-SQMH)**2+GMMHC**2)
23860 FACGH=FACGH*HBW4C/HBW4
23862 C...Messy case: do full loop integrals
23865 DO 390 I=1,2*MSTP(1)
23869 CALL PYWAUX(1,EPSS,W1SR,W1SI)
23870 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23871 CALL PYWAUX(2,EPSS,W2SR,W2SI)
23872 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23873 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
23874 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
23875 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
23876 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
23878 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23879 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
23880 FACGH=FACGH*WIDS(25,2)
23882 DO 400 I=MMINA,MMAXA
23883 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
23884 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
23892 ELSEIF(ISUB.EQ.112) THEN
23893 C...f + g -> f + h0 (q + g -> q + h0 only)
23894 IF(MSTP(38).NE.0) THEN
23895 C...Simple case: only do gg <-> h exactly.
23896 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23897 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
23898 & (SH**2+UH**2)/(-TH*SQM4)
23899 C...Propagators: as simulated in PYOFSH and as desired
23900 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23901 GMMHC=SQRT(SQM4)*WDTP(0)
23902 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23903 & ((SQM4-SQMH)**2+GMMHC**2)
23904 FACQH=FACQH*HBW4C/HBW4
23906 C...Messy case: do full loop integrals
23909 DO 410 I=1,2*MSTP(1)
23913 CALL PYWAUX(1,EPST,W1TR,W1TI)
23914 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23915 CALL PYWAUX(2,EPST,W2TR,W2TI)
23916 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23917 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
23918 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
23919 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
23920 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
23922 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23923 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
23924 FACQH=FACQH*WIDS(25,2)
23926 DO 430 I=MMINA,MMAXA
23927 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
23929 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
23930 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
23933 ISIG(NCHN,3-ISDE)=21
23939 ELSEIF(ISUB.EQ.113) THEN
23940 C...g + g -> g + h0
23941 IF(MSTP(38).NE.0) THEN
23942 C...Simple case: only do gg <-> h exactly.
23943 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23944 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
23945 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
23946 C...Propagators: as simulated in PYOFSH and as desired
23947 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23948 GMMHC=SQRT(SQM4)*WDTP(0)
23949 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23950 & ((SQM4-SQMH)**2+GMMHC**2)
23951 FACGH=FACGH*HBW4C/HBW4
23953 C...Messy case: do full loop integrals
23962 DO 440 I=1,2*MSTP(1)
23968 IF(EPSH.LT.1D-6) GOTO 440
23969 CALL PYWAUX(1,EPSS,W1SR,W1SI)
23970 CALL PYWAUX(1,EPST,W1TR,W1TI)
23971 CALL PYWAUX(1,EPSU,W1UR,W1UI)
23972 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23973 CALL PYWAUX(2,EPSS,W2SR,W2SI)
23974 CALL PYWAUX(2,EPST,W2TR,W2TI)
23975 CALL PYWAUX(2,EPSU,W2UR,W2UI)
23976 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23977 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
23978 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
23979 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
23980 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
23981 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
23982 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
23983 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
23984 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
23985 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
23986 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
23987 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
23988 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
23989 W3STUR=YHSTUR-Y3STUR-Y3UTSR
23990 W3STUI=YHSTUI-Y3STUI-Y3UTSI
23991 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
23992 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
23993 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
23994 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
23995 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
23996 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
23997 W3USTR=YHUSTR-Y3USTR-Y3TSUR
23998 W3USTI=YHUSTI-Y3USTI-Y3TSUI
23999 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
24000 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
24001 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
24002 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
24003 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
24004 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
24005 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
24006 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
24007 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
24008 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
24009 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
24010 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
24011 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
24012 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
24013 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
24014 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
24015 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
24016 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
24017 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
24018 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
24019 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
24020 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
24021 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
24022 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
24023 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
24024 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
24025 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
24026 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
24027 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
24028 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
24029 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
24030 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
24031 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
24032 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
24033 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
24034 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
24035 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
24036 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
24037 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
24038 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
24039 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
24040 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
24041 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
24042 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
24043 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
24044 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
24045 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
24046 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
24047 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
24048 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
24049 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
24050 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
24051 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
24052 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
24053 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
24054 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
24055 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
24056 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
24057 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
24058 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
24059 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
24060 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
24061 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24062 & (W2SR-W2HR+W3STUR))
24063 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
24064 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24065 & (W2TR-W2HR+W3TUSR))
24066 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
24067 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24068 & (W2UR-W2HR+W3USTR))
24069 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
24070 A2STUR=A2STUR+B2STUR+B2SUTR
24071 A2STUI=A2STUI+B2STUI+B2SUTI
24072 A2USTR=A2USTR+B2USTR+B2UTSR
24073 A2USTI=A2USTI+B2USTI+B2UTSI
24074 A2TUSR=A2TUSR+B2TUSR+B2TSUR
24075 A2TUSI=A2TUSI+B2TUSI+B2TSUI
24076 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
24077 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
24079 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
24080 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
24081 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
24082 FACGH=FACGH*WIDS(25,2)
24084 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
24093 ELSEIF(ISUB.LE.170) THEN
24094 IF(ISUB.EQ.121) THEN
24095 C...g + g -> Q + Qbar + h0
24096 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
24099 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24100 & (0.5D0*PMF/PMAS(24,1))**2
24102 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24104 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24106 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24107 IF(IA.GT.10) IKFI=3
24108 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24109 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24110 FACQQH=FACQQH/(1D0+RMSS(41))**2
24111 IF(IHIGG.NE.3) THEN
24112 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24113 & PARU(151+10*IHIGG))**2
24117 CALL PYQQBH(WTQQBH)
24118 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24120 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24121 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24122 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24128 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24131 ELSEIF(ISUB.EQ.122) THEN
24132 C...q + qbar -> Q + Qbar + h0
24135 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24136 & (0.5D0*PMF/PMAS(24,1))**2
24138 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24140 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24142 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24143 IF(IA.GT.10) IKFI=3
24144 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24145 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24146 FACQQH=FACQQH/(1D0+RMSS(41))**2
24147 IF(IHIGG.NE.3) THEN
24148 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24149 & PARU(151+10*IHIGG))**2
24153 CALL PYQQBH(WTQQBH)
24154 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24156 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24157 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24158 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24160 DO 470 I=MMINA,MMAXA
24161 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
24162 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
24167 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24170 ELSEIF(ISUB.EQ.123) THEN
24171 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
24173 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
24174 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24175 & PARU(154+10*IHIGG)**2
24176 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24177 & (VINT(216)-VINT(209)**2))**2
24178 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24179 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
24180 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24182 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24183 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24184 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24186 DO 490 I=MMIN1,MMAX1
24187 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
24189 DO 480 J=MMIN2,MMAX2
24190 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
24192 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
24193 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
24195 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
24196 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
24198 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
24199 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
24204 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
24208 ELSEIF(ISUB.EQ.124) THEN
24209 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
24211 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
24212 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24213 & PARU(155+10*IHIGG)**2
24214 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24215 & (VINT(216)-VINT(209)**2))**2
24216 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24217 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24219 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24220 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24221 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24223 DO 510 I=MMIN1,MMAX1
24224 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
24225 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
24226 DO 500 J=MMIN2,MMAX2
24227 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
24228 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
24229 IF(EI*EJ.GT.0D0) GOTO 500
24230 FACLR=VINT(180+I)*VINT(180+J)
24235 SIGH(NCHN)=FACLR*FACWW*FACBW
24239 ELSEIF(ISUB.EQ.143) THEN
24240 C...f + fbar' -> H+/-
24241 SQMHC=PMAS(37,1)**2
24242 CALL PYWIDT(37,SH,WDTP,WDTE)
24244 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
24245 HP=AEM/(8D0*XW)*SH/SQMW*SH
24246 DO 530 I=MMIN1,MMAX1
24247 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
24249 IM=(MOD(IA,10)+1)/2
24250 DO 520 J=MMIN2,MMAX2
24251 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
24253 JM=(MOD(JA,10)+1)/2
24254 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
24255 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24257 IF(MOD(IA,2).EQ.0) THEN
24264 RML=PYMRUN(IL,SH)**2/SH
24265 RMU=PYMRUN(IU,SH)**2/SH
24266 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
24267 IF(IA.LE.10) HI=HI*FACA/3D0
24268 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24269 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
24274 SIGH(NCHN)=HI*FACBW*HF
24278 ELSEIF(ISUB.EQ.161) THEN
24279 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
24280 C...(choice of only b and t to avoid kinematics problems)
24281 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
24282 C...H propagator: as simulated in PYOFSH and as desired
24283 SQMHC=PMAS(37,1)**2
24284 GMMHC=PMAS(37,1)*PMAS(37,2)
24285 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
24286 CALL PYWIDT(37,SQM4,WDTP,WDTE)
24287 GMMHCC=SQRT(SQM4)*WDTP(0)
24288 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
24289 FHCQ=FHCQ*HBW4C/HBW4
24290 DO 550 I=MMINA,MMAXA
24292 IF(IA.NE.5) GOTO 550
24293 SQML=PYMRUN(IA,SH)**2
24295 SQMQ=PYMRUN(IUA,SH)**2
24296 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
24297 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
24298 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
24299 & (SQMHC-SQMQ-SH)/SH)
24300 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
24302 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
24303 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 540
24306 ISIG(NCHN,3-ISDE)=21
24308 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
24317 C*********************************************************************
24320 C...Subprocess cross sections for SUSY processes,
24321 C...including Higgs pair production.
24322 C...Auxiliary to PYSIGH.
24324 SUBROUTINE PYSGSU(NCHN,SIGS)
24326 C...Double precision and integer declarations
24327 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24328 IMPLICIT INTEGER(I-N)
24329 INTEGER PYK,PYCHGE,PYCOMP
24330 C...Parameter statement to help give large particle numbers.
24331 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24332 &KEXCIT=4000000,KDIMEN=5000000)
24334 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24335 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24336 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24337 COMMON/PYINT1/MINT(400),VINT(400)
24338 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24339 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
24340 COMMON/PYINT4/MWID(500),WIDS(500,5)
24341 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24342 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24343 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
24344 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
24345 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
24346 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
24347 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
24348 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
24349 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
24350 C...Local arrays and complex variables
24351 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
24352 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
24353 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
24354 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
24357 C...Z and W width, combinations of weak mixing angle
24361 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
24363 C...Convert almost equivalent SUSY processes into each other
24364 C...Extract differences in flavours and couplings
24366 C...Sleptons and sneutrinos
24367 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
24368 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24371 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
24372 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24375 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
24376 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24378 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
24379 IF(ISUB.EQ.210) THEN
24381 ELSEIF(ISUB.EQ.211) THEN
24383 ELSEIF(ISUB.EQ.212) THEN
24387 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
24388 IF(ISUB.EQ.213) THEN
24389 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24391 ELSEIF(ISUB.EQ.214) THEN
24398 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
24399 IF(ISUB.EQ.216) THEN
24402 ELSEIF(ISUB.EQ.217) THEN
24405 ELSEIF(ISUB.EQ.218) THEN
24408 ELSEIF(ISUB.EQ.219) THEN
24411 ELSEIF(ISUB.EQ.220) THEN
24414 ELSEIF(ISUB.EQ.221) THEN
24417 ELSEIF(ISUB.EQ.222) THEN
24420 ELSEIF(ISUB.EQ.223) THEN
24423 ELSEIF(ISUB.EQ.224) THEN
24426 ELSEIF(ISUB.EQ.225) THEN
24433 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
24434 IF(ISUB.EQ.226) THEN
24437 ELSEIF(ISUB.EQ.227) THEN
24440 ELSEIF(ISUB.EQ.228) THEN
24446 C...Neutralino + chargino
24447 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
24448 IF(ISUB.EQ.229) THEN
24451 ELSEIF(ISUB.EQ.230) THEN
24454 ELSEIF(ISUB.EQ.231) THEN
24457 ELSEIF(ISUB.EQ.232) THEN
24460 ELSEIF(ISUB.EQ.233) THEN
24463 ELSEIF(ISUB.EQ.234) THEN
24466 ELSEIF(ISUB.EQ.235) THEN
24469 ELSEIF(ISUB.EQ.236) THEN
24475 C...Gluino + neutralino
24476 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
24477 IF(ISUB.EQ.237) THEN
24479 ELSEIF(ISUB.EQ.238) THEN
24481 ELSEIF(ISUB.EQ.239) THEN
24483 ELSEIF(ISUB.EQ.240) THEN
24488 C...Gluino + chargino
24489 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
24490 IF(ISUB.EQ.241) THEN
24492 ELSEIF(ISUB.EQ.242) THEN
24497 C...Squark + neutralino
24498 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
24500 IF(MOD(ISUB,2).NE.0) ILR=1
24501 IF(ISUB.LE.247) THEN
24503 ELSEIF(ISUB.LE.249) THEN
24505 ELSEIF(ISUB.LE.251) THEN
24507 ELSEIF(ISUB.LE.253) THEN
24513 C...Squark + chargino
24514 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
24515 IF(ISUB.LE.255) THEN
24517 ELSEIF(ISUB.LE.257) THEN
24520 IF(MOD(ISUB,2).EQ.0) THEN
24528 C...Squark + gluino
24529 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
24534 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
24536 IF(ISUB.EQ.262) ILR=1
24538 ELSEIF(ISUB.EQ.265) THEN
24542 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
24544 IF(ISUB.LE.273) THEN
24545 IF(ISUB.EQ.273) ILR=1
24548 ELSEIF(ISUB.LE.276) THEN
24549 IF(ISUB.EQ.276) ILR=1
24552 ELSEIF(ISUB.LE.278) THEN
24553 IF(ISUB.EQ.278) ILR=1
24557 IF(ISUB.EQ.280) ILR=1
24562 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
24564 IF(ISUB.LE.283) THEN
24565 IF(ISUB.EQ.283) ILR=1
24568 ELSEIF(ISUB.LE.286) THEN
24569 IF(ISUB.EQ.286) ILR=1
24572 ELSEIF(ISUB.LE.288) THEN
24573 IF(ISUB.EQ.288) ILR=1
24576 ELSEIF(ISUB.LE.290) THEN
24577 IF(ISUB.EQ.290) ILR=1
24580 ELSEIF(ISUB.LE.293) THEN
24581 IF(ISUB.EQ.293) ILR=1
24584 ELSEIF(ISUB.EQ.296) THEN
24588 C...Squark + gluino
24589 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
24594 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
24595 IF(ISUB.EQ.297) THEN
24596 RKF=.5D0*PARU(195)**2
24597 ELSEIF(ISUB.EQ.298) THEN
24598 RKF=.5D0*(1D0-PARU(195)**2)
24602 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
24603 IF(ISUB.EQ.299) THEN
24606 ELSEIF(ISUB.EQ.300) THEN
24612 ELSEIF(ISUB.EQ.301) THEN
24618 C...Supersymmetric processes - all of type 2 -> 2 :
24619 C...correct final-state Breit-Wigners from fixed to running width.
24620 IF(MSTP(42).GT.0) THEN
24622 KFLW=KFPR(ISUBSV,I)
24624 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
24625 IF(I.EQ.1) SQMI=SQM3
24626 IF(I.EQ.2) SQMI=SQM4
24627 SQMS=PMAS(KCW,1)**2
24628 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
24629 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
24630 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
24631 GMMI=SQRT(SQMI)*WDTP(0)
24632 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
24633 COMFAC=COMFAC*(HBWI/HBWS)
24637 C...Differential cross section expressions.
24639 IF(ISUB.LE.210) THEN
24640 IF(ISUB.EQ.201) THEN
24641 C...f + fbar -> e_L + e_Lbar
24642 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24643 DO 130 I=MMIN1,MMAX1
24645 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
24647 TT3I=SIGN(1D0,EI+1D-6)/2D0
24651 C...Color factor for e+ e-
24652 IF(IA.GE.11) FCOL=3D0
24653 IF(ISUBSV.EQ.301) THEN
24656 ELSEIF(ILR.EQ.1) THEN
24657 A1=SFMIX(KFID,3)**2
24658 A2=SFMIX(KFID,4)**2
24659 ELSEIF(ILR.EQ.0) THEN
24660 A1=SFMIX(KFID,1)**2
24661 A2=SFMIX(KFID,2)**2
24663 XLQ=(TT3J-EJ*XW)*A1
24667 TAA=(EI*EJ)**2*(POLL+POLR)
24668 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
24669 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
24670 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
24671 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
24675 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
24681 DK=1D0/(TH-SMZ(II)**2)
24682 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
24684 FREK=FAC2*TANW*EI*ZMIX(II,1)
24685 TNN1=TNN1+FLEK**2*DK
24686 TNN2=TNN2+FREK**2*DK
24688 DL=1D0/(TH-SMZ(JJ)**2)
24689 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
24691 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
24692 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
24695 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
24696 & A2**2*TNN2**2*POLR)
24697 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
24698 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
24699 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
24700 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
24701 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
24704 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
24707 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
24708 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
24709 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
24714 SIGH(NCHN)=FACQQ1+FACQQ2
24717 ELSEIF(ISUB.EQ.203) THEN
24718 C...f + fbar -> e_L + e_Rbar
24719 DO 160 I=MMIN1,MMAX1
24721 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
24722 EI=KCHG(IABS(I),1)/3D0
24723 TT3I=SIGN(1D0,EI)/2D0
24727 C...Color factor for e+ e-
24728 IF(IA.GE.11) FCOL=3D0
24729 A1=SFMIX(KFID,1)**2
24730 A2=SFMIX(KFID,2)**2
24735 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
24736 & /XW**2/XW1**2*A1*A2
24737 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
24742 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
24748 DK=1D0/(TH-SMZ(II)**2)
24749 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
24751 FREK=FAC2*TANW*EI*ZMIX(II,1)
24752 TNN1=TNN1+FLEK**2*DK
24753 TNN2=TNN2+FREK**2*DK
24755 DL=1D0/(TH-SMZ(JJ)**2)
24756 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
24758 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
24759 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
24762 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
24763 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
24764 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
24765 TZN=(UH*TH-SQM3*SQM4)*A1*A2
24766 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
24767 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
24770 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
24771 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
24772 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
24778 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24779 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
24784 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
24785 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24788 ELSEIF(ISUB.EQ.210) THEN
24789 C...q + qbar' -> W*- > ~l_L + ~nu_L
24790 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
24791 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
24792 DO 180 I=MMIN1,MMAX1
24794 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
24795 DO 170 J=MMIN2,MMAX2
24797 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
24798 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
24800 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
24801 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
24803 IF(KCHSUM.LT.0) KCHW=3
24808 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
24809 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
24810 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24812 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
24813 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
24815 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
24820 ELSEIF(ISUB.LE.220) THEN
24821 IF(ISUB.EQ.213) THEN
24822 C...f + fbar -> ~nu_L + ~nu_Lbar
24823 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
24824 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24825 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24827 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24830 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
24833 DO 190 I=MMIN1,MMAX1
24835 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
24838 C...Color factor for e+ e-
24839 IF(IA.GE.11) FCOL=3D0
24840 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
24844 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
24845 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
24848 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
24850 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
24856 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
24857 & *AEM**2*FCOL/3D0/XW**2
24860 ELSEIF(ISUB.EQ.216) THEN
24861 C...q + qbar -> ~chi0_1 + ~chi0_1
24862 IF(IZID1.EQ.IZID2) THEN
24863 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24865 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24866 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24868 FACXX=COMFAC*AEM**2/3D0/XW**2
24869 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
24872 WU2 = (UH-ZM12)*(UH-ZM22)
24873 WT2 = (TH-ZM12)*(TH-ZM22)
24874 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
24875 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
24876 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
24878 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
24879 IF(IZID2.NE.IZID1) THEN
24880 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
24883 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
24884 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
24886 DO 210 I=MMINA,MMAXA
24887 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
24888 EI=KCHG(IABS(I),1)/3D0
24889 T3I=SIGN(1D0,EI+1D-6)/2D0
24890 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
24891 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
24892 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
24893 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
24894 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
24895 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
24896 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
24898 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
24899 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
24900 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
24902 IF(IABS(I).GE.11) FCOL=3D0
24903 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
24904 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
24905 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
24906 & QRL*DCONJG(QRR)*POLR)*WS2
24911 SIGH(NCHN)=FACXX*FACGG1*FCOL
24915 ELSEIF(ISUB.LE.230) THEN
24916 IF(ISUB.EQ.226) THEN
24917 C...f + fbar -> ~chi+_1 + ~chi-_1
24918 FACXX=COMFAC*AEM**2/3D0
24921 WU2 = (UH-ZM12)*(UH-ZM22)
24922 WT2 = (TH-ZM12)*(TH-ZM22)
24923 WS2 = SMW(IZID1)*SMW(IZID2)*SH
24924 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
24925 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
24927 IF(IZID1.EQ.IZID2) DIFF=1D0
24929 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
24930 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
24931 IF(IZID2.NE.IZID1) THEN
24932 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
24933 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
24936 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
24937 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
24938 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
24939 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
24940 DO 230 I=MMINA,MMAXA
24941 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
24942 EI=KCHG(IABS(I),1)/3D0
24943 T3I=SIGN(1D0,EI+1D-6)/2D0
24944 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
24945 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
24946 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
24947 IF(MOD(I,2).EQ.0) THEN
24948 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
24949 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
24950 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
24951 & DCMPLX(T3I/XW/(TH-XML2))
24953 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
24954 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
24955 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
24956 & DCMPLX(T3I/XW/(TH-XML2))
24959 IF(IABS(I).GE.11) FCOL=3D0
24960 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
24961 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
24962 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
24963 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
24968 IF(IZID1.EQ.IZID2) THEN
24969 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24971 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
24972 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24977 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24978 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
24982 ELSEIF(ISUB.EQ.229) THEN
24983 C...q + qbar' -> ~chi0_1 + ~chi+-_1
24984 FACXX=COMFAC*AEM**2/6D0/XW**2
24987 WU2 = (UH-ZM12)*(UH-ZM22)
24988 WT2 = (TH-ZM12)*(TH-ZM22)
24989 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
24990 RT2I = 1D0/SQRT(2D0)
24991 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
24992 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
24994 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
24995 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
24998 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
25000 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
25001 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
25002 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
25003 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
25005 DO 270 I=MMIN1,MMAX1
25007 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
25009 T3I=SIGN(1D0,EI+1D-6)/2D0
25010 DO 260 J=MMIN2,MMAX2
25012 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
25013 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
25015 T3J=SIGN(1D0,EJ+1D-6)/2D0
25017 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25018 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25020 IF(KCHSUM.LT.0) KCHW=3
25021 IF(MOD(IA,2).EQ.0) THEN
25022 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
25023 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
25024 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
25025 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
25026 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25027 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
25030 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
25031 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
25032 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
25033 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
25034 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25035 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
25038 ZINTR=DBLE(QLR*DCONJG(QLL))
25039 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
25045 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25046 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25051 ELSEIF(ISUB.LE.240) THEN
25052 IF(ISUB.EQ.237) THEN
25053 C...q + qbar -> gluino + ~chi0_1
25054 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25055 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25056 FAC0=COMFAC*AS*AEM*4D0/9D0/XW
25059 DO 280 I=MMINA,MMAXA
25060 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
25061 EI=KCHG(IABS(I),1)/3D0
25063 XLQC = -TANW*EI*ZMIX(IZID,1)
25064 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25065 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25068 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
25069 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
25070 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
25071 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
25072 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
25073 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25074 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
25075 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
25076 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
25077 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25082 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
25086 ELSEIF(ISUB.LE.250) THEN
25087 IF(ISUB.EQ.241) THEN
25088 C...q + qbar' -> ~chi+-_1 + gluino
25089 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
25092 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
25093 FAC0=UMIX(IZID,1)**2
25094 FAC1=VMIX(IZID,1)**2
25095 DO 300 I=MMIN1,MMAX1
25097 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
25098 DO 290 J=MMIN2,MMAX2
25100 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
25101 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
25103 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25104 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25106 IF(KCHSUM.LT.0) KCHW=3
25107 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
25108 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
25109 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
25110 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
25111 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
25112 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
25113 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
25114 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
25115 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
25116 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
25117 & SH/(TH-XMU2)/(UH-XMD2))/2D0
25122 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
25123 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25124 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25128 ELSEIF(ISUB.EQ.243) THEN
25129 C...q + qbar -> gluino + gluino
25130 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25133 DO 310 I=MMINA,MMAXA
25134 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
25135 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
25137 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
25138 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
25139 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25140 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25141 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25142 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25143 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
25144 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
25145 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25146 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25147 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25148 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25152 C...1/2 for identical particles
25153 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
25156 ELSEIF(ISUB.EQ.244) THEN
25157 C...g + g -> gluino + gluino
25158 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25161 FACQQ1=COMFAC*AS**2*9D0/4D0*(
25162 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
25163 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
25164 FACQQ2=COMFAC*AS**2*9D0/4D0*(
25165 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
25166 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
25167 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
25168 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
25169 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
25174 SIGH(NCHN)=FACQQ1/2D0
25179 SIGH(NCHN)=FACQQ2/2D0
25184 SIGH(NCHN)=FACQQ3/2D0
25187 ELSEIF(ISUB.EQ.246) THEN
25188 C...g + q_j -> ~chi0_1 + ~q_j
25189 FAC0=COMFAC*AS*AEM/6D0/XW
25192 FACZQ0=FAC0*( (ZM2-TH)/SH +
25193 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25194 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25195 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25196 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
25197 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
25198 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
25199 EI=KCHG(IABS(I),1)/3D0
25201 XRQZ = -TANW*EI*ZMIX(IZID,1)
25202 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25203 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25205 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
25207 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
25213 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
25214 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
25217 ISIG(NCHN,3-ISDE)=21
25219 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25220 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25225 ELSEIF(ISUB.LE.260) THEN
25226 IF(ISUB.EQ.254) THEN
25227 C...g + q_j -> ~chi1_1 + ~q_i
25228 FAC0=COMFAC*AS*AEM/12D0/XW
25233 FACZQ0=FAC0*( (ZM2-TH)/SH +
25234 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25235 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25236 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
25237 IF(MOD(KFNSQ1,2).EQ.0) THEN
25244 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
25245 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
25246 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
25248 IF(MOD(IA,2).EQ.0) THEN
25253 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
25257 IF(I.LT.0) KCHWQ=5-KCHW
25259 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
25260 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
25263 ISIG(NCHN,3-ISDE)=21
25265 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25266 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
25270 ELSEIF(ISUB.EQ.258) THEN
25271 C...g + q_j -> gluino + ~q_i
25278 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
25279 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
25280 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
25281 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
25282 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
25284 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
25285 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
25286 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
25287 FACQG1=COMFAC*AS**2*FACQG1/2D0
25288 FACQG2=COMFAC*AS**2*FACQG2/2D0
25289 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25290 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
25291 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
25292 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
25295 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25296 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25298 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
25299 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
25302 ISIG(NCHN,3-ISDE)=21
25304 SIGH(NCHN)=FACQG1*FACSEL
25307 ISIG(NCHN,3-ISDE)=21
25309 SIGH(NCHN)=FACQG2*FACSEL
25314 ELSEIF(ISUB.LE.270) THEN
25315 IF(ISUB.EQ.261) THEN
25316 C...q_i + q_ibar -> ~t_1 + ~t_1bar
25317 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
25318 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25319 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25321 DO 390 I=MMIN1,MMAX1
25323 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
25324 IF(IA.GE.11.AND.IA.LE.18) THEN
25326 EJ=KCHG(KFNSQ,1)/3D0
25327 T3I=SIGN(1D0,EI)/2D0
25328 T3J=SIGN(1D0,EJ)/2D0
25329 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
25330 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
25331 XLF=2D0*(T3I-EI*XW)
25333 TAA=0.5D0*(EI*EJ)**2
25334 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
25335 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25336 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
25337 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25338 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
25344 SIGH(NCHN)=FACQQ1*FAC0
25347 ELSEIF(ISUB.EQ.263) THEN
25348 C...f + fbar -> ~t1 + ~t2bar
25349 DO 400 I=MMIN1,MMAX1
25351 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
25352 EI=KCHG(IABS(I),1)/3D0
25353 TT3I=SIGN(1D0,EI)/2D0
25357 C...Color factor for e+ e-
25358 IF(IA.GE.11) FCOL=3D0
25359 XLQ=2D0*(TT3J-EJ*XW)
25361 XLF=2D0*(TT3I-EI*XW)
25363 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
25364 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
25365 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25366 C...Factor of 2 for t1 t2bar + t2 t1bar
25367 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
25368 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
25373 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25374 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
25379 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
25380 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25383 ELSEIF(ISUB.EQ.264) THEN
25384 C...g + g -> ~t_1 + ~t_1bar
25387 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
25388 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25389 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
25390 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
25391 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
25405 ELSEIF(ISUB.LE.280) THEN
25406 IF(ISUB.EQ.271) THEN
25407 C...q + q' -> ~q + ~q' (~g exchange)
25408 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
25416 FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
25417 FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
25420 FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
25421 FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
25422 FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
25425 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
25426 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
25427 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
25428 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
25430 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
25433 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
25434 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
25436 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
25437 IF(I*J.LT.0) GOTO 420
25442 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25443 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
25446 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
25447 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
25449 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
25450 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25451 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
25458 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
25459 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
25461 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
25462 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25463 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
25469 ELSEIF(ISUB.EQ.274) THEN
25470 C...q + qbar' -> ~q + ~qbar'
25471 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
25475 C...Mrenna...Normalization.and.1/XMT
25476 FACQQ1=COMFAC*AS**2*2D0/9D0*(
25477 & (UH*TH-SQM3*SQM4)/XMT**2 )
25478 FACQQB=COMFAC*AS**2*2D0/9D0*(
25479 & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT))
25480 FACQQB=FACQQB+FACQQ1
25482 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
25485 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
25486 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
25487 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
25488 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
25490 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
25493 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
25494 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
25496 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
25497 IF(I*J.GT.0) GOTO 440
25502 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25503 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
25504 IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
25505 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25509 ELSEIF(ISUB.EQ.277) THEN
25510 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
25511 C...if i .eq. j covered in 274
25512 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
25513 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25515 DO 460 I=MMIN1,MMAX1
25517 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
25518 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
25519 IF(IA.EQ.KFNSQ) GOTO 460
25520 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
25522 EJ=KCHG(KFNSQ,1)/3D0
25524 T3I=SIGN(1D0,EI)/2D0
25526 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
25527 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
25529 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
25530 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
25532 XLF=2D0*(T3I-EI*XW)
25539 TAA=0.5D0*(EI*EJ)**2
25540 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
25541 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25542 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
25543 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25544 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
25545 ELSEIF(IA.LE.6) THEN
25546 FAC0=AS**2*8D0/9D0/2D0
25552 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25555 ELSEIF(ISUB.EQ.279) THEN
25556 C...g + g -> ~q_j + ~q_jbar
25559 C...5=RKF because ~t ~tbar treated separately
25560 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
25561 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
25562 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
25563 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
25568 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25573 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25583 C*********************************************************************
25586 C...Subprocess cross sections for Technicolor processes.
25587 C...Auxiliary to PYSIGH.
25589 SUBROUTINE PYSGTC(NCHN,SIGS)
25591 C...Double precision and integer declarations
25592 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25593 IMPLICIT INTEGER(I-N)
25594 INTEGER PYK,PYCHGE,PYCOMP
25595 C...Parameter statement to help give large particle numbers.
25596 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
25597 &KEXCIT=4000000,KDIMEN=5000000)
25599 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25600 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25601 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
25602 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25603 COMMON/PYINT1/MINT(400),VINT(400)
25604 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
25605 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
25606 COMMON/PYINT4/MWID(500),WIDS(500,5)
25607 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
25608 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
25609 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
25610 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
25611 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
25612 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
25613 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
25614 C...Local arrays and complex variables
25615 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
25616 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
25617 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
25618 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
25619 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
25620 COMPLEX*16 DVVS,DVVT,DVVU
25623 C...Combinations of weak mixing angle.
25625 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
25627 C...Convert almost equivalent technicolor processes into
25628 C...a few basic processes, and set distinguishing parameters.
25629 IF(ISUB.GE.361.AND.ISUB.LE.379) THEN
25632 SN2W=2D0*SQRT(PARU(102)*(1D0-PARU(102)))
25633 CS2W=1D0-2D0*PARU(102)
25634 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
25636 CSXI=COS(ASIN(RTCM(3)))
25637 CSXIP=COS(ASIN(RTCM(4)))
25638 QUPD=2D0*RTCM(2)-1D0
25639 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
25640 C... rho_tc0 -> W_L W_L
25641 IF(ISUB.EQ.361) THEN
25645 C... rho_tc0 -> W_L pi_tc-
25646 ELSEIF(ISUB.EQ.362) THEN
25650 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
25652 ELSEIF(ISUB.EQ.363) THEN
25656 CAB2=(1D0-RTCM(3)**2)**2
25657 C... rho_tc0/omega_tc -> gamma pi_tc
25658 ELSEIF(ISUB.EQ.364) THEN
25667 VZGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
25669 ELSEIF(ISUB.EQ.365) THEN
25673 VRGP=CSXIP/RTCM(12)
25678 VAGP=2D0*Q2UD*CSXIP
25679 VZGP=CSXIP/SN2W*(1D0-4D0*PARU(102)*Q2UD)
25681 ELSEIF(ISUB.EQ.366) THEN
25685 VOGP=CSXI*CT2W/RTCM(12)
25686 VRGP=-QUPD*CSXI*TANW/RTCM(12)
25689 VAGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
25690 VZGP=-QUPD*CSXI*CS2W/(1D0-PARU(102))
25692 ELSEIF(ISUB.EQ.367) THEN
25696 VRGP=CSXIP*CT2W/RTCM(12)
25697 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
25700 VAGP=CSXIP*(1D0-4D0*Q2UD*PARU(102))/SN2W
25701 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*PARU(102)**2)/SN2W**2
25703 ELSEIF(ISUB.EQ.368) THEN
25707 VOGP=CSXI/(2D0*SQRT(PARU(102)))/RTCM(12)
25711 ARGP=-CSXI/(2D0*SQRT(PARU(102)))/RTCM(13)
25712 VAGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
25713 VZGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
25714 C... rho_tc+ -> W_L Z_L
25715 ELSEIF(ISUB.EQ.370) THEN
25720 ELSEIF(ISUB.EQ.371) THEN
25724 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
25726 ELSEIF(ISUB.EQ.372) THEN
25730 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
25732 ELSEIF(ISUB.EQ.373) THEN
25736 CAB2=(1D0-RTCM(3)**2)**2
25738 ELSEIF(ISUB.EQ.374) THEN
25743 VWGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
25745 ELSEIF(ISUB.EQ.375) THEN
25749 VRGP=-QUPD*CSXI*TANW
25750 ARGP=CSXI/(2D0*SQRT(PARU(102)*(1D0-PARU(102))))
25751 VWGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
25753 ELSEIF(ISUB.EQ.376) THEN
25758 ARGP=-CSXI/(2D0*SQRT(PARU(102)))
25761 ELSEIF(ISUB.EQ.377) THEN
25766 VRGP=CSXIP/(2D0*SQRT(PARU(102)))
25767 VWGP=CSXIP/(2D0*PARU(102))
25771 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
25772 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
25773 IF(ITCM(5).LE.4) THEN
25791 ELSEIF(ITCM(5).EQ.5) THEN
25793 IF(ITCM(2).EQ.0) THEN
25798 ALPRHT=2.91D0*(3D0/ITCM(1))
25799 SIN2T=2D0*TANT3/(TANT3**2+1D0)
25800 SINT3=TANT3/SQRT(TANT3**2+1D0)
25801 XIG=SQRT(PYALPS(SH)/ALPRHT)
25802 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
25803 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
25804 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
25805 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
25806 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
25807 & SINT3**2)*2D0/SIN2T
25808 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
25809 & SINT3**2)*2D0/SIN2T
25811 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
25812 SM1112=X12*RTCM(28)**2*SIN2T
25813 SM1121=-X21*RTCM(28)**2*SIN2T
25816 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
25817 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
25820 ZTC(1,1)=DCMPLX(SH,0D0)
25821 CALL PYWIDT(3100021,SH,WDTP,WDTE)
25822 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
25823 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
25824 CALL PYWIDT(3100113,SH,WDTP,WDTE)
25825 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
25826 CALL PYWIDT(3400113,SH,WDTP,WDTE)
25827 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
25828 CALL PYWIDT(3200113,SH,WDTP,WDTE)
25829 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
25830 CALL PYWIDT(3300113,SH,WDTP,WDTE)
25831 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
25833 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
25837 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
25838 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
25839 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
25840 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
25853 CALL PYLDCM(ZTC,6,6,INDX,D)
25857 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
25862 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
25868 XIG=SQRT(PYALPS(-TH)/ALPRHT)
25870 ZTC(1,1)=DCMPLX(TH)
25871 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
25872 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
25873 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
25874 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
25875 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
25877 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
25881 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
25882 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
25883 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
25884 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
25896 CALL PYLDCM(ZTC,6,6,INDX,D)
25900 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
25904 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
25910 XIG=SQRT(PYALPS(-UH)/ALPRHT)
25912 ZTC(1,1)=DCMPLX(UH,0D0)
25913 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
25914 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
25915 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
25916 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
25917 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
25919 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
25923 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
25924 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
25925 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
25926 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
25938 CALL PYLDCM(ZTC,6,6,INDX,D)
25942 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
25946 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
25953 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
25954 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
25955 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
25956 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
25957 DQGS=DGGS-DGVS*DCMPLX(TANT3)
25958 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
25960 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
25961 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
25962 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
25963 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
25964 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
25965 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
25968 SQDQTS=ABS(DQTS)**2
25969 SQDQQS=ABS(DQQS)**2
25970 SQDQQT=ABS(DQQT)**2
25971 SQDQQU=ABS(DQQU)**2
25972 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
25974 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
25976 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
25978 SQDGGS=ABS(DGGS)**2
25979 SQDGGT=ABS(DGGT)**2
25980 SQDGGU=ABS(DGGU)**2
25984 REDGTU=DBLE(DGGU*DCONJG(DGGT))
25985 REDGSU=DBLE(DGGU*DCONJG(DGGS))
25986 REDGST=DBLE(DGGS*DCONJG(DGGT))
25987 REDQST=DBLE(DQQS*DCONJG(DQQT))
25988 REDQTU=DBLE(DQQT*DCONJG(DQQU))
25993 C...Differential cross section expressions.
25995 IF(ISUB.LE.190) THEN
25996 IF(ISUB.EQ.149) THEN
25997 C...g + g -> eta_tc
25998 KCTC=PYCOMP(KTECHN+331)
25999 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
26001 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
26002 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26004 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
26006 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26011 SIGH(NCHN)=HI*FACBW*HF
26014 ELSEIF(ISUB.EQ.165) THEN
26015 C...q + qbar -> l+ + l- (including contact term for compositeness)
26016 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26017 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26018 KFF=IABS(KFPR(ISUB,1))
26020 AF=SIGN(1D0,EF+0.1D0)
26025 IF(KFF.LE.10) FCOF=3D0
26027 IF(KFF.EQ.6) WID2=WIDS(6,1)
26028 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
26029 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
26030 DO 260 I=MMINA,MMAXA
26031 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
26032 EI=KCHG(IABS(I),1)/3D0
26033 AI=SIGN(1D0,EI+0.1D0)
26038 IF(IABS(I).LE.10) FCOI=FACA/3D0
26039 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
26040 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
26041 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
26042 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
26044 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
26045 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
26047 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
26048 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
26049 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
26050 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
26051 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
26056 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
26059 ELSEIF(ISUB.EQ.166) THEN
26060 C...q + q'bar -> l + nu_l (including contact term for compositeness)
26061 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
26062 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
26063 KFF=IABS(KFPR(ISUB,1))
26065 IF(KFF.LE.10) FCOF=3D0
26066 DO 280 I=MMIN1,MMAX1
26067 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
26069 DO 270 J=MMIN2,MMAX2
26070 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
26072 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
26073 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26076 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
26078 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
26079 & MOD(J,2).EQ.0)) THEN
26080 IF(KFF.EQ.5) WID2=WIDS(6,2)
26081 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
26082 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
26084 IF(KFF.EQ.5) WID2=WIDS(6,3)
26085 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
26086 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
26092 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
26093 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
26094 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
26099 ELSEIF(ISUB.LE.200) THEN
26100 IF(ISUB.EQ.191) THEN
26101 C...q + qbar -> rho_tc0.
26102 KCTC=PYCOMP(KTECHN+113)
26103 SQMRHT=PMAS(KCTC,1)**2
26104 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26106 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
26107 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26108 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26109 ALPRHT=2.91D0*(3D0/ITCM(1))
26110 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
26111 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26112 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26113 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26114 DO 290 I=MMINA,MMAXA
26115 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
26117 EI=KCHG(IABS(I),1)/3D0
26118 AI=SIGN(1D0,EI+0.1D0)
26122 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26123 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
26124 IF(IA.LE.10) HI=HI*FACA/3D0
26129 SIGH(NCHN)=HI*FACBW*HF
26132 ELSEIF(ISUB.EQ.192) THEN
26133 C...q + qbar' -> rho_tc+/-.
26134 KCTC=PYCOMP(KTECHN+213)
26135 SQMRHT=PMAS(KCTC,1)**2
26136 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26138 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
26139 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26140 ALPRHT=2.91D0*(3D0/ITCM(1))
26141 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
26142 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26143 DO 310 I=MMIN1,MMAX1
26144 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
26146 DO 300 J=MMIN2,MMAX2
26147 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
26149 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
26150 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26152 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26153 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
26155 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
26160 SIGH(NCHN)=HI*FACBW*HF
26164 ELSEIF(ISUB.EQ.193) THEN
26165 C...q + qbar -> omega_tc0.
26166 KCTC=PYCOMP(KTECHN+223)
26167 SQMOMT=PMAS(KCTC,1)**2
26168 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26170 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
26171 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26172 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26173 ALPRHT=2.91D0*(3D0/ITCM(1))
26174 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
26175 & (2D0*RTCM(2)-1D0)**2
26176 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26177 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26178 DO 320 I=MMINA,MMAXA
26179 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
26181 EI=KCHG(IABS(I),1)/3D0
26182 AI=SIGN(1D0,EI+0.1D0)
26186 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
26187 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
26188 IF(IA.LE.10) HI=HI*FACA/3D0
26193 SIGH(NCHN)=HI*FACBW*HF
26196 ELSEIF(ISUB.EQ.194) THEN
26197 C...f + fbar -> f' + fbar' via s-channel rho_tc and omega_tc.
26199 ALPRHT=2.91D0*(3D0/ITCM(1))
26201 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
26202 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
26204 QUPD=2D0*RTCM(2)-1D0
26205 FAR=SQRT(AEM/ALPRHT)
26213 CALL PYWIDT(23,SH,WDTP,WDTE)
26214 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26215 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26216 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26217 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26218 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26219 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26220 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26221 DAA=(-Sfzr*SSMO - Sfzo*SSMR + SSMO*SSMR*SSMZ)/DETD/SH
26222 DZZ=(-Sfar*SSMO - Sfao*SSMR + SSMO*SSMR)/DETD/SH
26223 DAZ=(far*fzr*SSMO + fao*fzo*SSMR)/DETD/SH
26225 XWRHT=1D0/(4D0*XW*(1D0-XW))
26226 KFF=IABS(KFPR(ISUB,1))
26228 AF=SIGN(1D0,EF+0.1D0)
26233 IF(KFF.LE.10) FCOF=3D0
26236 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
26237 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
26238 DZZ=DZZ*DCMPLX(XWRHT,0D0)
26239 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
26241 DO 330 I=MMINA,MMAXA
26242 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
26243 EI=KCHG(IABS(I),1)/3D0
26244 AI=SIGN(1D0,EI+0.1D0)
26249 IF(IABS(I).LE.10) FCOI=FCOI/3D0
26250 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
26251 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
26252 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
26253 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
26254 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
26255 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
26260 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
26263 ELSEIF(ISUB.EQ.195) THEN
26264 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+
26267 ALPRHT=2.91D0*(3D0/ITCM(1))
26268 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
26270 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26271 CALL PYWIDT(24,SH,WDTP,WDTE)
26272 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26273 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26274 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26277 IF(KFA.LE.8) FCOF=3D0
26278 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26279 HP=FACTC*ABS(SSMR/DETD)**2/SH**2*FCOF
26281 DO 350 I=MMIN1,MMAX1
26282 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
26284 DO 340 J=MMIN2,MMAX2
26285 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
26287 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
26288 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26290 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26292 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26297 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
26302 ELSEIF(ISUB.LE.380) THEN
26303 IF(ISUB.EQ.361) THEN
26304 C...f + fbar -> W_L W_L, W_L pi_tc, pi_tc pi_tc
26305 FACA=(SH**2*BE34**2-(TH-UH)**2)
26306 ALPRHT=2.91D0*(3D0/ITCM(1))
26307 HP=(1D0/12D0)*AEM**2*CAB2*COMFAC*FACA*3D0
26308 FAR=SQRT(AEM/ALPRHT)
26316 CALL PYWIDT(23,SH,WDTP,WDTE)
26317 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26318 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26319 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26320 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26321 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26322 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26323 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26324 DARHO=-(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26325 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26326 DAA=-(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
26327 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
26328 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH
26330 DO 360 I=MMINA,MMAXA
26331 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 360
26333 EI=KCHG(IABS(I),1)/3D0
26334 AI=SIGN(1D0,EI+0.1D0)
26336 VALI=0.25D0*(VI+AI)
26337 VARI=0.25D0*(VI-AI)
26338 F2L=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
26339 $ VALI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
26340 F2R=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
26341 $ VARI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
26342 HI=ABS(F2L)**2+ABS(F2R)**2
26343 IF(IA.LE.10) HI=HI/3D0
26348 IF(KFA.EQ.KFB) THEN
26349 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
26351 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26356 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26360 ELSEIF(ISUB.EQ.364) THEN
26361 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
26363 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
26364 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
26365 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
26367 ALPRHT=2.91D0*(3D0/ITCM(1))
26368 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
26369 FAR=SQRT(AEM/ALPRHT)
26377 CALL PYWIDT(23,SH,WDTP,WDTE)
26378 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26379 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26380 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26381 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26382 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26383 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26384 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26385 DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26386 DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26387 DAOME=(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)/DETD/SH
26388 DZOME=(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH
26389 DAA=(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
26390 DZZ=(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
26391 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH
26393 DO 370 I=MMINA,MMAXA
26394 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
26396 EI=KCHG(IABS(I),1)/3D0
26397 AI=SIGN(1D0,EI+0.1D0)
26399 VALI=0.25D0*(VI+AI)
26400 VARI=0.25D0*(VI-AI)
26401 C...........Add in anomaly contribution
26402 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
26403 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
26404 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
26405 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
26406 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
26407 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
26408 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
26409 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
26410 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
26411 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
26412 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
26413 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
26414 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
26415 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
26417 IF(IA.LE.10) HI=HI/3D0
26422 IF(ISUBSV.NE.368) THEN
26423 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
26425 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26430 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26434 ELSEIF(ISUB.EQ.370) THEN
26435 C...f + fbar' -> W_L Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
26437 FACA=(SH**2*BE34**2-(TH-UH)**2)
26438 ALPRHT=2.91D0*(3D0/ITCM(1))
26439 HP=(1D0/96D0)*AEM**2*CAB2*COMFAC*FACA*3D0/XW**2
26440 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26441 CALL PYWIDT(24,SH,WDTP,WDTE)
26442 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26443 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26444 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26445 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26448 HP=HP*ABS(DWW+DWRHO)**2
26449 DO 390 I=MMIN1,MMAX1
26450 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 390
26452 DO 380 J=MMIN2,MMAX2
26453 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 380
26455 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 380
26456 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26458 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26460 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26465 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26466 & WIDS(PYCOMP(KFB),2)
26470 ELSEIF(ISUB.EQ.374) THEN
26471 C...f + fbar' -> gamma pi_tc
26472 FANOM=SQRT(AEM)*ITCM(1)/2D0/PARU(2)/RTCM(1)
26473 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
26474 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*ARGP**2
26475 ALPRHT=2.91D0*(3D0/ITCM(1))
26476 HP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
26477 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26478 CALL PYWIDT(24,SH,WDTP,WDTE)
26479 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26480 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26481 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26482 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26484 DWRHO=-DCMPLX(FWR,0D0)/DETD/SH
26485 HP=HP*(AFAC*ABS(DWRHO)**2+
26486 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP/SQRT(SQTV))**2)
26487 DO 410 I=MMIN1,MMAX1
26488 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
26490 DO 400 J=MMIN2,MMAX2
26491 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
26493 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
26494 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26496 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26498 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26503 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26504 & WIDS(PYCOMP(KFB),2)
26509 ELSEIF(ISUB.LE.390) THEN
26510 IF(ISUB.EQ.381) THEN
26511 C...f + f' -> f + f' (g exchange)
26512 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
26513 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
26514 & MSTP(34)*2D0/3D0*UH2*REDQST)
26515 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
26516 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
26517 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
26518 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
26519 C...Modifications from contact interactions (compositeness)
26520 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
26521 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
26522 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
26523 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
26524 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
26525 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
26526 RATCII=(FACCI1*FACCI2+FACQQI)/(FACCI1+FACCI2)
26527 ELSEIF(ITCM(5).EQ.5) THEN
26532 CSM.......Check this change from
26536 DO 430 I=MMIN1,MMAX1
26538 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
26539 DO 420 J=MMIN2,MMAX2
26541 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
26546 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
26549 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
26552 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
26553 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
26560 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
26561 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
26562 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
26564 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
26565 SIGH(NCHN)=0.5D0*FACCI2*RATCII
26571 ELSEIF(ISUB.EQ.382) THEN
26572 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
26573 CALL PYWIDT(21,SH,WDTP,WDTE)
26574 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
26575 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26576 IF(ITCM(5).EQ.1) THEN
26577 C...Modifications from contact interactions (compositeness)
26580 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
26581 & WDTE(I,2)+WDTE(I,4))
26583 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
26584 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
26585 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26586 ELSEIF(ITCM(5).EQ.5) THEN
26587 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
26588 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
26589 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
26591 DO 450 I=MMINA,MMAXA
26592 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26593 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
26598 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
26600 ELSEIF(ITCM(5).EQ.5) THEN
26612 ELSEIF(ISUB.EQ.383) THEN
26613 C...f + fbar -> g + g (q + qbar -> g + g only)
26614 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
26615 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
26616 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
26617 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
26618 IF(ITCM(5).EQ.5) THEN
26619 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
26620 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
26621 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
26622 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
26624 DO 460 I=MMINA,MMAXA
26625 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26626 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
26631 SIGH(NCHN)=0.5D0*FACGG1
26632 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
26637 SIGH(NCHN)=0.5D0*FACGG2
26638 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
26641 ELSEIF(ISUB.EQ.384) THEN
26642 C...f + g -> f + g (q + g -> q + g only)
26643 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
26644 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
26645 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
26646 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
26647 DO 480 I=MMINA,MMAXA
26648 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
26650 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
26651 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
26654 ISIG(NCHN,3-ISDE)=21
26659 ISIG(NCHN,3-ISDE)=21
26665 ELSEIF(ISUB.EQ.385) THEN
26666 C...g + g -> f + fbar (g + g -> q + qbar only)
26667 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
26669 C...Begin by d, u, s flavours.
26671 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
26672 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
26673 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
26674 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
26675 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
26676 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
26677 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
26678 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
26679 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
26680 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
26691 C...Next c and b flavours: modified that and uhat for fixed
26692 C...cos(theta-hat).
26694 SQMAVG=PMAS(IFL,1)**2
26695 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
26696 BE34=SQRT(1D0-4D0*SQMAVG/SH)
26697 THQ=-0.5D0*SH*(1D0-BE34*CTH)
26698 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
26699 THUHQ=THQ*UHQ-SQMAVG*SH
26700 IF(MSTP(34).EQ.0) THEN
26701 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
26702 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
26704 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26705 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
26706 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26707 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
26709 IF(ITCM(5).GE.5) THEN
26711 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
26712 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26713 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
26714 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26716 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
26717 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26718 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
26719 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26722 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
26723 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
26727 ISIG(NCHN,3)=1+2*(IFL-3)
26732 ISIG(NCHN,3)=2+2*(IFL-3)
26738 ELSEIF(ISUB.EQ.386) THEN
26740 IF(ITCM(5).LE.4) THEN
26741 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
26742 & 2D0*TH/SH+TH2/SH2)*FACA
26743 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
26744 & 2D0*SH/UH+SH2/UH2)*FACA
26745 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
26746 & 2D0*UH/TH+UH2/TH2)
26748 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
26749 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
26750 & 4D0*REDGST*(SH + 2D0*TH)*
26751 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
26752 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
26753 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
26754 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
26755 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
26756 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
26757 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
26758 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
26759 & 4D0*REDGSU*(SH + 2D0*UH)*
26760 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
26761 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
26762 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
26763 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
26764 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
26765 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
26766 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
26767 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
26768 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
26769 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
26770 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
26771 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
26772 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
26773 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
26774 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
26775 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
26776 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
26777 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
26778 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
26779 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
26780 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
26781 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
26783 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
26788 SIGH(NCHN)=0.5D0*FACGG1
26793 SIGH(NCHN)=0.5D0*FACGG2
26798 SIGH(NCHN)=0.5D0*FACGG3
26801 ELSEIF(ISUB.EQ.387) THEN
26802 C...q + qbar -> Q + Qbar
26803 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
26804 THQ=-0.5D0*SH*(1D0-BE34*CTH)
26805 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
26806 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
26808 IF(ITCM(5).GE.5) THEN
26809 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
26810 FACQQB=FACQQB*SH2*SQDQTS
26812 FACQQB=FACQQB*SH2*SQDQQS
26815 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
26817 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
26818 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
26820 DO 520 I=MMINA,MMAXA
26821 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26822 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
26830 ELSEIF(ISUB.EQ.388) THEN
26831 C...g + g -> Q + Qbar
26832 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
26833 THQ=-0.5D0*SH*(1D0-BE34*CTH)
26834 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
26835 THUHQ=THQ*UHQ-SQMAVG*SH
26836 IF(MSTP(34).EQ.0) THEN
26837 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
26838 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
26840 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26841 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
26842 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26843 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
26845 IF(ITCM(5).GE.5) THEN
26846 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
26847 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
26848 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26849 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
26850 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26852 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
26853 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26854 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
26855 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26858 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
26859 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
26860 IF(MSTP(35).GE.1) THEN
26861 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
26862 FACQQ1=FACQQ1*FATRE
26863 FACQQ2=FACQQ2*FATRE
26866 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
26867 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
26870 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
26890 C*********************************************************************
26893 C...Subprocess cross sections for assorted exotic processes,
26894 C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
26895 C...Auxiliary to PYSIGH.
26897 SUBROUTINE PYSGEX(NCHN,SIGS)
26899 C...Double precision and integer declarations
26900 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26901 IMPLICIT INTEGER(I-N)
26902 INTEGER PYK,PYCHGE,PYCOMP
26903 C...Parameter statement to help give large particle numbers.
26904 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
26905 &KEXCIT=4000000,KDIMEN=5000000)
26907 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26908 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26909 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
26910 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26911 COMMON/PYINT1/MINT(400),VINT(400)
26912 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
26913 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
26914 COMMON/PYINT4/MWID(500),WIDS(500,5)
26915 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
26916 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
26917 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
26918 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
26919 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
26920 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
26921 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
26923 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
26925 C...Differential cross section expressions.
26927 IF(ISUB.LE.160) THEN
26928 IF(ISUB.EQ.141) THEN
26929 C...f + fbar -> gamma*/Z0/Z'0
26930 SQMZP=PMAS(32,1)**2
26932 CALL PYWIDT(32,SH,WDTP,WDTE)
26938 FACZP=4D0*COMFAC*3D0
26939 DO 100 I=MMINA,MMAXA
26940 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
26941 EI=KCHG(IABS(I),1)/3D0
26947 VPI=PARU(123-2*MOD(IABS(I),2))
26948 API=PARU(124-2*MOD(IABS(I),2))
26949 ELSEIF(IA.LE.4) THEN
26950 VPI=PARJ(182-2*MOD(IABS(I),2))
26951 API=PARJ(183-2*MOD(IABS(I),2))
26953 VPI=PARJ(190-2*MOD(IABS(I),2))
26954 API=PARJ(191-2*MOD(IABS(I),2))
26958 VPI=PARU(127-2*MOD(IABS(I),2))
26959 API=PARU(128-2*MOD(IABS(I),2))
26960 ELSEIF(IA.LE.14) THEN
26961 VPI=PARJ(186-2*MOD(IABS(I),2))
26962 API=PARJ(187-2*MOD(IABS(I),2))
26964 VPI=PARJ(194-2*MOD(IABS(I),2))
26965 API=PARJ(195-2*MOD(IABS(I),2))
26969 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
26971 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
26973 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
26978 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
26979 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
26980 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
26981 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
26982 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
26983 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
26984 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
26985 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
26988 ELSEIF(ISUB.EQ.142) THEN
26989 C...f + fbar' -> W'+/-
26990 SQMWP=PMAS(34,1)**2
26991 CALL PYWIDT(34,SH,WDTP,WDTE)
26993 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
26994 HP=AEM/(24D0*XW)*SH
26995 DO 120 I=MMIN1,MMAX1
26996 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
26998 DO 110 J=MMIN2,MMAX2
26999 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
27001 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
27002 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
27004 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
27005 HI=HP*(PARU(133)**2+PARU(134)**2)
27006 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
27007 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
27012 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
27013 SIGH(NCHN)=HI*FACBW*HF
27017 ELSEIF(ISUB.EQ.144) THEN
27020 CALL PYWIDT(41,SH,WDTP,WDTE)
27022 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
27023 HP=AEM/(12D0*XW)*SH
27024 DO 140 I=MMIN1,MMAX1
27025 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
27027 DO 130 J=MMIN2,MMAX2
27028 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
27030 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
27032 IF(IA.LE.10) HI=HI*FACA/3D0
27033 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
27038 SIGH(NCHN)=HI*FACBW*HF
27042 ELSEIF(ISUB.EQ.145) THEN
27043 C...q + l -> LQ (leptoquark)
27044 SQMLQ=PMAS(42,1)**2
27045 CALL PYWIDT(42,SH,WDTP,WDTE)
27047 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
27048 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
27050 KFLQQ=KFDP(MDCY(42,2),1)
27051 KFLQL=KFDP(MDCY(42,2),2)
27052 DO 160 I=MMIN1,MMAX1
27053 IF(KFAC(1,I).EQ.0) GOTO 160
27055 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
27056 DO 150 J=MMIN2,MMAX2
27057 IF(KFAC(2,J).EQ.0) GOTO 150
27059 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
27060 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
27061 IF(JA.EQ.IA) GOTO 150
27062 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
27063 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
27065 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
27070 SIGH(NCHN)=HI*FACBW*HF
27074 ELSEIF(ISUB.EQ.146) THEN
27075 C...e + gamma* -> e* (excited lepton)
27076 KFQSTR=KFPR(ISUB,1)
27077 KCQSTR=PYCOMP(KFQSTR)
27078 KFQEXC=MOD(KFQSTR,KEXCIT)
27079 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
27081 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
27082 QF=-RTCM(43)/2D0-RTCM(44)/2D0
27083 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
27084 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
27087 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
27089 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
27090 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
27092 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27093 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
27096 ISIG(NCHN,3-ISDE)=22
27098 SIGH(NCHN)=HI*FACBW*HF
27102 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
27103 C...d + g -> d* and u + g -> u* (excited quarks)
27104 KFQSTR=KFPR(ISUB,1)
27105 KCQSTR=PYCOMP(KFQSTR)
27106 KFQEXC=MOD(KFQSTR,KEXCIT)
27107 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
27109 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
27110 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
27111 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
27114 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
27116 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
27117 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
27119 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27120 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
27123 ISIG(NCHN,3-ISDE)=21
27125 SIGH(NCHN)=HI*FACBW*HF
27130 ELSEIF(ISUB.LE.190) THEN
27131 IF(ISUB.EQ.162) THEN
27132 C...q + g -> LQ + lbar; LQ=leptoquark
27133 SQMLQ=PMAS(42,1)**2
27134 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
27135 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
27136 KFLQQ=KFDP(MDCY(42,2),1)
27137 DO 220 I=MMINA,MMAXA
27138 IF(IABS(I).NE.KFLQQ) GOTO 220
27141 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
27142 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
27145 ISIG(NCHN,3-ISDE)=21
27147 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
27151 ELSEIF(ISUB.EQ.163) THEN
27152 C...g + g -> LQ + LQbar; LQ=leptoquark
27153 SQMLQ=PMAS(42,1)**2
27154 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
27155 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
27156 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
27157 & ((TH-SQMLQ)*(UH-SQMLQ)))
27158 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
27162 C...Since don't know proper colour flow, randomize between alternatives
27163 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
27167 ELSEIF(ISUB.EQ.164) THEN
27168 C...q + qbar -> LQ + LQbar; LQ=leptoquark
27169 DELTA=0.25D0*(SQM3-SQM4)**2/SH
27170 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
27173 C SQMLQ=PMAS(42,1)**2
27174 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
27175 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
27176 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
27177 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
27178 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
27179 KFLQQ=KFDP(MDCY(42,2),1)
27180 DO 240 I=MMINA,MMAXA
27181 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
27182 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
27188 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
27191 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
27192 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
27193 KFQSTR=KFPR(ISUB,2)
27194 KCQSTR=PYCOMP(KFQSTR)
27195 KFQEXC=MOD(KFQSTR,KEXCIT)
27196 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
27197 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
27198 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
27199 C...Propagators: as simulated in PYOFSH and as desired
27200 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
27201 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
27202 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
27203 GMMQC=SQRT(SQM4)*WDTP(0)
27204 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
27205 FACQSA=FACQSA*HBW4C/HBW4
27206 FACQSB=FACQSB*HBW4C/HBW4
27207 C...Branching ratios.
27208 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
27209 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
27210 DO 260 I=MMIN1,MMAX1
27212 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
27213 DO 250 J=MMIN2,MMAX2
27215 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
27216 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
27221 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
27222 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
27227 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
27228 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
27229 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
27234 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
27235 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
27236 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
27237 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
27242 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
27243 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
27248 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
27249 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
27250 ELSEIF(I.EQ.-J) THEN
27255 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27256 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27261 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27262 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27263 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
27268 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
27269 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
27270 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
27275 ELSEIF(ISUB.EQ.169) THEN
27276 C...q + qbar -> e + e* (excited lepton)
27277 KFQSTR=KFPR(ISUB,2)
27278 KCQSTR=PYCOMP(KFQSTR)
27279 KFQEXC=MOD(KFQSTR,KEXCIT)
27280 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
27281 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
27282 C...Propagators: as simulated in PYOFSH and as desired
27283 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
27284 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
27285 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
27286 GMMQC=SQRT(SQM4)*WDTP(0)
27287 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
27288 FACQSB=FACQSB*HBW4C/HBW4
27289 C...Branching ratios.
27290 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
27291 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
27292 DO 270 I=MMIN1,MMAX1
27294 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
27297 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
27302 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27303 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27308 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27309 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27313 ELSEIF(ISUB.LE.360) THEN
27314 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
27315 C...l + l -> H_L++/-- or H_R++/--.
27317 KFREC=PYCOMP(KFRES)
27318 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
27320 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
27321 DO 290 I=MMIN1,MMAX1
27323 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
27325 DO 280 J=MMIN2,MMAX2
27327 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
27329 IF(I*J.LT.0) GOTO 280
27330 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
27335 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
27336 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
27337 SIGH(NCHN)=HI*FACBW*HF
27341 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
27342 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
27344 KFREC=PYCOMP(KFRES)
27345 C...Propagators: as simulated in PYOFSH and as desired
27346 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
27347 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
27348 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
27349 GMMC=SQRT(SQM3)*WDTP(0)
27350 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
27351 FHCC=COMFAC*AEM*HBW3C/HBW3
27352 DO 310 I=MMINA,MMAXA
27354 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
27356 J=ISIGN(KFPR(ISUB,2),-I)
27357 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
27358 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
27359 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
27361 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
27362 & (TH-SQM4)*SH)/(TH-SQM4)**2
27363 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
27365 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
27366 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
27367 & ((UH-SQM3)*(TH-SQM4))
27368 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
27369 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
27370 & ((UH-SQM3)*(SH-SQML))
27371 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
27372 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
27373 & ((SH-SQML)*(TH-SQM4))
27374 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
27375 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
27377 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
27378 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
27381 ISIG(NCHN,3-ISDE)=22
27383 SIGH(NCHN)=FHCC*SMM*WIDSC
27387 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
27388 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
27390 KFREC=PYCOMP(KFRES)
27391 SQMH=PMAS(KFREC,1)**2
27392 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
27393 C...Propagators: H++/-- as simulated in PYOFSH and as desired
27394 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
27395 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
27396 GMMH3=SQRT(SQM3)*WDTP(0)
27397 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
27398 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
27399 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
27400 GMMH4=SQRT(SQM4)*WDTP(0)
27401 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
27402 C...Kinematical and coupling functions
27403 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
27404 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
27405 C...Loop over allowed flavours
27406 DO 320 I=MMINA,MMAXA
27407 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
27408 EI=KCHG(IABS(I),1)/3D0
27409 AI=SIGN(1D0,EI+0.1D0)
27412 IF(IABS(I).LE.10) FCOI=FACA/3D0
27413 IF(ISUB.EQ.349) THEN
27414 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
27415 IF(IABS(I).LT.10) THEN
27416 DSIGHH=8D0*AEM**2*(EI**2/SH2+
27417 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
27418 & (VI**2+AI**2)*XWHH**2*HBWZ)
27420 IAOFF=181+3*((IABS(I)-11)/2)
27421 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
27423 DSIGHH=8D0*AEM**2*(EI**2/SH2+
27424 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
27425 & (VI**2+AI**2)*XWHH**2*HBWZ)+
27426 & 8D0*AEM*(EI*HSUM/(SH*TH)+
27427 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
27431 IF(IABS(I).LT.10) THEN
27432 DSIGHH=8D0*AEM**2*EI**2/SH2
27434 IAOFF=181+3*((IABS(I)-11)/2)
27435 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
27437 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
27445 SIGH(NCHN)=FACHH*FCOI*DSIGHH
27448 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
27449 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
27451 KFREC=PYCOMP(KFRES)
27452 SQMH=PMAS(KFREC,1)**2
27453 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
27454 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
27455 & PMAS(PYCOMP(9900024),1)**2
27456 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
27457 FACPRT=1D0/((VINT(204)**2-VINT(215))*
27458 & (VINT(209)**2-VINT(216)))
27459 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
27460 & (VINT(209)**2+2D0*VINT(218)))
27461 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
27463 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
27464 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
27466 DO 340 I=MMIN1,MMAX1
27467 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
27468 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
27469 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
27470 DO 330 J=MMIN2,MMAX2
27471 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
27472 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
27473 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
27475 IF(IABS(KCHH).NE.2) GOTO 330
27476 FACLR=VINT(180+I)*VINT(180+J)
27477 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
27478 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
27479 FACPRP=0.5D0*(FACPRT+FACPRU)**2
27487 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
27491 ELSEIF(ISUB.EQ.353) THEN
27492 C...f + fbar -> Z_R0
27493 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
27494 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
27496 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
27497 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27498 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
27499 DO 350 I=MMINA,MMAXA
27500 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
27501 IF(IABS(I).LE.8) THEN
27502 EI=KCHG(IABS(I),1)/3D0
27503 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
27504 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
27509 HI=HP*(VI**2+AI**2)
27510 IF(IABS(I).LE.10) HI=HI*FACA/3D0
27515 SIGH(NCHN)=HI*FACBW*HF
27518 ELSEIF(ISUB.EQ.354) THEN
27519 C...f + fbar' -> W_R+/-
27520 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
27521 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
27523 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
27524 HP=AEM/(24D0*XW)*SH
27525 DO 370 I=MMIN1,MMAX1
27526 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
27528 DO 360 J=MMIN2,MMAX2
27529 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
27531 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
27532 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
27534 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
27536 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
27541 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
27542 SIGH(NCHN)=HI*FACBW*HF
27547 ELSEIF(ISUB.LE.400) THEN
27548 IF(ISUB.EQ.391) THEN
27549 C...f + fbar -> G*.
27550 KFGSTR=KFPR(ISUB,1)
27551 KCGSTR=PYCOMP(KFGSTR)
27552 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
27554 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27555 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
27556 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
27557 DO 380 I=MMINA,MMAXA
27558 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
27560 IF(IABS(I).LE.10) HI=HI*FACA/3D0
27568 ELSEIF(ISUB.EQ.392) THEN
27570 KFGSTR=KFPR(ISUB,1)
27571 KCGSTR=PYCOMP(KFGSTR)
27572 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
27574 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27575 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
27576 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
27577 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
27585 ELSEIF(ISUB.EQ.393) THEN
27586 C...q + qbar -> g + G*.
27587 KFGSTR=KFPR(ISUB,2)
27588 KCGSTR=PYCOMP(KFGSTR)
27589 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
27590 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
27591 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
27593 C...Propagators: as simulated in PYOFSH and as desired
27594 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
27595 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
27596 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
27597 HS=SQRT(SQM4)*WDTP(0)
27598 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27599 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
27600 FACG=FACG*HBW4C/HBW4
27601 DO 400 I=MMINA,MMAXA
27602 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
27603 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
27611 ELSEIF(ISUB.EQ.394) THEN
27612 C...q + g -> q + G*.
27613 KFGSTR=KFPR(ISUB,2)
27614 KCGSTR=PYCOMP(KFGSTR)
27615 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
27616 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
27617 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
27618 & 2D0*TH2*TH/(UH*SH2))
27619 C...Propagators: as simulated in PYOFSH and as desired
27620 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
27621 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
27622 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
27623 HS=SQRT(SQM4)*WDTP(0)
27624 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27625 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
27626 FACG=FACG*HBW4C/HBW4
27627 DO 420 I=MMINA,MMAXA
27628 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
27630 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
27631 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
27634 ISIG(NCHN,3-ISDE)=21
27640 ELSEIF(ISUB.EQ.395) THEN
27641 C...g + g -> g + G*.
27642 KFGSTR=KFPR(ISUB,2)
27643 KCGSTR=PYCOMP(KFGSTR)
27644 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
27645 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
27646 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
27647 C...Propagators: as simulated in PYOFSH and as desired
27648 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
27649 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
27650 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
27651 HS=SQRT(SQM4)*WDTP(0)
27652 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27653 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
27654 FACG=FACG*HBW4C/HBW4
27655 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
27668 C*********************************************************************
27671 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
27672 C...parton distributions according to a few different parametrizations.
27673 C...Note that what is coded is x times the probability distribution,
27674 C...i.e. xq(x,Q2) etc.
27676 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
27678 C...Double precision and integer declarations.
27679 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27680 IMPLICIT INTEGER(I-N)
27681 INTEGER PYK,PYCHGE,PYCOMP
27683 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27684 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27685 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27686 COMMON/PYINT1/MINT(400),VINT(400)
27687 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
27689 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
27691 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
27692 &XPPI(-6:6),XPPR(-6:6)
27694 C...Interface to PDFLIB.
27695 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
27697 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
27698 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
27699 CHARACTER*20 PARM(20)
27700 DATA VALUE/20*0D0/,PARM/20*' '/
27702 C...Data related to Schuler-Sjostrand photon distributions.
27703 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
27705 C...Reset parton distributions.
27711 C...Check x and particle species.
27712 IF(X.LE.0D0.OR.X.GE.1D0) THEN
27713 WRITE(MSTU(11),5000) X
27717 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
27718 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
27719 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
27720 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
27721 &KFA.NE.310.AND.KFA.NE.130) THEN
27722 WRITE(MSTU(11),5100) KF
27726 C...Electron (or muon or tau) parton distribution call.
27727 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
27728 CALL PYPDEL(KFA,X,Q2,XPEL)
27733 C...Photon parton distribution call (VDM+anomalous).
27734 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
27735 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
27736 CALL PYPDGA(X,Q2,XPGA)
27740 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
27743 IF(MSTP(55).GE.7) P2MX=4.0D0
27744 IF(MSTP(57).EQ.0) Q2MX=P2MX
27746 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27747 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
27752 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
27755 IF(MSTP(55).GE.11) P2MX=4.0D0
27756 IF(MSTP(57).EQ.0) Q2MX=P2MX
27758 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27759 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
27761 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
27764 ELSEIF(MSTP(56).EQ.2) THEN
27765 C...Call PDFLIB parton distributions.
27769 VALUE(2)=MSTP(55)/1000
27771 VALUE(3)=MOD(MSTP(55),1000)
27772 IF(MINT(93).NE.3000000+MSTP(55)) THEN
27773 CALL PDFSET(PARM,VALUE)
27774 MINT(93)=3000000+MSTP(55)
27777 QQ2=MAX(0D0,Q2MIN,Q2)
27778 IF(MSTP(57).EQ.0) QQ2=Q2MIN
27780 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27782 IF(MSTP(55).EQ.5004) THEN
27783 IF(5D0*P2.LT.QQ2.AND.
27784 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
27785 & P2.GE.0D0.AND.P2.LT.10D0.AND.
27786 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
27787 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
27802 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
27831 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
27834 C...Pion/gammaVDM parton distribution call.
27835 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
27836 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
27837 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
27838 & MSTP(55).LE.12) THEN
27839 ISET=1+MOD(MSTP(55)-1,4)
27842 IF(ISET.GE.3) P2MX=4.0D0
27843 IF(MSTP(57).EQ.0) Q2MX=P2MX
27845 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27846 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
27848 XPQ(KFL)=XPVMD(KFL)
27851 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
27852 CALL PYPDPI(X,Q2,XPPI)
27856 ELSEIF(MSTP(54).EQ.2) THEN
27857 C...Call PDFLIB parton distributions.
27861 VALUE(2)=MSTP(53)/1000
27863 VALUE(3)=MOD(MSTP(53),1000)
27864 IF(MINT(93).NE.2000000+MSTP(53)) THEN
27865 CALL PDFSET(PARM,VALUE)
27866 MINT(93)=2000000+MSTP(53)
27869 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27870 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27871 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27887 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
27890 C...Anomalous photon parton distribution call.
27891 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
27894 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
27895 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
27896 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
27897 IF(MSTP(57).EQ.0) Q2MX=P2MX
27899 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27900 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
27902 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
27905 ELSEIF(MSTP(56).EQ.1) THEN
27906 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
27907 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
27908 IF(MSTP(57).EQ.0) Q2MX=P2MX
27910 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27911 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
27913 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
27916 ELSEIF(MSTP(56).EQ.2) THEN
27917 IF(MSTP(57).EQ.0) Q2MX=P2MX
27918 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
27923 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
27924 IF(MSTP(57).EQ.0) Q2MX=P2MX
27925 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
27931 210 RKF=11D0*PYR(0)
27933 IF(RKF.GT.1D0) KFR=2
27934 IF(RKF.GT.5D0) KFR=3
27935 IF(RKF.GT.6D0) KFR=4
27936 IF(RKF.GT.10D0) KFR=5
27937 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
27938 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
27939 IF(MSTP(57).EQ.0) Q2MX=P2MX
27940 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
27947 C...Proton parton distribution call.
27949 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
27950 CALL PYPDPR(X,Q2,XPPR)
27954 ELSEIF(MSTP(52).EQ.2) THEN
27955 C...Call PDFLIB parton distributions.
27959 VALUE(2)=MSTP(51)/1000
27961 VALUE(3)=MOD(MSTP(51),1000)
27962 IF(MINT(93).NE.1000000+MSTP(51)) THEN
27963 CALL PDFSET_ALICE(PARM,VALUE)
27964 MINT(93)=1000000+MSTP(51)
27967 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27968 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27970 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27986 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
27990 C...Isospin average for pi0/gammaVDM.
27991 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
27992 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
27997 XPS=0.5D0*(XPQ(1)+XPQ(-2))
27998 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
28002 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
28003 XPQ(1)=XPQ(1)+0.2D0*XPV
28004 XPQ(-1)=XPQ(-1)+0.2D0*XPV
28005 XPQ(2)=XPQ(2)+0.8D0*XPV
28006 XPQ(-2)=XPQ(-2)+0.8D0*XPV
28007 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
28009 XPQ(-3)=XPQ(-3)+XPV
28010 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
28012 XPQ(-4)=XPQ(-4)+XPV
28013 IF(MSTP(55).GE.9) THEN
28019 XPQ(1)=XPQ(1)+0.5D0*XPV
28020 XPQ(-1)=XPQ(-1)+0.5D0*XPV
28021 XPQ(2)=XPQ(2)+0.5D0*XPV
28022 XPQ(-2)=XPQ(-2)+0.5D0*XPV
28025 C...Rescale for gammaVDM by effective gamma -> rho coupling.
28026 C+++Do not rescale?
28027 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
28028 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
28030 XPQ(KFL)=VINT(281)*XPQ(KFL)
28032 VINT(232)=VINT(281)*XPV
28035 C...Simple recipes for kaons.
28036 ELSEIF(KFA.EQ.321) THEN
28037 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
28039 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
28040 XPS=0.5D0*(XPQ(1)+XPQ(-2))
28041 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
28044 XPQ(1)=XPQ(1)+0.5D0*XPV
28045 XPQ(-1)=XPQ(-1)+0.5D0*XPV
28046 XPQ(3)=XPQ(3)+0.5D0*XPV
28047 XPQ(-3)=XPQ(-3)+0.5D0*XPV
28049 C...Isospin conjugation for neutron.
28050 ELSEIF(KFA.EQ.2112) THEN
28058 C...Simple recipes for hyperon (average valence parton distribution).
28059 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
28060 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
28061 XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
28062 XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
28067 XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
28068 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
28069 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
28072 C...Charge conjugation for antiparticle.
28075 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
28082 C...Allow gluon also in position 21.
28085 C...Check positivity and reset above maximum allowed flavour.
28087 XPQ(KFL)=MAX(0D0,XPQ(KFL))
28088 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
28091 C...Formats for error printouts.
28092 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
28093 5100 FORMAT(' Error: illegal particle code for parton distribution;',
28095 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
28101 C*********************************************************************
28104 C...Gives proton parton distribution at small x and/or Q^2 according to
28105 C...correct limiting behaviour.
28107 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
28109 C...Double precision and integer declarations.
28110 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28111 IMPLICIT INTEGER(I-N)
28112 INTEGER PYK,PYCHGE,PYCOMP
28114 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28115 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28116 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28117 COMMON/PYINT1/MINT(400),VINT(400)
28118 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28120 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
28121 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
28123 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
28127 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
28128 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
28129 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
28131 CALL PYPDFU(KF,X,Q2,XPQ)
28135 C...Reset. Check x.
28139 IF(X.LE.0D0.OR.X.GE.1D0) THEN
28140 WRITE(MSTU(11),5000) X
28144 C...Define valence content.
28148 IF(KF.EQ.2212) THEN
28151 ELSEIF(KF.EQ.-2212) THEN
28154 ELSEIF(KF.EQ.2112) THEN
28157 ELSEIF(KF.EQ.-2112) THEN
28160 ELSEIF(KF.EQ.211) THEN
28164 ELSEIF(KF.EQ.-211) THEN
28168 ELSEIF(MINT(105).LE.223) THEN
28173 ELSEIF(MINT(105).EQ.333) THEN
28178 ELSEIF(MINT(105).EQ.443) THEN
28185 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
28186 CALL PYPDFU(KFC,X,Q2,XPA)
28187 Q2MN=MAX(3D0,VINT(231))
28188 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
28189 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
28191 C...Large Q2 and large x: naive call is enough.
28192 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
28198 C...Small Q2 and large x: dampen boundary value.
28199 ELSEIF(X.GT.XMN) THEN
28201 C...Evaluate at boundary and define dampening factors.
28202 CALL PYPDFU(KFC,X,Q2MN,XPA)
28203 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
28204 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
28206 C...Separate valence and sea parts of parton distribution.
28208 XFV1=XPA(KFV1)-XPA(-KFV1)
28209 XPA(KFV1)=XPA(-KFV1)
28210 XFV2=XPA(KFV2)-XPA(-KFV2)
28211 XPA(KFV2)=XPA(-KFV2)
28213 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
28214 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
28215 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
28216 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
28219 C...Dampen valence and sea separately. Put back together.
28221 XPQ(KFL)=FS*XPA(KFL)
28224 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
28225 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
28227 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
28228 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
28229 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
28230 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
28234 C...Large Q2 and small x: interpolate behaviour.
28235 ELSEIF(Q2.GT.Q2MN) THEN
28237 C...Evaluate at extremes and define coefficients for interpolation.
28238 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
28240 CALL PYPDFU(KFC,X,Q2B,XPB)
28242 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
28243 FVA=(X/XMN)**0.45D0*FLA
28244 FSA=(X/XMN)**(-0.08D0)*FLA
28247 C...Separate valence and sea parts of parton distribution.
28249 XFVA1=XPA(KFV1)-XPA(-KFV1)
28250 XPA(KFV1)=XPA(-KFV1)
28251 XFVA2=XPA(KFV2)-XPA(-KFV2)
28252 XPA(KFV2)=XPA(-KFV2)
28253 XFVB1=XPB(KFV1)-XPB(-KFV1)
28254 XPB(KFV1)=XPB(-KFV1)
28255 XFVB2=XPB(KFV2)-XPB(-KFV2)
28256 XPB(KFV2)=XPB(-KFV2)
28258 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
28259 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
28260 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
28261 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
28262 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
28263 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
28264 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
28265 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
28268 C...Interpolate for valence and sea. Put back together.
28270 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
28273 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
28274 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
28276 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
28277 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
28278 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
28279 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
28283 C...Small Q2 and small x: dampen boundary value and add term.
28286 C...Evaluate at boundary and define dampening factors.
28287 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
28288 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
28290 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
28291 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
28292 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
28293 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
28294 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
28295 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
28297 C...Separate valence and sea parts of parton distribution.
28299 XFV1=XPA(KFV1)-XPA(-KFV1)
28300 XPA(KFV1)=XPA(-KFV1)
28301 XFV2=XPA(KFV2)-XPA(-KFV2)
28302 XPA(KFV2)=XPA(-KFV2)
28304 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
28305 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
28306 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
28307 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
28310 C...Dampen valence and sea separately. Add constant terms.
28311 C...Put back together.
28313 XPQ(KFL)=FSA*XPA(KFL)
28317 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
28319 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
28320 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
28323 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
28325 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
28326 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
28327 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
28328 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
28334 C...Format for error printout.
28335 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
28340 C*********************************************************************
28343 C...Gives electron (or muon, or tau) parton distribution.
28345 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
28347 C...Double precision and integer declarations.
28348 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28349 IMPLICIT INTEGER(I-N)
28350 INTEGER PYK,PYCHGE,PYCOMP
28352 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28353 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28354 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28355 COMMON/PYINT1/MINT(400),VINT(400)
28356 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28358 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
28360 C...Interface to PDFLIB.
28361 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
28363 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
28364 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
28365 CHARACTER*20 PARM(20)
28366 DATA VALUE/20*0D0/,PARM/20*' '/
28368 C...Some common constants.
28374 IF(KFA.EQ.13) PME=PMAS(13,1)
28375 IF(KFA.EQ.15) PME=PMAS(15,1)
28376 XL=LOG(MAX(1D-10,X))
28377 X1L=LOG(MAX(1D-10,1D0-X))
28378 HLE=LOG(MAX(3D0,Q2/PME**2))
28379 HBE2=(AEM/PARU(1))*(HLE-1D0)
28381 C...Electron inside electron, see R. Kleiss et al., in Z physics at
28382 C...LEP 1, CERN 89-08, p. 34
28383 IF(MSTP(59).LE.1) THEN
28384 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
28385 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
28386 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
28387 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
28388 & 4D0*XL/(1D0-X)-5D0-X)
28390 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
28391 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
28392 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
28394 C...Zero distribution for very large x and rescale it for intermediate.
28395 IF(X.GT.1D0-1D-10) THEN
28397 ELSEIF(X.GT.1D0-1D-7) THEN
28398 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
28402 C...Photon and (transverse) W- inside electron.
28403 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
28404 IF(MSTP(13).LE.1) THEN
28407 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
28409 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
28410 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
28411 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
28413 C...Electron or positron inside photon inside electron.
28414 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
28415 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
28416 & 2D0*X*(1D0+X)*XL)
28417 XPEL(11)=XPEL(11)+XFSEA
28420 C...Initialize PDFLIB photon parton distributions.
28421 IF(MSTP(56).EQ.2) THEN
28425 VALUE(2)=MSTP(55)/1000
28427 VALUE(3)=MOD(MSTP(55),1000)
28428 IF(MINT(93).NE.3000000+MSTP(55)) THEN
28429 CALL PDFSET(PARM,VALUE)
28430 MINT(93)=3000000+MSTP(55)
28434 C...Quarks and gluons inside photon inside electron:
28435 C...numerical convolution required.
28444 IF(ITER.EQ.0) NSTP=2
28446 SXP(KFL)=0.5D0*SXP(KFL)
28449 IF(ITER.EQ.0) WTSTP=0.5D0
28450 C...Pick grid of x_{gamma} values logarithmically even.
28455 XLE=XL*(ISTP-0.5D0)/NSTP
28457 XE=MIN(1D0-1D-10,EXP(XLE))
28458 XG=MIN(1D0-1D-10,X/XE)
28459 C...Evaluate photon inside electron parton distribution for convolution.
28460 XPGP=1D0+(1D0-XE)**2
28461 IF(MSTP(13).LE.1) THEN
28464 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
28466 C...Evaluate photon parton distributions for convolution.
28467 IF(MSTP(56).EQ.1) THEN
28468 IF(MSTP(55).EQ.1) THEN
28469 CALL PYPDGA(XG,Q2,XPGA)
28470 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
28473 IF(MSTP(55).GE.7) P2MX=4.0D0
28474 IF(MSTP(57).EQ.0) Q2MX=P2MX
28476 IF(VINT(120).LT.0D0) P2=VINT(120)**2
28477 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
28479 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
28482 IF(MSTP(55).GE.11) P2MX=4.0D0
28483 IF(MSTP(57).EQ.0) Q2MX=P2MX
28485 IF(VINT(120).LT.0D0) P2=VINT(120)**2
28486 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
28490 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
28492 ELSEIF(MSTP(56).EQ.2) THEN
28493 C...Call PDFLIB parton distributions.
28495 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
28496 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
28497 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
28498 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
28499 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
28500 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
28501 SXP(3)=SXP(3)+WTSTP*XPGP*STR
28502 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
28503 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
28504 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
28507 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
28508 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
28509 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
28511 C...Put convolution into output arrays.
28513 XPEL(0)=FCONV*SXP(0)
28515 XPEL(KFL)=FCONV*SXP(KFL)
28516 XPEL(-KFL)=XPEL(KFL)
28523 C*********************************************************************
28526 C...Gives photon parton distribution.
28528 SUBROUTINE PYPDGA(X,Q2,XPGA)
28530 C...Double precision and integer declarations.
28531 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28532 IMPLICIT INTEGER(I-N)
28533 INTEGER PYK,PYCHGE,PYCOMP
28535 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28536 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28537 COMMON/PYINT1/MINT(400),VINT(400)
28538 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
28540 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
28541 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
28542 &DGCS(4,3),DGDS(4,3),DGES(4,3)
28544 C...The following data lines are coefficients needed in the
28545 C...Drees and Grassie photon parton distribution parametrization.
28546 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
28547 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
28548 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
28549 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
28550 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
28551 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
28552 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
28553 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
28554 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
28555 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
28556 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
28557 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
28558 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
28559 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
28560 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
28561 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
28562 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
28563 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
28564 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
28565 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
28566 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
28567 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
28568 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
28569 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
28570 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
28571 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
28573 C...Photon parton distribution from Drees and Grassie.
28574 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
28579 IF(MSTP(57).LE.0) THEN
28582 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
28586 IF(Q2.GT.25D0) NF=4
28587 IF(Q2.GT.300D0) NF=5
28591 C...Evaluate gluon content.
28592 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
28593 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
28594 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
28595 XPGL=DGA*X**DGB*X1**DGC
28597 C...Evaluate up- and down-type quark content.
28598 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
28599 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
28600 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
28601 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
28602 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
28603 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
28604 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
28605 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
28606 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
28607 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
28608 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
28610 IF(NF.EQ.4) DGF=10D0
28611 IF(NF.EQ.5) DGF=55D0/6D0
28612 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
28614 XPQU=(XPQS+9D0*XPQN)/6D0
28615 XPQD=(XPQS-4.5D0*XPQN)/6D0
28616 ELSEIF(NF.EQ.4) THEN
28617 XPQU=(XPQS+6D0*XPQN)/8D0
28618 XPQD=(XPQS-6D0*XPQN)/8D0
28620 XPQU=(XPQS+7.5D0*XPQN)/10D0
28621 XPQD=(XPQS-5D0*XPQN)/10D0
28624 C...Put into output arrays.
28629 IF(NF.GE.4) XPGA(4)=AEM*XPQU
28630 IF(NF.GE.5) XPGA(5)=AEM*XPQD
28632 XPGA(-KFL)=XPGA(KFL)
28638 C*********************************************************************
28641 C...Constructs the F2 and parton distributions of the photon
28642 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
28643 C...For F2, c and b are included by the Bethe-Heitler formula;
28644 C...in the 'MSbar' scheme additionally a Cgamma term is added.
28645 C...Contains the SaS sets 1D, 1M, 2D and 2M.
28646 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28648 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
28650 C...Double precision and integer declarations.
28651 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28652 IMPLICIT INTEGER(I-N)
28653 INTEGER PYK,PYCHGE,PYCOMP
28655 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
28657 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
28658 SAVE /PYINT8/,/PYINT9/
28660 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
28661 C...Charm and bottom masses (low to compensate for J/psi etc.).
28662 DATA PMC/1.3D0/, PMB/4.6D0/
28663 C...alpha_em and alpha_em/(2*pi).
28664 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
28665 C...Lambda value for 4 flavours.
28667 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
28669 C...VMD couplings f_V**2/(4*pi).
28670 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
28671 C...Masses for rho (=omega) and phi.
28672 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
28673 C...Number of points in integration for IP2=1.
28691 C...Set Q0 cut-off parameter as function of set used.
28699 C...Scale choice for off-shell photon; common factors.
28704 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
28705 FACNOR=LOG(Q2/Q02)/NSTEP
28706 ELSEIF(IP2.EQ.2) THEN
28708 ELSEIF(IP2.EQ.3) THEN
28710 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
28711 ELSEIF(IP2.EQ.4) THEN
28712 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28713 & ((Q2+P2)*(Q02+P2)))
28714 ELSEIF(IP2.EQ.5) THEN
28715 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28716 & ((Q2+P2)*(Q02+P2)))
28717 P2MX=Q0*SQRT(P2MXA)
28718 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
28719 ELSEIF(IP2.EQ.6) THEN
28720 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28721 & ((Q2+P2)*(Q02+P2)))
28722 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
28724 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28725 & ((Q2+P2)*(Q02+P2)))
28726 P2MX=Q0*SQRT(P2MXA)
28728 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
28729 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
28730 IF(ABS(Q2-Q02).GT.1D-6) THEN
28731 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
28732 ELSEIF(P2.LT.Q02) THEN
28733 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
28739 C...Call VMD parametrization for d quark and use to give rho, omega,
28740 C...phi. Note dipole dampening for off-shell photon.
28741 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28745 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
28746 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
28748 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
28750 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
28751 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
28752 XPVMD(3)=XPVMD(3)+FACS*XFVAL
28753 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
28754 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
28755 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
28756 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
28757 VXPVMD(2)=FRACU*FACUD*XFVAL
28758 VXPVMD(3)=FACS*XFVAL
28759 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
28760 VXPVMD(-2)=FRACU*FACUD*XFVAL
28761 VXPVMD(-3)=FACS*XFVAL
28764 C...Anomalous parametrizations for different strategies
28765 C...for off-shell photons; except full integration.
28767 C...Call anomalous parametrization for d + u + s.
28768 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28770 XPANL(KFL)=FACNOR*XPGA(KFL)
28771 VXPANL(KFL)=FACNOR*VXPGA(KFL)
28774 C...Call anomalous parametrization for c and b.
28775 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28777 XPANH(KFL)=FACNOR*XPGA(KFL)
28778 VXPANH(KFL)=FACNOR*VXPGA(KFL)
28780 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28782 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
28783 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
28787 C...Special option: loop over flavours and integrate over k2.
28789 DO 160 ISTEP=1,NSTEP
28790 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
28791 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
28792 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
28793 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
28794 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
28795 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
28796 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
28798 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
28799 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
28800 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
28801 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
28807 C...Call Bethe-Heitler term expression for charm and bottom.
28808 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
28811 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
28815 C...For MSbar subtraction call C^gamma term expression for d, u, s.
28816 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
28817 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
28819 XPDIR(KFL)=XPGA(KFL)
28823 C...Store result in output array.
28826 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
28827 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
28828 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
28829 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
28830 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
28836 C*********************************************************************
28839 C...Evaluates the VMD parton distributions of a photon,
28840 C...evolved homogeneously from an initial scale P2 to Q2.
28841 C...Does not include dipole suppression factor.
28842 C...ISET is parton distribution set, see above;
28843 C...additionally ISET=0 is used for the evolution of an anomalous photon
28844 C...which branched at a scale P2 and then evolved homogeneously to Q2.
28845 C...ALAM is the 4-flavour Lambda, which is automatically converted
28846 C...to 3- and 5-flavour equivalents as needed.
28847 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28849 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
28851 C...Double precision and integer declarations.
28852 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28853 IMPLICIT INTEGER(I-N)
28854 INTEGER PYK,PYCHGE,PYCOMP
28855 C...Local arrays and data.
28856 DIMENSION XPGA(-6:6), VXPGA(-6:6)
28857 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
28866 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
28867 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
28868 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
28869 P2EFF=MAX(P2,1.2D0*ALAM3**2)
28870 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
28871 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
28872 Q2EFF=MAX(Q2,P2EFF)
28874 C...Find number of flavours at lower and upper scale.
28876 IF(P2EFF.LT.PMC**2) NFP=3
28877 IF(P2EFF.GT.PMB**2) NFP=5
28879 IF(Q2EFF.LT.PMC**2) NFQ=3
28880 IF(Q2EFF.GT.PMB**2) NFQ=5
28882 C...Find s as sum of 3-, 4- and 5-flavour parts.
28886 IF(NFQ.EQ.3) Q2DIV=Q2EFF
28887 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
28889 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
28891 IF(NFP.EQ.3) P2DIV=PMC**2
28893 IF(NFQ.EQ.5) Q2DIV=PMB**2
28894 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
28898 IF(NFP.EQ.5) P2DIV=P2EFF
28899 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
28902 C...Calculate frequent combinations of x and s.
28909 C...Evaluate homogeneous anomalous parton distributions below or
28910 C...above threshold.
28912 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28913 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28914 XVAL = X * 1.5D0 * (X**2+X1**2)
28918 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
28919 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
28920 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
28921 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
28922 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
28923 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
28924 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
28925 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
28926 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
28927 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
28928 & (2D0*X-1D0)*X*XL**2)
28931 C...Evaluate set 1D parton distributions below or above threshold.
28932 ELSEIF(ISET.EQ.1) THEN
28933 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28934 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28935 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
28936 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
28937 XSEA = 0.100D0 * X1**3.76D0
28939 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
28940 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
28941 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
28942 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
28943 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
28944 & X**0.40D0 * X1**(1.76D0+3D0*S)
28945 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
28946 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
28947 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
28948 XSEA0 = 0.100D0 * X1**3.76D0
28951 C...Evaluate set 1M parton distributions below or above threshold.
28952 ELSEIF(ISET.EQ.2) THEN
28953 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28954 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28955 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
28956 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
28959 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
28960 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
28961 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
28962 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
28963 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
28964 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
28965 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
28966 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
28971 C...Evaluate set 2D parton distributions below or above threshold.
28972 ELSEIF(ISET.EQ.3) THEN
28973 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28974 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28975 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
28976 XGLU = 1.925D0 * X1**2
28977 XSEA = 0.242D0 * X1**4
28979 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
28980 & X**(0.46D0+0.25D0*S) *
28981 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
28982 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
28983 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
28984 & EXP(-18.67D0*S) *
28985 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
28986 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
28987 & XL**(9.3D0*S/(1D0+1.7D0*S))
28988 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
28989 & (1D0-0.607D0*S+21.95D0*S2) *
28990 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
28991 XSEA0 = 0.242D0 * X1**4
28994 C...Evaluate set 2M parton distributions below or above threshold.
28995 ELSEIF(ISET.EQ.4) THEN
28996 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28997 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28998 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
28999 XGLU = 1.808D0 * X1**2
29000 XSEA = 0.209D0 * X1**4
29002 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
29003 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
29004 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
29005 & XL**(5.15D0*S/(1D0+2D0*S)) +
29006 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
29007 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
29008 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
29009 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
29010 & XL**(10.9D0*S/(1D0+2.5D0*S))
29011 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
29012 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
29013 & X1**(4D0+S) * XL**(0.45D0*S)
29014 XSEA0 = 0.209D0 * X1**4
29018 C...Threshold factors for c and b sea.
29019 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
29021 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29022 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29024 XCHM=XSEA*(1D0-(SCH/SLL)**2)
29026 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
29030 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29031 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29033 XBOT=XSEA*(1D0-(SBT/SLL)**2)
29035 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
29039 C...Fill parton distributions.
29046 XPGA(KFA)=XPGA(KFA)+XVAL
29048 XPGA(-KFL)=XPGA(KFL)
29056 C*********************************************************************
29059 C...Evaluates the parton distributions of the anomalous photon,
29060 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
29061 C...KF=0 gives the sum over (up to) 5 flavours,
29062 C...KF<0 limits to flavours up to abs(KF),
29063 C...KF>0 is for flavour KF only.
29064 C...ALAM is the 4-flavour Lambda, which is automatically converted
29065 C...to 3- and 5-flavour equivalents as needed.
29066 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
29068 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
29070 C...Double precision and integer declarations.
29071 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29072 IMPLICIT INTEGER(I-N)
29073 INTEGER PYK,PYCHGE,PYCOMP
29074 C...Local arrays and data.
29075 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
29076 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
29083 IF(Q2.LE.P2) RETURN
29086 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
29087 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
29089 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
29090 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
29091 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
29092 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
29093 Q2EFF=MAX(Q2,P2EFF)
29096 C...Find number of flavours at lower and upper scale.
29098 IF(P2EFF.LT.PMC**2) NFP=3
29099 IF(P2EFF.GT.PMB**2) NFP=5
29101 IF(Q2EFF.LT.PMC**2) NFQ=3
29102 IF(Q2EFF.GT.PMB**2) NFQ=5
29104 C...Define range of flavour loop.
29108 ELSEIF(KF.LT.0) THEN
29116 C...Loop over flavours the photon can branch into.
29117 DO 110 KFL=KFLMN,KFLMX
29119 C...Light flavours: calculate t range and (approximate) s range.
29120 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
29121 TDIFF=LOG(Q2EFF/P2EFF)
29122 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
29123 & LOG(P2EFF/ALAMSQ(NFQ)))
29124 IF(NFQ.GT.NFP) THEN
29126 IF(NFQ.EQ.4) Q2DIV=PMC**2
29127 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
29128 & LOG(P2EFF/ALAMSQ(NFQ)))
29129 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
29130 & LOG(P2EFF/ALAMSQ(NFQ-1)))
29131 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
29133 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
29135 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
29136 & LOG(P2EFF/ALAMSQ(4)))
29137 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
29138 & LOG(P2EFF/ALAMSQ(3)))
29139 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
29142 C...u and s quark do not need a separate treatment when d has been done.
29143 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
29145 C...Charm: as above, but only include range above c threshold.
29146 ELSEIF(KFL.EQ.4) THEN
29147 IF(Q2.LE.PMC**2) GOTO 110
29148 P2EFF=MAX(P2EFF,PMC**2)
29149 Q2EFF=MAX(Q2EFF,P2EFF)
29150 TDIFF=LOG(Q2EFF/P2EFF)
29151 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
29152 & LOG(P2EFF/ALAMSQ(NFQ)))
29153 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
29155 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
29156 & LOG(P2EFF/ALAMSQ(NFQ)))
29157 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
29158 & LOG(P2EFF/ALAMSQ(NFQ-1)))
29159 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
29162 C...Bottom: as above, but only include range above b threshold.
29163 ELSEIF(KFL.EQ.5) THEN
29164 IF(Q2.LE.PMB**2) GOTO 110
29165 P2EFF=MAX(P2EFF,PMB**2)
29166 Q2EFF=MAX(Q2,P2EFF)
29167 TDIFF=LOG(Q2EFF/P2EFF)
29168 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
29169 & LOG(P2EFF/ALAMSQ(NFQ)))
29172 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
29174 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
29175 FAC=AEM2PI*2D0*CHSQ*TDIFF
29177 C...Evaluate parton distributions (normalized to unit momentum sum).
29178 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
29179 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
29180 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
29181 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
29182 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
29183 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
29184 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
29185 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
29186 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
29187 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
29188 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
29189 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
29191 C...Threshold factors for c and b sea.
29192 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
29194 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29195 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29196 XCHM=XSEA*(1D0-(SCH/SLL)**3)
29199 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29200 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29201 XBOT=XSEA*(1D0-(SBT/SLL)**3)
29205 C...Add contribution of each valence flavour.
29206 XPGA(0)=XPGA(0)+FAC*XGLU
29207 XPGA(1)=XPGA(1)+FAC*XSEA
29208 XPGA(2)=XPGA(2)+FAC*XSEA
29209 XPGA(3)=XPGA(3)+FAC*XSEA
29210 XPGA(4)=XPGA(4)+FAC*XCHM
29211 XPGA(5)=XPGA(5)+FAC*XBOT
29212 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
29213 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
29216 XPGA(-KFL)=XPGA(KFL)
29217 VXPGA(-KFL)=VXPGA(KFL)
29223 C*********************************************************************
29226 C...Evaluates the Bethe-Heitler cross section for heavy flavour
29228 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
29230 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
29232 C...Double precision and integer declarations.
29233 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29234 IMPLICIT INTEGER(I-N)
29235 INTEGER PYK,PYCHGE,PYCOMP
29238 DATA AEM2PI/0.0011614D0/
29244 C...Check kinematics limits.
29245 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
29247 BETA2=1D0-4D0*PM2/W2
29248 IF(BETA2.LT.1D-10) RETURN
29252 C...Simple case: P2 = 0.
29253 IF(P2.LT.1D-4) THEN
29254 IF(BETA.LT.0.99D0) THEN
29255 XBL=LOG((1D0+BETA)/(1D0-BETA))
29257 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
29259 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
29260 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
29262 C...Complicated case: P2 > 0, based on approximation of
29263 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
29265 RPQ=1D0-4D0*X**2*P2/Q2
29266 IF(RPQ.GT.1D-10) THEN
29267 RPBE=SQRT(RPQ*BETA2)
29268 IF(RPBE.LT.0.99D0) THEN
29269 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
29270 XBI=2D0*RPBE/(1D0-RPBE**2)
29272 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
29273 XBL=LOG((1D0+RPBE)**2/RPBESN)
29274 XBI=2D0*RPBE/RPBESN
29276 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
29277 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
29278 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
29282 C...Multiply by charge-squared etc. to get parton distribution.
29284 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
29285 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
29290 C*********************************************************************
29293 C...Evaluates the direct contribution, i.e. the C^gamma term,
29294 C...as needed in MSbar parametrizations.
29295 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
29297 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
29299 C...Double precision and integer declarations.
29300 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29301 IMPLICIT INTEGER(I-N)
29302 INTEGER PYK,PYCHGE,PYCOMP
29303 C...Local array and data.
29304 DIMENSION XPGA(-6:6)
29305 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
29312 C...Evaluate common x-dependent expression.
29313 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
29314 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
29316 C...d, u, s part by simple charge factor.
29317 XPGA(1)=(1D0/9D0)*CGAM
29318 XPGA(2)=(4D0/9D0)*CGAM
29319 XPGA(3)=(1D0/9D0)*CGAM
29321 C...Also fill for antiquarks.
29329 C*********************************************************************
29332 C...Gives pi+ parton distribution according to two different
29333 C...parametrizations.
29335 SUBROUTINE PYPDPI(X,Q2,XPPI)
29337 C...Double precision and integer declarations.
29338 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29339 IMPLICIT INTEGER(I-N)
29340 INTEGER PYK,PYCHGE,PYCOMP
29342 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29343 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29344 COMMON/PYINT1/MINT(400),VINT(400)
29345 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
29347 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
29349 C...The following data lines are coefficients needed in the
29350 C...Owens pion parton distribution parametrizations, see below.
29351 C...Expansion coefficients for up and down valence quark distributions.
29352 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
29353 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29354 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29355 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
29356 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
29357 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29358 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29359 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
29360 C...Expansion coefficients for gluon distribution.
29361 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
29362 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
29363 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
29364 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
29365 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
29366 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
29367 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
29368 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
29369 C...Expansion coefficients for (up+down+strange) quark sea distribution.
29370 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
29371 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
29372 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
29373 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
29374 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
29375 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
29376 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
29377 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
29378 C...Expansion coefficients for charm quark sea distribution.
29379 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
29380 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
29381 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
29382 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
29383 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
29384 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
29385 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
29386 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
29388 C...Euler's beta function, requires ordinary Gamma function
29389 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
29391 C...Reset output array.
29396 IF(MSTP(53).LE.2) THEN
29397 C...Pion parton distributions from Owens.
29398 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
29400 C...Determine set, Lambda and s expansion variable.
29402 IF(NSET.EQ.1) ALAM=0.2D0
29403 IF(NSET.EQ.2) ALAM=0.4D0
29405 IF(MSTP(57).LE.0) THEN
29408 Q2IN=MIN(2D3,MAX(4D0,Q2))
29409 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
29412 C...Calculate parton distributions.
29415 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
29416 & COW(3,IS,KFL,NSET)*SD**2
29419 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
29421 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
29426 C...Put into output array.
29429 XPPI(2)=XQ(1)+XQ(3)/6D0
29432 XPPI(-1)=XQ(1)+XQ(3)/6D0
29437 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
29438 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
29442 C...Determine s expansion variable and some x expressions.
29444 IF(MSTP(57).LE.0) THEN
29447 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
29448 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
29454 C...Evaluate valence, gluon and sea distributions.
29455 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
29456 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
29457 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
29459 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
29460 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
29462 & (1D0-X)**(0.390D0+1.053D0*SD)
29463 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
29465 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
29467 & XL**(2.538D0-0.763D0*SD)
29468 IF(SD.LE.0.888D0) THEN
29471 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
29473 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
29476 IF(SD.LE.1.351D0) THEN
29479 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
29480 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
29484 C...Put into output array.
29492 XPPI(-KFL)=XPPI(KFL)
29494 XPPI(2)=XPPI(2)+XFVAL
29495 XPPI(-1)=XPPI(-1)+XFVAL
29501 C*********************************************************************
29504 C...Gives proton parton distributions according to a few different
29505 C...parametrizations.
29507 SUBROUTINE PYPDPR(X,Q2,XPPR)
29509 C...Double precision and integer declarations.
29510 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29511 IMPLICIT INTEGER(I-N)
29512 INTEGER PYK,PYCHGE,PYCOMP
29514 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29515 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29516 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29517 COMMON/PYINT1/MINT(400),VINT(400)
29518 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
29519 C...Arrays and data.
29520 DIMENSION XPPR(-6:6),Q2MIN(16)
29521 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
29522 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
29524 C...Reset output array.
29529 C...Common preliminaries.
29530 NSET=MAX(1,MIN(16,MSTP(51)))
29531 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
29532 VINT(231)=Q2MIN(NSET)
29533 IF(MSTP(57).EQ.0) THEN
29536 Q2L=MAX(Q2MIN(NSET),Q2)
29539 IF(NSET.GE.1.AND.NSET.LE.3) THEN
29540 C...Interface to the CTEQ 3 parton distributions.
29541 QRT=SQRT(MAX(1D0,Q2L))
29543 C...Loop over flavours.
29546 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
29547 ELSEIF(I.LE.2) THEN
29548 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
29554 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
29555 C...Interface to the GRV 94 distributions.
29557 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29558 ELSEIF(NSET.EQ.5) THEN
29559 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29561 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29564 C...Put into output array.
29566 XPPR(-1)=0.5D0*(UDB+DEL)
29567 XPPR(-2)=0.5D0*(UDB-DEL)
29571 XPPR(1)=DV+XPPR(-1)
29572 XPPR(2)=UV+XPPR(-2)
29577 ELSEIF(NSET.EQ.7) THEN
29578 C...Interface to the CTEQ 5L parton distributions.
29579 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
29580 C...freezing x*f(x,Q2) at borders.
29581 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
29582 XIN=MAX(1D-6,MIN(1D0,X))
29584 C...Loop over flavours (with u <-> d notation mismatch).
29585 SUMUDB=PYCT5L(-1,XIN,QRT)
29586 RATUDB=PYCT5L(-2,XIN,QRT)
29589 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
29590 ELSEIF(I.EQ.2) THEN
29591 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
29592 ELSEIF(I.EQ.-1) THEN
29593 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
29594 ELSEIF(I.EQ.-2) THEN
29595 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
29597 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
29598 IF(I.LT.0) XPPR(-I)=XPPR(I)
29602 ELSEIF(NSET.EQ.8) THEN
29603 C...Interface to the CTEQ 5M1 parton distributions.
29604 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
29605 XIN=MAX(1D-6,MIN(1D0,X))
29607 C...Loop over flavours (with u <-> d notation mismatch).
29608 SUMUDB=PYCT5M(-1,XIN,QRT)
29609 RATUDB=PYCT5M(-2,XIN,QRT)
29612 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
29613 ELSEIF(I.EQ.2) THEN
29614 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
29615 ELSEIF(I.EQ.-1) THEN
29616 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
29617 ELSEIF(I.EQ.-2) THEN
29618 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
29620 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
29621 IF(I.LT.0) XPPR(-I)=XPPR(I)
29625 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
29626 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
29627 C...obsolete but offers backwards compatibility.
29628 CALL PYPDPO(X,Q2L,XPPR)
29630 C...Symmetric choice for debugging only
29631 ELSEIF(NSET.EQ.16) THEN
29649 C*********************************************************************
29652 C...Gives the CTEQ 3 parton distribution function sets in
29653 C...parametrized form, of October 24, 1994.
29654 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
29655 C...J. Qiu, W.K. Tung and H. Weerts.
29657 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
29659 C...Double precision declaration.
29660 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29661 IMPLICIT INTEGER(I-N)
29663 C...Data on Lambda values of fits, minimum Q and quark masses.
29664 DIMENSION ALM(3), QMS(4:6)
29665 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
29666 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
29668 C....Check flavour thresholds. Set up QI for SB.
29671 IF(Q .LE. QMS(IP)) THEN
29680 C...Use "standard lambda" of parametrization program for expansion.
29682 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
29687 C...Expansion for CTEQ3L.
29688 IF(ISET .EQ. 1) THEN
29689 IF(IPRT .EQ. 2) THEN
29690 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
29692 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
29693 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
29694 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
29695 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
29696 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
29697 ELSEIF(IPRT .EQ. 1) THEN
29698 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
29700 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
29701 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
29702 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
29703 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
29704 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
29705 ELSEIF(IPRT .EQ. 0) THEN
29706 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
29708 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
29709 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
29710 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
29711 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
29712 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
29713 ELSEIF(IPRT .EQ. -1) THEN
29714 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
29716 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
29717 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
29718 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
29719 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
29720 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
29721 ELSEIF(IPRT .EQ. -2) THEN
29722 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
29724 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
29725 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
29726 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
29727 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
29728 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
29729 ELSEIF(IPRT .EQ. -3) THEN
29730 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
29732 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
29733 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
29734 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
29735 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
29736 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
29737 ELSEIF(IPRT .EQ. -4) THEN
29738 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
29740 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
29741 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
29742 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
29743 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
29744 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
29745 ELSEIF(IPRT .EQ. -5) THEN
29746 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
29748 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
29749 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
29750 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
29751 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
29752 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
29753 ELSEIF(IPRT .EQ. -6) THEN
29754 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
29756 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
29757 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
29758 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
29759 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
29760 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
29763 C...Expansion for CTEQ3M.
29764 ELSEIF(ISET .EQ. 2) THEN
29765 IF(IPRT .EQ. 2) THEN
29766 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
29768 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
29769 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
29770 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
29771 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
29772 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
29773 ELSEIF(IPRT .EQ. 1) THEN
29774 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
29776 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
29777 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
29778 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
29779 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
29780 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
29781 ELSEIF(IPRT .EQ. 0) THEN
29782 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
29784 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
29785 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
29786 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
29787 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
29788 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
29789 ELSEIF(IPRT .EQ. -1) THEN
29790 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
29792 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
29793 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
29794 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
29795 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
29796 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
29797 ELSEIF(IPRT .EQ. -2) THEN
29798 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
29800 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
29801 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
29802 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
29803 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
29804 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
29805 ELSEIF(IPRT .EQ. -3) THEN
29806 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
29808 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
29809 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
29810 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
29811 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
29812 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
29813 ELSEIF(IPRT .EQ. -4) THEN
29814 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
29816 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
29817 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
29818 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
29819 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
29820 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
29821 ELSEIF(IPRT .EQ. -5) THEN
29822 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
29824 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
29825 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
29826 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
29827 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
29828 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
29829 ELSEIF(IPRT .EQ. -6) THEN
29830 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
29832 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
29833 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
29834 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
29835 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
29836 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
29839 C...Expansion for CTEQ3D.
29840 ELSEIF(ISET .EQ. 3) THEN
29841 IF(IPRT .EQ. 2) THEN
29842 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
29844 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
29845 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
29846 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
29847 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
29848 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
29849 ELSEIF(IPRT .EQ. 1) THEN
29850 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
29852 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
29853 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
29854 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
29855 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
29856 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
29857 ELSEIF(IPRT .EQ. 0) THEN
29858 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
29860 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
29861 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
29862 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
29863 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
29864 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
29865 ELSEIF(IPRT .EQ. -1) THEN
29866 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
29868 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
29869 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
29870 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
29871 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
29872 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
29873 ELSEIF(IPRT .EQ. -2) THEN
29874 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
29876 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
29877 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
29878 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
29879 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
29880 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
29881 ELSEIF(IPRT .EQ. -3) THEN
29882 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
29884 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
29885 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
29886 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
29887 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
29888 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
29889 ELSEIF(IPRT .EQ. -4) THEN
29890 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
29892 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
29893 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
29894 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
29895 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
29896 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
29897 ELSEIF(IPRT .EQ. -5) THEN
29898 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
29900 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
29901 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
29902 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
29903 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
29904 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
29905 ELSEIF(IPRT .EQ. -6) THEN
29906 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
29908 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
29909 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
29910 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
29911 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
29912 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
29916 C...Calculation of x * f(x, Q).
29917 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
29918 & *(LOG(1D0+1D0/X))**A5 )
29923 C*********************************************************************
29926 C...Gives the GRV 94 L (leading order) parton distribution function set
29927 C...in parametrized form.
29928 C...Authors: M. Glueck, E. Reya and A. Vogt.
29930 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29932 C...Double precision declaration.
29933 IMPLICIT DOUBLE PRECISION (A - Z)
29935 C...Common expressions.
29937 LAM2 = 0.2322D0 * 0.2322D0
29938 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
29944 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
29945 AKU = 0.590D0 - 0.024D0 * S
29946 BKU = 0.131D0 + 0.063D0 * S
29947 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
29948 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
29949 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
29950 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
29951 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
29954 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
29956 BKD = 0.486D0 + 0.062D0 * S
29957 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
29958 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
29959 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
29960 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
29961 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
29964 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
29965 AKE = 0.409D0 - 0.005D0 * S
29966 BKE = 0.799D0 + 0.071D0 * S
29967 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
29968 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
29970 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
29971 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
29976 AKX = 0.410D0 - 0.232D0 * S
29977 BKX = 0.534D0 - 0.457D0 * S
29978 AGX = 0.890D0 - 0.140D0 * S
29980 CX = 0.320D0 + 0.683D0 * S
29981 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
29982 EX = 4.119D0 + 1.713D0 * S
29983 ESX = 0.682D0 + 2.978D0 * S
29984 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
29991 AKS = 1.798D0 - 0.596D0 * S
29992 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
29993 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
29994 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
29995 EST = 3.981D0 + 1.638D0 * S
29997 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
30005 BC = 4.24D0 - 0.804D0 * S
30006 DCT = 3.46D0 - 1.076D0 * S
30007 ECT = 4.61D0 + 1.49D0 * S
30008 ESC = 2.555D0 + 1.961D0 * S
30009 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
30018 DBT = 2.929D0 + 1.396D0 * S
30019 EBT = 4.71D0 + 1.514D0 * S
30020 ESB = 4.02D0 + 1.239D0 * S
30021 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
30026 AKG = 1.742D0 - 0.930D0 * S
30027 BKG = - 0.399D0 * S2
30028 AG = 7.486D0 - 2.185D0 * S
30029 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
30030 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
30031 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
30032 EG = 0.807D0 + 2.005D0 * S
30033 ESG = 3.841D0 + 0.316D0 * S
30034 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
30040 C*********************************************************************
30043 C...Gives the GRV 94 M (MSbar) parton distribution function set
30044 C...in parametrized form.
30045 C...Authors: M. Glueck, E. Reya and A. Vogt.
30047 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
30049 C...Double precision declaration.
30050 IMPLICIT DOUBLE PRECISION (A - Z)
30052 C...Common expressions.
30054 LAM2 = 0.248D0 * 0.248D0
30055 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
30061 NU = 1.304D0 + 0.863D0 * S
30062 AKU = 0.558D0 - 0.020D0 * S
30064 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
30065 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
30066 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
30067 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
30068 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
30071 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
30072 AKD = 0.270D0 - 0.019D0 * S
30074 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
30075 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
30076 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
30077 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
30078 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
30081 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
30082 AKE = 0.409D0 - 0.007D0 * S
30083 BKE = 0.782D0 + 0.082D0 * S
30084 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
30085 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
30087 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
30088 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
30096 BGX = 3.210D0 - 1.866D0 * S
30098 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
30099 EX = 3.077D0 + 1.446D0 * S
30100 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
30101 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
30108 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
30109 AS = -4.329D0 + 1.131D0 * S
30110 BS = 9.568D0 - 1.744D0 * S
30111 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
30112 EST = 3.031D0 + 1.639D0 * S
30113 ESS = 5.837D0 + 0.815D0 * S
30114 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
30120 AKC = -0.625D0 - 0.523D0 * S
30122 BC = 1.896D0 + 1.616D0 * S
30123 DCT = 4.12D0 + 0.683D0 * S
30124 ECT = 4.36D0 + 1.328D0 * S
30125 ESC = 0.677D0 + 0.679D0 * S
30126 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
30132 AKB = - 0.193D0 * S
30135 DBT = 3.447D0 + 0.927D0 * S
30136 EBT = 4.68D0 + 1.259D0 * S
30137 ESB = 1.892D0 + 2.199D0 * S
30138 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
30143 AKG = 1.724D0 + 0.157D0 * S
30144 BKG = 0.800D0 + 1.016D0 * S
30145 AG = 7.517D0 - 2.547D0 * S
30146 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
30147 CG = 4.039D0 + 1.491D0 * S
30148 DG = 3.404D0 + 0.830D0 * S
30149 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
30150 ESG = 3.256D0 - 0.436D0 * S
30151 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
30156 C*********************************************************************
30159 C...Gives the GRV 94 D (DIS) parton distribution function set
30160 C...in parametrized form.
30161 C...Authors: M. Glueck, E. Reya and A. Vogt.
30163 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
30165 C...Double precision declaration.
30166 IMPLICIT DOUBLE PRECISION (A - Z)
30168 C...Common expressions.
30170 LAM2 = 0.248D0 * 0.248D0
30171 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
30177 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
30178 AKU = 0.563D0 - 0.025D0 * S
30179 BKU = 0.054D0 + 0.154D0 * S
30180 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
30181 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
30182 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
30183 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
30184 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
30187 ND = 0.156D0 - 0.017D0 * S
30188 AKD = 0.299D0 - 0.022D0 * S
30189 BKD = 0.259D0 - 0.015D0 * S
30190 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
30191 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
30192 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
30193 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
30194 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
30197 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
30198 AKE = 0.419D0 - 0.013D0 * S
30199 BKE = 1.064D0 - 0.038D0 * S
30200 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
30201 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
30202 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
30203 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
30204 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
30209 AKX = 0.326D0 + 0.150D0 * S
30210 BKX = 0.956D0 + 0.405D0 * S
30212 BGX = 3.794D0 - 2.359D0 * DS
30214 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
30215 EX = 3.049D0 + 1.597D0 * S
30216 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
30217 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
30224 AKS = 1.415D0 - 0.641D0 * DS
30225 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
30226 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
30227 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
30228 EST = 4.546D0 + 0.372D0 * S2
30229 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
30230 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
30236 AKC = -0.625D0 - 0.523D0 * S
30238 BC = 1.896D0 + 1.616D0 * S
30239 DCT = 4.12D0 + 0.683D0 * S
30240 ECT = 4.36D0 + 1.328D0 * S
30241 ESC = 0.677D0 + 0.679D0 * S
30242 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
30248 AKB = - 0.193D0 * S
30251 DBT = 3.447D0 + 0.927D0 * S
30252 EBT = 4.68D0 + 1.259D0 * S
30253 ESB = 1.892D0 + 2.199D0 * S
30254 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
30260 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
30261 AG = 25.09D0 - 7.935D0 * S
30262 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
30263 CG = 590.3D0 - 173.8D0 * S
30264 DG = 5.196D0 + 1.857D0 * S
30265 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
30266 ESG = 3.232D0 - 0.542D0 * S
30267 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
30272 C*********************************************************************
30275 C...Auxiliary for the GRV 94 parton distribution functions
30276 C...for u and d valence and d-u sea.
30277 C...Authors: M. Glueck, E. Reya and A. Vogt.
30279 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
30281 C...Double precision declaration.
30282 IMPLICIT DOUBLE PRECISION (A - Z)
30286 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
30292 C*********************************************************************
30295 C...Auxiliary for the GRV 94 parton distribution functions
30296 C...for d+u sea and gluon.
30297 C...Authors: M. Glueck, E. Reya and A. Vogt.
30299 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
30301 C...Double precision declaration.
30302 IMPLICIT DOUBLE PRECISION (A - Z)
30306 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
30307 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
30312 C*********************************************************************
30315 C...Auxiliary for the GRV 94 parton distribution functions
30316 C...for s, c and b sea.
30317 C...Authors: M. Glueck, E. Reya and A. Vogt.
30319 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
30321 C...Double precision declaration.
30322 IMPLICIT DOUBLE PRECISION (A - Z)
30330 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
30331 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
30337 C*********************************************************************
30340 C...Auxiliary function for parametrization of CTEQ5L.
30341 C...Author: J. Pumplin 9/99.
30343 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
30344 C...in Parametrized Form
30345 C... September 15, 1999
30347 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
30348 C... CTEQ5 PPARTON DISTRIBUTIONS"
30351 C...The CTEQ5M1 set given here is an updated version of the original
30352 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
30353 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
30354 C...almost all applications.
30355 C...The improvement is in the QCD evolution which is now more
30356 C...accurate, and which agrees completely with the benchmark work
30357 C...of the HERA 96/97 Workshop.
30358 C...The differences between the parametrized and the corresponding
30359 C...table versions (on which it is based) are of similar order as
30360 C...between the two version.
30362 C...!! Because accurate parametrizations over a wide range of (x,Q)
30363 C...is hard to obtain, only the most widely used sets CTEQ5M and
30364 C...CTEQ5L are available in parametrized form for now.
30366 C...These parametrizations were obtained by Jon Pumplin.
30368 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
30369 C -------------------------------------------------------------------
30370 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
30371 C 3 CTEQ5L Leading Order 0.127 192 146
30372 C -------------------------------------------------------------------
30373 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
30374 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
30377 C...The two Iset value are adopted to agree with the standard table
30380 C...Range of validity:
30381 C...The range of (x, Q) covered by this parametrization of the QCD
30382 C...evolved parton distributions is 1E-6 < x < 1 ;
30383 C...1.1 GeV < Q < 10 TeV. Of course, the PDF's are constrained by
30384 C...data only in a subset of that region; and the assumed DGLAP
30385 C...evolution is unlikely to be valid for all of it either.
30387 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
30388 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
30389 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
30390 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
30392 FUNCTION PYCT5L(IFL,X,Q)
30394 C...Double precision declaration.
30395 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30396 IMPLICIT INTEGER(I-N)
30398 PARAMETER (NEX=8, NLF=2)
30399 DIMENSION AM(0:NEX,0:NLF,-5:2)
30400 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
30401 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
30402 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
30403 DIMENSION AF(0:NEX)
30405 DATA MEXVEC( 2) / 8 /
30406 DATA MLFVEC( 2) / 2 /
30407 DATA UT1VEC( 2) / 0.4971265E+01 /
30408 DATA UT2VEC( 2) / -0.1105128E+01 /
30409 DATA ALFVEC( 2) / 0.2987216E+00 /
30410 DATA QMAVEC( 2) / 0.0000000E+00 /
30411 DATA (AM( 0,K, 2),K=0, 2)
30412 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
30413 DATA (AM( 1,K, 2),K=0, 2)
30414 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
30415 DATA (AM( 2,K, 2),K=0, 2)
30416 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
30417 DATA (AM( 3,K, 2),K=0, 2)
30418 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
30419 DATA (AM( 4,K, 2),K=0, 2)
30420 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
30421 DATA (AM( 5,K, 2),K=0, 2)
30422 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
30423 DATA (AM( 6,K, 2),K=0, 2)
30424 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
30425 DATA (AM( 7,K, 2),K=0, 2)
30426 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
30427 DATA (AM( 8,K, 2),K=0, 2)
30428 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
30430 DATA MEXVEC( 1) / 8 /
30431 DATA MLFVEC( 1) / 2 /
30432 DATA UT1VEC( 1) / 0.2612618E+01 /
30433 DATA UT2VEC( 1) / -0.1258304E+06 /
30434 DATA ALFVEC( 1) / 0.3407552E+00 /
30435 DATA QMAVEC( 1) / 0.0000000E+00 /
30436 DATA (AM( 0,K, 1),K=0, 2)
30437 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
30438 DATA (AM( 1,K, 1),K=0, 2)
30439 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
30440 DATA (AM( 2,K, 1),K=0, 2)
30441 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
30442 DATA (AM( 3,K, 1),K=0, 2)
30443 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
30444 DATA (AM( 4,K, 1),K=0, 2)
30445 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
30446 DATA (AM( 5,K, 1),K=0, 2)
30447 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
30448 DATA (AM( 6,K, 1),K=0, 2)
30449 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
30450 DATA (AM( 7,K, 1),K=0, 2)
30451 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
30452 DATA (AM( 8,K, 1),K=0, 2)
30453 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
30455 DATA MEXVEC( 0) / 8 /
30456 DATA MLFVEC( 0) / 2 /
30457 DATA UT1VEC( 0) / -0.4656819E+00 /
30458 DATA UT2VEC( 0) / -0.2742390E+03 /
30459 DATA ALFVEC( 0) / 0.4491863E+00 /
30460 DATA QMAVEC( 0) / 0.0000000E+00 /
30461 DATA (AM( 0,K, 0),K=0, 2)
30462 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
30463 DATA (AM( 1,K, 0),K=0, 2)
30464 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
30465 DATA (AM( 2,K, 0),K=0, 2)
30466 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
30467 DATA (AM( 3,K, 0),K=0, 2)
30468 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
30469 DATA (AM( 4,K, 0),K=0, 2)
30470 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
30471 DATA (AM( 5,K, 0),K=0, 2)
30472 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
30473 DATA (AM( 6,K, 0),K=0, 2)
30474 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
30475 DATA (AM( 7,K, 0),K=0, 2)
30476 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
30477 DATA (AM( 8,K, 0),K=0, 2)
30478 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
30480 DATA MEXVEC(-1) / 8 /
30481 DATA MLFVEC(-1) / 2 /
30482 DATA UT1VEC(-1) / 0.3862583E+01 /
30483 DATA UT2VEC(-1) / -0.1265969E+01 /
30484 DATA ALFVEC(-1) / 0.2457668E+00 /
30485 DATA QMAVEC(-1) / 0.0000000E+00 /
30486 DATA (AM( 0,K,-1),K=0, 2)
30487 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
30488 DATA (AM( 1,K,-1),K=0, 2)
30489 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
30490 DATA (AM( 2,K,-1),K=0, 2)
30491 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
30492 DATA (AM( 3,K,-1),K=0, 2)
30493 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
30494 DATA (AM( 4,K,-1),K=0, 2)
30495 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
30496 DATA (AM( 5,K,-1),K=0, 2)
30497 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
30498 DATA (AM( 6,K,-1),K=0, 2)
30499 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
30500 DATA (AM( 7,K,-1),K=0, 2)
30501 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
30502 DATA (AM( 8,K,-1),K=0, 2)
30503 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
30505 DATA MEXVEC(-2) / 7 /
30506 DATA MLFVEC(-2) / 2 /
30507 DATA UT1VEC(-2) / 0.1895615E+00 /
30508 DATA UT2VEC(-2) / -0.3069097E+01 /
30509 DATA ALFVEC(-2) / 0.5293999E+00 /
30510 DATA QMAVEC(-2) / 0.0000000E+00 /
30511 DATA (AM( 0,K,-2),K=0, 2)
30512 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
30513 DATA (AM( 1,K,-2),K=0, 2)
30514 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
30515 DATA (AM( 2,K,-2),K=0, 2)
30516 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
30517 DATA (AM( 3,K,-2),K=0, 2)
30518 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
30519 DATA (AM( 4,K,-2),K=0, 2)
30520 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
30521 DATA (AM( 5,K,-2),K=0, 2)
30522 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
30523 DATA (AM( 6,K,-2),K=0, 2)
30524 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
30525 DATA (AM( 7,K,-2),K=0, 2)
30526 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
30528 DATA MEXVEC(-3) / 7 /
30529 DATA MLFVEC(-3) / 2 /
30530 DATA UT1VEC(-3) / 0.3753257E+01 /
30531 DATA UT2VEC(-3) / -0.1113085E+01 /
30532 DATA ALFVEC(-3) / 0.3713141E+00 /
30533 DATA QMAVEC(-3) / 0.0000000E+00 /
30534 DATA (AM( 0,K,-3),K=0, 2)
30535 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
30536 DATA (AM( 1,K,-3),K=0, 2)
30537 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
30538 DATA (AM( 2,K,-3),K=0, 2)
30539 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
30540 DATA (AM( 3,K,-3),K=0, 2)
30541 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
30542 DATA (AM( 4,K,-3),K=0, 2)
30543 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
30544 DATA (AM( 5,K,-3),K=0, 2)
30545 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
30546 DATA (AM( 6,K,-3),K=0, 2)
30547 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
30548 DATA (AM( 7,K,-3),K=0, 2)
30549 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
30551 DATA MEXVEC(-4) / 7 /
30552 DATA MLFVEC(-4) / 2 /
30553 DATA UT1VEC(-4) / 0.4400772E+01 /
30554 DATA UT2VEC(-4) / -0.1356116E+01 /
30555 DATA ALFVEC(-4) / 0.3712017E-01 /
30556 DATA QMAVEC(-4) / 0.1300000E+01 /
30557 DATA (AM( 0,K,-4),K=0, 2)
30558 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
30559 DATA (AM( 1,K,-4),K=0, 2)
30560 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
30561 DATA (AM( 2,K,-4),K=0, 2)
30562 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
30563 DATA (AM( 3,K,-4),K=0, 2)
30564 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
30565 DATA (AM( 4,K,-4),K=0, 2)
30566 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
30567 DATA (AM( 5,K,-4),K=0, 2)
30568 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
30569 DATA (AM( 6,K,-4),K=0, 2)
30570 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
30571 DATA (AM( 7,K,-4),K=0, 2)
30572 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
30574 DATA MEXVEC(-5) / 6 /
30575 DATA MLFVEC(-5) / 2 /
30576 DATA UT1VEC(-5) / 0.5562568E+01 /
30577 DATA UT2VEC(-5) / -0.1801317E+01 /
30578 DATA ALFVEC(-5) / 0.4952010E-02 /
30579 DATA QMAVEC(-5) / 0.4500000E+01 /
30580 DATA (AM( 0,K,-5),K=0, 2)
30581 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
30582 DATA (AM( 1,K,-5),K=0, 2)
30583 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
30584 DATA (AM( 2,K,-5),K=0, 2)
30585 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
30586 DATA (AM( 3,K,-5),K=0, 2)
30587 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
30588 DATA (AM( 4,K,-5),K=0, 2)
30589 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
30590 DATA (AM( 5,K,-5),K=0, 2)
30591 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
30592 DATA (AM( 6,K,-5),K=0, 2)
30593 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
30595 IF(Q .LE. QMAVEC(IFL)) THEN
30600 IF(X .GE. 1.D0) THEN
30605 TMP = LOG(Q/ALFVEC(IFL))
30606 IF(TMP .LE. 0.D0) THEN
30618 DO 100 K = 0, MLFVEC(IFL)
30619 AF(I) = AF(I) + SBX*AM(I,K,IFL)
30625 U = LOG(X/0.00001D0)
30627 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
30628 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
30629 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
30630 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
30631 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
30633 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
30635 C...Include threshold factor.
30636 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
30641 C*********************************************************************
30644 C...Auxiliary function for parametrization of CTEQ5M1.
30645 C...Author: J. Pumplin 9/99.
30647 FUNCTION PYCT5M(IFL,X,Q)
30649 C...Double precision declaration.
30650 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30651 IMPLICIT INTEGER(I-N)
30653 PARAMETER (NEX=8, NLF=2)
30654 DIMENSION AM(0:NEX,0:NLF,-5:2)
30655 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
30656 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
30657 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
30658 DIMENSION AF(0:NEX)
30660 DATA MEXVEC( 2) / 8 /
30661 DATA MLFVEC( 2) / 2 /
30662 DATA UT1VEC( 2) / 0.5141718E+01 /
30663 DATA UT2VEC( 2) / -0.1346944E+01 /
30664 DATA ALFVEC( 2) / 0.5260555E+00 /
30665 DATA QMAVEC( 2) / 0.0000000E+00 /
30666 DATA (AM( 0,K, 2),K=0, 2)
30667 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
30668 DATA (AM( 1,K, 2),K=0, 2)
30669 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
30670 DATA (AM( 2,K, 2),K=0, 2)
30671 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
30672 DATA (AM( 3,K, 2),K=0, 2)
30673 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
30674 DATA (AM( 4,K, 2),K=0, 2)
30675 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
30676 DATA (AM( 5,K, 2),K=0, 2)
30677 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
30678 DATA (AM( 6,K, 2),K=0, 2)
30679 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
30680 DATA (AM( 7,K, 2),K=0, 2)
30681 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
30682 DATA (AM( 8,K, 2),K=0, 2)
30683 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
30685 DATA MEXVEC( 1) / 8 /
30686 DATA MLFVEC( 1) / 2 /
30687 DATA UT1VEC( 1) / 0.4138426E+01 /
30688 DATA UT2VEC( 1) / -0.3221374E+01 /
30689 DATA ALFVEC( 1) / 0.4960962E+00 /
30690 DATA QMAVEC( 1) / 0.0000000E+00 /
30691 DATA (AM( 0,K, 1),K=0, 2)
30692 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
30693 DATA (AM( 1,K, 1),K=0, 2)
30694 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
30695 DATA (AM( 2,K, 1),K=0, 2)
30696 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
30697 DATA (AM( 3,K, 1),K=0, 2)
30698 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
30699 DATA (AM( 4,K, 1),K=0, 2)
30700 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
30701 DATA (AM( 5,K, 1),K=0, 2)
30702 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
30703 DATA (AM( 6,K, 1),K=0, 2)
30704 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
30705 DATA (AM( 7,K, 1),K=0, 2)
30706 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
30707 DATA (AM( 8,K, 1),K=0, 2)
30708 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
30710 DATA MEXVEC( 0) / 8 /
30711 DATA MLFVEC( 0) / 2 /
30712 DATA UT1VEC( 0) / -0.1026789E+01 /
30713 DATA UT2VEC( 0) / -0.9051707E+01 /
30714 DATA ALFVEC( 0) / 0.9462977E+00 /
30715 DATA QMAVEC( 0) / 0.0000000E+00 /
30716 DATA (AM( 0,K, 0),K=0, 2)
30717 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
30718 DATA (AM( 1,K, 0),K=0, 2)
30719 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
30720 DATA (AM( 2,K, 0),K=0, 2)
30721 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
30722 DATA (AM( 3,K, 0),K=0, 2)
30723 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
30724 DATA (AM( 4,K, 0),K=0, 2)
30725 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
30726 DATA (AM( 5,K, 0),K=0, 2)
30727 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
30728 DATA (AM( 6,K, 0),K=0, 2)
30729 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
30730 DATA (AM( 7,K, 0),K=0, 2)
30731 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
30732 DATA (AM( 8,K, 0),K=0, 2)
30733 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
30735 DATA MEXVEC(-1) / 8 /
30736 DATA MLFVEC(-1) / 2 /
30737 DATA UT1VEC(-1) / 0.5243571E+01 /
30738 DATA UT2VEC(-1) / -0.2870513E+01 /
30739 DATA ALFVEC(-1) / 0.6701448E+00 /
30740 DATA QMAVEC(-1) / 0.0000000E+00 /
30741 DATA (AM( 0,K,-1),K=0, 2)
30742 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
30743 DATA (AM( 1,K,-1),K=0, 2)
30744 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
30745 DATA (AM( 2,K,-1),K=0, 2)
30746 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
30747 DATA (AM( 3,K,-1),K=0, 2)
30748 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
30749 DATA (AM( 4,K,-1),K=0, 2)
30750 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
30751 DATA (AM( 5,K,-1),K=0, 2)
30752 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
30753 DATA (AM( 6,K,-1),K=0, 2)
30754 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
30755 DATA (AM( 7,K,-1),K=0, 2)
30756 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
30757 DATA (AM( 8,K,-1),K=0, 2)
30758 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
30760 DATA MEXVEC(-2) / 7 /
30761 DATA MLFVEC(-2) / 2 /
30762 DATA UT1VEC(-2) / 0.4782210E+01 /
30763 DATA UT2VEC(-2) / -0.1976856E+02 /
30764 DATA ALFVEC(-2) / 0.7558374E+00 /
30765 DATA QMAVEC(-2) / 0.0000000E+00 /
30766 DATA (AM( 0,K,-2),K=0, 2)
30767 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
30768 DATA (AM( 1,K,-2),K=0, 2)
30769 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
30770 DATA (AM( 2,K,-2),K=0, 2)
30771 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
30772 DATA (AM( 3,K,-2),K=0, 2)
30773 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
30774 DATA (AM( 4,K,-2),K=0, 2)
30775 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
30776 DATA (AM( 5,K,-2),K=0, 2)
30777 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
30778 DATA (AM( 6,K,-2),K=0, 2)
30779 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
30780 DATA (AM( 7,K,-2),K=0, 2)
30781 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
30783 DATA MEXVEC(-3) / 7 /
30784 DATA MLFVEC(-3) / 2 /
30785 DATA UT1VEC(-3) / 0.4518239E+01 /
30786 DATA UT2VEC(-3) / -0.2690590E+01 /
30787 DATA ALFVEC(-3) / 0.6124079E+00 /
30788 DATA QMAVEC(-3) / 0.0000000E+00 /
30789 DATA (AM( 0,K,-3),K=0, 2)
30790 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
30791 DATA (AM( 1,K,-3),K=0, 2)
30792 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
30793 DATA (AM( 2,K,-3),K=0, 2)
30794 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
30795 DATA (AM( 3,K,-3),K=0, 2)
30796 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
30797 DATA (AM( 4,K,-3),K=0, 2)
30798 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
30799 DATA (AM( 5,K,-3),K=0, 2)
30800 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
30801 DATA (AM( 6,K,-3),K=0, 2)
30802 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
30803 DATA (AM( 7,K,-3),K=0, 2)
30804 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
30806 DATA MEXVEC(-4) / 7 /
30807 DATA MLFVEC(-4) / 2 /
30808 DATA UT1VEC(-4) / 0.2783230E+01 /
30809 DATA UT2VEC(-4) / -0.1746328E+01 /
30810 DATA ALFVEC(-4) / 0.1115653E+01 /
30811 DATA QMAVEC(-4) / 0.1300000E+01 /
30812 DATA (AM( 0,K,-4),K=0, 2)
30813 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
30814 DATA (AM( 1,K,-4),K=0, 2)
30815 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
30816 DATA (AM( 2,K,-4),K=0, 2)
30817 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
30818 DATA (AM( 3,K,-4),K=0, 2)
30819 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
30820 DATA (AM( 4,K,-4),K=0, 2)
30821 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
30822 DATA (AM( 5,K,-4),K=0, 2)
30823 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
30824 DATA (AM( 6,K,-4),K=0, 2)
30825 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
30826 DATA (AM( 7,K,-4),K=0, 2)
30827 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
30829 DATA MEXVEC(-5) / 6 /
30830 DATA MLFVEC(-5) / 2 /
30831 DATA UT1VEC(-5) / 0.1619654E+02 /
30832 DATA UT2VEC(-5) / -0.3367346E+01 /
30833 DATA ALFVEC(-5) / 0.5109891E-02 /
30834 DATA QMAVEC(-5) / 0.4500000E+01 /
30835 DATA (AM( 0,K,-5),K=0, 2)
30836 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
30837 DATA (AM( 1,K,-5),K=0, 2)
30838 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
30839 DATA (AM( 2,K,-5),K=0, 2)
30840 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
30841 DATA (AM( 3,K,-5),K=0, 2)
30842 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
30843 DATA (AM( 4,K,-5),K=0, 2)
30844 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
30845 DATA (AM( 5,K,-5),K=0, 2)
30846 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
30847 DATA (AM( 6,K,-5),K=0, 2)
30848 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
30850 IF(Q .LE. QMAVEC(IFL)) THEN
30855 IF(X .GE. 1.D0) THEN
30860 TMP = LOG(Q/ALFVEC(IFL))
30861 IF(TMP .LE. 0.D0) THEN
30873 DO 100 K = 0, MLFVEC(IFL)
30874 AF(I) = AF(I) + SBX*AM(I,K,IFL)
30880 U = LOG(X/0.00001D0)
30882 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
30883 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
30884 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
30885 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
30886 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
30888 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
30890 C...Include threshold factor.
30891 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
30896 C*********************************************************************
30899 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
30900 C...a few older parametrizations, now obsolete but convenient for
30901 C...backwards checks.
30903 SUBROUTINE PYPDPO(X,Q2,XPPR)
30905 C...Double precision and integer declarations.
30906 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30907 IMPLICIT INTEGER(I-N)
30908 INTEGER PYK,PYCHGE,PYCOMP
30910 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30911 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30912 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30913 COMMON/PYINT1/MINT(400),VINT(400)
30914 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
30915 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
30916 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
30919 C...The following data lines are coefficients needed in the
30920 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
30921 C...parametrizations, see below.
30922 C...Powers of 1-x in different cases.
30923 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
30924 C...Expansion coefficients for up valence quark distribution.
30925 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
30926 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
30927 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
30928 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
30929 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
30930 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
30931 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
30932 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
30933 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
30934 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
30935 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
30936 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
30937 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
30938 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
30939 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
30940 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
30941 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
30942 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
30943 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
30944 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
30945 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
30946 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
30947 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
30948 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
30949 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
30950 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
30951 C...Expansion coefficients for down valence quark distribution.
30952 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
30953 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
30954 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
30955 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
30956 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
30957 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
30958 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
30959 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
30960 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
30961 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
30962 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
30963 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
30964 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
30965 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
30966 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
30967 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
30968 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
30969 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
30970 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
30971 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
30972 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
30973 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
30974 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
30975 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
30976 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
30977 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
30978 C...Expansion coefficients for up and down sea quark distributions.
30979 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
30980 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
30981 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
30982 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
30983 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
30984 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
30985 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
30986 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
30987 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
30988 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
30989 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
30990 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
30991 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
30992 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
30993 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
30994 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
30995 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
30996 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
30997 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
30998 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
30999 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
31000 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
31001 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
31002 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
31003 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
31004 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
31005 C...Expansion coefficients for gluon distribution.
31006 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
31007 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
31008 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
31009 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
31010 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
31011 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
31012 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
31013 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
31014 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
31015 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
31016 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
31017 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
31018 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
31019 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
31020 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
31021 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
31022 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
31023 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
31024 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
31025 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
31026 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
31027 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
31028 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
31029 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
31030 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
31031 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
31032 C...Expansion coefficients for strange sea quark distribution.
31033 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
31034 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
31035 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
31036 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
31037 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
31038 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
31039 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
31040 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
31041 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
31042 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
31043 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
31044 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
31045 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
31046 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
31047 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
31048 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
31049 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
31050 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
31051 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
31052 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
31053 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
31054 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
31055 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
31056 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
31057 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
31058 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
31059 C...Expansion coefficients for charm sea quark distribution.
31060 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
31061 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
31062 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
31063 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
31064 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
31065 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
31066 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
31067 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
31068 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
31069 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
31070 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
31071 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
31072 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
31073 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
31074 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
31075 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
31076 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
31077 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
31078 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
31079 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
31080 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
31081 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
31082 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
31083 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
31084 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
31085 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
31086 C...Expansion coefficients for bottom sea quark distribution.
31087 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
31088 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
31089 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
31090 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
31091 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
31092 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
31093 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
31094 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
31095 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
31096 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
31097 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
31098 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
31099 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
31100 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
31101 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
31102 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
31103 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
31104 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
31105 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
31106 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
31107 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
31108 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
31109 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
31110 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
31111 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
31112 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
31113 C...Expansion coefficients for top sea quark distribution.
31114 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
31115 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
31116 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
31117 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
31118 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
31119 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
31120 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
31121 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
31122 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
31123 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
31124 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
31125 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
31126 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
31127 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
31128 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
31129 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
31130 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
31131 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
31132 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
31133 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
31134 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
31135 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
31136 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
31137 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
31138 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
31139 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
31141 C...The following data lines are coefficients needed in the
31142 C...Duke, Owens proton structure function parametrizations, see below.
31143 C...Expansion coefficients for (up+down) valence quark distribution.
31144 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
31145 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31146 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31147 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
31148 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
31149 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31150 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31151 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
31152 C...Expansion coefficients for down valence quark distribution.
31153 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
31154 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31155 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
31156 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
31157 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
31158 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31159 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
31160 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
31161 C...Expansion coefficients for (up+down+strange) sea quark distribution.
31162 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
31163 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31164 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
31165 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
31166 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
31167 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31168 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
31169 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
31170 C...Expansion coefficients for charm sea quark distribution.
31171 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
31172 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31173 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
31174 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
31175 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
31176 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31177 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
31178 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
31179 C...Expansion coefficients for gluon distribution.
31180 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
31181 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
31182 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
31183 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
31184 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
31185 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
31186 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
31187 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
31189 C...Euler's beta function, requires ordinary Gamma function
31190 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
31192 C...Leading order proton parton distributions from Glueck, Reya and
31193 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
31195 IF(MSTP(51).EQ.11) THEN
31197 C...Determine s expansion variable and some x expressions.
31198 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
31199 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
31204 C...Evaluate valence, gluon and sea distributions.
31205 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
31206 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
31207 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
31208 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
31209 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
31210 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
31211 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
31212 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
31213 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
31214 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
31215 & SQRT(4.066D0*SD**1.218D0*XL)))*
31216 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
31217 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
31218 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
31219 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
31220 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
31221 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
31222 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
31223 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
31224 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
31225 IF(SD.LE.0.888D0) THEN
31228 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
31229 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
31230 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
31232 IF(SD.LE.1.351D0) THEN
31235 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
31236 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
31237 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
31240 C...Put into output array.
31242 XPPR(1)=XFVDD+XFSEA
31243 XPPR(2)=XFVUD-XFVDD+XFSEA
31253 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
31254 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
31255 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
31257 C...Determine set, Lambda and x and t expansion variables.
31259 IF(NSET.EQ.1) ALAM=0.2D0
31260 IF(NSET.EQ.2) ALAM=0.29D0
31261 TMIN=LOG(5D0/ALAM**2)
31262 TMAX=LOG(1D8/ALAM**2)
31263 T=LOG(MAX(1D0,Q2/ALAM**2))
31264 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
31266 IF(X.LE.0.1D0) NX=2
31267 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
31268 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
31270 C...Chebyshev polynomials for x and t expansion.
31273 TX(3)=2D0*VX**2-1D0
31274 TX(4)=4D0*VX**3-3D0*VX
31275 TX(5)=8D0*VX**4-8D0*VX**2+1D0
31276 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
31279 TT(3)=2D0*VT**2-1D0
31280 TT(4)=4D0*VT**3-3D0*VT
31281 TT(5)=8D0*VT**4-8D0*VT**2+1D0
31282 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
31284 C...Calculate structure functions.
31289 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
31292 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
31295 C...Put into output array.
31297 XPPR(1)=XQ(2)+XQ(3)
31298 XPPR(2)=XQ(1)+XQ(3)
31306 C...Special expansion for bottom (threshold effects).
31307 IF(MSTP(58).GE.5) THEN
31308 IF(NSET.EQ.1) TMIN=8.1905D0
31309 IF(NSET.EQ.2) TMIN=7.4474D0
31311 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
31314 TT(3)=2D0*VT**2-1D0
31315 TT(4)=4D0*VT**3-3D0*VT
31316 TT(5)=8D0*VT**4-8D0*VT**2+1D0
31317 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
31321 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
31324 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
31329 C...Special expansion for top (threshold effects).
31330 IF(MSTP(58).GE.6) THEN
31331 IF(NSET.EQ.1) TMIN=11.5528D0
31332 IF(NSET.EQ.2) TMIN=10.8097D0
31333 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
31334 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
31336 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
31339 TT(3)=2D0*VT**2-1D0
31340 TT(4)=4D0*VT**3-3D0*VT
31341 TT(5)=8D0*VT**4-8D0*VT**2+1D0
31342 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
31346 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
31349 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
31354 C...Proton parton distributions from Duke, Owens.
31355 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
31356 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
31358 C...Determine set, Lambda and s expansion parameter.
31360 IF(NSET.EQ.1) ALAM=0.2D0
31361 IF(NSET.EQ.2) ALAM=0.4D0
31362 Q2IN=MIN(1D6,MAX(4D0,Q2))
31363 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
31365 C...Calculate structure functions.
31368 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
31369 & CDO(3,IS,KFL,NSET)*SD**2
31372 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
31373 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
31375 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
31376 & TS(5)*X**2+TS(6)*X**3)
31380 C...Put into output arrays.
31382 XPPR(1)=XQ(2)+XQ(3)/6D0
31383 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
31396 C*********************************************************************
31399 C...Gives threshold attractive/repulsive factor for heavy flavour
31402 FUNCTION PYHFTH(SH,SQM,FRATT)
31404 C...Double precision and integer declarations.
31405 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31406 IMPLICIT INTEGER(I-N)
31407 INTEGER PYK,PYCHGE,PYCOMP
31409 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31410 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31411 COMMON/PYINT1/MINT(400),VINT(400)
31412 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
31414 C...Value for alpha_strong.
31415 IF(MSTP(35).LE.1) THEN
31420 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
31426 C...Evaluate attractive and repulsive factors.
31427 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
31428 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
31429 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
31430 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
31431 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
31437 C*********************************************************************
31440 C...Splits a hadron remnant into two (partons or hadron + parton)
31441 C...in case it is more complicated than just a quark or a diquark.
31443 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
31445 C...Double precision and integer declarations.
31446 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31447 IMPLICIT INTEGER(I-N)
31448 INTEGER PYK,PYCHGE,PYCOMP
31449 C...Commonblocks. PYDAT1 temporary
31450 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31451 COMMON/PYINT1/MINT(400),VINT(400)
31452 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31453 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
31457 C...Preliminaries. Parton composition.
31460 KFL(1)=MOD(KFA/1000,10)
31461 KFL(2)=MOD(KFA/100,10)
31462 KFL(3)=MOD(KFA/10,10)
31463 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
31464 KFL(2)=INT(1.5D0+PYR(0))
31465 IF(MINT(105).EQ.333) KFL(2)=3
31466 IF(MINT(105).EQ.443) KFL(2)=4
31468 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
31471 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
31474 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
31475 KFL(2)=MOD(KFA/10,10)
31476 KFL(3)=MOD(KFA/100,10)
31478 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
31485 C...Subdivide lepton.
31486 IF(KFA.GE.11.AND.KFA.LE.18) THEN
31487 IF(KFLR.EQ.KFA) THEN
31489 ELSEIF(KFLR.EQ.22) THEN
31491 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
31493 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
31495 ELSEIF(KFLR.EQ.21) THEN
31503 C...Subdivide photon.
31504 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
31505 IF(KFLR.NE.21) THEN
31510 IF(RAGR.GT.0.125D0) KFLSP=2
31511 IF(RAGR.GT.0.625D0) KFLSP=3
31512 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
31516 C...Subdivide Reggeon or Pomeron.
31517 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
31518 IF(KFLIN.EQ.21) THEN
31524 C...Subdivide meson.
31525 ELSEIF(KFL(1).EQ.0) THEN
31526 KFL(2)=KFL(2)*(-1)**KFL(2)
31527 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
31528 IF(KFLR.EQ.KFL(2)) THEN
31530 ELSEIF(KFLR.EQ.KFL(3)) THEN
31532 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
31535 ELSEIF(KFLR.EQ.21) THEN
31538 ELSEIF(KFLR*KFL(2).GT.0) THEN
31541 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
31542 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31544 ELSEIF(KFLCH.EQ.0) THEN
31545 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31553 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
31554 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31556 ELSEIF(KFLCH.EQ.0) THEN
31557 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31564 C...Subdivide baryon.
31568 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
31571 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
31574 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
31575 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
31578 IAGR=1.00001D0+2.99998D0*PYR(0)
31581 IF(IAGR.EQ.1) ID1=2
31582 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
31585 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
31586 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
31587 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
31588 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
31589 ELSEIF(MOD(KFA,10).EQ.2) THEN
31590 IF(IAGR.EQ.1) KSP=1
31591 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
31593 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
31594 IF(KFLR.EQ.21) THEN
31596 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
31599 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
31600 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31602 ELSEIF(KFLCH.EQ.0) THEN
31603 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31607 ELSEIF(NAGR.EQ.0) THEN
31610 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
31611 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31613 ELSEIF(KFLCH.EQ.0) THEN
31614 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31622 C...Add on correct sign for result.
31629 C*********************************************************************
31632 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
31633 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
31634 C...(Dover, 1965) 6.1.36.
31638 C...Double precision and integer declarations.
31639 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31640 IMPLICIT INTEGER(I-N)
31641 INTEGER PYK,PYCHGE,PYCOMP
31642 C...Local array and data.
31644 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
31645 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
31654 PYGAMM=PYGAMM+B(I)*DXP
31660 PYGAMM=(X-IX)*PYGAMM
31667 C***********************************************************************
31670 C...Calculates real and imaginary parts of the auxiliary functions W1
31671 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
31672 C...der Bij, Nucl. Phys. B297 (1988) 221.
31674 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
31676 C...Double precision and integer declarations.
31677 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31678 IMPLICIT INTEGER(I-N)
31679 INTEGER PYK,PYCHGE,PYCOMP
31681 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31684 ASINH(X)=LOG(X+SQRT(X**2+1D0))
31685 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
31687 IF(EPS.LT.0D0) THEN
31688 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
31689 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
31691 ELSEIF(EPS.LT.1D0) THEN
31692 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
31693 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
31694 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
31695 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
31697 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
31698 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
31705 C***********************************************************************
31708 C...Calculates real and imaginary parts of the auxiliary function I3;
31709 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
31710 C...Nucl. Phys. B297 (1988) 221.
31712 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
31714 C...Double precision and integer declarations.
31715 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31716 IMPLICIT INTEGER(I-N)
31717 INTEGER PYK,PYCHGE,PYCOMP
31719 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31722 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
31723 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
31725 IF(EPS.LT.0D0) THEN
31726 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31727 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
31728 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
31729 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
31730 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
31731 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
31732 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
31733 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
31735 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
31736 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
31737 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
31738 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
31739 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
31740 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
31741 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
31742 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
31743 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31744 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
31745 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
31746 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
31747 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
31748 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
31749 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
31750 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
31752 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
31753 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
31754 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
31755 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
31756 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
31759 ELSEIF(EPS.LT.1D0) THEN
31760 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31761 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
31762 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
31763 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
31764 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
31765 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
31766 & (0.25D0*(RAT+1D0)*EPS))
31767 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
31768 & (0.25D0*(RAT+1D0)*EPS))
31769 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
31770 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
31771 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
31772 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
31773 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
31774 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
31775 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
31776 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
31777 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31778 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
31779 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
31780 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
31781 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
31782 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
31783 & (1D0+0.25D0*RAT*EPS-GA))
31784 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
31785 & (1D0+0.25D0*RAT*EPS-GA))
31787 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
31788 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
31789 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
31790 & LOG((GA+BE-1D0)/(BE-GA))
31791 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
31794 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
31795 RCTHE=RSQ*(1D0-2D0*BE/EPS)
31796 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
31797 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
31798 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
31800 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
31801 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
31802 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
31803 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
31804 & (PHI-THE)*(PHI+THE-PARU(1))
31805 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
31806 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
31809 Y3RE=2D0/(2D0*BE-1D0)*F3RE
31810 Y3IM=2D0/(2D0*BE-1D0)*F3IM
31815 C***********************************************************************
31818 C...Calculates real and imaginary part of Spence function; see
31819 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
31821 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
31823 C...Double precision and integer declarations.
31824 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31825 IMPLICIT INTEGER(I-N)
31826 INTEGER PYK,PYCHGE,PYCOMP
31828 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31830 C...Local array and data.
31833 &1.000000D+00, -5.000000D-01, 1.666667D-01,
31834 &0.000000D+00, -3.333333D-02, 0.000000D+00,
31835 &2.380952D-02, 0.000000D+00, -3.333333D-02,
31836 &0.000000D+00, 7.575757D-02, 0.000000D+00,
31837 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
31841 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
31842 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
31843 IF(IREIM.EQ.2) PYSPEN=0D0
31847 XMOD=SQRT(XRE**2+XIM**2)
31848 IF(XMOD.LT.1D-6) THEN
31849 IF(IREIM.EQ.1) PYSPEN=0D0
31850 IF(IREIM.EQ.2) PYSPEN=0D0
31854 XARG=SIGN(ACOS(XRE/XMOD),XIM)
31858 IF(XMOD.GT.1D0) THEN
31860 ALGXIM=XARG-SIGN(PARU(1),XARG)
31861 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
31862 SP0IM=-ALGXRE*ALGXIM
31869 IF(XRE.GT.0.5D0) THEN
31874 XMOD=SQRT(XRE**2+XIM**2)
31875 XARG=SIGN(ACOS(XRE/XMOD),XIM)
31878 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
31879 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
31885 XMOD=SQRT(XRE**2+XIM**2)
31886 XARG=SIGN(ACOS(XRE/XMOD),XIM)
31895 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
31896 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
31897 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
31900 SPRE=SPRE+B(I)*TERMRE
31901 SPIM=SPIM+B(I)*TERMIM
31904 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
31905 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
31910 C***********************************************************************
31913 C...Calculates the matrix element for the processes
31914 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
31915 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
31916 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
31918 SUBROUTINE PYQQBH(WTQQBH)
31920 C...Double precision and integer declarations.
31921 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31922 IMPLICIT INTEGER(I-N)
31923 INTEGER PYK,PYCHGE,PYCOMP
31925 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31926 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31927 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31928 COMMON/PYINT1/MINT(400),VINT(400)
31929 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31930 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
31931 C...Local arrays and function.
31932 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
31933 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
31936 C...Mass parameters.
31939 SHPR=SQRT(VINT(26))*VINT(1)
31940 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
31941 PH=SQRT(VINT(21))*VINT(1)
31945 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
31947 PT=SQRT(MAX(0D0,VINT(197+5*I)))
31948 PP(I,1)=PT*COS(VINT(198+5*I))
31949 PP(I,2)=PT*SIN(VINT(198+5*I))
31951 PP(3,1)=-PP(1,1)-PP(2,1)
31952 PP(3,2)=-PP(1,2)-PP(2,2)
31953 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
31954 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
31955 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
31957 PP(3,3)=PMT3*SINH(VINT(211))
31958 PP(3,4)=PMT3*COSH(VINT(211))
31959 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
31960 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
31961 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
31962 PP(2,3)=-PP(1,3)-PP(3,3)
31963 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
31964 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
31966 C...Set up incoming kinematics and derived momentum combinations.
31970 PP(I,3)=-0.5D0*SHPR*(-1)**I
31971 PP(I,4)=-0.5D0*SHPR
31974 PP(6,J)=PP(1,J)+PP(2,J)
31975 PP(7,J)=PP(1,J)+PP(3,J)
31976 PP(8,J)=PP(1,J)+PP(4,J)
31977 PP(9,J)=PP(1,J)+PP(5,J)
31978 PP(10,J)=-PP(2,J)-PP(3,J)
31979 PP(11,J)=-PP(2,J)-PP(4,J)
31980 PP(12,J)=-PP(2,J)-PP(5,J)
31981 PP(13,J)=-PP(4,J)-PP(5,J)
31984 C...Derived kinematics invariants.
32013 C...Define colour coefficients for g + g -> Q + Qbar + H.
32014 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
32018 CLR(I+3,J+3)=16D0/3D0
32019 CLR(I,J+3)=-2D0/3D0
32020 CLR(I+3,J)=-2D0/3D0
32033 CLR(6+K1,6+K2)=12D0
32037 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
32038 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
32039 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
32040 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
32041 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
32042 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
32043 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
32045 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
32046 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
32047 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
32048 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
32049 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
32050 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
32051 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
32052 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
32053 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
32054 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
32055 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
32056 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
32057 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
32058 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
32059 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
32060 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
32061 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
32062 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
32064 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
32065 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
32066 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
32067 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
32068 & +X4*X9*X5+X4*X5**2)
32069 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
32070 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
32071 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
32072 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
32073 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
32074 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
32075 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
32076 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
32077 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
32078 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
32079 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
32080 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
32081 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
32082 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
32083 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
32084 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
32085 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
32086 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
32087 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
32088 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
32090 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
32091 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
32092 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
32093 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
32094 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
32095 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
32096 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
32098 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
32099 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
32100 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
32101 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
32102 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
32103 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
32105 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
32106 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
32107 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
32108 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
32109 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
32110 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
32111 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
32113 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
32114 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
32115 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
32116 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
32117 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
32118 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
32119 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
32120 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
32121 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
32122 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
32123 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
32124 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
32125 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
32126 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
32127 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
32128 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
32129 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
32130 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
32131 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
32132 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
32133 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
32134 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
32135 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
32136 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
32137 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
32138 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
32139 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
32140 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
32141 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
32142 & +X3*X8*X5+X3*X5**2)
32143 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
32144 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
32145 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
32146 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
32147 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
32148 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
32149 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
32151 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
32152 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
32153 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
32154 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
32155 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
32156 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
32157 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
32158 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
32159 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
32160 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
32161 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
32162 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
32163 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
32164 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
32165 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
32166 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
32167 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
32168 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
32169 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
32170 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
32171 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
32172 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
32173 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
32174 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
32175 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
32176 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
32178 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
32179 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
32180 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
32181 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
32182 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
32183 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
32184 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
32185 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
32186 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
32187 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
32188 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
32189 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
32190 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
32191 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
32192 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
32193 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
32194 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
32195 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
32196 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
32197 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
32198 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
32199 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
32200 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
32201 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
32202 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
32203 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
32205 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
32206 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
32207 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
32208 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
32209 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
32210 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
32211 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
32212 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
32213 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
32214 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
32215 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
32216 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
32217 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
32218 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
32219 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
32220 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
32221 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
32222 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
32223 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
32224 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
32225 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
32226 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
32227 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
32228 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
32229 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
32230 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
32231 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
32232 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
32233 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
32234 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
32235 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
32236 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
32237 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
32238 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
32239 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
32240 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
32241 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
32242 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
32243 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
32244 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
32245 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
32246 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
32247 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
32248 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
32250 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
32251 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
32252 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
32253 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
32254 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
32255 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
32256 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
32257 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
32258 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
32259 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
32260 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
32262 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
32263 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
32264 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
32265 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
32266 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
32267 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
32269 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
32270 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
32271 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
32273 FM(9,10)=0.5D0*(FMXX+FM(9,10))
32274 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
32275 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
32276 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
32278 C...Repackage matrix elements.
32284 RM(7,7)=FM(7,7)-2D0*FM(9,9)
32285 RM(7,8)=FM(7,8)-2D0*FM(9,10)
32286 RM(8,8)=FM(8,8)-2D0*FM(10,10)
32288 C...Produce final result: matrix elements * colours * propagators.
32293 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
32296 WTQQBH=-WTQQBH/256D0
32299 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
32300 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
32301 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
32303 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
32304 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
32305 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
32307 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
32308 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
32311 C...Produce final result: matrix elements * propagators.
32313 A12=A12/(DX(7)*DX(8))
32315 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
32321 C*********************************************************************
32324 C...Initializes supersymmetry: finds sparticle masses and
32325 C...branching ratios and stores this information.
32326 C...AUTHOR: STEPHEN MRENNA
32327 C...Baryon- and lepton-number violating parameters by P. Z. Skands.
32331 C...Double precision and integer declarations.
32332 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32333 IMPLICIT INTEGER(I-N)
32334 INTEGER PYK,PYCHGE,PYCOMP
32335 C...Parameter statement to help give large particle numbers.
32336 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32337 &KEXCIT=4000000,KDIMEN=5000000)
32339 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32340 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32341 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32342 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32343 COMMON/PYINT4/MWID(500),WIDS(500,5)
32344 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32345 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
32346 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32347 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
32348 COMMON/PYHTRI/HHH(7)
32349 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
32352 C...Local variables.
32353 DOUBLE PRECISION ALFA,BETA
32354 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
32355 INTEGER I,J,J1,I1,K1
32356 INTEGER KC,LKNT,IDLAM(400,3)
32357 DOUBLE PRECISION XLAM(0:400)
32358 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
32359 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
32360 DOUBLE PRECISION DELM,XMDIF
32361 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
32362 DOUBLE PRECISION ARG,SGNMU,R
32365 INTEGER KFSUSY(36),MWIDSU(36),MDCYSU(36)
32368 &1000001,2000001,1000002,2000002,1000003,2000003,
32369 &1000004,2000004,1000005,2000005,1000006,2000006,
32370 &1000011,2000011,1000012,2000012,1000013,2000013,
32371 &1000014,2000014,1000015,2000015,1000016,2000016,
32372 &1000021,1000022,1000023,1000025,1000035,1000024,
32373 &1000037,1000039, 25, 35, 36, 37/
32376 C...Do nothing if SUSY not requested.
32378 IF(IMSSM.EQ.0) RETURN
32380 C...Save copy of MWID(KC) and MDCY(KC,1) values before
32381 C...they are set to zero for the LSP.
32388 MDCYSU(I)=MDCY(KC,1)
32392 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
32396 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
32398 MDCY(KC,1)=MDCYSU(I)
32402 C...First part of routine: set masses and couplings.
32404 C...Reset mixing values in sfermion sector to pure left/right.
32412 C...Common couplings.
32417 COS2B=COS(2D0*BETA)
32423 C...Define sparticle masses for a general MSSM simulation.
32424 IF(IMSSM.EQ.1) THEN
32425 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
32427 KC=PYCOMP(KSUSY1+I)
32428 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
32429 KC=PYCOMP(KSUSY2+I)
32430 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
32431 KC=PYCOMP(KSUSY1+I+1)
32432 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
32433 KC=PYCOMP(KSUSY2+I+1)
32434 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
32436 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
32437 IF(XARG.LT.0D0) THEN
32438 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
32439 & ' FROM THE SUM RULE. '
32440 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
32446 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
32447 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
32448 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
32449 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
32451 IF(IMSS(8).EQ.1) THEN
32456 C...Alternatively derive masses from SUGRA relations.
32457 ELSEIF(IMSSM.EQ.2) THEN
32460 ELSEIF(IMSSM.EQ.12) THEN
32466 C...Add in extra D-term contributions.
32467 IF(IMSS(7).EQ.1) THEN
32472 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32473 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
32474 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
32475 WRITE(MSTU(11),*) 'C DX = ',DX
32476 WRITE(MSTU(11),*) 'C DY = ',DY
32477 WRITE(MSTU(11),*) 'C DS = ',DS
32478 WRITE(MSTU(11),*) 'C '
32479 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
32480 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
32481 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32482 DQ2=DY/6D0-DX/3D0-DS/3D0
32483 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
32484 DD2=DY/3D0+DX-2D0*DS/3D0
32485 DL2=-DY/2D0+DX-2D0*DS/3D0
32486 DE2=DY-DX/3D0-DS/3D0
32487 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
32488 DHD2=-DY/2D0-2D0*DX/3D0+DS
32489 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
32491 DMA2 = 2D0*DMU2+DHU2+DHD2
32493 KC=PYCOMP(KSUSY1+I)
32494 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
32495 KC=PYCOMP(KSUSY2+I)
32496 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
32497 KC=PYCOMP(KSUSY1+I+1)
32498 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
32499 KC=PYCOMP(KSUSY2+I+1)
32500 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
32503 KC=PYCOMP(KSUSY1+I)
32504 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
32505 KC=PYCOMP(KSUSY2+I)
32506 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
32507 KC=PYCOMP(KSUSY1+I+1)
32508 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
32510 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
32511 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
32514 SGNMU=SIGN(1D0,RMSS(4))
32515 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
32516 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
32517 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
32518 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
32519 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
32520 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
32521 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
32522 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
32523 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
32524 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
32525 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
32526 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
32527 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
32530 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
32531 RMSS(6)=SQRT(RMSS(6)**2+DL2)
32532 RMSS(7)=SQRT(RMSS(7)**2+DE2)
32533 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
32534 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
32535 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
32536 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
32537 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
32540 C...Fix the third generation sfermions.
32543 C...Fix the neutralino--chargino--gluino sector.
32546 C...Fix the Higgs sector.
32549 C...Choose the Gunion-Haber convention.
32553 C...Print information on mass parameters.
32554 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
32555 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32556 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
32557 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
32558 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
32559 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
32560 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
32561 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
32562 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
32563 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
32564 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32566 IF(IMSS(20).EQ.1) THEN
32567 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32568 WRITE(MSTU(11),*) ' DEBUG MODE '
32569 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
32570 & UMIX(2,1),UMIX(2,2)
32571 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
32572 & UMIXI(2,1),UMIXI(2,2)
32573 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
32574 & VMIX(2,1),VMIX(2,2)
32575 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
32576 & VMIXI(2,1),VMIXI(2,2)
32577 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
32578 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
32579 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
32580 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
32581 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
32582 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
32583 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
32584 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
32585 WRITE(MSTU(11),*) ' ALFA = ',ALFA
32586 WRITE(MSTU(11),*) ' BETA = ',BETA
32587 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
32588 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
32589 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32592 C...Set up the Higgs couplings - needed here since initialization
32593 C...in PYINRE did not yet occur when PYWIDT is called below.
32605 C2B=COSB**2-SINB**2
32606 C...tanb (used for H+)
32610 C...Coupling to d-type quarks
32611 PARU(161)=SINA/COSB
32612 C...Coupling to u-type quarks
32613 PARU(162)=-COSA/SINB
32614 C...Coupling to leptons
32615 PARU(163)=PARU(161)
32619 PARU(165)=PARU(164)
32622 C...Coupling to d-type quarks
32623 PARU(171)=-COSA/COSB
32624 C...Coupling to u-type quarks
32625 PARU(172)=-SINA/SINB
32626 C...Coupling to leptons
32627 PARU(173)=PARU(171)
32631 PARU(175)=PARU(174)
32633 IF(IMSS(4).EQ.2) THEN
32634 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
32636 HHH(3)=HHH(3)+HHH(4)+HHH(5)
32637 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
32638 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
32639 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
32640 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
32644 IF(IMSS(4).EQ.2) THEN
32645 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
32647 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
32648 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
32649 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
32650 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
32653 IF(IMSS(4).EQ.2) THEN
32654 PARU(177)=COS(2D0*BE)*COS(BE+AL)
32656 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
32657 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
32658 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
32659 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
32662 IF(IMSS(4).EQ.2) THEN
32663 PARU(178)=PARU(177)
32665 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
32668 C...Coupling to d-type quarks
32670 C...Coupling to u-type quarks
32671 PARU(182)=1D0/PARU(181)
32672 C...Coupling to leptons
32673 PARU(183)=PARU(181)
32676 C...Coupling to Z h
32677 PARU(186)=COS(BE-AL)
32678 C...Coupling to Z H
32679 PARU(187)=SIN(BE-AL)
32685 C...Coupling to W h
32686 PARU(195)=COS(BE-AL)
32688 C...Tell that all Higgs couplings have been set.
32691 C...Set R-Violating couplings.
32692 C...Set lambda couplings to common value or "natural values".
32693 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
32694 VIR3=1D0/(126D0)**3
32698 IF (IRI.NE.IRJ) THEN
32699 IF (IRI.LT.IRJ) THEN
32700 RVLAM(IRI,IRJ,IRK)=RMSS(51)
32701 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
32702 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
32703 & PMAS(9+2*IRK,1)*VIR3)
32705 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
32708 RVLAM(IRI,IRJ,IRK)=0D0
32714 C...Set lambda' couplings to common value or "natural values".
32715 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
32716 VIR3=1D0/(126D0)**3
32720 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
32721 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
32722 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
32723 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
32728 C...Set lambda'' couplings to common value or "natural values".
32729 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
32730 VIR3=1D0/(126D0)**3
32734 IF (IRJ.NE.IRK) THEN
32735 IF (IRJ.LT.IRK) THEN
32736 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
32737 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
32738 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
32739 & PMAS(2*IRK-1,1)*VIR3)
32741 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
32744 RVLAMB(IRI,IRJ,IRK) = 0D0
32751 C...Antisymmetrize couplings set by user
32752 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
32756 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
32757 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
32758 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
32760 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
32761 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
32762 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
32769 C...Second part of routine: set decay modes and branching ratios.
32771 C...Allow chi10 -> gravitino + gamma or not.
32772 KC=PYCOMP(KSUSY1+39)
32773 IF( IMSS(11) .NE. 0 ) THEN
32774 PMAS(KC,1)=RMSS(21)/1000000000D0
32775 PMAS(KC,2)=0.0001D0
32777 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
32778 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
32780 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
32781 & ' ALLOWING SUSY LLE DECAYS'
32782 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
32783 & ' ALLOWING SUSY LQD DECAYS'
32784 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
32785 & ' ALLOWING SUSY UDD DECAYS'
32786 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
32787 & ' --- Warning: R-Violating couplings possibly',
32788 & ' incompatible with proton decay'
32794 C...Loop over sparticle and Higgs species.
32795 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
32796 C...Find the LSP or NLSP for a gravitino LSP
32801 IF(KF.EQ.1000039) GOTO 300
32803 IF(PMAS(KC,1).LT.PMLSP) THEN
32813 C...Sfermion decays.
32815 C...First check to see if sneutrino is lighter than chi10.
32816 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
32817 & PMAS(KC,1).LT.PMCHI1) THEN
32819 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
32823 ELSEIF(I.EQ.25) THEN
32824 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
32825 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
32827 C...Neutralino decays.
32828 ELSEIF(I.GE.26.AND.I.LE.29) THEN
32829 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
32830 C...chi10 stable or chi10 -> gravitino + gamma.
32831 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
32837 C...Chargino decays.
32838 ELSEIF(I.GE.30.AND.I.LE.31) THEN
32839 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
32841 C...Gravitino is stable.
32842 ELSEIF(I.EQ.32) THEN
32847 ELSEIF(I.GE.33.AND.I.LE.36) THEN
32848 C...Calculate decays to non-SUSY particles.
32849 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
32854 DO 330 I1=1,MDCY(KC,3)
32856 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
32857 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
32859 XLAM(0)=XLAM(0)+XLAM(I1)
32861 IDLAM(I1,J1)=KFDP(K1,J1)
32865 C...Add the decays to SUSY particles.
32866 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
32868 C...Zero the branching ratios for use in loop mode
32869 C...thanks to K. Matchev (FNAL)
32870 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
32874 C...Set stable particles.
32882 C...Store branching ratios in the standard tables.
32884 IDC=MDCY(KC,2)+MDCY(KC,3)-1
32890 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
32891 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
32892 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
32893 BRAT(IDC)=XLAM(IL)/XLAM(0)
32895 IF(MDME(IDC,1).GE.1) THEN
32896 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
32897 & PMAS(PYCOMP(KFDP(IDC,2)),1)
32898 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
32899 & PMAS(PYCOMP(KFDP(IDC,3)),1)
32902 IF(XMDIF.GE.0D0) THEN
32903 DELM=MIN(DELM,XMDIF)
32905 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
32906 WRITE(MSTU(11),*) ' KF = ',KF
32907 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
32911 ELSEIF(IDC.EQ.IDCSV) THEN
32912 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
32913 & 'channel not recognized:'
32914 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
32921 C...Store width, cutoff and lifetime.
32923 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
32924 PMAS(KC,3)=PMAS(KC,2)*10D0
32926 PMAS(KC,3)=0.95D0*DELM
32928 IF(PMAS(KC,2).NE.0D0) THEN
32929 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
32937 C*********************************************************************
32940 C...Uses approximate analytical formulae to determine the full set of
32941 C...MSSM parameters from SUGRA input.
32942 C...See M. Drees and S.P. Martin, hep-ph/9504124
32946 C...Double precision and integer declarations.
32947 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32948 IMPLICIT INTEGER(I-N)
32949 INTEGER PYK,PYCHGE,PYCOMP
32950 C...Parameter statement to help give large particle numbers.
32951 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32952 &KEXCIT=4000000,KDIMEN=5000000)
32954 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32955 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32956 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32957 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
32974 SINB=TANB/SQRT(TANB**2+1D0)
32977 DTERM=XMZ2*COS(2D0*BETA)
32978 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
32979 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
32982 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
32983 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
32984 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
32985 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
32987 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
32988 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
32989 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
32990 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
32992 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
32993 IF(XARG.LT.0D0) THEN
32994 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
32995 & ' FROM THE SUM RULE. '
32996 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
33002 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
33003 PMAS(PYCOMP(KSUSY2+I),1)=XMER
33004 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
33005 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
33007 RMT=PYMRUN(6,PMAS(6,1)**2)
33008 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
33009 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
33010 RMB=PYMRUN(5,PMAS(6,1)**2)
33011 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
33012 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
33013 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
33014 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
33017 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
33018 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
33019 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
33020 XMU=SIGN(SQRT(XMU2),RMSS(4))
33022 IF(XMA2.GT.0D0) THEN
33023 RMSS(19)=SQRT(XMA2)
33025 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
33028 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
33029 IF(ARG.GT.0D0) THEN
33032 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
33035 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
33036 IF(ARG.GT.0D0) THEN
33039 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
33042 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
33043 IF(ARG.GT.0D0) THEN
33046 RMSS(10)=-SQRT(-ARG)
33048 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
33049 IF(ARG.GT.0D0) THEN
33052 RMSS(12)=-SQRT(-ARG)
33054 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
33055 IF(ARG.GT.0D0) THEN
33058 RMSS(11)=-SQRT(-ARG)
33064 C*********************************************************************
33067 C...Interface to ISASUSY version 7.61.
33068 C...Warning: if you use earlier versions, change dimension to
33069 C...SUPER(66) in /SSPAR/ and remove MHPNEG and ASM3 from /SUGPAS/.
33070 C...Calls SUGRA (in ISAJET) to perform RGE evolution.
33071 C...Then converts to Gunion-Haber conventions.
33074 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33076 INTEGER PYK,PYCHGE,PYCOMP
33077 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33078 &KEXCIT=4000000,KDIMEN=5000000)
33082 PARAMETER (DOC='22 Nov 2002')
33084 C...ISASUGRA Input:
33085 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
33086 C...ISASUGRA Output
33087 CHARACTER*40 ISAVER,VISAJE
33089 COMMON /SSPAR/ SUPER(69)
33090 COMMON /SUGMG/ MSS(32),GSS(29),MGUTSS,GGUTSS,AGUTSS,FTGUT,
33091 $FBGUT,FTAGUT,FNGUT
33092 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
33093 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
33094 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
33095 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3
33096 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
33097 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
33099 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
33100 C SUPER: Filled by ISASUGRA.
33101 C SUPER(1) = mass of ~g
33102 C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
33103 C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
33104 C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
33106 C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
33107 C SUPER(29) = Higgsino mass = - mu
33108 C SUPER(30) = ratio v2/v1 of vev's
33109 C SUPER(31:34) = Signed neutralino masses
33110 C SUPER(35:50) = Neutralino mixing matrix
33111 C SUPER(51:52) = Signed chargino masses
33112 C SUPER(53:54) = Chargino left, right mixing angles
33113 C SUPER(55:58) = mass of h0, H0, A0, H+
33114 C SUPER(59) = Higgs mixing angle alpha
33115 C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
33116 C SUPER(66) = Gravitino mass
33117 C GSS: Filled by ISASUGRA
33118 C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
33119 C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
33120 C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
33121 C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
33122 C GSS(13) = M_h1^2 GSS(14) = M_h2^2 GSS(15) = M_er^2
33123 C GSS(16) = M_el^2 GSS(17) = M_dnr^2 GSS(18) = M_upr^2
33124 C GSS(19) = M_upl^2 GSS(20) = M_taur^2 GSS(21) = M_taul^2
33125 C GSS(22) = M_btr^2 GSS(23) = M_tpr^2 GSS(24) = M_tpl^2
33126 C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
33127 C GSS(28) = M_nr GSS(29) = A_n
33128 C MSS: Filled by ISASUGRA
33129 C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
33130 C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
33131 C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
33132 C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
33133 C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
33134 C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
33135 C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
33136 C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
33137 C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
33138 C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
33139 C MSS(31) = ha0 MSS(32) = h+
33140 C Unification, filled by ISASUGRA if applicable.
33141 C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
33142 C...SPYTHIA Input/Output:
33144 DOUBLE PRECISION RMSS
33145 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33146 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33147 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33148 SAVE /SUGMG/,/SSPAR/
33150 C...PYTHIA common blocks
33152 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33153 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33154 C...Particle properties + some flavour parameters.
33155 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33156 SAVE /PYDAT2/,/PYSSMT/
33158 C...Start by checking for incompatibilities/inconsistencies:
33160 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
33161 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
33162 & ,' option not used by PYSUGI'
33165 C...ISAJET works with REAL numbers.
33166 MZERO=REAL(RMSS(8))
33168 AZERO=REAL(RMSS(16))
33170 SGNMU=REAL(RMSS(4))
33171 MTOP=REAL(PMAS(6,1))
33172 C...Initialize MSSM parameter array
33177 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,1)
33178 C...Check whether ISASUSY thought the model was OK.
33179 IF (NOGOOD.NE.0) THEN
33180 IF (NOGOOD.EQ.1) CALL PYERRM(26
33181 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
33182 IF (NOGOOD.EQ.2) CALL PYERRM(26
33183 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
33184 IF (NOGOOD.EQ.3) CALL PYERRM(26
33185 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
33186 IF (NOGOOD.EQ.4) CALL PYERRM(26
33187 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
33188 IF (NOGOOD.EQ.7) CALL PYERRM(26
33189 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
33190 IF (NOGOOD.EQ.8) CALL PYERRM(26
33191 & ,'(PYSUGI:) SUSY parameters give m(h0)^2 < 0.')
33192 C...Give warning, but don't stop, if LSP not ~chi_10.
33193 IF (NOGOOD.EQ.5) CALL PYERRM(16
33194 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
33196 C...Warn about possible GUT scale tachyons.
33197 IF (ITACHY.NE.0) CALL PYERRM(16,
33198 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
33205 C...Mu = - Higgsino mass.
33208 C...Slepton and squark masses. 2 first generations.
33209 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
33210 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
33211 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
33212 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
33213 C...Third generation.
33214 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
33219 C...~b, ~t, and ~tau trilinear couplings and mixing angles.
33226 C...Higgs mixing angle alpha (Gunion-Haber convention).
33227 RMSS(18)=-SUPER(59)
33230 C...GUT scale coupling
33232 C...Gravitino mass (for future compatibility)
33235 C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
33237 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
33238 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
33239 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
33240 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
33242 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
33243 C...Squarks and Sleptons.
33246 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
33247 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
33248 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
33249 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
33250 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
33251 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
33252 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
33253 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
33254 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
33256 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
33257 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
33258 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
33260 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
33261 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
33262 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
33263 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
33264 C...Signed masses (extra minus from going to G-H convention).
33270 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
33271 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
33272 C...Signed masses (extra minus from going to G-H convention).
33276 C... Neutralino Mixing.
33278 ZMIX(IN,1)= SUPER(38+4*(IN-1))
33279 ZMIX(IN,2)= SUPER(37+4*(IN-1))
33280 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
33281 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
33283 C...Chargino Mixing (PYTHIA same angle as HERWIG).
33286 IF (SUPER(53).GT.0) THX=-1D0
33287 IF (SUPER(54).GT.0) THY=-1D0
33288 UMIX(1,1) = -SIN(SUPER(53))
33289 UMIX(1,2) = -COS(SUPER(53))
33290 UMIX(2,1) = -THX*COS(SUPER(53))
33291 UMIX(2,2) = THX*SIN(SUPER(53))
33292 VMIX(1,1) = -SIN(SUPER(54))
33293 VMIX(1,2) = -COS(SUPER(54))
33294 VMIX(2,1) = -THY*COS(SUPER(54))
33295 VMIX(2,2) = THY*SIN(SUPER(54))
33296 C...Sfermion mixing (PYTHIA same angle as ISAJET)
33297 SFMIX(5,1)=COS(SUPER(63))
33298 SFMIX(5,2)=SIN(SUPER(63))
33299 SFMIX(5,3)=-SIN(SUPER(63))
33300 SFMIX(5,4)=COS(SUPER(63))
33301 SFMIX(6,1)=COS(SUPER(61))
33302 SFMIX(6,2)=SIN(SUPER(61))
33303 SFMIX(6,3)=-SIN(SUPER(61))
33304 SFMIX(6,4)=COS(SUPER(61))
33305 SFMIX(15,1)=COS(SUPER(65))
33306 SFMIX(15,2)=SIN(SUPER(65))
33307 SFMIX(15,3)=-SIN(SUPER(65))
33308 SFMIX(15,4)=COS(SUPER(65))
33310 IF (MSTP(122).NE.0) THEN
33311 C...Print a few lines to make the user know what's happening
33313 WRITE(MSTU(11),5000) DOC, ISAVER
33314 WRITE(MSTU(11),5100)
33315 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU), MTOP
33316 WRITE(MSTU(11),5300)
33317 WRITE(MSTU(11),5500) 'EW scale masses'
33318 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
33319 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
33320 & ,(SUPER(IP),IP=19,25,2)
33321 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
33323 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
33324 WRITE(MSTU(11),5400)
33325 WRITE(MSTU(11),5500) 'Mixing structure'
33326 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
33327 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
33328 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
33329 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
33330 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
33331 & ),(SFMIX(15,J),J=3,4)
33332 WRITE(MSTU(11),5400)
33333 WRITE(MSTU(11),5500) 'Couplings'
33334 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
33335 WRITE(MSTU(11),5400)
33336 WRITE(MSTU(11),6500)
33339 C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
33340 C...output by ISASUGRA.
33343 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.1: PYTHIA/ISASUGRA '
33344 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
33345 & ,1x,'-',1x,'P.Z. Skands'/1x,'*',2x,A/1x,'*')
33346 5100 FORMAT(1x,'*',1x,'ISASUGRA Input:'/1x,'*',1x,'----------------')
33347 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
33348 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
33349 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUGRA Output:'/1x,'*',1x
33350 & ,'----------------')
33351 5400 FORMAT(1x,'*',1x,A)
33352 5500 FORMAT(1x,'*',1x,A,':')
33353 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
33354 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
33355 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
33356 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
33357 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
33359 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
33360 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
33361 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
33363 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
33364 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
33365 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
33366 6000 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
33367 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
33368 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
33369 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
33370 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
33371 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
33372 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
33373 & ,1x,F6.3,1x),'|')
33374 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
33375 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
33376 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
33377 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
33378 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
33379 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
33380 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
33381 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
33382 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
33383 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
33384 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
33385 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
33386 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
33387 & ,4x,'Alpha_GUT = ',F8.2)
33388 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
33391 C*********************************************************************
33394 C...Determines the running mass of Squarks.
33396 FUNCTION PYRNMQ(ID,DTERM)
33398 C...Double precision and integer declarations.
33399 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33400 IMPLICIT INTEGER(I-N)
33401 INTEGER PYK,PYCHGE,PYCOMP
33403 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33406 C...Local variables.
33407 DOUBLE PRECISION PI,R
33408 DOUBLE PRECISION TOL
33409 DOUBLE PRECISION CI(3)
33411 DOUBLE PRECISION PYALPS
33413 DATA PI,R/3.141592654D0,.61803399D0/
33414 DATA CI/0.47D0,0.07D0,0.02D0/
33418 AG=(0.71D0)**2/4D0/PI
33425 AS=PYALPS(XM02+6D0*XMG2)
33426 CG=8D0/9D0*((AS/AG)**2-1D0)
33427 BX=XM02+(CA+CG)*XMG2+DTERM
33428 AX=MIN(50D0**2,0.5D0*BX)
33429 CX=MAX(2000D0**2,2D0*BX)
33433 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
33441 CG=8D0/9D0*((AS1/AG)**2-1D0)
33442 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
33444 CG=8D0/9D0*((AS2/AG)**2-1D0)
33445 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
33446 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
33453 CG=8D0/9D0*((AS2/AG)**2-1D0)
33454 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
33461 CG=8D0/9D0*((AS1/AG)**2-1D0)
33462 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
33477 C*********************************************************************
33480 C...Calculates the mass eigenstates of the third generation sfermions.
33481 C...Created: 5-31-96
33485 C...Double precision and integer declarations.
33486 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33487 IMPLICIT INTEGER(I-N)
33488 INTEGER PYK,PYCHGE,PYCOMP
33489 C...Parameter statement to help give large particle numbers.
33490 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33491 &KEXCIT=4000000,KDIMEN=5000000)
33493 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33494 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33495 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33496 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33497 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33498 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
33500 C...Local variables.
33501 DOUBLE PRECISION BETA
33502 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
33503 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
33504 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
33505 DOUBLE PRECISION ATR,AMQR,AMQL
33506 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
33507 INTEGER IF,I,J,II,JJ,IT,L
33521 COS2B=COS(2D0*BETA)
33523 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
33533 XMQL2=CTT2*XM12+STT2*XM22
33534 XMQR2=STT2*XM12+CTT2*XM22
33535 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
33536 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
33538 C......SUBTRACT OUT D-TERM AND FERMION MASS
33539 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
33540 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
33541 IF(XMQL2.GE.0D0) THEN
33542 RMSS(10)=SQRT(XMQL2)
33544 RMSS(10)=-SQRT(-XMQL2)
33546 IF(XMQR2.GE.0D0) THEN
33547 RMSS(12)=SQRT(XMQR2)
33549 RMSS(12)=-SQRT(-XMQR2)
33552 C SAME FOR BOTTOM SQUARK
33558 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
33559 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
33560 IF(ABS(CTT).GE..9999D0) THEN
33563 ELSEIF(ABS(CTT).LE.1D-4) THEN
33567 XM12=(XMQL2-STT2*XM22)/CTT2
33568 XMQR2=STT2*XM12+CTT2*XM22
33569 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
33572 C......SUBTRACT OUT D-TERM AND FERMION MASS
33573 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
33574 IF(XMQR2.GE.0D0) THEN
33575 RMSS(11)=SQRT(XMQR2)
33577 RMSS(11)=-SQRT(-XMQR2)
33579 C SAME FOR TAU SLEPTON
33586 XMQL2=CTT2*XM12+STT2*XM22
33587 XMQR2=STT2*XM12+CTT2*XM22
33590 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
33592 C......SUBTRACT OUT D-TERM AND FERMION MASS
33593 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
33594 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
33595 IF(XMQL2.GE.0D0) THEN
33596 RMSS(13)=SQRT(XMQL2)
33598 RMSS(13)=-SQRT(-XMQL2)
33600 IF(XMQR2.GE.0D0) THEN
33601 RMSS(14)=SQRT(XMQR2)
33603 RMSS(14)=-SQRT(-XMQR2)
33608 IF(AMQL.LT.0D0) THEN
33615 IF(AMQR.LT.0D0) THEN
33621 XMF=PYMRUN(IF,PMAS(6,1)**2)
33623 AM2(1,1)=XMQL2+XMF2
33624 AM2(2,2)=XMQR2+XMF2
33625 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
33628 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
33629 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
33630 AM2(1,2)=XMF*(ATR+XMU*TANB)
33631 ELSEIF(L.EQ.2) THEN
33632 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
33633 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
33634 AM2(1,2)=XMF*(ATR+XMU/TANB)
33635 ELSEIF(L.EQ.3) THEN
33636 IF(IMSS(8).EQ.1) THEN
33637 AM2(1,1)=RMSS(6)**2
33638 AM2(2,2)=RMSS(7)**2
33643 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
33644 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
33645 AM2(1,2)=XMF*(ATR+XMU*TANB)
33650 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
33651 IF(DETM.LT.0D0) THEN
33652 WRITE(MSTU(11),*) ID2(L),DETM,AM2
33653 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
33655 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
33656 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
33660 IF(XMF22-XMF12.GT.0D0) THEN
33661 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
33663 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
33664 & AM2(1,2)/(XMF22-XMF12))
33680 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
33686 IF(DI(1,1).GT.DI(2,2)) THEN
33687 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
33688 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
33689 WRITE(MSTU(11),*) AM2
33690 WRITE(MSTU(11),*) DI
33691 WRITE(MSTU(11),*) RT
33702 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
33703 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
33704 & ' OFF DIAGONAL ELEMENTS '
33705 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
33706 WRITE(MSTU(11),*) DI
33707 WRITE(MSTU(11),*) ' ROTATION = ',RT
33709 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
33710 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
33711 & ' NEGATIVE MASSES '
33714 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
33715 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
33716 SFMIX(IF,1)=RT(1,1)
33717 SFMIX(IF,2)=RT(1,2)
33718 SFMIX(IF,3)=RT(2,1)
33719 SFMIX(IF,4)=RT(2,2)
33722 C.....TAU SNEUTRINO MASS...L=3
33724 XARG=AM2(1,1)+XMW2*COS2B
33725 IF(XARG.LT.0D0) THEN
33726 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
33727 & ' FROM THE SUM RULE. '
33728 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
33731 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
33737 C*********************************************************************
33740 C...Finds the mass eigenstates and mixing matrices for neutralinos
33745 C...Double precision and integer declarations.
33746 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33747 IMPLICIT INTEGER(I-N)
33749 C...Parameter statement to help give large particle numbers.
33750 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33751 &KEXCIT=4000000,KDIMEN=5000000)
33753 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33754 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33755 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33756 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33757 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33758 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
33760 C...Local variables.
33761 DOUBLE PRECISION XMW,XMZ,XM(4)
33762 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),AI(4,4)
33763 DOUBLE PRECISION WI(4),FV1(4),FV2(4),FV3(4)
33764 DOUBLE PRECISION COSW,SINW
33765 DOUBLE PRECISION XMU
33766 DOUBLE PRECISION TANB,COSB,SINB
33767 DOUBLE PRECISION XM1,XM2,XM3,BETA
33768 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
33769 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
33770 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
33771 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
33772 DOUBLE PRECISION PYALPS,PYALEM
33773 DOUBLE PRECISION PYRNM3
33774 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
33775 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
33776 DATA KFNCHI/1000022,1000023,1000025,1000035/
33779 IF(IMSS(1).EQ.2) THEN
33782 C...M1, M2, AND M3 ARE INDEPENDENT
33787 ELSEIF(IOPT.GE.1) THEN
33791 A1=AEM/(1D0-PARU(102))
33794 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
33796 XM2=XM1*A2/A1*3D0/5D0
33798 ELSEIF(IOPT.EQ.3) THEN
33799 XM1=XM2*5D0/3D0*A1/A2
33804 IF(XM3.LE.0D0) THEN
33805 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
33811 IF(IMSS(3).EQ.1) THEN
33812 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
33817 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
33818 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
33819 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
33825 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
33826 RM2=PMAS(I,1)**2/XM3**2
33827 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
33828 IF(ARG.GE.0D0) THEN
33829 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
33831 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
33836 ELSEIF(X0.EQ.0D0) THEN
33840 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
33841 & 0.5D0*X0**2*LOG(AX0)
33842 BT=(-1D0-2D0*X0)/4D0
33847 ELSEIF(X1.EQ.0D0) THEN
33851 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
33852 & X1**2*LOG(AX1)+AT
33853 BT=(-1D0-2D0*X1)/4D0+BT
33857 X0=0.5D0*(1D0+RM2-RM1)
33858 Y0=-0.5D0*SQRT(-ARG)
33859 AMGX0=SQRT(X0**2+Y0**2)
33860 AM1X0=SQRT((1D0-X0)**2+Y0**2)
33861 ARGX0=ATAN2(-X0,-Y0)
33862 AR1X0=ATAN2(1D0-X0,Y0)
33867 ARGX1=ATAN2(-X1,-Y1)
33868 AR1X1=ATAN2(1D0-X1,Y1)
33869 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
33870 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
33871 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
33872 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
33873 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
33874 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
33879 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
33880 & /(2D0*PARU(2))*(15D0+AQ))
33883 C...NEUTRALINO MASSES
33892 SINW=SQRT(PARU(102))
33893 COSW=SQRT(1D0-PARU(102))
33900 C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
33901 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
33902 AR(1,1) = XM1*COS(RMSS(30))
33903 AI(1,1) = XM1*SIN(RMSS(30))
33904 AR(2,2) = XM2*COS(RMSS(31))
33905 AI(2,2) = XM2*SIN(RMSS(31))
33910 AR(1,3) = -XMZ*SINW*COSB
33912 AR(1,4) = XMZ*SINW*SINB
33914 AR(2,3) = XMZ*COSW*COSB
33916 AR(2,4) = -XMZ*COSW*SINB
33918 AR(3,4) = -XMU*COS(RMSS(33))
33919 AI(3,4) = -XMU*SIN(RMSS(33))
33920 AR(4,3) = -XMU*COS(RMSS(33))
33921 AI(4,3) = -XMU*SIN(RMSS(33))
33922 C CALL PYEIG4(AR,WR,ZR)
33923 CALL PYEICG(4,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
33925 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
33934 IF(XM(K).LT.XM(J)) THEN
33952 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
33955 S=S+ZR(J,K)**2+ZI(J,K)**2
33958 ZMIX(I,J)=ZR(J,K)/SQRT(S)
33959 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
33960 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
33961 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
33965 C...CHARGINO MASSES
33966 C.....Find eigenvectors of X X^*
33969 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
33970 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
33971 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
33972 &XMU*COS(RMSS(33))*SINB)
33973 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
33974 &XMU*SIN(RMSS(33))*SINB)
33975 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
33976 &XMU*COS(RMSS(33))*SINB)
33977 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
33978 &XMU*SIN(RMSS(33))*SINB)
33979 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
33981 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
33985 IF(WR(2).LT.WR(1)) THEN
33995 S=S+ZR(J,K)**2+ZI(J,K)**2
33998 UMIX(I,J)=ZR(J,K)/SQRT(S)
33999 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
34000 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
34001 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
34004 IF(ABS(SMW(1)).LT.ABS(SMZ(1))) THEN
34005 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
34007 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
34008 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
34010 C.....Find eigenvectors of X^* X
34013 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
34014 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
34015 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
34016 &XMU*COS(RMSS(33))*COSB)
34017 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
34018 &XMU*SIN(RMSS(33))*COSB)
34019 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
34020 &XMU*COS(RMSS(33))*COSB)
34021 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
34022 &XMU*SIN(RMSS(33))*COSB)
34023 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
34025 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
34029 IF(WR(2).LT.WR(1)) THEN
34038 S=S+ZR(J,K)**2+ZI(J,K)**2
34041 VMIX(I,J)=ZR(J,K)/SQRT(S)
34042 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
34043 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
34044 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
34052 C*********************************************************************
34055 C...Calculates the running of M3, the SU(3) gluino mass parameter.
34057 FUNCTION PYRNM3(RGUT)
34059 C...Double precision and integer declarations.
34060 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34061 IMPLICIT INTEGER(I-N)
34062 INTEGER PYK,PYCHGE,PYCOMP
34064 C...Local variables.
34066 DOUBLE PRECISION TOL
34068 DOUBLE PRECISION PYALPS
34070 DATA R/0.61803399D0/
34074 BX=RGUT*PYALPS(RGUT**2)
34075 AX=MIN(50D0,BX*0.5D0)
34076 CX=MAX(2000D0,2D0*BX)
34080 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
34088 F1=ABS(X1-RGUT*AS1)
34090 F2=ABS(X2-RGUT*AS2)
34091 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
34098 F2=ABS(X2-RGUT*AS2)
34105 F1=ABS(X1-RGUT*AS1)
34120 C*********************************************************************
34123 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
34124 C...Specific application: mixing in neutralino sector.
34126 SUBROUTINE PYEIG4(A,W,Z)
34128 C...Double precision and integer declarations.
34129 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34130 IMPLICIT INTEGER(I-N)
34131 INTEGER PYK,PYCHGE,PYCOMP
34133 C...Arrays: in call and local.
34134 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
34136 C...Coefficients of fourth-degree equation from matrix.
34137 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
34138 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
34142 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
34151 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
34152 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
34153 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
34154 B0=B0+(-1D0)**(I+1)*A(1,I)*(
34155 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
34156 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
34157 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
34160 C...Coefficients of third-degree equation needed for
34161 C...separation into two second-degree equations.
34162 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
34165 C0=-B1**2-B0*B3**2+4D0*B0*B2
34166 CQ=C1/3D0-C2**2/9D0
34167 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
34170 C...Cases with one or three real roots.
34171 IF(CQR.GE.0D0) THEN
34172 S1=(CR+SQRT(CQR))**(1D0/3D0)
34173 S2=(CR-SQRT(CQR))**(1D0/3D0)
34177 THE=ACOS(CR/SABS**3)/3D0
34182 C...Find and solve two second-degree equations.
34183 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
34184 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
34185 Q1=U/2D0+SQRT(U**2/4D0-B0)
34186 Q2=U/2D0-SQRT(U**2/4D0-B0)
34187 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
34192 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
34193 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
34194 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
34195 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
34197 C...Order eigenvalues in asceding mass.
34200 DO 130 I2=I1-1,1,-1
34201 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
34207 C...Find equation system for eigenvectors.
34210 D(J1,J1)=A(J1,J1)-W(I)
34217 C...Find largest element in matrix.
34221 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
34224 DAMAX=ABS(D(J1,J2))
34228 C...Subtract others by multiple of row selected above.
34230 DO 210 J3=JA+1,JA+3
34232 RL=D(J1,JB)/D(JA,JB)
34234 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
34235 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
34238 DAMAX=ABS(D(J1,J2))
34242 C...Do one more subtraction of a row.
34244 DO 230 J3=JC+1,JC+3
34246 IF(J1.EQ.JA) GOTO 230
34247 RL=D(J1,JD)/D(JC,JD)
34249 IF(J2.EQ.JB) GOTO 220
34250 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
34251 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
34253 DAMAX=ABS(D(J1,J2))
34257 C...Construct unnormalized eigenvector.
34259 JF2=JD+2-4*((JD+1)/4)
34260 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
34261 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
34264 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
34265 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
34268 C...Normalize and fill in final array.
34269 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
34270 SGN=(-1D0)**INT(PYR(0)+0.5D0)
34279 C*********************************************************************
34282 C...Determines the Higgs boson mass spectrum using several inputs.
34284 SUBROUTINE PYHGGM(ALPHA)
34286 C...Double precision and integer declarations.
34287 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34288 IMPLICIT INTEGER(I-N)
34289 INTEGER PYK,PYCHGE,PYCOMP
34290 C...Parameter statement to help give large particle numbers.
34291 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34292 &KEXCIT=4000000,KDIMEN=5000000)
34294 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34295 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34296 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34297 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34298 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
34300 C...Local variables.
34301 DOUBLE PRECISION AT,AB,XMU,TANB
34302 DOUBLE PRECISION ALPHA
34304 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
34305 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
34306 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
34307 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
34310 IF(IHOPT.EQ.2) THEN
34326 DMC=PMAS(PYCOMP(KSUSY1+37),1)
34333 IF(IHOPT.EQ.0) THEN
34334 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
34335 & DMHCH,DSA,DCA,DTANBA)
34336 ELSEIF(IHOPT.EQ.1) THEN
34337 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
34338 & DMHCH,DSA,DCA,DTANBA)
34339 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
34340 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
34341 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
34347 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
34348 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
34349 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
34350 & PMAS(PYCOMP(1000006),1),DSTOP2
34352 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
34353 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
34354 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
34355 & PMAS(PYCOMP(2000006),1),DSTOP1
34357 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
34358 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
34359 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
34360 & PMAS(PYCOMP(1000005),1),DSBOT2
34362 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
34363 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
34364 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
34365 & PMAS(PYCOMP(2000005),1),DSBOT1
34380 C*********************************************************************
34383 C...This routine computes the renormalization group improved
34384 C...values of Higgs masses and couplings in the MSSM.
34386 C...Program based on the work by M. Carena, J.R. Espinosa,
34387 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
34389 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
34390 C...All masses in GeV units. MA is the CP-odd Higgs mass,
34391 C...MTOP is the physical top mass, MQ and MUR are the soft
34392 C...supersymmetry breaking mass parameters of left handed
34393 C...and right handed stops respectively, AU and AD are the
34394 C...stop and sbottom trilinear soft breaking terms,
34395 C...respectively, and MU is the supersymmetric
34396 C...Higgs mass parameter. We use the conventions from
34397 C...the physics report of Haber and Kane: left right
34398 C...stop mixing term proportional to (AU - MU/TANB)
34399 C...We use as input TANB defined at the scale MTOP
34401 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
34402 C...where MH and HM are the lightest and heaviest CP-even
34403 C...Higgs masses, MHCH is the charged Higgs mass and
34404 C...ALPHA is the Higgs mixing angle
34405 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
34407 C...Range of validity:
34408 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
34409 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
34410 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
34411 C...are the sbottom mass eigenvalues, respectively. This
34412 C...range automatically excludes the existence of tachyons.
34413 C...For the charged Higgs mass computation, the method is
34415 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
34416 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
34417 C...where M_SUSY**2 is the average of the squared stop mass
34418 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
34419 C...masses have been assumed to be of order of the stop ones
34420 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
34422 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
34423 &XMHCH,SA,CA,TANBA)
34425 C...Double precision and integer declarations.
34426 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34427 IMPLICIT INTEGER(I-N)
34428 INTEGER PYK,PYCHGE,PYCOMP
34429 C...Parameter statement to help give large particle numbers.
34430 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34431 &KEXCIT=4000000,KDIMEN=5000000)
34433 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34434 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34435 COMMON/PYHTRI/HHH(7)
34436 SAVE /PYDAT1/,/PYDAT2/
34438 C...Local variables.
34439 DOUBLE PRECISION PYALEM,PYALPS
34440 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
34441 DOUBLE PRECISION XMHCH,SA,CA
34442 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
34443 DOUBLE PRECISION Q02
34444 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
34445 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
34446 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
34447 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
34448 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
34449 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
34450 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
34451 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
34456 ALP1=AEM/(1D0-PARU(102))
34469 C...MBOTTOM(MTOP) = 3. GEV
34470 XMB = PYMRUN(5,XMTOP**2)
34471 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
34472 &LOG(XMTOP**2/XMZ**2))
34474 C...RMTOP= RUNNING TOP QUARK MASS
34475 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
34476 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
34477 T = LOG(XMS**2/XMTOP**2)
34478 SINB = TANB/((1D0 + TANB**2)**0.5D0)
34480 C...IF(MA.LE.XMTOP) TANBA = TANBT
34482 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
34483 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
34484 &LOG(XMA**2/XMTOP**2))
34486 SINBT = TANBT/SQRT(1D0 + TANBT**2)
34487 COSBT = 1D0/SQRT(1D0 + TANBT**2)
34488 C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
34489 G1 = SQRT(ALP1*4D0*PI)
34490 G2 = SQRT(ALP2*4D0*PI)
34491 G3 = SQRT(ALP3*4D0*PI)
34506 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
34507 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
34508 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
34509 &+ 3D0*(AU + AD)**2/XMS2)/6D0
34510 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
34511 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
34512 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
34513 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
34514 &- 16D0*G3**2) *T/16D0/PI2)
34515 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
34516 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
34517 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
34518 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
34519 &- 16D0*G3**2) *T/16D0/PI2)
34520 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
34521 &(HU2 + HD2)*T/16D0/PI2)
34522 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
34523 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
34524 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
34525 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
34526 &- 16D0*G3**2) *T/16D0/PI2)
34527 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
34528 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
34529 &- 16D0*G3**2) *T/16D0/PI2)
34530 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
34531 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
34532 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
34533 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
34535 &(1+ (6D0*HU2 -2D0* HD2
34536 &- 16D0*G3**2) *T/16D0/PI2)
34537 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
34539 &(1+ (6D0*HD2 -2D0* HU2/2D0
34540 &- 16D0*G3**2) *T/16D0/PI2)
34541 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
34542 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
34543 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
34544 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
34545 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
34546 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34547 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
34548 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34549 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
34550 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34551 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
34552 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34560 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
34561 &2D0* XLAM6*SINBT*COSBT
34562 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
34564 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
34566 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
34567 &2D0* XLAM6* COSBT*SINBT
34568 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
34569 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
34570 &((XLAM1* COSBT**2 +2D0*
34571 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
34572 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
34574 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
34575 &+ XLAM4) + XLAM6*COSBT**2
34576 &+ XLAM7* SINBT**2))
34578 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
34579 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
34582 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
34583 XMHCH = SQRT(XMHCH2)
34585 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
34586 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
34587 &XLAM6* COSBT*SINBT
34588 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
34589 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
34590 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
34591 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
34593 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
34594 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
34595 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
34596 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
34597 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
34598 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
34599 &XLAM6* COSBT*SINBT
34600 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
34601 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
34602 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
34612 C*********************************************************************
34615 C...This subroutine computes the CP-even higgs and CP-odd pole
34616 c...Higgs masses and mixing angles.
34618 C...Program based on the work by M. Carena, M. Quiros
34619 C...and C.E.M. Wagner, "Effective potential methods and
34620 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
34622 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
34624 C...where MCHI is the largest chargino mass, MA is the running
34625 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
34626 C...expectaion values at the scale MTOP, MQ is the third generation
34627 C...left handed squark mass parameter, MUR is the third generation
34628 C...right handed stop mass parameter, MDR is the third generation
34629 C...right handed sbottom mass parameter, MTOP is the pole top quark
34630 C...mass; AT,AB are the soft supersymmetry breaking trilinear
34631 C...couplings of the stop and sbottoms, respectively, and MU is the
34632 C...supersymmetric mass parameter
34634 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
34635 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
34636 C...masses are given, what makes the running of the program
34637 c...much faster and it is quite generally a good approximation
34638 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
34639 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
34640 c...and if IHIGGS=3, then h,H,A polarizations are computed
34642 C...Output: MH and MHP which are the lightest CP-even Higgs running
34643 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
34644 C...Higgs running and pole masses, repectively; SA and CA are the
34645 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
34646 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
34647 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
34648 C...the value of TANB at the CP-odd Higgs mass scale
34650 C...This subroutine makes use of CERN library subroutine
34651 C...integration package, which makes the computation of the
34652 C...pole Higgs masses somewhat faster. We thank P. Janot for this
34653 C...improvement. Those who are not able to call the CERN
34654 C...libraries, please use the subroutine SUBHPOLE2.F, which
34655 C...although somewhat slower, gives identical results
34657 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
34658 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
34660 C...Double precision and integer declarations.
34661 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34662 IMPLICIT INTEGER(I-N)
34665 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34667 INTEGER PYK,PYCHGE,PYCOMP
34669 C...Local variables.
34670 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
34671 &SSBOT2(2),B(2,2),COUPB(2,2),
34672 &HCOUPT(2,2),HCOUPB(2,2),
34673 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
34682 RXMT=PYMRUN(6,XMT**2)
34683 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
34684 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
34686 SINB = TANB/(TANB**2+1D0)**0.5D0
34687 COSB = 1D0/(TANB**2+1D0)**0.5D0
34688 COS2B = SINB**2 - COSB**2
34689 SINBPA = SINB*CA + COSB*SA
34690 COSBPA = COSB*CA - SINB*SA
34691 RMBOT = PYMRUN(5,XMT**2)
34694 IF(XMUR.LT.0D0) XMUR2=-XMUR2
34696 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
34697 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
34698 IF(XMST11.LT.0D0) GOTO 500
34699 IF(XMST22.LT.0D0) GOTO 500
34700 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
34701 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
34702 IF(XMSB11.LT.0D0) GOTO 500
34703 IF(XMSB22.LT.0D0) GOTO 500
34704 C WMST11 = RXMT**2 + XMQ2
34705 C WMST22 = RXMT**2 + XMUR2
34706 XMST12 = RXMT*(AT - XMU/TANB)
34707 XMSB12 = RMBOT*(AB - XMU*TANB)
34709 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34710 C...STOP EIGENVALUES CALCULATION
34711 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34713 STOP12 = 0.5D0*(XMST11+XMST22) +
34714 &0.5D0*((XMST11+XMST22)**2 -
34715 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
34716 STOP22 = 0.5D0*(XMST11+XMST22) -
34717 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
34718 &XMST12**2))**0.5D0
34720 IF(STOP22.LT.0D0) GOTO 500
34723 STOP1 = STOP12**0.5D0
34724 STOP2 = STOP22**0.5D0
34728 IF(XMST12.EQ.0D0) XST11 = 1D0
34729 IF(XMST12.EQ.0D0) XST12 = 0D0
34730 IF(XMST12.EQ.0D0) XST21 = 0D0
34731 IF(XMST12.EQ.0D0) XST22 = 1D0
34733 IF(XMST12.EQ.0D0) GOTO 110
34735 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
34736 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
34737 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
34738 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
34745 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
34746 &0.5D0*((XMSB11+XMSB22)**2 -
34747 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
34748 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
34749 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
34750 &XMSB12**2))**0.5D0
34751 IF(SBOT22.LT.0D0) GOTO 500
34752 SBOT1 = SBOT12**0.5D0
34753 SBOT2 = SBOT22**0.5D0
34758 IF(XMSB12.EQ.0D0) XSB11 = 1D0
34759 IF(XMSB12.EQ.0D0) XSB12 = 0D0
34760 IF(XMSB12.EQ.0D0) XSB21 = 0D0
34761 IF(XMSB12.EQ.0D0) XSB22 = 1D0
34763 IF(XMSB12.EQ.0D0) GOTO 130
34765 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
34766 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
34767 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
34768 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
34780 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34781 C...STARTING OF LIGHT HIGGS
34782 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34784 IF(IHIGGS.EQ.0) GOTO 490
34789 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
34790 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
34791 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
34792 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
34801 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
34802 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
34803 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
34804 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
34812 180 ITER = ITER + 1
34815 PR(I3)=PRUN+(I3-2)*EPS/2
34820 POLT = POLT + COUPT(I,J)**2*3D0*
34821 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
34828 POLB = POLB + COUPB(I,J)**2*3D0*
34829 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
34836 & 3D0*RXMT**2/8D0/PI**2/ V **2*
34838 & (-2D0*XMT**2+0.5D0*P2)*
34839 & PYFINT(P2,XMT2,XMT2)
34841 POL = POLT + POLB + POLTT
34842 POLAR(I3) = P2 - XMH**2 - POL
34844 DERIV = (POLAR(3)-POLAR(1))/EPS
34845 DRUN = - POLAR(2)/DERIV
34848 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
34854 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34855 C...END OF LIGHT HIGGS
34856 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34858 250 IF(IHIGGS.EQ.1) GOTO 490
34860 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34861 C... STARTING OF HEAVY HIGGS
34862 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34867 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
34868 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
34869 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
34870 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
34878 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
34879 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
34880 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
34881 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
34890 300 ITER = ITER + 1
34892 PR(I3)=PRUN+(I3-2)*EPS/2
34898 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
34899 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
34906 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
34907 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
34915 & 3D0*RXMT**2/8D0/PI**2/ V **2*
34917 & (-2D0*XMT**2+0.5D0*HP2)*
34918 & PYFINT(HP2,XMT2,XMT2)
34920 HPOL = HPOLT + HPOLB + HPOLTT
34921 POLAR(I3) =HP2-HM**2-HPOL
34923 DERIV = (POLAR(3)-POLAR(1))/EPS
34924 DRUN = - POLAR(2)/DERIV
34927 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
34935 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34936 C... END OF HEAVY HIGGS
34937 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34939 IF(IHIGGS.EQ.2) GOTO 490
34941 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34942 C...BEGINNING OF PSEUDOSCALAR HIGGS
34943 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34948 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
34949 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
34955 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
34956 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
34963 420 ITER = ITER + 1
34965 PR(I3)=PRUN+(I3-2)*EPS/2
34970 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
34971 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
34977 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
34978 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
34984 & 3D0*RXMT**2/8D0/PI**2/ V **2*
34985 & COSB**2/SINB**2 *
34987 & PYFINT(AP2,XMT2,XMT2)
34988 APOL = APOLT + APOLB + APOLTT
34989 POLAR(I3) = AP2 - XMA**2 -APOL
34991 DERIV = (POLAR(3)-POLAR(1))/EPS
34992 DRUN = - POLAR(2)/DERIV
34995 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
35001 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35002 C...END OF PSEUDOSCALAR HIGGS
35003 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35005 IF(IHIGGS.EQ.3) GOTO 490
35010 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
35011 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
35012 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
35013 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
35017 C*********************************************************************
35020 C...Auxiliary to PYPOLE.
35022 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
35023 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
35024 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
35025 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
35028 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35039 C MBOTTOM(MTOP) = 3. GEV
35040 MB = PYMRUN(5,MTOP**2)
35041 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
35042 *LOG(MTOP**2/MZ**2))
35043 C RMTOP= RUNNING TOP QUARK MASS
35044 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
35045 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
35046 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
35047 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
35048 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35050 C NEW DEFINITION, TGLU.
35052 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35053 TGLU = LOG(MGLU**2/MTOP**2)
35054 SINB = TANB/DSQRT(1D0 + TANB**2)
35057 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
35058 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
35059 *LOG(MA**2/MTOP**2))
35060 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
35061 SINB = TANBT/SQRT(1D0 + TANBT**2)
35062 COSB = 1D0/DSQRT(1D0 + TANBT**2)
35063 G1 = SQRT(ALPHA1*4D0*PI)
35064 G2 = SQRT(ALPHA2*4D0*PI)
35065 G3 = SQRT(ALPHA3*4D0*PI)
35068 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
35069 *SBOT1,SBOT2,DELTAMT,DELTAMB)
35070 IF(MQ.GT.MUR) TP = TQ - TU
35071 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
35072 IF(MQ.GT.MUR) TDP = TU
35073 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
35074 IF(MQ.GT.MD) TPD = TQ - TD
35075 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
35076 IF(MQ.GT.MD) TDPD = TD
35077 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
35079 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
35080 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
35081 * HD**2*(G1**2/3D0+G2**2)*TPD
35083 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
35084 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
35085 * HU**2*(-G1**2/3D0+G2**2)*TP
35087 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35089 C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
35090 C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
35091 C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
35095 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35098 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
35099 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
35100 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
35103 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
35104 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
35107 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
35108 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
35111 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
35112 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
35115 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
35116 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
35119 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
35120 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
35125 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
35126 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
35127 *(G2**2-G1**2/3D0)*TPD
35128 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
35129 *1D0/16D0/PI**2*G1**2*HU**2*TP
35130 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
35131 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
35132 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
35133 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
35135 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
35136 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
35137 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
35138 *+ (3D0*HD**2/2D0 + HU**2/2D0
35139 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
35140 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
35141 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
35142 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
35143 *(TP + TDP)/8D0/PI**2)
35144 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
35145 *+ (3D0*HU**2/2D0 + HD**2/2D0
35146 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
35147 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
35148 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
35149 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
35150 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
35151 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
35152 LAMBDA4 = (- G2**2/2D0)*(1D0
35153 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
35154 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
35160 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
35161 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
35163 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
35164 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
35165 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
35166 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
35169 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35170 CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
35171 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35173 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
35175 IF(MCHI.GT.MSSUSY) GOTO 100
35176 IF(MCHI.LT.MTOP) MCHI=MTOP
35178 TCHAR=LOG(MSSUSY**2/MCHI**2)
35180 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
35181 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
35182 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
35184 DELTAM112=2D0*DELTAL12*V**2*COSB**2
35185 DELTAM222=2D0*DELTAL12*V**2*SINB**2
35186 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
35188 M2(1,1)=M2(1,1)+DELTAM112
35189 M2(2,2)=M2(2,2)+DELTAM222
35190 M2(1,2)=M2(1,2)+DELTAM122
35191 M2(2,1)=M2(2,1)+DELTAM122
35195 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35196 CCC END OF CHARGINOS/NEUTRALINOS
35197 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35201 M2P(I,J) = M2(I,J) + VH(I,J)
35204 TRM2P = M2P(1,1) + M2P(2,2)
35205 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
35206 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
35207 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
35209 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
35211 IF(MH2P.LT.0.) GOTO 130
35213 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
35214 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
35215 IF(COS2ALPHA.GE.0.) THEN
35216 ALPHA = ASIN(SIN2ALPHA)/2D0
35218 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
35222 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35224 C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
35225 C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
35226 C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
35229 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35230 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
35231 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
35236 C*********************************************************************
35239 C...Auxiliary to PYRGHM.
35241 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
35242 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
35243 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
35244 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
35246 INTEGER MSTU,MSTJ,KCHG
35247 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35248 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35249 SAVE /PYDAT1/,/PYDAT2/
35251 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
35253 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
35254 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
35256 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
35261 SINBA = TANBA/DSQRT(TANBA**2+1D0)
35262 COSBA = SINBA/TANBA
35264 SINB = TANB/DSQRT(TANB**2+1D0)
35270 SW = 1D0-MW**2/MZ**2
35273 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
35274 G2 = DSQRT(0.0336D0*4D0*PI)
35275 G1 = DSQRT(0.0101D0*4D0*PI)
35277 IF(MQ.GT.MUR) MST = MQ
35278 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
35280 MSUSYT = DSQRT(MST**2 + MTOP**2)
35282 IF(MQ.GT.MD) MSB = MQ
35283 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
35285 MB = PYMRUN(5,MSB**2)
35286 MSUSYB = DSQRT(MSB**2 + MB**2)
35287 TT = LOG(MSUSYT**2/MTOP**2)
35288 TB = LOG(MSUSYB**2/MTOP**2)
35290 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
35291 HT = RMTOP/(V*SINB)
35294 G32 = ALPHA3*4D0*PI
35295 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
35296 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
35297 AL2 = 3D0/8D0/PI**2*HT**2
35298 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
35299 C ALST = 3./8./PI**2*HTST**2
35300 AL1 = 3D0/8D0/PI**2*HB**2
35303 AL(1,2) = (AL2+AL1)/2D0
35304 AL(2,1) = (AL2+AL1)/2D0
35307 IF(MA.GT.MTOP) THEN
35308 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
35309 * LOG(MTOP**2/MA**2))
35312 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
35313 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
35314 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
35315 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
35320 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
35321 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
35322 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
35323 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
35327 SINBT = TANBST/DSQRT(1D0+TANBST**2)
35330 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
35331 COSBB = SINBB/TANBSB
35336 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
35337 MTOP2 = DSQRT(MTOP4)
35338 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
35339 * /(1D0+DELTAMB)**4
35340 MBOT2 = DSQRT(MBOT4)
35342 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
35343 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35344 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35345 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
35346 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
35347 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35348 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35349 * MQ2 - MUR2)**2*0.25D0
35350 * + MTOP2*(AT-XMU/TANBST)**2)
35351 IF(STOP22.LT.0.) GOTO 120
35352 SBOT12 = (MQ2 + MD2)*.5D0
35353 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35354 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35355 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35356 SBOT22 = (MQ2 + MD2)*.5D0
35357 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35358 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35359 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35360 IF(SBOT22.LT.0.) SBOT22 = 10000D0
35362 STOP1 = DSQRT(STOP12)
35363 STOP2 = DSQRT(STOP22)
35364 SBOT1 = DSQRT(SBOT12)
35365 SBOT2 = DSQRT(SBOT22)
35367 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35369 C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
35370 C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
35371 C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
35372 C INDUCED CORRECTIONS.
35374 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35379 IF(X.EQ.Y) X = X - 0.00001D0
35380 IF(X.EQ.Z) X = X - 0.00002D0
35381 IF(Y.EQ.Z) Y = Y - 0.00003D0
35387 IF(X.EQ.Y) X = X - 0.00001D0
35388 IF(X.EQ.Z) X = X - 0.00002D0
35389 IF(Y.EQ.Z) Y = Y - 0.00003D0
35391 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
35392 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
35396 IF(X.EQ.Y) X = X - 0.00001D0
35397 IF(X.EQ.Z) X = X - 0.00002D0
35398 IF(Y.EQ.Z) Y = Y - 0.00003D0
35400 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
35402 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35404 C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
35405 C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
35406 C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
35407 C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
35408 C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
35409 C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
35410 C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
35411 C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
35412 C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
35413 C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
35414 C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
35417 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35419 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
35420 MTOP2 = DSQRT(MTOP4)
35421 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
35422 * /(1D0+DELTAMB)**4
35423 MBOT2 = DSQRT(MBOT4)
35425 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
35426 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35427 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35428 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
35429 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
35430 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35431 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35432 * MQ2 - MUR2)**2*0.25D0
35433 * + MTOP2*(AT-XMU/TANBST)**2)
35435 IF(STOP22.LT.0.) GOTO 120
35436 SBOT12 = (MQ2 + MD2)*.5D0
35437 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35438 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35439 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35440 SBOT22 = (MQ2 + MD2)*.5D0
35441 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35442 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35443 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35444 IF(SBOT22.LT.0.) GOTO 120
35447 STOP1 = DSQRT(STOP12)
35448 STOP2 = DSQRT(STOP22)
35449 SBOT1 = DSQRT(SBOT12)
35450 SBOT2 = DSQRT(SBOT22)
35452 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35454 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35457 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
35459 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
35460 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
35462 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
35464 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
35465 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
35467 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
35468 * (-.5D0*LOG(STOP12/STOP22)
35469 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
35470 * G(STOP12,STOP22))
35472 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
35473 * (.5D0*LOG(SBOT12/SBOT22)
35474 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
35475 * G(SBOT12,SBOT22))
35477 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
35478 * (MQ2+MBOT2)/(MD2+MBOT2))
35479 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
35480 * LOG(SBOT1**2/SBOT2**2)) +
35481 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
35482 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
35485 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
35486 * -STOP2**2))**2*G(STOP12,STOP22)
35488 VH3B(1,1)=VH3B(1,1)+
35489 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
35491 VH3T(1,1) = VH3T(1,1) +
35492 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
35494 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
35495 * (MQ2+MTOP2)/(MUR2+MTOP2))
35496 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
35497 * LOG(STOP1**2/STOP2**2)) +
35498 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
35499 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
35502 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
35503 * -SBOT2**2))**2*G(SBOT12,SBOT22)
35505 VH3T(2,2)=VH3T(2,2)+
35506 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
35507 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
35509 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
35510 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
35511 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
35514 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
35515 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
35516 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
35519 VH3T(1,2)=VH3T(1,2) +
35520 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
35522 VH3B(1,2)=VH3B(1,2) +
35523 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
35525 VH3T(2,1) = VH3T(1,2)
35526 VH3B(2,1) = VH3B(1,2)
35528 C TQ = LOG((MQ2 + MTOP2)/MTOP2)
35529 C TU = LOG((MUR2+MTOP2)/MTOP2)
35530 C TQD = LOG((MQ2 + MB**2)/MB**2)
35531 C TD = LOG((MD2+MB**2)/MB**2)
35536 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
35537 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
35538 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
35539 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
35558 C*********************************************************************
35561 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
35563 FUNCTION PYFINT(A,B,C)
35565 C...Double precision and integer declarations.
35566 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35567 IMPLICIT INTEGER(I-N)
35568 INTEGER PYK,PYCHGE,PYCOMP
35570 COMMON/PYINTS/XXM(20)
35573 C...Local variables.
35575 DOUBLE PRECISION PYFISB
35582 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
35587 C*********************************************************************
35590 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
35594 C...Double precision and integer declarations.
35595 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35596 IMPLICIT INTEGER(I-N)
35597 INTEGER PYK,PYCHGE,PYCOMP
35599 COMMON/PYINTS/XXM(20)
35602 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
35603 &(X*(XXM(2)-XXM(3))+XXM(3)))
35608 C*********************************************************************
35611 C...Calculates decays of sfermions.
35613 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
35615 C...Double precision and integer declarations.
35616 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35617 IMPLICIT INTEGER(I-N)
35618 INTEGER PYK,PYCHGE,PYCOMP
35619 C...Parameter statement to help give large particle numbers.
35620 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35621 &KEXCIT=4000000,KDIMEN=5000000)
35623 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35624 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35625 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35626 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35627 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35628 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
35630 C...Local variables.
35631 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
35632 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
35634 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
35635 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
35636 DOUBLE PRECISION PYLAMF,XL
35637 DOUBLE PRECISION TANW,XW,AEM,C1,AS
35638 DOUBLE PRECISION AL,AR,BL,BR
35639 DOUBLE PRECISION CH1,CH2,CH3,CH4
35640 DOUBLE PRECISION XMBOT,XMTOP
35641 DOUBLE PRECISION XLAM(0:400)
35642 INTEGER IDLAM(400,3)
35643 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
35644 DOUBLE PRECISION SR2
35645 DOUBLE PRECISION CBETA,SBETA
35646 DOUBLE PRECISION CW
35647 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
35648 DOUBLE PRECISION COSA,SINA,TANB
35649 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
35650 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
35652 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
35653 DATA IGG/23,25,35,36/
35654 DATA PI/3.141592654D0/
35655 DATA SR2/1.4142136D0/
35656 DATA KFNCHI/1000022,1000023,1000025,1000035/
35657 DATA KFCCHI/1000024,1000037/
35659 C...COUNT THE NUMBER OF DECAY MODES
35663 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
35664 &KFIN.EQ.KSUSY2+16) RETURN
35670 TANW = SQRT(XW/(1D0-XW))
35675 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
35680 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
35681 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
35687 C...ILR is 1 for left and 2 for right.
35689 C...IFL is matching non-SUSY flavour.
35690 IFL=MOD(KFIN,KSUSY1)
35691 C...IDU is weak isospin, 1 for down and 2 for up.
35702 XMBOT=PYMRUN(5,XMI2)
35703 XMTOP=PYMRUN(6,XMI2)
35717 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
35719 IF(IMSS(11).EQ.1) THEN
35722 XMGR=PMAS(PYCOMP(IDG),1)
35723 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
35726 ELSEIF(IFL.EQ.6) THEN
35731 IF(XMI.GT.XMGR+XMF) THEN
35736 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
35740 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
35742 C...CHARGED DECAYS:
35744 C...DI -> U CHI1-,CHI2-
35748 C...UI -> D CHI1+,CHI2+
35755 IF(XMI.GE.AXMJ+XMFP) THEN
35762 ELSEIF(IFL.LT.6) THEN
35767 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
35768 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
35774 ELSEIF(IFL.LT.5) THEN
35779 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
35780 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
35784 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
35785 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
35786 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
35787 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
35803 XL=PYLAMF(XMI2,XMA2,XMB2)
35804 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
35805 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
35806 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
35809 IDLAM(LKNT,1)=-KFCCHI(IX)
35810 IDLAM(LKNT,2)=IFL+1
35812 IDLAM(LKNT,1)=KFCCHI(IX)
35813 IDLAM(LKNT,2)=IFL-1
35824 IF(XMI.GE.AXMJ+XMF) THEN
35830 ELSEIF(IFL.LT.5) THEN
35833 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
35834 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
35835 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
35840 ELSEIF(IFL.LT.5) THEN
35843 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
35844 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
35845 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
35849 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
35850 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
35851 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
35852 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
35868 XL=PYLAMF(XMI2,XMA2,XMB2)
35869 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
35870 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
35871 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
35872 IDLAM(LKNT,1)=KFNCHI(IX)
35878 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
35882 IF(ILR.EQ.1) GOTO 160
35884 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
35885 IF(XMI.LT.XMSF1+XMB) GOTO 160
35887 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
35890 ELSEIF(IG.EQ.25) THEN
35893 ELSEIF(IFL.EQ.6) THEN
35895 ELSEIF(IFL.LT.5) THEN
35901 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
35902 & XMF**2/XMW*COSA/SBETA
35903 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
35904 & XMF**2/XMW*COSA/SBETA
35906 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
35907 & XMF**2/XMW*(-SINA)/CBETA
35908 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
35909 & XMF**2/XMW*(-SINA)/CBETA
35913 ELSEIF(IFL.EQ.6) THEN
35915 ELSEIF(IFL.EQ.15) THEN
35920 C.........need to complexify
35922 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
35925 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
35931 ELSEIF(IG.EQ.35) THEN
35934 ELSEIF(IFL.EQ.6) THEN
35936 ELSEIF(IFL.LT.5) THEN
35942 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
35943 & XMF**2/XMW*SINA/SBETA
35944 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
35945 & XMF**2/XMW*SINA/SBETA
35947 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
35948 & XMF**2/XMW*COSA/CBETA
35949 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
35950 & XMF**2/XMW*COSA/CBETA
35954 ELSEIF(IFL.EQ.6) THEN
35956 ELSEIF(IFL.EQ.15) THEN
35961 C.........Need to complexify
35963 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
35966 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
35972 ELSEIF(IG.EQ.36) THEN
35977 ELSEIF(IFL.EQ.6) THEN
35979 ELSEIF(IFL.LT.5) THEN
35986 ELSEIF(IFL.EQ.6) THEN
35988 ELSEIF(IFL.EQ.15) THEN
35993 C.........Need to complexify
35995 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
35997 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
36003 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
36004 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
36005 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
36006 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36009 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
36011 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
36014 IDLAM(LKNT,1)=KFIN-KSUSY1
36020 IF(MOD(IFL,2).EQ.0) THEN
36026 XMSF1=PMAS(PYCOMP(KF1),1)
36027 XMSF2=PMAS(PYCOMP(KF2),1)
36028 IF(XMI.GT.XMB+XMSF1) THEN
36029 IF(MOD(IFL,2).EQ.0) THEN
36031 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
36033 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
36037 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
36039 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
36042 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36044 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
36047 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
36049 IF(XMI.GT.XMB+XMSF2) THEN
36050 IF(MOD(IFL,2).EQ.0) THEN
36052 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
36054 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
36058 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
36060 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
36063 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
36065 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
36068 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
36073 IF(MOD(IFL,2).EQ.0) THEN
36079 XMSF1=PMAS(PYCOMP(KF1),1)
36080 XMSF2=PMAS(PYCOMP(KF2),1)
36081 IF(XMI.GT.XMB+XMSF1) THEN
36086 IF(MOD(IFL,2).EQ.0) THEN
36089 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
36090 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
36091 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
36092 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
36095 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
36096 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
36097 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
36098 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
36109 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
36110 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
36111 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
36112 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
36115 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
36116 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
36117 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
36118 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
36127 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36129 C.......Need to complexify
36130 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
36131 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
36132 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
36133 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
36136 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
36138 IF(XMI.GT.XMB+XMSF2) THEN
36143 IF(MOD(IFL,2).EQ.0) THEN
36146 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
36147 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
36148 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
36149 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
36152 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
36153 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
36154 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
36155 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
36166 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
36167 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
36168 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
36169 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
36172 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
36173 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
36174 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
36175 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
36184 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36186 C.......Need to complexify
36187 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
36188 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
36189 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
36190 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
36193 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
36196 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
36201 IF(IFL.EQ.6) XMF=PMAS(6,1)
36202 IF(IFL.EQ.5) XMF=PMAS(5,1)
36203 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
36205 IF(XMI.GE.AXMJ+XMF) THEN
36222 XL=PYLAMF(XMI2,XMA2,XMB2)
36223 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
36224 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
36225 IDLAM(LKNT,1)=KSUSY1+21
36231 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
36232 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
36233 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
36234 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
36235 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
36236 C...M*M = C1**2 * G**2/(16PI**2)
36237 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
36239 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
36240 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
36241 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
36242 IDLAM(LKNT,1)=KSUSY1+22
36247 C...R-violating sfermion decays (SKANDS).
36248 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
36253 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
36254 XLAM(0)=XLAM(0)+XLAM(I)
36256 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
36261 C*********************************************************************
36264 C...Calculates gluino decay modes.
36266 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
36268 C...Double precision and integer declarations.
36269 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36270 IMPLICIT INTEGER(I-N)
36271 INTEGER PYK,PYCHGE,PYCOMP
36272 C...Parameter statement to help give large particle numbers.
36273 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36274 &KEXCIT=4000000,KDIMEN=5000000)
36276 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36277 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36278 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36279 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36280 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36282 C COMMON/PYINTS/XXM(20)
36284 COMMON/PYINTC/XXC(10),CXC(8)
36285 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
36287 C...Local variables
36288 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
36289 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
36290 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
36291 DOUBLE PRECISION PYLAMF,XL
36292 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
36293 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
36294 DOUBLE PRECISION XLAM(0:400)
36295 INTEGER IDLAM(400,3)
36296 INTEGER LKNT,IX,ILR,I,IKNT,IFL
36297 DOUBLE PRECISION SR2
36298 DOUBLE PRECISION GAM
36299 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
36300 EXTERNAL PYGAUS,PYXXZ6
36301 DOUBLE PRECISION PYGAUS,PYXXZ6
36302 DOUBLE PRECISION PREC
36303 INTEGER KFNCHI(4),KFCCHI(2)
36304 DATA PI/3.141592654D0/
36305 DATA SR2/1.4142136D0/
36307 DATA KFNCHI/1000022,1000023,1000025,1000035/
36308 DATA KFCCHI/1000024,1000037/
36310 C...COUNT THE NUMBER OF DECAY MODES
36312 IF(KFIN.NE.KSUSY1+21) RETURN
36316 TANW = SQRT(XW/(1D0-XW))
36326 XMI=SIGN(XMI,RMSS(3))
36328 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
36330 IF(IMSS(11).EQ.1) THEN
36333 XMGR=PMAS(PYCOMP(IDG),1)
36334 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
36335 IF(AXMI.GT.XMGR) THEN
36344 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
36348 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
36351 IF(AXMI.GE.AXMJ+XMF) THEN
36352 C...Minus sign difference from gluino-quark-squark feynman rules
36369 XL=PYLAMF(XMI2,XMA2,XMB2)
36370 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
36371 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
36372 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
36376 XLAM(LKNT)=XLAM(LKNT-1)
36377 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36378 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36384 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
36385 C...GLUINO -> NI Q QBAR
36389 IF(AXMI.GE.AXMJ) THEN
36391 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
36393 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
36400 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
36401 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
36407 T3I=SIGN(1D0,EI+1D-6)/2D0
36408 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36409 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36413 CXC(4)=DCONJG(GLIJ)
36417 CXC(8)=-DCONJG(GRIJ)
36419 S12MAX=(AXMI-AXMJ)**2
36420 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
36421 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
36423 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
36424 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
36425 IDLAM(LKNT,1)=KFNCHI(IX)
36429 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
36431 XLAM(LKNT)=XLAM(LKNT-1)
36432 IDLAM(LKNT,1)=KFNCHI(IX)
36437 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
36438 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
36439 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
36441 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
36442 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
36444 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
36447 IDLAM(LKNT,1)=KFNCHI(IX)
36450 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
36455 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
36456 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
36457 C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
36461 T3I=SIGN(1D0,EI+1D-6)/2D0
36462 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36463 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36465 CXC(4)=DCONJG(GLIJ)
36467 CXC(8)=-DCONJG(GRIJ)
36468 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
36469 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
36471 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
36472 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
36473 IDLAM(LKNT,1)=KFNCHI(IX)
36477 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
36479 XLAM(LKNT)=XLAM(LKNT-1)
36480 IDLAM(LKNT,1)=KFNCHI(IX)
36485 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
36486 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
36488 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
36489 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
36490 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
36492 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
36493 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
36495 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
36498 IDLAM(LKNT,1)=KFNCHI(IX)
36501 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
36507 C...GLUINO -> CI Q QBAR'
36511 IF(AXMI.GE.AXMJ) THEN
36513 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
36514 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
36517 S12MAX=(AXMI-AXMJ)**2
36522 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
36523 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
36526 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
36528 CXC(1)=DCMPLX(0D0,0D0)
36529 CXC(3)=DCMPLX(0D0,0D0)
36530 CXC(5)=DCMPLX(0D0,0D0)
36531 CXC(7)=DCMPLX(0D0,0D0)
36532 CXC(2)=UMIXC(IX,1)*OLPP/SR2
36533 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
36534 CXC(6)=DCMPLX(0D0,0D0)
36535 CXC(8)=DCMPLX(0D0,0D0)
36536 IF(XXC(5).LT.AXMI) THEN
36538 ELSEIF(XXC(6).LT.AXMI) THEN
36543 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
36544 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
36546 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
36547 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36548 IDLAM(LKNT,1)=KFCCHI(IX)
36552 XLAM(LKNT)=XLAM(LKNT-1)
36553 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36554 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36555 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36557 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
36559 XLAM(LKNT)=XLAM(LKNT-1)
36560 IDLAM(LKNT,1)=KFCCHI(IX)
36564 XLAM(LKNT)=XLAM(LKNT-1)
36565 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36566 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36567 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36573 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
36574 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
36575 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
36576 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
36577 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
36578 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
36579 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
36580 IF(XMI.GT.PMOLT2+XMF) PMOLT2=100D0*AXMI
36581 IF(XMI.GT.PMOLT1+XMF) PMOLT1=100D0*AXMI
36582 IF(XMI.GT.PMOLB2+XMFP) PMOLB2=100D0*AXMI
36583 IF(XMI.GT.PMOLB1+XMFP) PMOLB1=100D0*AXMI
36584 CALL PYTBBC(IX,100,XMI,GAM)
36587 IDLAM(LKNT,1)=KFCCHI(IX)
36591 XLAM(LKNT)=XLAM(LKNT-1)
36592 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36593 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36594 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36595 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
36596 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
36597 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
36598 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
36604 C...R-parity violating (3-body) decays.
36605 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
36610 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
36611 XLAM(0)=XLAM(0)+XLAM(I)
36613 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
36618 C*********************************************************************
36621 C...Calculates the three-body decay of gluinos into
36622 C...neutralinos and third generation fermions.
36624 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
36626 C...Double precision and integer declarations.
36627 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36628 IMPLICIT INTEGER(I-N)
36629 INTEGER PYK,PYCHGE,PYCOMP
36630 C...Parameter statement to help give large particle numbers.
36631 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36632 &KEXCIT=4000000,KDIMEN=5000000)
36634 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36635 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36636 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36637 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36638 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36639 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
36641 C...Local variables.
36642 EXTERNAL PYSIMP,PYLAMF
36643 DOUBLE PRECISION PYSIMP,PYLAMF
36645 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
36646 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
36647 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
36648 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
36649 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
36650 DOUBLE PRECISION XLN1,XLN2,B1,B2
36651 DOUBLE PRECISION E,XMGLU,GAM
36652 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
36653 SAVE HRB,HLB,FLB,FRB
36654 DOUBLE PRECISION ALPHAW,ALPHAS
36655 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
36656 SAVE HLT,HRT,FLT,FRT
36657 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
36659 DOUBLE PRECISION AMBOT,SINC,COSC
36660 DOUBLE PRECISION AMTOP,SINA,COSA
36661 DOUBLE PRECISION SINW,COSW,TANW
36662 DOUBLE PRECISION ROT1(4,4)
36665 DATA IFIRST/.TRUE./
36668 SINB=TANB/SQRT(1D0+TANB**2)
36679 AMBOT=PYMRUN(5,XMGLU**2)
36680 AMTOP=PYMRUN(6,XMGLU**2)
36682 FAKT1=AMBOT/W2/AMW/COSB
36683 FAKT2=AMTOP/W2/AMW/SINB
36694 ROT1(2,1)=-ROT1(1,2)
36695 ROT1(2,2)=ROT1(1,1)
36698 ROT1(4,3)=-ROT1(3,4)
36699 ROT1(4,4)=ROT1(3,3)
36703 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
36708 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
36709 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
36710 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
36712 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
36713 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
36714 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
36715 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
36718 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
36719 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
36720 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
36721 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
36722 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
36723 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
36724 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
36728 C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
36729 C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
36730 C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
36731 C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
36735 IF(NINT(3D0*E).EQ.2) THEN
36742 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
36743 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
36752 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
36753 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
36759 SIN2D=SIND*COSD*2D0
36773 ALPHAW=PYALEM(XMG2)
36774 ALPHAS=PYALPS(XMG2)
36778 XM24=(XMG2+XM2)*(XM2+XMR2)
36780 SMAX=(XMG-ABS(XMR))**2
36781 XMQA=XMG2+2D0*XM2+XMR2
36783 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
36785 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
36787 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
36788 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
36789 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
36790 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
36791 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
36792 & +2D0*(FF*SIND2-HH*COSD2))*W
36793 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
36794 & +4D0*HFL*XM*XMR)*XLN1
36795 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
36796 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
36797 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
36798 & +8D0*HFL*XMQ4*SIN2D)*B1
36799 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
36800 & +4D0*HFR*XMR*XM)*XLN2
36801 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
36802 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
36803 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
36804 & -8D0*HFR*XMQ4*SIN2D)*B2
36805 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
36806 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
36807 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
36808 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
36809 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
36810 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
36811 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
36812 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
36813 G(5)=(2D0*(HH*COSD2-FF*SIND2)
36814 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
36815 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
36816 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
36817 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
36818 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
36819 & +COS2D*XM*(SBAR+XMG2-XMR2))
36820 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
36821 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
36822 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
36823 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
36824 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
36825 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
36826 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
36829 SUMME(LIN)=SUMME(LIN)+G(J)
36834 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
36835 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
36840 C*********************************************************************
36843 C...Calculates the three-body decay of gluinos into
36844 C...charginos and third generation fermions.
36846 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
36848 C...Double precision and integer declarations.
36849 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36850 IMPLICIT INTEGER(I-N)
36851 INTEGER PYK,PYCHGE,PYCOMP
36852 C...Parameter statement to help give large particle numbers.
36853 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36854 &KEXCIT=4000000,KDIMEN=5000000)
36856 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36857 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36858 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36859 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36860 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36861 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
36863 C...Local variables.
36864 EXTERNAL PYSIMP,PYLAMF
36865 DOUBLE PRECISION PYSIMP,PYLAMF
36867 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
36868 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
36869 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
36870 DOUBLE PRECISION SUMME(0:100),A(4,8)
36871 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
36872 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
36873 DOUBLE PRECISION XMGLU,GAM
36874 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
36875 &DDD(2),EEE(2),FFF(2)
36876 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
36877 DOUBLE PRECISION ALPHAW,ALPHAS
36878 DOUBLE PRECISION AMC(2)
36880 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
36881 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
36885 DATA IFIRST/.TRUE./
36888 SINB=TANB/SQRT(1D0+TANB**2)
36896 AMBOT=PYMRUN(5,XMGLU**2)
36897 AMTOP=PYMRUN(6,XMGLU**2)
36900 FAKT1=AMBOT/W2/AMW/COSB
36901 FAKT2=AMTOP/W2/AMW/SINB
36906 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
36907 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
36908 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
36909 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
36910 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
36911 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
36912 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
36913 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
36915 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
36916 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
36917 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
36918 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
36922 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
36923 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
36924 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
36925 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
36927 COS2A=COSA**2-SINA**2
36928 SIN2A=SINA*COSA*2D0
36929 COS2C=COSC**2-SINC**2
36930 SIN2C=SINC*COSC*2D0
36937 ALPHAW=PYALEM(XMG2)
36938 ALPHAS=PYALPS(XMG2)
36942 XMQ2=XMG2+XMT2+XMB2+XMR2
36943 XMQ4=XMG*XMT*XMB*XMR
36944 XMQ3=XMG2*XMR2+XMT2*XMB2
36945 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
36946 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
36948 XMST(1)=AMST(1)*AMST(1)
36949 XMST(2)=AMST(1)*AMST(1)
36950 XMST(3)=AMST(2)*AMST(2)
36951 XMST(4)=AMST(2)*AMST(2)
36952 XMSB(1)=AMSB(1)*AMSB(1)
36953 XMSB(2)=AMSB(2)*AMSB(2)
36954 XMSB(3)=AMSB(1)*AMSB(1)
36955 XMSB(4)=AMSB(2)*AMSB(2)
36957 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
36958 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
36959 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
36960 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
36961 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
36962 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
36963 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
36964 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
36966 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
36967 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
36968 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
36969 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
36970 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
36971 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
36972 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
36973 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
36975 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
36976 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
36977 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
36978 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
36979 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
36980 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
36981 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
36982 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
36984 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
36985 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
36986 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
36987 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
36988 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
36989 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
36990 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
36991 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
36993 SMAX=(XMG-ABS(XMR))**2
36994 SMIN=(XMB+XMT)**2+0.1D0
36997 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
36998 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
37000 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
37001 W=DSQRT(W)/2D0/SBAR
37002 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
37003 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
37004 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
37005 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
37006 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
37007 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
37008 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
37009 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
37010 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
37011 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
37012 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
37013 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
37014 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
37015 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
37016 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
37017 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
37018 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
37019 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
37020 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
37021 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
37022 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
37023 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
37024 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
37025 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
37026 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
37027 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
37028 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
37029 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
37030 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
37031 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
37032 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
37033 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
37034 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
37035 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
37036 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
37037 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
37038 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
37039 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
37040 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
37041 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
37042 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
37043 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
37044 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
37046 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
37047 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
37048 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
37049 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
37050 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
37051 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
37052 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
37053 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
37054 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
37055 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
37056 & -A(J,6)*(XMG2+XMR2-SBAR)
37057 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
37058 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
37059 & /(GRS+XMSB(J)+XMST(J))
37063 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
37064 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
37069 C*********************************************************************
37072 C...Calculates decay widths for the neutralinos (admixtures of
37073 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
37075 C...Input: KCIN = KF code for particle
37076 C...Output: XLAM = widths
37077 C... IDLAM = KF codes for decay particles
37078 C... IKNT = number of decay channels defined
37079 C...AUTHOR: STEPHEN MRENNA
37081 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
37082 C...when CHIGAMMA .NE. 0
37083 C...10 FEB 96: Calculate this decay for small tan(beta)
37085 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
37087 C...Double precision and integer declarations.
37088 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37089 IMPLICIT INTEGER(I-N)
37090 INTEGER PYK,PYCHGE,PYCOMP
37091 C...Parameter statement to help give large particle numbers.
37092 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37093 &KEXCIT=4000000,KDIMEN=5000000)
37095 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37096 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37097 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
37098 c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37100 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37101 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
37102 C COMMON/PYINTS/XXM(20)
37104 COMMON/PYINTC/XXC(10),CXC(8)
37105 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
37107 C...Local variables.
37108 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
37109 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
37111 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
37112 &XMZ,XMZ2,AXMJ,AXMI
37113 DOUBLE PRECISION S12MIN,S12MAX
37114 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
37115 DOUBLE PRECISION PYLAMF,XL
37116 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
37117 DOUBLE PRECISION PYX2XH,PYX2XG
37118 DOUBLE PRECISION XLAM(0:400)
37119 INTEGER IDLAM(400,3)
37120 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
37121 INTEGER ITH(3),KF1,KF2
37123 DOUBLE PRECISION DH(3),EH(3)
37124 DOUBLE PRECISION SR2
37125 DOUBLE PRECISION CBETA,SBETA
37126 DOUBLE PRECISION GAMCON,XMT1,XMT2
37127 DOUBLE PRECISION PYALEM,PI,PYALPS
37128 DOUBLE PRECISION RAT1,RAT2
37129 DOUBLE PRECISION T3T,FCOL
37130 DOUBLE PRECISION ALFA,BETA,TANB
37131 DOUBLE PRECISION PYXXGA
37132 EXTERNAL PYGAUS,PYXXZ6
37133 DOUBLE PRECISION PYGAUS,PYXXZ6
37134 DOUBLE PRECISION PREC
37135 INTEGER KFNCHI(4),KFCCHI(2)
37139 DATA PI/3.141592654D0/
37140 DATA SR2/1.4142136D0/
37141 DATA KFNCHI/1000022,1000023,1000025,1000035/
37142 DATA KFCCHI/1000024,1000037/
37144 C...COUNT THE NUMBER OF DECAY MODES
37153 TANW = SQRT(XW/XW1)
37155 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
37157 IF(KFIN.EQ.KFNCHI(2)) IX=2
37158 IF(KFIN.EQ.KFNCHI(3)) IX=3
37159 IF(KFIN.EQ.KFNCHI(4)) IX=4
37179 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
37184 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
37185 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
37189 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
37190 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
37192 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
37193 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
37197 GAMCON=AEM**3/8D0/PI/XMW2/XW
37198 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
37199 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
37200 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
37201 IDLAM(LKNT,1)=KSUSY1+22
37204 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
37208 C...GRAVITINO DECAY MODES
37210 IF(IMSS(11).EQ.1) THEN
37213 XMGR=PMAS(PYCOMP(IDG),1)
37216 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
37217 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
37222 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
37224 IF(AXMI.GT.XMGR+XMZ) THEN
37229 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
37230 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
37231 & (1D0-XMZ2/XMI2)**4
37233 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
37238 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
37239 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
37241 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
37246 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
37247 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
37249 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
37254 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
37255 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
37257 IF(IX.EQ.1) GOTO 300
37265 C...CHI0_I -> CHI0_J + GAMMA
37266 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
37267 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
37268 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
37269 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
37270 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
37271 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
37272 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
37274 IDLAM(LKNT,1)=KFNCHI(IJ)
37277 GAMCON=AEM**3/8D0/PI/XMW2/XW
37278 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
37279 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
37280 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
37284 C...CHI0_I -> CHI0_J + Z0
37285 IF(AXMI.GE.AXMJ+XMZ) THEN
37287 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
37288 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
37290 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37291 GLR=DBLE(OLPP*DCONJG(ORPP))
37292 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
37293 IDLAM(LKNT,1)=KFNCHI(IJ)
37296 ELSEIF(AXMI.GE.AXMJ) THEN
37303 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
37304 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
37306 C...CHARGED LEPTONS
37308 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37309 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37311 T3I=SIGN(1D0,EI+1D-6)/2D0
37312 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37313 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37314 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37315 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37317 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37318 CXC(4)=DCONJG(GLIJ)
37319 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37321 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37322 CXC(8)=-DCONJG(GRIJ)
37324 S12MAX=(AXMI-AXMJ)**2
37325 IF( XXC(5).LT.AXMI ) THEN
37328 IF(XXC(6).LT.AXMI ) THEN
37334 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
37336 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37337 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37338 IDLAM(LKNT,1)=KFNCHI(IJ)
37341 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
37343 XLAM(LKNT)=XLAM(LKNT-1)
37344 IDLAM(LKNT,1)=KFNCHI(IJ)
37350 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
37351 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
37352 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
37354 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
37355 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
37357 IF( XXC(5).LT.AXMI ) THEN
37360 IF(XXC(6).LT.AXMI ) THEN
37366 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
37368 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37369 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37370 IDLAM(LKNT,1)=KFNCHI(IJ)
37378 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37379 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37381 T3I=SIGN(1D0,EI+1D-6)/2D0
37382 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37383 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37384 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37385 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37387 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37388 CXC(4)=DCONJG(GLIJ)
37389 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37391 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37392 CXC(8)=-DCONJG(GRIJ)
37394 S12MAX=(AXMI-AXMJ)**2
37395 IF( XXC(5).LT.AXMI ) THEN
37398 IF( XXC(6).LT.AXMI ) THEN
37405 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37406 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37407 IDLAM(LKNT,1)=KFNCHI(IJ)
37411 XLAM(LKNT)=XLAM(LKNT-1)
37412 IDLAM(LKNT,1)=KFNCHI(IJ)
37417 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
37419 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
37420 IF( XXC(5).LT.AXMI ) THEN
37425 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37426 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37429 XLAM(LKNT)=XLAM(LKNT-1)
37431 IDLAM(LKNT,1)=KFNCHI(IJ)
37437 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37438 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37440 T3I=SIGN(1D0,EI+1D-6)/2D0
37441 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37442 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37443 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37444 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37446 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37447 CXC(4)=DCONJG(GLIJ)
37448 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37450 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37451 CXC(8)=-DCONJG(GRIJ)
37453 S12MAX=(AXMI-AXMJ)**2
37454 IF( XXC(5).LT.AXMI ) THEN
37457 IF( XXC(6).LT.AXMI ) THEN
37463 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
37465 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37466 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
37467 IDLAM(LKNT,1)=KFNCHI(IJ)
37470 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
37472 XLAM(LKNT)=XLAM(LKNT-1)
37473 IDLAM(LKNT,1)=KFNCHI(IJ)
37479 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
37480 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
37481 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
37483 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
37484 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
37486 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
37487 IF(XXC(5).LT.AXMI) THEN
37489 ELSEIF(XXC(6).LT.AXMI) THEN
37494 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
37496 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37497 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
37498 IDLAM(LKNT,1)=KFNCHI(IJ)
37506 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37507 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37509 T3I=SIGN(1D0,EI+1D-6)/2D0
37510 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37511 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37512 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37513 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37515 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37516 CXC(4)=DCONJG(GLIJ)
37517 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37519 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37520 CXC(8)=-DCONJG(GRIJ)
37522 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
37523 IF(XXC(5).LT.AXMI) THEN
37525 ELSEIF(XXC(6).LT.AXMI) THEN
37531 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
37533 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37534 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
37535 IDLAM(LKNT,1)=KFNCHI(IJ)
37538 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
37540 XLAM(LKNT)=XLAM(LKNT-1)
37541 IDLAM(LKNT,1)=KFNCHI(IJ)
37549 C...CHI0_I -> CHI0_J + H0_K
37556 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
37557 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
37558 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
37559 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
37560 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
37561 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
37562 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
37563 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
37565 XMH=PMAS(ITH(IH),1)
37567 IF(AXMI.GE.AXMJ+XMH) THEN
37569 XL=PYLAMF(XMI2,XMJ2,XMH2)
37570 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
37572 C...SIGN OF MASSES I,J
37574 IF(IH.EQ.3) XMK=-XMK
37575 GX2=ABS(F21K)**2+ABS(F12K)**2
37576 GLR=DBLE(F21K*DCONJG(F12K))
37577 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
37578 IDLAM(LKNT,1)=KFNCHI(IJ)
37579 IDLAM(LKNT,2)=ITH(IH)
37585 C...CHI0_I -> CHI+_J + W-
37590 IF(AXMI.GE.AXMJ+XMW) THEN
37592 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
37593 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
37594 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
37595 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
37596 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
37597 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
37598 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
37599 IDLAM(LKNT,1)=KFCCHI(IJ)
37603 XLAM(LKNT)=XLAM(LKNT-1)
37604 IDLAM(LKNT,1)=-KFCCHI(IJ)
37607 ELSEIF(AXMI.GE.AXMJ) THEN
37609 S12MAX=(AXMI-AXMJ)**2
37610 RT2I = 1D0/SQRT(2D0)
37611 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
37612 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
37613 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
37614 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
37615 CXC(5)=DCMPLX(0D0,0D0)
37616 CXC(7)=DCMPLX(0D0,0D0)
37620 T3I=SIGN(1D0,EI+1D-6)/2D0
37622 T3J=SIGN(1D0,EJ+1D-6)/2D0
37623 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
37624 & TANW+ZMIXC(IX,2)*T3J)*RT2I
37625 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
37626 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
37627 CXC(6)=DCMPLX(0D0,0D0)
37628 CXC(8)=DCMPLX(0D0,0D0)
37633 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
37634 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
37637 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
37638 IF(XXC(5).LT.AXMI) THEN
37640 ELSEIF(XXC(6).LT.AXMI) THEN
37645 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
37647 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37648 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37649 IDLAM(LKNT,1)=KFCCHI(IJ)
37653 XLAM(LKNT)=XLAM(LKNT-1)
37654 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37655 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37656 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37657 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
37659 XLAM(LKNT)=XLAM(LKNT-1)
37660 IDLAM(LKNT,1)=KFCCHI(IJ)
37664 XLAM(LKNT)=XLAM(LKNT-1)
37665 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37666 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37667 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37671 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
37672 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
37673 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
37675 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
37676 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
37678 IF(XXC(5).LT.AXMI) THEN
37681 IF(XXC(6).LT.AXMI) THEN
37686 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
37688 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37689 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37690 XLAM(LKNT)=XLAM(LKNT-1)
37691 IDLAM(LKNT,1)=KFCCHI(IJ)
37695 XLAM(LKNT)=XLAM(LKNT-1)
37696 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37697 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37698 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37701 C...NOW, DO THE QUARKS
37706 T3I=SIGN(1D0,EI+1D-6)/2D0
37708 T3J=SIGN(1D0,EJ+1D-6)/2D0
37709 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
37710 & TANW+ZMIXC(IX,2)*T3J)
37711 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
37712 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
37713 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
37714 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
37715 IF(XXC(5).LT.AXMI) THEN
37718 IF(XXC(6).LT.AXMI) THEN
37723 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
37725 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
37726 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37727 IDLAM(LKNT,1)=KFCCHI(IJ)
37731 XLAM(LKNT)=XLAM(LKNT-1)
37732 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37733 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37734 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37735 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
37737 XLAM(LKNT)=XLAM(LKNT-1)
37738 IDLAM(LKNT,1)=KFCCHI(IJ)
37742 XLAM(LKNT)=XLAM(LKNT-1)
37743 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37744 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37745 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37753 C...CHI0_I -> CHI+_I + H-
37759 IF(AXMI.GE.AXMJ+XMHP) THEN
37761 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
37762 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
37763 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
37764 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
37766 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37767 GLR=DBLE(OLPP*DCONJG(ORPP))
37768 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
37769 IDLAM(LKNT,1)=KFCCHI(IJ)
37770 IDLAM(LKNT,2)=-ITHC
37773 XLAM(LKNT)=XLAM(LKNT-1)
37774 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37775 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37776 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37782 C...2-BODY DECAYS TO FERMION SFERMION
37784 IF(J.GE.7.AND.J.LE.10) GOTO 290
37787 XMSF1=PMAS(PYCOMP(KF1),1)
37788 XMSF2=PMAS(PYCOMP(KF2),1)
37798 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
37799 IF(MOD(J,2).EQ.0) THEN
37800 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
37801 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
37802 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
37805 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
37806 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
37807 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
37812 IF(AXMI.GE.XMF+XMSF1) THEN
37816 XL=PYLAMF(XMI2,XMA2,XMB2)
37817 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
37818 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
37819 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37820 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37825 XLAM(LKNT)=XLAM(LKNT-1)
37826 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37827 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37832 IF(AXMI.GE.XMF+XMSF2) THEN
37836 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
37837 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
37838 XL=PYLAMF(XMI2,XMA2,XMB2)
37839 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37840 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37845 XLAM(LKNT)=XLAM(LKNT-1)
37846 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37847 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37852 C...3-BODY DECAY TO Q Q~ GLUINO
37853 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
37854 IF(AXMI.GE.XMJ) THEN
37855 RT2I = 1D0/SQRT(2D0)
37856 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
37864 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37865 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37866 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
37872 T3I=SIGN(1D0,EI+1D-6)/2D0
37873 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
37874 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
37878 CXC(4)=DCONJG(GLIJ)
37882 CXC(8)=-DCONJG(GRIJ)
37884 S12MAX=(AXMI-AXMJ)**2
37885 C...ALL QUARKS BUT T
37886 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
37888 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
37889 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37890 IDLAM(LKNT,1)=KSUSY1+21
37893 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
37895 XLAM(LKNT)=XLAM(LKNT-1)
37896 IDLAM(LKNT,1)=KSUSY1+21
37902 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
37903 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
37904 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
37906 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
37907 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
37909 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
37912 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
37914 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
37915 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37916 IDLAM(LKNT,1)=KSUSY1+21
37923 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37924 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37925 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
37929 T3I=SIGN(1D0,EI+1D-6)/2D0
37930 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
37931 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
37933 CXC(4)=DCONJG(GLIJ)
37935 CXC(8)=-DCONJG(GRIJ)
37936 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
37938 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
37939 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37940 IDLAM(LKNT,1)=KSUSY1+21
37943 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
37945 XLAM(LKNT)=XLAM(LKNT-1)
37946 IDLAM(LKNT,1)=KSUSY1+21
37954 C...R-violating decay modes (SKANDS).
37955 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
37960 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
37961 XLAM(0)=XLAM(0)+XLAM(I)
37963 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
37968 C*********************************************************************
37971 C...Calculate decay widths for the charginos (admixtures of
37972 C...charged Wino and charged Higgsino.
37974 C...Input: KCIN = KF code for particle
37975 C...Output: XLAM = widths
37976 C... IDLAM = KF codes for decay particles
37977 C... IKNT = number of decay channels defined
37978 C...AUTHOR: STEPHEN MRENNA
37980 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
37981 C...when CHIENU .NE. 0
37983 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
37985 C...Double precision and integer declarations.
37986 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37987 IMPLICIT INTEGER(I-N)
37988 INTEGER PYK,PYCHGE,PYCOMP
37989 C...Parameter statement to help give large particle numbers.
37990 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37991 &KEXCIT=4000000,KDIMEN=5000000)
37993 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37994 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37995 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
37996 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37997 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
37999 C COMMON/PYINTS/XXM(20)
38001 COMMON/PYINTC/XXC(10),CXC(8)
38002 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
38004 C...Local variables
38005 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
38006 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
38008 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
38009 &XMZ,XMZ2,AXMJ,AXMI
38010 DOUBLE PRECISION S12MIN,S12MAX
38011 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
38012 DOUBLE PRECISION PYLAMF,XL
38013 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
38014 DOUBLE PRECISION PYX2XH,PYX2XG
38015 DOUBLE PRECISION XLAM(0:400)
38016 INTEGER IDLAM(400,3)
38017 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
38020 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
38021 DOUBLE PRECISION SR2
38022 DOUBLE PRECISION CBETA,SBETA,TANB
38024 DOUBLE PRECISION PYALEM,PI,PYALPS
38025 DOUBLE PRECISION FCOL
38026 INTEGER KF1,KF2,ISF
38027 INTEGER KFNCHI(4),KFCCHI(2)
38029 DOUBLE PRECISION TEMP
38030 EXTERNAL PYGAUS,PYXXZ6
38031 DOUBLE PRECISION PYGAUS,PYXXZ6
38032 DOUBLE PRECISION PREC
38035 DATA ETAH/1D0,1D0,-1D0/
38036 DATA SR2/1.4142136D0/
38037 DATA PI/3.141592654D0/
38039 DATA KFNCHI/1000022,1000023,1000025,1000035/
38040 DATA KFCCHI/1000024,1000037/
38042 C...COUNT THE NUMBER OF DECAY MODES
38050 TANW = SQRT(XW/XW1)
38052 C...1 OR 2 DEPENDING ON CHARGINO TYPE
38054 IF(KFIN.EQ.KFCCHI(2)) IX=2
38072 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
38073 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
38077 C...GRAVITINO DECAY MODES
38079 IF(IMSS(11).EQ.1) THEN
38082 XMGR=PMAS(PYCOMP(IDG),1)
38084 C COSW=SQRT(1D0-XW)
38085 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
38086 IF(AXMI.GT.XMGR+XMW) THEN
38092 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
38093 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
38094 & (1D0-XMW2/XMI2)**4
38096 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
38101 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
38102 & (ABS(UMIXC(IX,2))*SBETA)**2))
38103 & *(1D0-PMAS(37,1)**2/XMI2)**4
38107 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
38108 IF(IX.EQ.1) GOTO 170
38113 C...CHI_2+ -> CHI_1+ + Z0
38114 IF(AXMI.GE.AXMJ+XMZ) THEN
38117 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
38118 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
38119 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
38120 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
38121 GX2=ABS(OLPP)**2+ABS(ORPP)**2
38122 GLR=DBLE(OLPP*DCONJG(ORPP))
38123 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
38124 IDLAM(LKNT,1)=KFCCHI(1)
38128 C...CHARGED LEPTONS
38129 ELSEIF(AXMI.GE.AXMJ) THEN
38131 S12MAX=(AXMI-AXMJ)**2
38134 EI=KCHG(IABS(IA),1)/3D0
38135 T3I=SIGN(1D0,EI+1D-6)/2D0
38140 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38145 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
38146 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
38147 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
38148 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
38149 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38150 CXC(2)=DCMPLX(0D0,0D0)
38151 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38152 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
38153 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38154 CXC(6)=DCMPLX(0D0,0D0)
38155 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38156 CXC(8)=DCMPLX(0D0,0D0)
38157 IF( XXC(5).LT.AXMI ) THEN
38162 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
38164 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
38165 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38166 IDLAM(LKNT,1)=KFCCHI(1)
38169 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
38171 XLAM(LKNT)=XLAM(LKNT-1)
38172 IDLAM(LKNT,1)=KFCCHI(1)
38176 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
38178 XLAM(LKNT)=XLAM(LKNT-1)
38179 IDLAM(LKNT,1)=KFCCHI(1)
38189 EI=KCHG(IABS(IA),1)/3D0
38190 T3I=SIGN(1D0,EI+1D-6)/2D0
38191 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38193 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38194 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38195 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
38196 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38197 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38198 IF( XXC(5).LT.AXMI ) THEN
38203 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
38205 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
38206 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38207 IDLAM(LKNT,1)=KFCCHI(1)
38211 XLAM(LKNT)=XLAM(LKNT-1)
38212 IDLAM(LKNT,1)=KFCCHI(1)
38216 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
38217 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
38218 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
38220 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
38222 IF( XXC(5).LT.AXMI ) THEN
38227 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
38228 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38229 IDLAM(LKNT,1)=KFCCHI(1)
38238 EI=KCHG(IABS(IA),1)/3D0
38239 T3I=SIGN(1D0,EI+1D-6)/2D0
38240 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38242 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38243 CXC(2)=DCMPLX(0D0,0D0)
38244 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38245 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
38246 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38247 CXC(6)=DCMPLX(0D0,0D0)
38248 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38249 CXC(8)=DCMPLX(0D0,0D0)
38250 IF( XXC(5).LT.AXMI ) THEN
38255 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
38257 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38258 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38259 IDLAM(LKNT,1)=KFCCHI(1)
38262 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
38264 XLAM(LKNT)=XLAM(LKNT-1)
38265 IDLAM(LKNT,1)=KFCCHI(1)
38270 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
38271 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
38272 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
38274 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
38276 IF( XXC(5).LT.AXMI ) THEN
38281 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38282 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38283 IDLAM(LKNT,1)=KFCCHI(1)
38292 EI=KCHG(IABS(IA),1)/3D0
38293 T3I=SIGN(1D0,EI+1D-6)/2D0
38294 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38296 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38297 CXC(2)=DCMPLX(0D0,0D0)
38298 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38299 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
38300 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38301 CXC(6)=DCMPLX(0D0,0D0)
38302 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38303 CXC(8)=DCMPLX(0D0,0D0)
38304 IF( XXC(5).LT.AXMI ) THEN
38309 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
38311 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38312 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38313 IDLAM(LKNT,1)=KFCCHI(1)
38316 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
38318 XLAM(LKNT)=XLAM(LKNT-1)
38319 IDLAM(LKNT,1)=KFCCHI(1)
38327 C...CHI_2+ -> CHI_1+ + H0_K
38335 XMH=PMAS(ITH(IH),1)
38337 C...NO 3-BODY OPTION
38338 IF(AXMI.GE.AXMJ+XMH) THEN
38340 XL=PYLAMF(XMI2,XMJ2,XMH2)
38341 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
38342 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
38343 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
38344 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
38346 GX2=ABS(OLPP)**2+ABS(ORPP)**2
38347 GLR=DBLE(OLPP*DCONJG(ORPP))
38348 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
38349 IDLAM(LKNT,1)=KFCCHI(1)
38350 IDLAM(LKNT,2)=ITH(IH)
38355 C...CHI1 JUMPS TO HERE
38358 C...CHI+_I -> CHI0_J + W+
38363 IF(AXMI.GE.AXMJ+XMW) THEN
38366 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
38368 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
38369 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
38370 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
38371 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
38372 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
38373 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
38374 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
38375 IDLAM(LKNT,1)=KFNCHI(IJ)
38379 ELSEIF(AXMI.GE.AXMJ) THEN
38381 S12MAX=(AXMI-AXMJ)**2
38383 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
38385 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
38386 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
38387 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
38388 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
38389 CXC(5)=DCMPLX(0D0,0D0)
38390 CXC(7)=DCMPLX(0D0,0D0)
38394 T3I=SIGN(1D0,EI+1D-6)/2D0
38396 T3J=SIGN(1D0,EJ+1D-6)/2D0
38397 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
38398 & TANW+ZMIXC(IJ,2)*T3J)/SR2
38399 CXC(4)=-DCONJG(UMIXC(IX,1))*(
38400 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
38401 CXC(6)=DCMPLX(0D0,0D0)
38402 CXC(8)=DCMPLX(0D0,0D0)
38407 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38408 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
38411 CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
38412 IF(XXC(5).LT.AXMI) THEN
38414 ELSEIF(XXC(6).LT.AXMI) THEN
38419 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
38420 C...--> 1/(16PI)/M**3*(AEM/XW)**2
38421 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
38423 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38424 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
38425 IDLAM(LKNT,1)=KFNCHI(IJ)
38428 C...ONLY DECAY CHI+1 -> E+ NU_E
38429 IF( IMSS(12).NE. 0 ) GOTO 260
38430 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
38432 XLAM(LKNT)=XLAM(LKNT-1)
38433 IDLAM(LKNT,1)=KFNCHI(IJ)
38438 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
38440 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
38441 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
38443 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
38445 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
38446 IF(XXC(5).LT.AXMI) THEN
38448 ELSEIF(XXC(6).LT.AXMI) THEN
38453 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38454 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
38455 IDLAM(LKNT,1)=KFNCHI(IJ)
38460 C...NOW, DO THE QUARKS
38465 T3I=SIGN(1D0,EI+1D-6)/2D0
38467 T3J=SIGN(1D0,EJ+1D-6)/2D0
38468 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
38469 & TANW+ZMIXC(IX,2)*T3J)
38470 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
38471 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
38472 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38473 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
38474 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
38475 IF(XXC(5).LT.AXMI) THEN
38478 IF(XXC(6).LT.AXMI) THEN
38483 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
38485 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38486 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38487 IDLAM(LKNT,1)=KFNCHI(IJ)
38490 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
38492 XLAM(LKNT)=XLAM(LKNT-1)
38493 IDLAM(LKNT,1)=KFNCHI(IJ)
38502 C...CHI+_I -> CHI0_J + H+
38508 IF(AXMI.GE.AXMJ+XMHP) THEN
38510 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
38511 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
38512 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
38513 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
38515 GX2=ABS(OLPP)**2+ABS(ORPP)**2
38516 GLR=DBLE(OLPP*DCONJG(ORPP))
38517 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
38518 IDLAM(LKNT,1)=KFNCHI(IJ)
38526 C...2-BODY DECAYS TO FERMION SFERMION
38528 IF(J.GE.7.AND.J.LE.10) GOTO 240
38529 IF(MOD(J,2).EQ.0) THEN
38535 XMSF1=PMAS(PYCOMP(KF1),1)
38536 XMSF2=PMAS(PYCOMP(KF2),1)
38545 IF(MOD(J,2).EQ.0) THEN
38548 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
38549 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
38555 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
38557 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
38562 IF(AXMI.GE.XMF+XMSF1) THEN
38566 XL=PYLAMF(XMI2,XMA2,XMB2)
38567 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
38568 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
38569 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
38570 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
38572 IF(MOD(J,2).EQ.0) THEN
38582 IF(AXMI.GE.XMF+XMSF2) THEN
38586 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
38587 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
38588 XL=PYLAMF(XMI2,XMA2,XMB2)
38589 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
38590 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
38592 IF(MOD(J,2).EQ.0) THEN
38602 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
38603 C...A 2-BODY -- 2-BODY CHAIN
38604 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
38605 IF(AXMI.GE.XMJ) THEN
38608 S12MAX=(AXMI-AXMJ)**2
38613 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
38614 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
38617 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
38619 CXC(1)=DCMPLX(0D0,0D0)
38620 CXC(3)=DCMPLX(0D0,0D0)
38621 CXC(5)=DCMPLX(0D0,0D0)
38622 CXC(7)=DCMPLX(0D0,0D0)
38623 CXC(2)=UMIXC(IX,1)*OLPP/SR2
38624 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
38625 CXC(6)=DCMPLX(0D0,0D0)
38626 CXC(8)=DCMPLX(0D0,0D0)
38627 IF(XXC(5).LT.AXMI) THEN
38629 ELSEIF(XXC(6).LT.AXMI) THEN
38634 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
38635 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
38637 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
38638 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38639 IDLAM(LKNT,1)=KSUSY1+21
38642 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
38644 XLAM(LKNT)=XLAM(LKNT-1)
38645 IDLAM(LKNT,1)=KSUSY1+21
38653 C...R-violating decay modes (SKANDS).
38654 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
38659 XLAM(0)=XLAM(0)+XLAM(I)
38660 IF(XLAM(I).LT.0D0) THEN
38661 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
38662 & (IDLAM(I,J),J=1,3)
38666 IF(XLAM(0).EQ.0D0) THEN
38668 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
38669 WRITE(MSTU(11),*) LKNT
38670 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
38676 C*********************************************************************
38679 C...Used in the calculation of inoi -> inoj + f + ~f.
38683 C...Double precision and integer declarations.
38684 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38685 IMPLICIT INTEGER(I-N)
38686 INTEGER PYK,PYCHGE,PYCOMP
38687 C...Parameter statement to help give large particle numbers.
38688 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38689 &KEXCIT=4000000,KDIMEN=5000000)
38691 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38692 C COMMON/PYINTS/XXM(20)
38694 COMMON/PYINTC/XXC(10),CXC(8)
38695 SAVE /PYDAT1/,/PYINTC/
38697 C...Local variables.
38698 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
38699 DOUBLE PRECISION PYXXZ6,X
38700 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
38701 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
38702 DOUBLE PRECISION SIJ
38703 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
38704 DOUBLE PRECISION OL2
38705 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
38708 C...Statement functions.
38709 C...Integral from x to y of (t-a)(b-t) dt.
38710 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
38711 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
38712 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
38713 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
38714 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
38715 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
38716 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
38717 C...Integral from x to y of (t-a)/(b-t) dt.
38718 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
38719 C...Integral from x to y of 1/(t-a) dt.
38720 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
38728 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
38729 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
38730 &( (X-XM22-S)**2 -4D0*XM22*S ) )
38732 S23MIN=(S23AVE-S23DEL)
38733 S23MAX=(S23AVE+S23DEL)
38750 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
38751 SIJ=2D0*XXC(2)*XXC(4)*S13
38752 IF(XMV.LE.1000D0) THEN
38753 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
38754 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
38755 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
38756 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
38757 IF(XXC(5).LE.10000D0) THEN
38758 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
38759 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
38760 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
38761 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
38762 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
38763 & *(S13-XMV**2)/WPROP2
38768 IF(XXC(6).LE.10000D0) THEN
38769 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
38770 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
38771 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
38772 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
38773 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
38774 & *(S13-XMV**2)/WPROP2
38783 IF(XXC(5).LE.10000D0) THEN
38784 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
38785 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
38786 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
38787 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
38791 IF(XXC(6).LE.10000D0) THEN
38792 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
38793 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
38794 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
38795 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
38800 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
38802 IF(PYXXZ6.LT.0D0) THEN
38803 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
38804 WRITE(MSTU(11),*) XXc(1),XXc(2),XXc(3),XXc(4)
38805 WRITE(MSTU(11),*) (XXc(I),I=5,8)
38806 WRITE(MSTU(11),*) (XXc(I),I=9,12)
38807 WRITE(MSTU(11),*) (XXc(I),I=13,16)
38808 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
38809 WRITE(MSTU(11),*) S23MIN,S23MAX
38817 C*********************************************************************
38820 C...Calculates chi0_i -> chi0_j + gamma.
38822 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
38824 C...Double precision and integer declarations.
38825 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38826 IMPLICIT INTEGER(I-N)
38827 INTEGER PYK,PYCHGE,PYCOMP
38829 C...Local variables.
38830 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
38831 DOUBLE PRECISION F1,F2
38833 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
38834 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
38835 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
38836 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
38841 C*********************************************************************
38844 C...Calculates the decay rate for ino -> ino + gauge boson.
38846 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
38848 C...Double precision and integer declarations.
38849 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38850 IMPLICIT INTEGER(I-N)
38851 INTEGER PYK,PYCHGE,PYCOMP
38853 C...Local variables.
38854 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
38855 DOUBLE PRECISION XL,PYLAMF,C1
38856 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
38862 XL=PYLAMF(XMI2,XMJ2,XMV2)
38863 PYX2XG=C1/8D0/XMI3*SQRT(XL)
38864 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
38865 &12D0*GLR*XM1*XM2*XMV2)
38870 C*********************************************************************
38873 C...Calculates the decay rate for ino -> ino + H.
38875 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
38877 C...Double precision and integer declarations.
38878 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38879 IMPLICIT INTEGER(I-N)
38880 INTEGER PYK,PYCHGE,PYCOMP
38882 C...Local variables.
38883 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
38884 DOUBLE PRECISION XL,PYLAMF,C1
38885 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
38891 XL=PYLAMF(XMI2,XMJ2,XMV2)
38892 PYX2XH=C1/8D0/XMI3*SQRT(XL)
38893 &*(GX2*(XMI2+XMJ2-XMV2)+
38899 C*********************************************************************
38902 C...Calculates the non-standard decay modes of the Higgs boson.
38904 C...Author: Stephen Mrenna
38905 C...Last Update: April 2001
38906 C......Allow complex values for Z,U, and V
38908 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
38910 C...Double precision and integer declarations.
38911 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38912 IMPLICIT INTEGER(I-N)
38913 INTEGER PYK,PYCHGE,PYCOMP
38914 C...Parameter statement to help give large particle numbers.
38915 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38916 &KEXCIT=4000000,KDIMEN=5000000)
38918 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38919 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38920 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38921 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
38922 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
38923 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
38924 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
38926 C...Local variables.
38927 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
38928 COMPLEX*16 QIJ,RIJ,F21K,F12K
38930 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
38931 DOUBLE PRECISION XMI2,XMI3,XMJ2
38932 DOUBLE PRECISION PYLAMF,XL,CF,EI
38934 DOUBLE PRECISION TANW,XW,AEM,C1,AS
38935 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
38936 DOUBLE PRECISION XLAM(0:400)
38937 INTEGER IDLAM(400,3)
38938 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
38940 INTEGER KFNCHI(4),KFCCHI(2)
38941 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
38942 DOUBLE PRECISION SR2
38943 DOUBLE PRECISION BETA,ALFA
38944 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
38945 DOUBLE PRECISION PYALEM
38946 DOUBLE PRECISION AL,AR,ALR
38947 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
38948 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
38949 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
38950 DATA ITH/25,35,36,37/
38951 DATA ETAH/1D0,1D0,-1D0/
38952 DATA SR2/1.4142136D0/
38953 DATA KFNCHI/1000022,1000023,1000025,1000035/
38954 DATA KFCCHI/1000024,1000037/
38956 C...COUNT THE NUMBER OF DECAY MODES
38963 TANW = SQRT(XW/(1D0-XW))
38966 C...1 - 4 DEPENDING ON Higgs species.
38968 IF(KFIN.EQ.ITH(2)) IH=2
38969 IF(KFIN.EQ.ITH(3)) IH=3
38970 IF(KFIN.EQ.ITH(4)) IH=4
38993 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
38998 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
38999 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
39004 IF(IH.EQ.4) GOTO 220
39006 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
39007 C...H0_K -> CHI0_I + CHI0_J
39020 IF(AXMI.GE.AXMJ+AXMK) THEN
39022 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
39023 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
39024 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
39025 & ZMIXC(IJ,3)*ZMIXC(IK,1))
39026 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
39027 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
39028 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
39029 & ZMIXC(IJ,4)*ZMIXC(IK,1))
39030 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
39031 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
39032 C...SIGN OF MASSES I,J
39034 GX2=ABS(F12K)**2+ABS(F21K)**2
39035 GLR=DBLE(F12K*DCONJG(F21K))
39036 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
39037 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
39038 IDLAM(LKNT,1)=KFNCHI(IJ)
39039 IDLAM(LKNT,2)=KFNCHI(IK)
39045 C...H0_K -> CHI+_I CHI-_J
39052 IF(AXMI.GE.AXMJ+AXMK) THEN
39054 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
39055 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
39056 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
39057 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
39058 GX2=ABS(OLPP)**2+ABS(ORPP)**2
39059 GLR=DBLE(OLPP*DCONJG(ORPP))
39061 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
39062 IDLAM(LKNT,1)=KFCCHI(IJ)
39063 IDLAM(LKNT,2)=-KFCCHI(IK)
39069 C...HIGGS TO SFERMION SFERMION
39071 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
39073 XMJL=PMAS(PYCOMP(IJ),1)
39074 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
39075 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
39078 XL=PYLAMF(XMI2,XMJ2,XMJ2)
39085 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
39086 & XMF**2/XMW*SINA/CBETA
39087 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
39088 & XMF**2/XMW*SINA/CBETA
39090 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
39092 ELSEIF(IFL.EQ.15) THEN
39093 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
39099 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
39100 & XMF**2/XMW*COSA/SBETA
39101 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
39102 & XMF**2/XMW*COSA/SBETA
39104 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
39111 ELSEIF(IH.EQ.2) THEN
39113 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
39114 & XMF**2/XMW*COSA/CBETA
39115 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
39116 & XMF**2/XMW*COSA/CBETA
39118 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
39120 ELSEIF(IFL.EQ.15) THEN
39121 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
39127 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
39128 & XMF**2/XMW*SINA/SBETA
39129 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
39130 & XMF**2/XMW*SINA/SBETA
39132 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
39139 ELSEIF(IH.EQ.3) THEN
39145 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
39146 ELSEIF(IFL.EQ.15) THEN
39147 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
39151 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
39155 IF(IH.EQ.3) GOTO 180
39159 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
39166 IF(AXMI.GE.2D0*XMJ) THEN
39168 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39170 & +2D0*GHLR*ALR)**2
39176 IF(AXMI.GE.2D0*XMJR) THEN
39180 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
39183 XL=PYLAMF(XMI2,XMJ2,XMJ2)
39184 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39186 & +2D0*GHLR*ALR)**2
39187 IDLAM(LKNT,1)=IJ+KSUSY1
39188 IDLAM(LKNT,2)=-(IJ+KSUSY1)
39193 IF(AXMI.GE.XMJL+XMJR) THEN
39195 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
39196 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
39197 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
39200 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
39201 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39202 & (GHLL*AL+GHRR*AR)**2
39204 IDLAM(LKNT,2)=-(IJ+KSUSY1)
39208 IDLAM(LKNT,2)=IJ+KSUSY1
39210 XLAM(LKNT)=XLAM(LKNT-1)
39220 C...H+ -> CHI+_I + CHI0_J
39228 IF(AXMI.GE.AXMJ+AXMK) THEN
39230 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
39231 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
39232 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
39233 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
39234 GX2=ABS(OLPP)**2+ABS(ORPP)**2
39235 GLR=DBLE(OLPP*DCONJG(ORPP))
39236 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
39237 IDLAM(LKNT,1)=KFNCHI(IJ)
39238 IDLAM(LKNT,2)=KFCCHI(IK)
39244 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
39245 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
39251 XM1=PMAS(PYCOMP(KSUSY1+6),1)
39252 XM2=PMAS(PYCOMP(KSUSY1+5),1)
39253 IF(XMI.GE.XM1+XM2) THEN
39254 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39256 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39257 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
39258 IDLAM(LKNT,1)=KSUSY1+6
39259 IDLAM(LKNT,2)=-(KSUSY1+5)
39264 XM1=PMAS(PYCOMP(KSUSY2+6),1)
39265 XM2=PMAS(PYCOMP(KSUSY1+5),1)
39266 IF(XMI.GE.XM1+XM2) THEN
39267 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39269 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39270 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
39271 IDLAM(LKNT,1)=KSUSY2+6
39272 IDLAM(LKNT,2)=-(KSUSY1+5)
39277 XM1=PMAS(PYCOMP(KSUSY1+6),1)
39278 XM2=PMAS(PYCOMP(KSUSY2+5),1)
39279 IF(XMI.GE.XM1+XM2) THEN
39280 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39282 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39283 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
39284 IDLAM(LKNT,1)=KSUSY1+6
39285 IDLAM(LKNT,2)=-(KSUSY2+5)
39290 XM1=PMAS(PYCOMP(KSUSY2+6),1)
39291 XM2=PMAS(PYCOMP(KSUSY2+5),1)
39292 IF(XMI.GE.XM1+XM2) THEN
39293 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39295 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39296 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
39297 IDLAM(LKNT,1)=KSUSY2+6
39298 IDLAM(LKNT,2)=-(KSUSY2+5)
39303 GL=-XMW/SR2*SIN(2D0*BETA)
39305 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
39306 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
39307 IF(XMI.GE.XM1+XM2) THEN
39308 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39310 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
39311 IDLAM(LKNT,1)=-(KSUSY1+IJ)
39312 IDLAM(LKNT,2)=KSUSY1+IJ+1
39320 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
39321 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
39322 IF(XMI.GE.XM1+XM2) THEN
39323 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39325 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
39326 IDLAM(LKNT,1)=-(KSUSY1+IJ)
39327 IDLAM(LKNT,2)=KSUSY1+IJ+1
39332 C...H+ -> TAU1 NUTAUL
39333 XM1=PMAS(PYCOMP(KSUSY1+15),1)
39334 XM2=PMAS(PYCOMP(KSUSY1+16),1)
39335 IF(XMI.GE.XM1+XM2) THEN
39336 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39338 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
39339 IDLAM(LKNT,1)=-(KSUSY1+15)
39340 IDLAM(LKNT,2)= KSUSY1+16
39344 C...H+ -> TAU2 NUTAUL
39345 XM1=PMAS(PYCOMP(KSUSY2+15),1)
39346 XM2=PMAS(PYCOMP(KSUSY1+16),1)
39347 IF(XMI.GE.XM1+XM2) THEN
39348 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39350 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
39351 IDLAM(LKNT,1)=-(KSUSY2+15)
39352 IDLAM(LKNT,2)= KSUSY1+16
39360 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
39361 XLAM(0)=XLAM(0)+XLAM(I)
39363 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
39368 C*********************************************************************
39371 C...Calculates the decay rate for a Higgs to an ino pair.
39373 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
39375 C...Double precision and integer declarations.
39376 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39377 IMPLICIT INTEGER(I-N)
39378 INTEGER PYK,PYCHGE,PYCOMP
39380 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39383 C...Local variables.
39384 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
39385 DOUBLE PRECISION XL,PYLAMF,C1
39386 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
39392 XL=PYLAMF(XMI2,XMJ2,XMK2)
39393 PYH2XX=C1/4D0/XMI3*SQRT(XL)
39394 &*(GX2*(XMI2-XMJ2-XMK2)-
39396 IF(PYH2XX.LT.0D0) THEN
39397 WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
39398 WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GX2,GLR,XM1,XM2,XM3
39405 C*********************************************************************
39408 C...Integration by adaptive Gaussian quadrature.
39409 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
39411 FUNCTION PYGAUS(F, A, B, EPS)
39413 C...Double precision and integer declarations.
39414 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39415 IMPLICIT INTEGER(I-N)
39416 INTEGER PYK,PYCHGE,PYCOMP
39418 C...Local declarations.
39420 DOUBLE PRECISION F,W(12), X(12)
39421 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
39422 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
39423 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
39424 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
39425 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
39426 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
39427 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
39428 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
39429 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
39430 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
39431 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
39432 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
39434 C...The Gaussian quadrature algorithm.
39436 IF(B .EQ. A) GOTO 140
39437 CONST = 5D-3 / ABS(B-A)
39448 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
39453 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
39456 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
39458 IF(BB .NE. B) GOTO 100
39461 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
39463 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
39472 C*********************************************************************
39475 C...Integration by adaptive Gaussian quadrature.
39476 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
39477 C...Carbon copy of PYGAUS, but avoids having to use it recursively.
39479 FUNCTION PYGAU2(F, A, B, EPS)
39481 C...Double precision and integer declarations.
39482 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39483 IMPLICIT INTEGER(I-N)
39484 INTEGER PYK,PYCHGE,PYCOMP
39486 C...Local declarations.
39488 DOUBLE PRECISION F,W(12), X(12)
39489 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
39490 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
39491 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
39492 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
39493 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
39494 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
39495 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
39496 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
39497 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
39498 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
39499 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
39500 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
39502 C...The Gaussian quadrature algorithm.
39504 IF(B .EQ. A) GOTO 140
39505 CONST = 5D-3 / ABS(B-A)
39516 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
39521 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
39524 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
39526 IF(BB .NE. B) GOTO 100
39529 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
39531 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
39540 C*********************************************************************
39543 C...Simpson formula for an integral.
39545 FUNCTION PYSIMP(Y,X0,X1,N)
39547 C...Double precision and integer declarations.
39548 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39549 IMPLICIT INTEGER(I-N)
39550 INTEGER PYK,PYCHGE,PYCOMP
39552 C...Local variables.
39553 DOUBLE PRECISION Y,X0,X1,H,S
39559 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
39566 C*********************************************************************
39569 C...The standard lambda function.
39571 FUNCTION PYLAMF(X,Y,Z)
39573 C...Double precision and integer declarations.
39574 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39575 IMPLICIT INTEGER(I-N)
39576 INTEGER PYK,PYCHGE,PYCOMP
39578 C...Local variables.
39579 DOUBLE PRECISION PYLAMF,X,Y,Z
39581 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
39582 IF(PYLAMF.LT.0D0) PYLAMF=0D0
39587 C*********************************************************************
39590 C...Generates 3-body decays of gauginos.
39592 SUBROUTINE PYTBDY(IDIN)
39594 C...Double precision and integer declarations.
39595 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39596 IMPLICIT INTEGER(I-N)
39597 INTEGER PYK,PYCHGE,PYCOMP
39598 C...Parameter statement to help give large particle numbers.
39599 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
39600 &KEXCIT=4000000,KDIMEN=5000000)
39602 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39603 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39604 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39605 C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
39606 C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39607 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
39608 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
39609 C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
39610 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
39612 C...Local variables.
39613 DOUBLE PRECISION XM(5)
39614 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
39615 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
39616 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
39617 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
39618 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
39619 DOUBLE PRECISION CPHI1,SPHI1
39620 DOUBLE PRECISION S23DEL,EPS
39621 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
39622 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
39623 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
39625 DATA INOID/22,23,25,35/
39636 S12MIN=(XM(1)+XM(2))**2
39637 S12MAX=(XM(5)-XM(3))**2
39638 YJACO1=S12MAX-S12MIN
39640 C...Initialize some parameters
39649 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
39650 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
39652 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
39653 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
39654 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
39655 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
39660 EI=KCHG(IABS(IA),1)/3D0
39661 T3I=SIGN(1D0,EI+1D-6)/2D0
39662 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
39664 ELSEIF(IZID1*IZID2.NE.0) THEN
39666 GMMZ=PMAS(23,1)*PMAS(23,2)
39668 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
39669 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
39671 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
39672 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
39674 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
39676 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
39678 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
39679 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
39680 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
39681 XM1M2=SMZ(IZID1)*SMZ(IZID2)
39682 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
39684 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
39686 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
39688 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
39690 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
39691 IF(IZID1.NE.0) THEN
39692 XM1M2=SMZ(IZID1)*SMW(IWID2)
39696 XM1M2=SMZ(IZID2)*SMW(IWID1)
39699 RT2I = 1D0/SQRT(2D0)
39701 GMMZ=PMAS(24,1)*PMAS(24,2)
39703 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
39704 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
39707 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
39709 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
39710 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
39711 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
39712 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
39714 T3J=SIGN(1D0,EJ+1D-6)/2D0
39715 QRLS=DCMPLX(0D0,0D0)
39721 XLR2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
39722 XLL2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
39723 IF(MOD(IA,2).EQ.0) THEN
39724 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
39725 & TANW+ZMIXC(IZID2,2)*T3I)
39726 QLRT=-DCONJG(UMIXC(IZID1,1))*(
39727 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
39729 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
39730 & TANW+ZMIXC(IZID2,2)*T3J)
39731 QLRT=-DCONJG(UMIXC(IZID1,1))*(
39732 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
39734 ELSEIF(IWID1*IWID2.NE.0) THEN
39737 XM1M2=SMW(IWID1)*SMW(IWID2)
39739 GMMZ=PMAS(23,1)*PMAS(23,2)
39741 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
39742 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
39743 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
39744 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
39746 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
39747 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
39748 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
39749 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
39750 QRLS=-DCMPLX(EI/XW1)*ORPP
39751 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
39752 QRRS=-DCMPLX(EI/XW1)*OLPP
39753 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
39754 IF(MOD(IA,2).EQ.0) THEN
39755 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
39756 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
39758 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
39759 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
39761 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
39768 IF(ISKIP.NE.0) THEN
39771 S12=S12MIN+YJACO1*(KT-1)/99
39772 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
39773 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
39774 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
39775 & -(2D0*XM(1)*XM(2))**2
39776 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
39777 & -(2D0*XM(3)*XM(5))**2
39780 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
39782 S23MIN=S23AVE-S23DEL
39783 S23MAX=S23AVE+S23DEL
39784 YJACO2=S23MAX-S23MIN
39787 S23=S23MIN+YJACO2*(KS-1)/99
39790 WU2 = (UH-ZM12)*(UH-ZM22)
39791 WT2 = (TH-ZM12)*(TH-ZM22)
39793 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
39794 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
39795 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
39796 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
39797 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
39798 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
39799 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
39800 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
39801 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
39802 IF(WT0.GT.WTMAX) WTMAX=WT0
39812 BX=S12MIN+0.5D0*YJACO1
39815 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
39823 C...SOLVE FOR F1 AND F2
39824 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
39825 &-(2D0*XM(1)*XM(2))**2
39826 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
39827 &-(2D0*XM(3)*XM(5))**2
39830 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
39832 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
39833 &-(2D0*XM(1)*XM(2))**2
39834 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
39835 &-(2D0*XM(3)*XM(5))**2
39838 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
39841 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
39842 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
39848 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
39849 & -(2D0*XM(1)*XM(2))**2
39850 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
39851 & -(2D0*XM(3)*XM(5))**2
39854 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
39861 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
39862 & -(2D0*XM(1)*XM(2))**2
39863 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
39864 & -(2D0*XM(3)*XM(5))**2
39867 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
39872 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
39882 180 S12=S12MIN+PYR(0)*YJACO1
39885 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
39886 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
39887 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
39888 &-(2D0*XM(1)*XM(2))**2
39889 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
39890 &-(2D0*XM(3)*XM(5))**2
39893 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
39895 S23MIN=S23AVE-S23DEL
39896 S23MAX=S23AVE+S23DEL
39897 YJACO2=S23MAX-S23MIN
39898 S23=S23MIN+PYR(0)*YJACO2
39900 C...CHECK THE SAMPLING
39901 IF(IKNT.GT.100) THEN
39902 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
39905 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
39907 IF(ISKIP.EQ.0) GOTO 190
39913 WU2 = (UH-ZM12)*(UH-ZM22)
39914 WT2 = (TH-ZM12)*(TH-ZM22)
39916 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
39917 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
39919 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
39920 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
39921 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
39922 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
39923 c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
39924 c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
39925 c &/DCMPLX(TH-XML2)
39926 c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
39927 c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
39928 c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
39929 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
39930 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
39931 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
39933 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
39934 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
39936 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
39937 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
39939 P1=SQRT(D1*D1-XM(1)**2)
39940 P2=SQRT(D2*D2-XM(2)**2)
39941 P3=SQRT(D3*D3-XM(3)**2)
39942 CTHE1=2D0*PYR(0)-1D0
39943 ANG1=2D0*PYR(0)*PARU(1)
39947 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
39949 P(N+1,1)=P1*STHE1*CPHI1
39950 P(N+1,2)=P1*STHE1*SPHI1
39955 ANG3=2D0*PYR(0)*PARU(1)
39958 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
39960 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
39962 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
39963 &+P3*STHE3*SPHI3*SPHI1
39964 &+P3*CTHE3*STHE1*CPHI1
39965 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
39966 &-P3*STHE3*SPHI3*CPHI1
39967 &+P3*CTHE3*STHE1*SPHI1
39968 P(N+3,3)=P3*STHE3*CPHI3*STHE1
39973 P(N+2,I)=-P(N+1,I)-P(N+3,I)
39980 C*********************************************************************
39983 C...Finds the s-hat dependent eigenvalues of the inverse propagator
39984 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
39985 C...phase space generation.
39987 SUBROUTINE PYTECM(S1,S2)
39989 C...Double precision and integer declarations.
39990 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39991 IMPLICIT INTEGER(I-N)
39992 INTEGER PYK,PYCHGE,PYCOMP
39993 C...Parameter statement to help give large particle numbers.
39994 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
39995 &KEXCIT=4000000,KDIMEN=5000000)
39997 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39998 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39999 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40000 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
40001 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
40003 C...Local variables.
40004 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12),
40005 &AT(4,4),WI(4),FV1(4),FV2(4),FV3(4),sh,aem,tanw,ct2w,qupd,alprht,
40006 &far,fao,fzr,fzo,shr,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5)
40009 SH=PMAS(PYCOMP(KTECHN+113),1)**2
40012 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
40013 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
40014 QUPD=2D0*RTCM(2)-1D0
40016 ALPRHT=2.91D0*(3D0/DBLE(ITCM(1)))
40017 FAR=SQRT(AEM/ALPRHT)
40023 AR(2,2) = SH-PMAS(23,1)**2
40024 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
40025 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
40045 CALL PYWIDT(23,SH,WDTP,WDTE)
40046 AT(2,2) = WDTP(0)*SHR
40047 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
40048 AT(3,3) = WDTP(0)*SHR
40049 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
40050 AT(4,4) = WDTP(0)*SHR
40052 CALL PYEICG(4,4,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
40054 WI(I)=SQRT(ABS(SH-WR(I)))
40057 R1=MIN(WR(1),WR(2),WR(3),WR(4))
40062 IF(ABS(WR(I)-R1).LT.1D-6) THEN
40066 IF(WR(I).LE.R2) THEN
40076 C*********************************************************************
40079 C...Finds eigenvalues of a general complex matrix
40081 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
40082 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
40083 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
40084 C OF A COMPLEX GENERAL MATRIX.
40088 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
40089 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40090 C DIMENSION STATEMENT.
40092 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
40094 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
40095 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
40097 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
40098 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
40099 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
40103 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
40104 C RESPECTIVELY, OF THE EIGENVALUES.
40106 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
40107 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
40109 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
40110 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
40111 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
40113 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
40115 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40116 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40118 C THIS VERSION DATED AUGUST 1983.
40121 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
40123 INTEGER N,NM,IS1,IS2,IERR,MATZ
40124 DOUBLE PRECISION AR(4,4),AI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
40125 X FV1(4),FV2(4),FV3(4)
40126 IF (N .LE. NM) GOTO 100
40130 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
40131 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
40132 IF (MATZ .NE. 0) GOTO 110
40133 C .......... FIND EIGENVALUES ONLY ..........
40134 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
40136 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
40137 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
40138 IF (IERR .NE. 0) GOTO 120
40139 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
40143 C*********************************************************************
40146 C...Auxiliary to PYEICG.
40148 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
40149 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
40151 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
40152 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
40153 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
40155 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
40156 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
40160 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
40161 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40162 C DIMENSION STATEMENT.
40164 C N IS THE ORDER OF THE MATRIX.
40166 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
40167 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
40168 C SET LOW=1, IGH=N.
40170 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
40171 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
40172 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
40173 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
40174 C THE REDUCTION BY CORTH, IF PERFORMED.
40178 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
40179 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
40180 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
40181 C EIGENVECTORS IS TO BE PERFORMED.
40183 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
40184 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
40185 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
40186 C FOR INDICES IERR+1,...,N.
40189 C ZERO FOR NORMAL RETURN,
40190 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
40191 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
40193 C CALLS PYCDIV FOR COMPLEX DIVISION.
40194 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
40195 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
40197 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40198 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40200 C THIS VERSION DATED AUGUST 1983.
40203 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
40205 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
40206 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4)
40207 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
40211 IF (LOW .EQ. IGH) GOTO 130
40212 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
40217 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
40218 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
40219 YR = HR(I,I-1) / NORM
40220 YI = HI(I,I-1) / NORM
40225 SI = YR * HI(I,J) - YI * HR(I,J)
40226 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
40231 SI = YR * HI(J,I) + YI * HR(J,I)
40232 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
40237 C .......... STORE ROOTS ISOLATED BY CBAL ..........
40238 130 DO 140 I = 1, N
40239 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
40248 C .......... SEARCH FOR NEXT EIGENVALUE ..........
40249 150 IF (EN .LT. LOW) GOTO 320
40252 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
40253 C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
40254 160 DO 170 LL = LOW, EN
40256 IF (L .EQ. LOW) GOTO 180
40257 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
40258 X + DABS(HR(L,L)) + DABS(HI(L,L))
40259 TST2 = TST1 + DABS(HR(L,L-1))
40260 IF (TST2 .EQ. TST1) GOTO 180
40262 C .......... FORM SHIFT ..........
40263 180 IF (L .EQ. EN) GOTO 300
40264 IF (ITN .EQ. 0) GOTO 310
40265 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
40268 XR = HR(ENM1,EN) * HR(EN,ENM1)
40269 XI = HI(ENM1,EN) * HR(EN,ENM1)
40270 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
40271 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
40272 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
40273 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
40274 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
40277 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
40281 C .......... FORM EXCEPTIONAL SHIFT ..........
40282 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
40285 210 DO 220 I = LOW, EN
40286 HR(I,I) = HR(I,I) - SR
40287 HI(I,I) = HI(I,I) - SI
40294 C .......... REDUCE TO TRIANGLE (ROWS) ..........
40300 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
40301 XR = HR(I-1,I-1) / NORM
40303 XI = HI(I-1,I-1) / NORM
40306 HI(I-1,I-1) = 0.0D0
40307 HI(I,I-1) = SR / NORM
40314 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
40315 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
40316 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
40317 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
40323 IF (SI .EQ. 0.0D0) GOTO 250
40324 NORM = PYTHAG(HR(EN,EN),SI)
40325 SR = HR(EN,EN) / NORM
40329 C .......... INVERSE OPERATION (COLUMNS) ..........
40330 250 DO 280 J = LP1, EN
40339 IF (I .EQ. J) GOTO 260
40341 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
40342 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
40343 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
40344 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
40349 IF (SI .EQ. 0.0D0) GOTO 160
40354 HR(I,EN) = SR * YR - SI * YI
40355 HI(I,EN) = SR * YI + SI * YR
40359 C .......... A ROOT FOUND ..........
40360 300 WR(EN) = HR(EN,EN) + TR
40361 WI(EN) = HI(EN,EN) + TI
40364 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
40365 C CONVERGED AFTER 30*N ITERATIONS ..........
40370 C*********************************************************************
40373 C...Auxiliary to PYEICG.
40375 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
40376 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
40378 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
40379 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
40380 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
40382 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
40383 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
40384 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
40385 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
40386 C THIS GENERAL MATRIX TO HESSENBERG FORM.
40390 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
40391 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40392 C DIMENSION STATEMENT.
40394 C N IS THE ORDER OF THE MATRIX.
40396 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
40397 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
40398 C SET LOW=1, IGH=N.
40400 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
40401 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
40402 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
40403 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
40404 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
40406 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
40407 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
40408 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
40409 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
40410 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
40411 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
40416 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
40417 C HAVE BEEN DESTROYED.
40419 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
40420 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
40421 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
40422 C FOR INDICES IERR+1,...,N.
40424 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
40425 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
40426 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
40427 C THE EIGENVECTORS HAS BEEN FOUND.
40430 C ZERO FOR NORMAL RETURN,
40431 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
40432 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
40434 C CALLS PYCDIV FOR COMPLEX DIVISION.
40435 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
40436 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
40438 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40439 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40441 C THIS VERSION DATED OCTOBER 1989.
40443 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
40444 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
40447 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
40449 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
40450 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
40451 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
40453 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
40457 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
40466 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
40467 C FROM THE INFORMATION LEFT BY CORTH ..........
40468 IEND = IGH - LOW - 1
40469 IF (IEND.LT.0) GOTO 220
40470 IF (IEND.EQ.0) GOTO 170
40471 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
40472 DO 160 II = 1, IEND
40474 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
40475 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
40476 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
40477 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
40480 DO 120 K = IP1, IGH
40481 ORTR(K) = HR(K,I-1)
40482 ORTI(K) = HI(K,I-1)
40490 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
40491 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
40498 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
40499 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
40505 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
40510 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
40511 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
40512 YR = HR(I,I-1) / NORM
40513 YI = HI(I,I-1) / NORM
40518 SI = YR * HI(I,J) - YI * HR(I,J)
40519 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
40524 SI = YR * HI(J,I) + YI * HR(J,I)
40525 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
40529 DO 200 J = LOW, IGH
40530 SI = YR * ZI(J,I) + YI * ZR(J,I)
40531 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
40536 C .......... STORE ROOTS ISOLATED BY CBAL ..........
40537 220 DO 230 I = 1, N
40538 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
40547 C .......... SEARCH FOR NEXT EIGENVALUE ..........
40548 240 IF (EN .LT. LOW) GOTO 430
40551 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
40552 C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
40553 250 DO 260 LL = LOW, EN
40555 IF (L .EQ. LOW) GOTO 270
40556 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
40557 X + DABS(HR(L,L)) + DABS(HI(L,L))
40558 TST2 = TST1 + DABS(HR(L,L-1))
40559 IF (TST2 .EQ. TST1) GOTO 270
40561 C .......... FORM SHIFT ..........
40562 270 IF (L .EQ. EN) GOTO 420
40563 IF (ITN .EQ. 0) GOTO 550
40564 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
40567 XR = HR(ENM1,EN) * HR(EN,ENM1)
40568 XI = HI(ENM1,EN) * HR(EN,ENM1)
40569 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
40570 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
40571 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
40572 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
40573 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
40576 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
40580 C .......... FORM EXCEPTIONAL SHIFT ..........
40581 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
40584 300 DO 310 I = LOW, EN
40585 HR(I,I) = HR(I,I) - SR
40586 HI(I,I) = HI(I,I) - SI
40593 C .......... REDUCE TO TRIANGLE (ROWS) ..........
40599 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
40600 XR = HR(I-1,I-1) / NORM
40602 XI = HI(I-1,I-1) / NORM
40605 HI(I-1,I-1) = 0.0D0
40606 HI(I,I-1) = SR / NORM
40613 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
40614 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
40615 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
40616 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
40622 IF (SI .EQ. 0.0D0) GOTO 350
40623 NORM = PYTHAG(HR(EN,EN),SI)
40624 SR = HR(EN,EN) / NORM
40628 IF (EN .EQ. N) GOTO 350
40634 HR(EN,J) = SR * YR + SI * YI
40635 HI(EN,J) = SR * YI - SI * YR
40637 C .......... INVERSE OPERATION (COLUMNS) ..........
40638 350 DO 390 J = LP1, EN
40647 IF (I .EQ. J) GOTO 360
40649 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
40650 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
40651 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
40652 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
40655 DO 380 I = LOW, IGH
40660 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
40661 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
40662 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
40663 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
40668 IF (SI .EQ. 0.0D0) GOTO 250
40673 HR(I,EN) = SR * YR - SI * YI
40674 HI(I,EN) = SR * YI + SI * YR
40677 DO 410 I = LOW, IGH
40680 ZR(I,EN) = SR * YR - SI * YI
40681 ZI(I,EN) = SR * YI + SI * YR
40685 C .......... A ROOT FOUND ..........
40686 420 HR(EN,EN) = HR(EN,EN) + TR
40688 HI(EN,EN) = HI(EN,EN) + TI
40692 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
40693 C VECTORS OF UPPER TRIANGULAR FORM ..........
40699 TR = DABS(HR(I,J)) + DABS(HI(I,J))
40700 IF (TR .GT. NORM) NORM = TR
40703 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
40704 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
40712 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
40713 DO 490 II = 1, ENM1
40720 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
40721 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
40726 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
40729 460 YR = 0.01D0 * YR
40731 IF (TST2 .GT. TST1) GOTO 460
40733 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
40734 C .......... OVERFLOW CONTROL ..........
40735 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
40736 IF (TR .EQ. 0.0D0) GOTO 490
40738 TST2 = TST1 + 1.0D0/TST1
40739 IF (TST2 .GT. TST1) GOTO 490
40741 HR(J,EN) = HR(J,EN)/TR
40742 HI(J,EN) = HI(J,EN)/TR
40748 C .......... END BACKSUBSTITUTION ..........
40749 C .......... VECTORS OF ISOLATED ROOTS ..........
40751 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
40759 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
40760 C VECTORS OF ORIGINAL FULL MATRIX.
40761 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
40766 DO 540 I = LOW, IGH
40771 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
40772 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
40780 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
40781 C CONVERGED AFTER 30*N ITERATIONS ..........
40786 C*********************************************************************
40789 C...Auxiliary to PYCMQR
40791 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
40794 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
40796 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
40797 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
40799 S = DABS(BR) + DABS(BI)
40804 S = BRS**2 + BIS**2
40805 CR = (ARS*BRS + AIS*BIS)/S
40806 CI = (AIS*BRS - ARS*BIS)/S
40810 C*********************************************************************
40813 C...Auxiliary to PYCMQR
40815 C (YR,YI) = COMPLEX DSQRT(XR,XI)
40816 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
40819 SUBROUTINE PYCSRT(XR,XI,YR,YI)
40821 DOUBLE PRECISION XR,XI,YR,YI
40822 DOUBLE PRECISION S,TR,TI,PYTHAG
40826 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
40827 IF (TR .GE. 0.0D0) YR = S
40828 IF (TI .LT. 0.0D0) S = -S
40829 IF (TR .LE. 0.0D0) YI = S
40830 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
40831 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
40835 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
40836 DOUBLE PRECISION A,B
40838 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
40840 DOUBLE PRECISION P,R,S,T,U
40841 P = DMAX1(DABS(A),DABS(B))
40842 IF (P .EQ. 0.0D0) GOTO 110
40843 R = (DMIN1(DABS(A),DABS(B))/P)**2
40846 IF (T .EQ. 4.0D0) GOTO 110
40848 U = 1.0D0 + 2.0D0*S
40856 C*********************************************************************
40859 C...Auxiliary to PYEICG
40861 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
40862 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
40863 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
40864 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
40866 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
40867 C EIGENVALUES WHENEVER POSSIBLE.
40871 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
40872 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40873 C DIMENSION STATEMENT.
40875 C N IS THE ORDER OF THE MATRIX.
40877 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
40878 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
40882 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
40883 C RESPECTIVELY, OF THE BALANCED MATRIX.
40885 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
40886 C ARE EQUAL TO ZERO IF
40887 C (1) I IS GREATER THAN J AND
40888 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
40890 C SCALE CONTAINS INFORMATION DETERMINING THE
40891 C PERMUTATIONS AND SCALING FACTORS USED.
40893 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
40894 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
40895 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
40896 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
40897 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
40898 C = D(J,J) J = LOW,...,IGH
40899 C = P(J) J = IGH+1,...,N.
40900 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
40903 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
40905 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
40906 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
40907 C K,L HAVE BEEN REVERSED.)
40909 C ARITHMETIC IS REAL THROUGHOUT.
40911 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40912 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40914 C THIS VERSION DATED AUGUST 1983.
40917 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
40919 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
40920 DOUBLE PRECISION AR(4,4),AI(4,4),SCALE(4)
40921 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
40930 C .......... IN-LINE PROCEDURE FOR ROW AND
40931 C COLUMN EXCHANGE ..........
40933 IF (J .EQ. M) GOTO 130
40953 130 IF(IEXC.EQ.1) GOTO 140
40954 IF(IEXC.EQ.2) GOTO 180
40955 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
40956 C AND PUSH THEM DOWN ..........
40957 140 IF (L .EQ. 1) GOTO 320
40959 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
40960 150 DO 170 JJ = 1, L
40964 IF (I .EQ. J) GOTO 160
40965 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
40974 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
40975 C AND PUSH THEM LEFT ..........
40978 190 DO 210 J = K, L
40981 IF (I .EQ. J) GOTO 200
40982 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
40989 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
40991 220 SCALE(I) = 1.0D0
40992 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
40993 230 NOCONV = .FALSE.
41000 IF (J .EQ. I) GOTO 240
41001 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
41002 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
41004 C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
41005 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
41009 250 IF (C .GE. G) GOTO 260
41014 270 IF (C .LT. G) GOTO 280
41018 C .......... NOW BALANCE ..........
41019 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
41021 SCALE(I) = SCALE(I) * F
41025 AR(I,J) = AR(I,J) * G
41026 AI(I,J) = AI(I,J) * G
41030 AR(J,I) = AR(J,I) * F
41031 AI(J,I) = AI(J,I) * F
41036 IF (NOCONV) GOTO 230
41043 C*********************************************************************
41046 C...Auxiliary to PYEICG.
41048 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
41049 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
41050 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
41051 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
41053 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
41054 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
41055 C BALANCED MATRIX DETERMINED BY CBAL.
41059 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
41060 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
41061 C DIMENSION STATEMENT.
41063 C N IS THE ORDER OF THE MATRIX.
41065 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
41067 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
41068 C AND SCALING FACTORS USED BY CBAL.
41070 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
41072 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
41073 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
41074 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
41078 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
41079 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
41080 C IN THEIR FIRST M COLUMNS.
41082 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
41083 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
41085 C THIS VERSION DATED AUGUST 1983.
41088 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
41090 INTEGER I,J,K,M,N,II,NM,IGH,LOW
41091 DOUBLE PRECISION SCALE(4),ZR(4,4),ZI(4,4)
41094 IF (M .EQ. 0) GOTO 150
41095 IF (IGH .EQ. LOW) GOTO 120
41097 DO 110 I = LOW, IGH
41099 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
41100 C IF THE FOREGOING STATEMENT IS REPLACED BY
41101 C S=1.0D0/SCALE(I). ..........
41103 ZR(I,J) = ZR(I,J) * S
41104 ZI(I,J) = ZI(I,J) * S
41108 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
41109 C IGH+1 STEP 1 UNTIL N DO -- ..........
41110 120 DO 140 II = 1, N
41112 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
41113 IF (I .LT. LOW) I = LOW - II
41115 IF (K .EQ. I) GOTO 140
41131 C*********************************************************************
41134 C...Auxiliary to PYEICG.
41136 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
41137 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
41138 C BY MARTIN AND WILKINSON.
41139 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
41141 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
41142 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
41143 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
41144 C UNITARY SIMILARITY TRANSFORMATIONS.
41148 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
41149 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
41150 C DIMENSION STATEMENT.
41152 C N IS THE ORDER OF THE MATRIX.
41154 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
41155 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
41156 C SET LOW=1, IGH=N.
41158 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
41159 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
41163 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
41164 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
41165 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
41166 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
41167 C HESSENBERG MATRIX.
41169 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
41170 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
41172 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
41174 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
41175 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
41177 C THIS VERSION DATED AUGUST 1983.
41180 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
41182 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
41183 DOUBLE PRECISION AR(4,4),AI(4,4),ORTR(4),ORTI(4)
41184 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
41188 IF (LA .LT. KP1) GOTO 210
41195 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
41197 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
41199 IF (SCALE .EQ. 0.0D0) GOTO 200
41201 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
41204 ORTR(I) = AR(I,M-1) / SCALE
41205 ORTI(I) = AI(I,M-1) / SCALE
41206 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
41210 F = PYTHAG(ORTR(M),ORTI(M))
41211 IF (F .EQ. 0.0D0) GOTO 120
41214 ORTR(M) = (1.0D0 + G) * ORTR(M)
41215 ORTI(M) = (1.0D0 + G) * ORTI(M)
41220 C .......... FORM (I-(U*UT)/H) * A ..........
41221 130 DO 160 J = M, N
41224 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
41227 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
41228 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
41235 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
41236 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
41240 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
41244 C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
41247 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
41248 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
41255 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
41256 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
41261 ORTR(M) = SCALE * ORTR(M)
41262 ORTI(M) = SCALE * ORTI(M)
41263 AR(M,M-1) = -G * AR(M,M-1)
41264 AI(M,M-1) = -G * AI(M,M-1)
41270 C*********************************************************************
41273 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
41276 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
41278 INTEGER N,NP,INDX(N)
41280 COMPLEX*16 A(NP,NP)
41281 PARAMETER (TINY=1.0D-20)
41283 REAL*8 AAMAX,VV(6),DUM
41284 COMPLEX*16 SUM,DUMC
41290 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
41292 IF (AAMAX.EQ.0D0) PAUSE 'SINGULAR MATRIX IN PYLDCM'
41299 SUM=SUM-A(I,K)*A(K,J)
41307 SUM=SUM-A(I,K)*A(K,J)
41311 IF (DUM.GE.AAMAX) THEN
41326 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
41329 A(I,J)=A(I,J)/A(J,J)
41337 C*********************************************************************
41340 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
41343 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
41345 INTEGER N,NP,INDX(N)
41346 COMPLEX*16 A(NP,NP),B(N)
41357 SUM=SUM-A(I,J)*B(J)
41359 ELSE IF (ABS(SUM).NE.0D0) THEN
41367 SUM=SUM-A(I,J)*B(J)
41374 C***********************************************************************
41377 C...Calculates full and partial widths of resonances.
41378 C....copy of PYWIDT, used for techniparticle widths
41380 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
41382 C...Double precision and integer declarations.
41383 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41384 IMPLICIT INTEGER(I-N)
41385 INTEGER PYK,PYCHGE,PYCOMP
41386 C...Parameter statement to help give large particle numbers.
41387 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
41388 &KEXCIT=4000000,KDIMEN=5000000)
41390 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41391 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41392 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
41393 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
41394 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41395 COMMON/PYINT1/MINT(400),VINT(400)
41396 COMMON/PYINT4/MWID(500),WIDS(500,5)
41397 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41398 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
41399 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
41400 &/PYINT4/,/PYMSSM/,/PYTCSM/
41401 C...Local arrays and saved variables.
41402 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
41404 SAVE MOFSV,WIDWSV,WID2SV
41405 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
41407 C...Compressed code and sign; mass.
41414 C...Reset width information.
41422 C...Common electroweak and strong constants.
41425 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
41428 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
41430 RADC=1D0+AS/PARU(1)
41432 IF(KFLA.EQ.23) THEN
41435 XWC=1D0/(16D0*XW*XW1)
41436 FAC=(AEM*XWC/3D0)*SHR
41438 DO 130 I=1,MDCY(KC,3)
41440 IF(MDME(IDC,1).LT.0) GOTO 130
41441 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
41442 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
41443 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
41448 AF=SIGN(1D0,EF+0.1D0)
41451 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
41452 IF(I.EQ.6) WID2=WIDS(6,1)
41453 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
41454 ELSEIF(I.LE.16) THEN
41455 C...Z0 -> l+ + l-, nu + nubar
41457 AF=SIGN(1D0,EF+0.1D0)
41460 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
41462 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
41463 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
41465 WDTP(0)=WDTP(0)+WDTP(I)
41466 IF(MDME(IDC,1).GT.0) THEN
41467 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
41468 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
41469 & WDTE(I,MDME(IDC,1))
41470 WDTE(I,0)=WDTE(I,MDME(IDC,1))
41471 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
41476 ELSEIF(KFLA.EQ.24) THEN
41478 FAC=(AEM/(24D0*XW))*SHR
41479 DO 140 I=1,MDCY(KC,3)
41481 IF(MDME(IDC,1).LT.0) GOTO 140
41482 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
41483 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
41484 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
41487 C...W+/- -> q + qbar'
41488 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
41490 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
41491 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
41492 IF(I.GE.13) WID2=WID2*WIDS(7,3)
41494 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
41495 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
41496 IF(I.GE.13) WID2=WID2*WIDS(7,2)
41498 ELSEIF(I.LE.20) THEN
41499 C...W+/- -> l+/- + nu
41502 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
41504 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
41507 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
41508 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
41509 WDTP(0)=WDTP(0)+WDTP(I)
41510 IF(MDME(IDC,1).GT.0) THEN
41511 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
41512 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
41513 WDTE(I,0)=WDTE(I,MDME(IDC,1))
41514 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
41518 C.....V8 -> quark anti-quark
41519 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
41522 IF(ITCM(2).EQ.0) THEN
41524 ELSEIF(ITCM(2).EQ.1) THEN
41527 DO 150 I=1,MDCY(KC,3)
41529 IF(MDME(IDC,1).LT.0) GOTO 150
41530 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
41532 IF(RM1.GT.0.25D0) GOTO 150
41534 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
41539 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
41540 IF(I.EQ.6) WID2=WIDS(6,1)
41541 WDTP(0)=WDTP(0)+WDTP(I)
41542 IF(MDME(IDC,1).GT.0) THEN
41543 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
41544 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
41545 WDTE(I,0)=WDTE(I,MDME(IDC,1))
41546 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
41554 C*********************************************************************
41557 C...Calculates R-violating decays of sfermions.
41560 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
41562 C...Double precision and integer declarations.
41563 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41564 IMPLICIT INTEGER(I-N)
41565 C...Parameter statement to help give large particle numbers.
41566 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
41567 &KEXCIT=4000000,KDIMEN=5000000)
41569 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41570 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41571 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
41572 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
41573 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
41574 C...Local variables.
41575 DOUBLE PRECISION XLAM(0:400)
41576 INTEGER IDLAM(400,3), PYCOMP
41577 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
41579 C...IS R-VIOLATION ON ?
41580 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
41581 C...Mass eigenstate counter
41582 ICNT=INT(KFIN/KSUSY1)
41583 C...SM KF code of SUSY particle
41584 KFSM=KFIN-ICNT*KSUSY1
41585 C...Squared Sparticle Mass
41586 SM=PMAS(PYCOMP(KFIN),1)**2
41587 C... Squared mass of top quark
41588 SMT=PMAS(PYCOMP(6),1)**2
41589 C...IS L-VIOLATION ON ?
41590 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
41591 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
41592 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
41598 C...~e,~mu,~tau -> nu_I + lepton-_J
41600 IDLAM(LKNT,1)= 12 +2*(I-1)
41601 IDLAM(LKNT,2)= 11 +2*(J-1)
41604 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41605 IF (IMSS(51).NE.0) XLAM(LKNT) =
41606 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41607 C...KINEMATICS CHECK
41608 IF (XLAM(LKNT).EQ.0D0) THEN
41614 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
41620 IDLAM(LKNT,1)=-12 -2*(I-1)
41621 IDLAM(LKNT,2)= 11 +2*(K-1)
41624 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41625 IF (IMSS(51).NE.0) XLAM(LKNT) =
41626 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41627 C...KINEMATICS CHECK
41628 IF (XLAM(LKNT).EQ.0D0) THEN
41634 C...~e,~mu,~tau -> u_Jbar + d_K
41639 IDLAM(LKNT,1)=-2 -2*(J-1)
41640 IDLAM(LKNT,2)= 1 +2*(K-1)
41643 IF (IMSS(52).NE.0) THEN
41644 C...Use massive top quark
41645 IF (IDLAM(LKNT,1).EQ.-6) THEN
41646 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
41649 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
41650 C...If no top quark, all decay products massless
41652 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41654 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41656 C...KINEMATICS CHECK
41657 IF (XLAM(LKNT).EQ.0D0) THEN
41664 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
41665 C...No right-handed neutrinos
41667 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
41672 C...~nu_J -> lepton+_I + lepton-_K
41674 IDLAM(LKNT,1)=-11 -2*(I-1)
41675 IDLAM(LKNT,2)= 11 +2*(K-1)
41678 RM2=RVLAM(I,J,K)**2 * SM
41679 IF (IMSS(51).NE.0) XLAM(LKNT) =
41680 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41681 C...KINEMATICS CHECK
41682 IF (XLAM(LKNT).EQ.0D0) THEN
41688 C...~nu_I -> dbar_J + d_K
41693 IDLAM(LKNT,1)=-1 -2*(J-1)
41694 IDLAM(LKNT,2)= 1 +2*(K-1)
41697 RM2=3*RVLAMP(I,J,K)**2 * SM
41698 IF (IMSS(52).NE.0) XLAM(LKNT) =
41699 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41700 C...KINEMATICS CHECK
41701 IF (XLAM(LKNT).EQ.0D0) THEN
41708 C * SDOWN -> NU(BAR) + D and LEPTON- + U
41709 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
41713 C...~d_J -> nu_Ibar + d_K
41715 IDLAM(LKNT,1)=-12 -2*(I-1)
41716 IDLAM(LKNT,2)= 1 +2*(K-1)
41719 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41720 IF (IMSS(52).NE.0) XLAM(LKNT) =
41721 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41722 C...KINEMATICS CHECK
41723 IF (XLAM(LKNT).EQ.0D0) THEN
41731 C...~d_K -> nu_I + d_J
41733 IDLAM(LKNT,1)= 12 +2*(I-1)
41734 IDLAM(LKNT,2)= 1 +2*(J-1)
41737 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41738 IF (IMSS(52).NE.0) XLAM(LKNT) =
41739 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41740 C...KINEMATICS CHECK
41741 IF (XLAM(LKNT).EQ.0D0) THEN
41744 C...~d_K -> lepton_I- + u_J
41746 IDLAM(LKNT,1)= 11 +2*(I-1)
41747 IDLAM(LKNT,2)= 2 +2*(J-1)
41750 IF (IMSS(52).NE.0) THEN
41751 C...Use massive top quark
41752 IF (IDLAM(LKNT,2).EQ.6) THEN
41753 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
41755 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
41756 C...If no top quark, all decay products massless
41758 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41760 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41762 C...KINEMATICS CHECK
41763 IF (XLAM(LKNT).EQ.0D0) THEN
41770 C * SUP -> LEPTON+ + D
41771 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
41775 C...~u_J -> lepton_I+ + d_K
41777 IDLAM(LKNT,1)=-11 -2*(I-1)
41778 IDLAM(LKNT,2)= 1 +2*(K-1)
41781 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41782 IF (IMSS(52).NE.0) XLAM(LKNT) =
41783 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41784 C...KINEMATICS CHECK
41785 IF (XLAM(LKNT).EQ.0D0) THEN
41792 C...BARYON NUMBER VIOLATING DECAYS
41793 IF (IMSS(53).GE.1) THEN
41794 C * SUP -> DBAR + DBAR
41795 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
41799 C...~u_I -> dbar_J + dbar_K
41801 C...(anti-) symmetry J <-> K.
41803 IDLAM(LKNT,1) = -1 -2*(J-1)
41804 IDLAM(LKNT,2) = -1 -2*(K-1)
41807 RM2 = 2.*(RVLAMB(I,J,K)**2)
41808 & * SFMIX(KFSM,2*ICNT)**2 * SM
41810 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41811 C...KINEMATICS CHECK
41812 IF (XLAM(LKNT).EQ.0D0) THEN
41819 C * SDOWN -> UBAR + DBAR
41820 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
41824 C...LAMB coupling antisymmetric in J and K.
41826 C...~d_K -> ubar_I + dbar_K
41828 IDLAM(LKNT,1)= -2 -2*(I-1)
41829 IDLAM(LKNT,2)= -1 -2*(J-1)
41832 C...Use massive top quark
41833 IF (IDLAM(LKNT,1).EQ.-6) THEN
41834 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
41837 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
41838 C...If no top quark, all decay products massless
41840 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41842 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41844 C...KINEMATICS CHECK
41845 IF (XLAM(LKNT).EQ.0D0) THEN
41858 C*********************************************************************
41861 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
41864 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
41866 C...Double precision and integer declarations.
41867 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41868 IMPLICIT INTEGER(I-N)
41869 C...Parameter statement to help give large particle numbers.
41870 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
41871 &KEXCIT=4000000,KDIMEN=5000000)
41873 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41874 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41875 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41876 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
41877 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
41878 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
41879 C...Local variables.
41880 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
41882 DOUBLE PRECISION XLAM(0:400)
41883 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
41884 INTEGER IDLAM(400,3), PYCOMP
41886 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
41888 C...R-VIOLATING DECAYS
41889 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
41891 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
41892 C...WHICH NEUTRALINO ?
41894 IF (KFSM.EQ.23) NCHI=2
41895 IF (KFSM.EQ.25) NCHI=3
41896 IF (KFSM.EQ.35) NCHI=4
41897 C...SIGN OF MASS (Opposite convention as HERWIG)
41899 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
41901 C...Useful parameters for the calculation of the A and B constants.
41902 WMASS = PMAS(PYCOMP(24),1)
41903 ECHG = 2*SQRT(PARU(103)*PARU(1))
41904 COSB=1/(SQRT(1+RMSS(5)**2))
41905 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
41906 COSW=SQRT(1-PARU(102))
41907 SINW=SQRT(PARU(102))
41908 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
41909 C...Run quark masses to neutralino mass squared (for Higgs-type
41911 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
41913 RMQ(I)=PYMRUN(I,SQMCHI)
41915 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
41917 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
41918 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
41919 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
41920 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
41922 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
41923 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
41924 C2=ECHG*ZPMIX(NCHI,1)
41925 C3=GW*ZPMIX(NCHI,2)/COSW
41929 C x=1-2 : Select A or B constant (1:A ; 2:B)
41930 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
41931 C 11-16:e,nu_e,mu,...)
41932 C z=1-2 : Mass eigenstate number
41933 C...CALCULATE COUPLINGS
41935 CMS=PMAS(PYCOMP(I),1)
41936 C...Intermediate sleptons
41937 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
41938 & *(C2-C3*SINW**2))
41939 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
41940 & *(C2-C3*SINW**2))
41941 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
41943 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
41945 C...Inermediate sneutrinos
41947 AB(2,I+1,1)=5D-1*C3
41950 C...Inermediate sdown
41953 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
41954 & *ED*(C2-C3*SINW**2))
41955 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
41956 & *ED*(C2-C3*SINW**2))
41957 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
41958 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
41959 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
41960 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
41961 C...Inermediate sup
41964 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
41965 & *EU*(C2-C3*SINW**2))
41966 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
41967 & *EU*(C2-C3*SINW**2))
41968 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
41969 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
41970 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
41971 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
41974 IF (IMSS(51).GE.1) THEN
41975 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
41976 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
41977 C...STEP IN I,J,K USING SINGLE COUNTER
41979 C...LAMBDA COUPLING ASYM IN I,J
41980 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
41982 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
41983 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
41984 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
41986 C...Set coupling, and decay product masses on/off
41987 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
41988 & ,MOD(ISC,3)+1)**2
41990 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
41992 C...Resonance KF codes (1=I,2=J,3=K)
41993 KFR(1)=-IDLAM(LKNT,1)
41994 KFR(2)=-IDLAM(LKNT,2)
41995 KFR(3)=-IDLAM(LKNT,3)
41996 C...Calculate width.
41997 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
41998 & IDLAM(LKNT,3),XLAM(LKNT))
41999 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42000 C...Charge conjugate mode.
42002 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42003 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42004 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42005 XLAM(LKNT)=XLAM(LKNT-1)
42006 C...KINEMATICS CHECK
42007 IF (XLAM(LKNT).EQ.0D0) THEN
42014 IF (IMSS(52).GE.1) THEN
42015 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
42016 C * CHI0 -> NUBAR_I + DBAR_J + D_K
42019 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
42020 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42021 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42023 C...Set coupling, and decay product masses on/off
42024 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
42025 & ,MOD(ISC,3)+1)**2
42027 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
42029 C...Resonance KF codes (1=I,2=J,3=K)
42030 KFR(1)=-IDLAM(LKNT,1)
42031 KFR(2)=-IDLAM(LKNT,2)
42032 KFR(3)=-IDLAM(LKNT,3)
42033 C...Calculate width.
42034 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42036 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42037 C...Charge conjugate mode.
42039 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42040 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42041 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42042 XLAM(LKNT)=XLAM(LKNT-1)
42043 C...KINEMATICS CHECK
42044 IF (XLAM(LKNT).EQ.0D0) THEN
42048 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
42050 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42051 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
42052 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42054 C...Set coupling, and decay product masses on/off
42055 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
42056 & ,MOD(ISC,3)+1)**2
42058 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
42059 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
42060 C...Resonance KF codes (1=I,2=J,3=K)
42061 KFR(1)=-IDLAM(LKNT,1)
42062 KFR(2)=-IDLAM(LKNT,2)
42063 KFR(3)=-IDLAM(LKNT,3)
42064 C...Calculate width.
42065 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42067 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42068 C...Charge conjugate mode.
42070 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42071 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42072 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42073 XLAM(LKNT)=XLAM(LKNT-1)
42074 C...KINEMATICS CHECK
42075 IF (XLAM(LKNT).EQ.0D0) THEN
42081 IF (IMSS(53).GE.1) THEN
42082 C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
42083 C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
42085 C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
42086 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
42088 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
42089 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42090 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42092 C...Set coupling, and decay product masses on/off
42093 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
42094 & +1,MOD(ISC,3)+1)**2
42096 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
42097 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
42098 C...Resonance KF codes (1=I,2=J,3=K)
42099 KFR(1) = IDLAM(LKNT,1)
42100 KFR(2) = IDLAM(LKNT,2)
42101 KFR(3) = IDLAM(LKNT,3)
42102 C...Calculate width.
42103 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42104 & IDLAM(LKNT,3),XLAM(LKNT))
42105 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42106 C...Charge conjugate mode.
42108 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42109 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42110 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42111 XLAM(LKNT)=XLAM(LKNT-1)
42112 C...KINEMATICS CHECK
42113 IF (XLAM(LKNT).EQ.0D0) THEN
42125 C*********************************************************************
42128 C...Calculates R-violating chargino decay widths.
42131 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
42133 C...Double precision and integer declarations.
42134 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42135 IMPLICIT INTEGER(I-N)
42136 C...Parameter statement to help give large particle numbers.
42137 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42138 &KEXCIT=4000000,KDIMEN=5000000)
42140 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42141 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42142 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42143 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42144 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42145 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
42146 C...Local variables.
42147 DOUBLE PRECISION XLAM(0:400)
42148 INTEGER IDLAM(400,3), PYCOMP
42149 C...Information from main routine to PYRVGW
42150 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
42152 C...Auxiliary variables needed for BV (RV Gauge STOre)
42153 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
42155 C...Running quark masses
42156 DOUBLE PRECISION RMQ(6)
42157 C...Decay product masses on/off
42159 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
42163 C...IF R-VIOLATION ON.
42164 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
42166 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
42167 C...WHICH CHARGINO ?
42169 IF (KFSM.EQ.37) NCHI = 2
42171 C...Useful parameters for calculating the A and B constants.
42172 C...SIGN OF MASS (Opposite convention as HERWIG)
42174 IF (SMW(NCHI).LT.0D0) ISM = -1
42175 WMASS = PMAS(PYCOMP(24),1)
42176 COSB = 1/(SQRT(1+RMSS(5)**2))
42177 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
42178 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
42179 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
42180 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
42183 C...Running masses at Q^2=MCHI^2.
42184 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
42186 RMQ(I)=PYMRUN(I,SQMCHI)
42189 C... AB(x,y,z) coefficients:
42190 C x=1-2 : A or B coefficient (1:A ; 2:B)
42191 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
42192 C 11-16:e,nu_e,mu,...)
42193 C z=1-2 : Mass eigenstate number
42195 C...Intermediate sleptons
42198 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
42200 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
42202 C...Intermediate sneutrinos
42203 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
42205 AB(2,I+1,1) = ISM*C3
42207 C...Intermediate sdown
42209 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
42210 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
42211 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
42212 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
42213 C...Intermediate sup
42215 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
42216 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
42217 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
42218 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
42221 C...LLE TYPE R-VIOLATION
42222 IF (IMSS(51).GE.1) THEN
42223 C...LOOP OVER DECAY MODES
42226 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
42227 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
42229 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
42230 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
42231 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
42233 C...Set coupling, and decay product masses on/off
42234 RVLAMC = GW2 * 5D-1 *
42235 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
42238 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
42239 C...Resonance KF codes (1=I,2=J,3=K).
42242 KFR(3) = -IDLAM(LKNT,3)+1
42243 C...Calculate width.
42244 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42245 & IDLAM(LKNT,3),XLAM(LKNT))
42246 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42247 C...KINEMATICS CHECK
42248 IF (XLAM(LKNT).EQ.0D0) THEN
42252 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
42253 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
42255 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
42256 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
42257 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
42259 C...Set coupling, and decay product masses on/off
42260 RVLAMC = GW2 * 5D-1 *
42261 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42262 C...I,J SYMMETRY => FACTOR 2
42265 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
42266 C...Resonance KF codes (1=I,2=J,3=K)
42267 KFR(1)=IDLAM(LKNT,1)-1
42268 KFR(2)=IDLAM(LKNT,2)-1
42270 C...Calculate width.
42271 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42272 & IDLAM(LKNT,3),XLAM(LKNT))
42273 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42274 C...KINEMATICS CHECK
42275 IF (XLAM(LKNT).EQ.0D0) THEN
42280 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
42282 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42283 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
42284 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
42286 C...Set coupling, and decay product masses on/off
42287 RVLAMC = GW2 * 5D-1 *
42288 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42289 C...I,J SYMMETRY => FACTOR 2
42292 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
42293 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
42294 C...Resonance KF codes (1=I,2=J,3=K)
42295 KFR(1) =-IDLAM(LKNT,1)+1
42296 KFR(2) =-IDLAM(LKNT,2)+1
42298 C...Calculate width.
42299 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42300 & IDLAM(LKNT,3),XLAM(LKNT))
42301 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42302 C...KINEMATICS CHECK
42303 IF (XLAM(LKNT).EQ.0D0) THEN
42310 C...LQD TYPE R-VIOLATION
42311 IF (IMSS(52).GE.1) THEN
42312 C...LOOP OVER DECAY MODES
42315 C...CHI+ -> NUBAR_I + DBAR_J + U_K
42317 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
42318 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42319 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
42321 C...Set coupling, and decay product masses on/off
42322 RVLAMC = 3. * GW2 * 5D-1 *
42323 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42325 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
42327 C...Resonance KF codes (1=I,2=J,3=K)
42330 KFR(3)=-IDLAM(LKNT,3)+1
42331 C...Calculate width.
42332 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42334 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42335 C...KINEMATICS CHECK
42336 IF (XLAM(LKNT).EQ.0D0) THEN
42340 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
42342 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42343 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
42344 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
42346 C...Set coupling, and decay product masses on/off
42347 RVLAMC = 3. * GW2 * 5D-1 *
42348 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42350 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
42351 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
42352 C...Resonance KF codes (1=I,2=J,3=K)
42355 KFR(3)=-IDLAM(LKNT,3)+1
42356 C...Calculate width.
42357 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42359 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42360 C...KINEMATICS CHECK
42361 IF (XLAM(LKNT).EQ.0D0) THEN
42365 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
42367 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42368 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42369 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42371 C...Set coupling, and decay product masses on/off
42372 RVLAMC = 3. * GW2 * 5D-1 *
42373 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42375 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
42376 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
42377 C...Resonance KF codes (1=I,2=J,3=K)
42378 KFR(1)=-IDLAM(LKNT,1)+1
42379 KFR(2)=-IDLAM(LKNT,2)+1
42381 C...Calculate width.
42382 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42384 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42385 C...KINEMATICS CHECK
42386 IF (XLAM(LKNT).EQ.0D0) THEN
42390 C * CHI+ -> NU_I + U_J + DBAR_K.
42392 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
42393 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
42394 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42396 C...Set coupling, and decay product masses on/off
42398 RVLAMC = 3. * GW2 * 5D-1 *
42399 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42400 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
42402 C...Resonance KF codes (1=I,2=J,3=K)
42403 KFR(1)=IDLAM(LKNT,1)-1
42404 KFR(2)=IDLAM(LKNT,2)-1
42406 C...Calculate width.
42407 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42409 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42410 C...KINEMATICS CHECK
42411 IF (XLAM(LKNT).EQ.0D0) THEN
42418 C...UDD TYPE R-VIOLATION
42419 C...These decays need special treatment since more than one BV coupling
42420 C...contributes (with interference). Consider e.g. (symbolically)
42421 C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
42422 C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
42423 C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
42424 C...The problem is that a single call to PYRVGW would evaluate all
42425 C...these terms and sum them, but without the different couplings. The
42426 C...way out is to call PYRVGW three times, once for the first line, once
42427 C...for the second line, and then once for all the lines (it is
42428 C...impossible to get just the last line out) without multiplying by
42429 C...couplings. The last line is then obtained as the result of the third
42430 C...call minus the results of the two first calls. Each term is then
42431 C...multiplied by its respective coupling before the whole thing is
42432 C...summed up in XLAM.
42433 C...Note that with three interfering resonances, this procedure becomes
42434 C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
42436 IF (IMSS(53).GE.1) THEN
42437 C...LOOP OVER DECAY MODES
42440 C...CHI+ -> U_I + U_J + D_K
42441 C...Decay mode I<->J symmetric.
42442 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
42444 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
42445 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
42446 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42448 C...Set coupling, and decay product masses on/off
42449 RVLAMC= 6. * GW2 * 5D-1
42450 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
42452 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
42454 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
42457 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
42458 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
42459 C...Resonance KF codes (1=I,2=J,3=K)
42460 KFR(1) = -IDLAM(LKNT,1)+1
42463 C...Calculate width.
42464 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42465 & IDLAM(LKNT,3),XRESI)
42466 C...Resonance KF codes (1=I,2=J,3=K)
42468 KFR(2) = -IDLAM(LKNT,2)+1
42470 C...Calculate width.
42471 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42472 & IDLAM(LKNT,3),XRESJ)
42473 C...Resonance KF codes (1=I,2=J,3=K)
42474 KFR(1) = -IDLAM(LKNT,1)+1
42475 KFR(2) = -IDLAM(LKNT,2)+1
42477 C...Calculate width.
42478 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42479 & IDLAM(LKNT,3),XRESIJ)
42480 IF (ABS((XRESI+XRESJ)/XRESIJ-1.).GT.1D-4) THEN
42481 XRESIJ = XRESIJ-XRESI-XRESJ
42485 C...CALCULATE TOTAL WIDTH
42486 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
42487 & + RVLJIK*RVLIJK * XRESIJ
42488 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42489 C...KINEMATICS CHECK
42490 IF (XLAM(LKNT).EQ.0D0) THEN
42494 C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
42495 C...Symmetry I<->J<->K.
42496 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
42497 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
42499 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
42500 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42501 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42503 C...Set coupling, and decay product masses on/off
42504 RVLAMC = 6. * GW2 * 5D-1
42505 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
42507 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
42509 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
42512 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
42513 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
42514 C...Collect symmetry factors
42515 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
42516 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
42517 & RVLAMC = 5D-1 * RVLAMC
42518 C...Resonance KF codes (1=I,2=J,3=K)
42519 KFR(1) = IDLAM(LKNT,1)-1
42522 C...Calculate width.
42523 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42524 & IDLAM(LKNT,3),XRESI)
42525 C...Resonance KF codes (1=I,2=J,3=K)
42527 KFR(2) = IDLAM(LKNT,2)-1
42529 C...Calculate width.
42530 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42531 & IDLAM(LKNT,3),XRESJ)
42532 C...Resonance KF codes (1=I,2=J,3=K)
42535 KFR(3) = IDLAM(LKNT,3)-1
42536 C...Calculate width.
42537 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42538 & IDLAM(LKNT,3),XRESK)
42539 C...Resonance KF codes (1=I,2=J,3=K)
42540 KFR(1) = IDLAM(LKNT,1)-1
42541 KFR(2) = IDLAM(LKNT,2)-1
42543 C...Calculate width.
42544 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42545 & IDLAM(LKNT,3),XRESIJ)
42546 IF (ABS(XRESIJ/(XRESI+XRESJ)-1.).GT.1D-4) THEN
42547 XRESIJ = XRESI+XRESJ-XRESIJ
42551 C...Resonance KF codes (1=I,2=J,3=K)
42553 KFR(2) = IDLAM(LKNT,2)-1
42554 KFR(3) = IDLAM(LKNT,3)-1
42555 C...Calculate width.
42556 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42557 & IDLAM(LKNT,3),XRESJK)
42558 IF (ABS(XRESJK/(XRESJ+XRESK)-1.).GT.1D-4) THEN
42559 XRESJK = XRESJ+XRESK-XRESJK
42563 C...Resonance KF codes (1=I,2=J,3=K)
42564 KFR(1) = IDLAM(LKNT,1)-1
42566 KFR(3) = IDLAM(LKNT,3)-1
42567 C...Calculate width.
42568 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42569 & IDLAM(LKNT,3),XRESIK)
42570 IF (ABS(XRESIK/(XRESI+XRESK)-1.).GT.1D-4) THEN
42571 XRESIK = XRESI+XRESK-XRESIK
42575 C...CALCULATE TOTAL WIDTH
42577 & RVLIJK**2 * XRESI
42578 & + RVLJKI**2 * XRESJ
42579 & + RVLKIJ**2 * XRESK
42580 & + RVLIJK*RVLJKI * XRESIJ
42581 & + RVLIJK*RVLKIJ * XRESIK
42582 & + RVLJKI*RVLKIJ * XRESJK
42583 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
42584 C...KINEMATICS CHECK
42585 IF (XLAM(LKNT).EQ.0D0) THEN
42597 C*********************************************************************
42600 C...Calculates R-violating gluino decay widths.
42601 C...See BV part of PYRVCH for comments about the way the BV decay width
42602 C...is calculated. Same comments apply here.
42605 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
42607 C...Double precision and integer declarations.
42608 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42609 IMPLICIT INTEGER(I-N)
42610 C...Parameter statement to help give large particle numbers.
42611 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42612 &KEXCIT=4000000,KDIMEN=5000000)
42614 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42615 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42616 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42617 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42618 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42619 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
42620 C...Local variables.
42621 DOUBLE PRECISION XLAM(0:400)
42622 INTEGER IDLAM(400,3), PYCOMP
42623 C...Information from main routine to PYRVGW
42624 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
42626 C...Auxiliary variables needed for BV (RV Gauge STOre)
42627 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
42629 C...Running quark masses
42630 DOUBLE PRECISION RMQ(6)
42631 C...Decay product masses on/off
42633 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
42636 C...IF LQD OR UDD TYPE R-VIOLATION ON.
42637 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
42641 C x=1-2 : Select A or B coupling (1:A ; 2:B)
42642 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
42643 C 11-16:e,nu_e,mu,... not used here)
42644 C z=1-2 : Mass eigenstate number
42647 AB(1,I,1) = SFMIX(I,2)
42648 AB(1,I,2) = SFMIX(I,4)
42650 AB(2,I,1) = -SFMIX(I,1)
42651 AB(2,I,2) = -SFMIX(I,3)
42653 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
42655 IF (IMSS(52).GE.1) THEN
42656 C...STEP IN I,J,K USING SINGLE COUNTER
42658 C * GLUINO -> NUBAR_I + DBAR_J + D_K.
42660 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
42661 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42662 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42664 C...Set coupling, and decay product masses on/off
42665 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42668 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
42669 C...Resonance KF codes (1=I,2=J,3=K)
42671 KFR(2) = -IDLAM(LKNT,2)
42672 KFR(3) = -IDLAM(LKNT,3)
42673 C...Calculate width.
42674 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42677 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42678 C...Charge conjugate mode.
42680 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
42681 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
42682 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
42683 XLAM(LKNT) = XLAM(LKNT-1)
42684 C...KINEMATICS CHECK
42685 IF (XLAM(LKNT).EQ.0D0) THEN
42689 C * GLUINO -> LEPTON+_I + UBAR_J + D_K
42691 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42692 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
42693 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42695 C...Set coupling, and decay product masses on/off
42696 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
42697 & **2* 5D-1 * GSTR2
42699 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
42700 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
42701 C...Resonance KF codes (1=I,2=J,3=K)
42703 KFR(2) = -IDLAM(LKNT,2)
42704 KFR(3) = -IDLAM(LKNT,3)
42705 C...Calculate width.
42706 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42708 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42709 C...Charge conjugate mode.
42711 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
42712 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
42713 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
42714 XLAM(LKNT) = XLAM(LKNT-1)
42715 C...KINEMATICS CHECK
42716 IF (XLAM(LKNT).EQ.0D0) THEN
42724 IF (IMSS(53).GE.1) THEN
42725 C...STEP IN I,J,K USING SINGLE COUNTER
42727 C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
42728 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
42730 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
42731 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42732 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42734 C...Set coupling, and decay product masses on/off. A factor of 2 for
42735 C...(N_C-1) has been used to cancel a factor 0.5.
42736 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
42739 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
42740 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
42741 C...Resonance KF codes (1=I,2=J,3=K)
42742 KFR(1) = IDLAM(LKNT,1)
42745 C...Calculate width.
42746 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42748 C...Resonance KF codes (1=I,2=J,3=K)
42750 KFR(2) = IDLAM(LKNT,2)
42752 C...Calculate width.
42753 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42755 C...Resonance KF codes (1=I,2=J,3=K)
42758 KFR(3) = IDLAM(LKNT,3)
42759 C...Calculate width.
42760 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42762 C...Resonance KF codes (1=I,2=J,3=K)
42763 KFR(1) = IDLAM(LKNT,1)
42764 KFR(2) = IDLAM(LKNT,2)
42766 C...Calculate width.
42767 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42769 C...Calculate interference function. (Factor -1/2 to make up for factor
42771 IF (ABS((XRESI+XRESJ)/XRESIJ-1D0).GT.1D-4) THEN
42772 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
42776 C...Resonance KF codes (1=I,2=J,3=K)
42778 KFR(2) = IDLAM(LKNT,2)
42779 KFR(3) = IDLAM(LKNT,3)
42780 C...Calculate width.
42781 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42783 IF (ABS((XRESJ+XRESK)/XRESJK-1).GT.1D-4) THEN
42784 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
42788 C...Resonance KF codes (1=I,2=J,3=K)
42789 KFR(1) = IDLAM(LKNT,1)
42791 KFR(3) = IDLAM(LKNT,3)
42792 C...Calculate width.
42793 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42795 IF (ABS((XRESI+XRESK)/XRESIK-1).GT.1D-4) THEN
42796 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
42800 C...Calculate total width (factor 1/2 from 1/(N_C-1))
42801 XLAM(LKNT) = XRESI + XRESJ + XRESK
42802 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
42804 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42805 C...Charge conjugate mode.
42807 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
42808 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
42809 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
42810 XLAM(LKNT) = XLAM(LKNT-1)
42811 C...KINEMATICS CHECK
42812 IF (XLAM(LKNT).EQ.0D0) THEN
42822 C*********************************************************************
42825 C...Auxiliary function to PYRVSF for calculating R-Violating
42826 C...sfermion widths. Though the decay products are most often treated
42827 C...as massless in the calculation, the kinematical boundary of phase
42828 C...space is tested using the true masses.
42829 C...MODE = 1: All decay products massive
42830 C...MODE = 2: Decay product 1 massless
42831 C...MODE = 3: Decay product 2 massless
42832 C...MODE = 4: All decay products massless
42834 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
42836 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42837 IMPLICIT INTEGER (I-N)
42838 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42839 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42840 SAVE /PYDAT1/,/PYDAT2/
42841 DOUBLE PRECISION SM(3)
42842 INTEGER PYCOMP, KC(3)
42846 SM(1)=PMAS(KC(1),1)**2
42847 SM(2)=PMAS(KC(2),1)**2
42848 SM(3)=PMAS(KC(3),1)**2
42849 C...Kinematics check
42850 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
42854 C...CM momenta squared
42855 IF (MODE.EQ.1) THEN
42856 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
42857 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
42858 ELSE IF (MODE.EQ.2) THEN
42859 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
42860 ELSE IF (MODE.EQ.3) THEN
42861 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
42865 C...Calculate Width
42866 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
42870 C*********************************************************************
42873 C...Generalized Matrix Element for R-Violating 3-body widths.
42875 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
42877 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42878 IMPLICIT INTEGER (I-N)
42879 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42880 &KEXCIT=4000000,KDIMEN=5000000)
42881 PARAMETER (EPS=1D-4)
42882 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42883 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
42885 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42886 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42887 DOUBLE PRECISION XLIM(3,3)
42888 INTEGER KC(0:3), PYCOMP
42889 LOGICAL DCMASS, DCHECK(6)
42890 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
42894 KC(0) = PYCOMP(KFIN)
42895 KC(1) = PYCOMP(ID1)
42896 KC(2) = PYCOMP(ID2)
42897 KC(3) = PYCOMP(ID3)
42898 RMS(0) = PMAS(KC(0),1)
42899 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
42900 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
42901 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
42902 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
42903 XLIM(1,1)=(RMS(1)+RMS(2))**2
42904 XLIM(1,2)=(RMS(0)-RMS(3))**2
42905 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
42906 XLIM(2,1)=(RMS(2)+RMS(3))**2
42907 XLIM(2,2)=(RMS(0)-RMS(1))**2
42908 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
42909 XLIM(3,1)=(RMS(1)+RMS(3))**2
42910 XLIM(3,2)=(RMS(0)-RMS(2))**2
42911 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
42912 C...Check Phase Space
42913 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
42917 C...INITIALIZE RESONANCE INFORMATION
42920 IRES = 2*(JRES-1)+IMASS
42922 DCHECK(IRES) =.FALSE.
42923 C...NO RIGHT-HANDED NEUTRINOS
42924 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
42925 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
42926 & .KFR(JRES).EQ.0) GOTO 100
42927 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
42928 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
42929 INTRES(IRES,1) = IABS(KFR(JRES))
42930 INTRES(IRES,2) = IMASS
42931 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
42932 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
42936 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
42938 C...RESONANCE CONTRIBUTIONS
42939 C...(Only sum contributions where the resonance is off shell).
42940 C...Store whether diagram on/off in DCHECK.
42941 C...LOOP OVER MASS STATES
42944 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
42945 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
42946 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
42947 DCHECK(IDR) =.TRUE.
42948 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
42952 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
42953 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
42954 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
42955 DCHECK(IDR) =.TRUE.
42956 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
42960 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
42961 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
42962 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
42963 DCHECK(IDR) =.TRUE.
42964 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
42967 C... L-R INTERFERENCES
42968 C... (Only add contributions where both contributing diagrams
42969 C... are non-resonant).
42971 IF (DCHECK(1).AND.DCHECK(2)) THEN
42972 C...Bug corrected 11/12 2001. Skands.
42973 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
42974 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
42975 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
42979 IF (DCHECK(3).AND.DCHECK(4)) THEN
42980 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
42981 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
42982 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
42986 IF (DCHECK(5).AND.DCHECK(6)) THEN
42987 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
42988 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
42989 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
42991 C... TRUE INTERFERENCES
42992 C... (Only add contributions where both contributing diagrams
42993 C... are non-resonant).
42995 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
43000 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
43001 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
43002 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
43003 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
43008 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
43009 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
43010 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
43011 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
43016 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
43017 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
43018 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
43019 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
43027 C*********************************************************************
43030 C...Function to integrate resonance contributions
43032 FUNCTION PYRVI1(ID1,ID2,ID3)
43035 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
43036 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
43037 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
43038 LOGICAL MFLAG,DCMASS
43039 EXTERNAL PYRVG1,PYGAUS
43040 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
43042 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43043 SAVE/PYRVNV/,/PYRVPM/
43044 C...Initialize mass and width information
43050 RESM(1)= RES(IDR,1)
43051 RESW(1)= RES(IDR,2)
43052 C...A->B and B->A for antisparticles
43053 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43054 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43055 C...Integration boundaries and mass flag
43056 LO = (RM(1)+RM(2))**2
43057 HI = (RM(0)-RM(3))**2
43059 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
43063 C*********************************************************************
43066 C...Function to integrate L-R interference contributions
43068 FUNCTION PYRVI2(ID1,ID2,ID3)
43071 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
43072 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
43073 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
43074 LOGICAL MFLAG,DCMASS
43075 EXTERNAL PYRVG2,PYGAUS
43076 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
43078 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43079 SAVE/PYRVNV/,/PYRVPM/
43080 C...Initialize mass and width information
43086 RESM(1)= RES(IDR,1)
43087 RESW(1)= RES(IDR,2)
43088 RESM(2)= RES(IDR+1,1)
43089 RESW(2)= RES(IDR+1,2)
43090 C...A->B and B->A for antisparticles
43091 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43092 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43093 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
43094 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
43095 C...Boundaries and mass flag
43096 LO = (RM(1)+RM(2))**2
43097 HI = (RM(0)-RM(3))**2
43099 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
43103 C*********************************************************************
43106 C...Function to integrate true interference contributions
43108 FUNCTION PYRVI3(ID1,ID2,ID3)
43111 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
43112 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
43113 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
43114 LOGICAL MFLAG,DCMASS
43115 EXTERNAL PYRVG3,PYGAUS
43116 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
43118 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43119 SAVE/PYRVNV/,/PYRVPM/
43120 C...Initialize mass and width information
43126 RESM(1)= RES(IDR,1)
43127 RESW(1)= RES(IDR,2)
43128 RESM(2)= RES(IDR2,1)
43129 RESW(2)= RES(IDR2,2)
43130 C...A -> B and B -> A for antisparticles
43131 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43132 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43133 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
43134 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
43135 C...Boundaries and mass flag
43136 LO = (RM(1)+RM(2))**2
43137 HI = (RM(0)-RM(3))**2
43139 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
43143 C*********************************************************************
43146 C...Integrand for resonance contributions
43151 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43152 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
43153 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
43156 RVR = PYRVR(X,RESM(1),RESW(1))
43157 C1 = 2D0*SQRT(MAX(0D0,X))
43158 IF (.NOT.MFLAG) THEN
43160 E3 = (RM(0)**2-X)/C1
43162 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
43164 E2 = (X-RM(1)**2+RM(2)**2)/C1
43165 E3 = (RM(0)**2-X-RM(3)**2)/C1
43166 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
43167 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
43168 DELTAY = 4D0*SR1*SR2
43169 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
43170 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
43171 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
43176 C*********************************************************************
43179 C...Integrand for L-R interference contributions
43184 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43185 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
43186 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
43189 C1 = 2D0*SQRT(MAX(0D0,X))
43190 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
43191 IF (.NOT.MFLAG) THEN
43193 E3 = (RM(0)**2-X)/C1
43195 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
43197 E2 = (X-RM(1)**2+RM(2)**2)/C1
43198 E3 = (RM(0)**2-X-RM(3)**2)/C1
43199 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
43200 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
43201 DELTAY = 4D0*SR1*SR2
43202 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
43203 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
43204 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
43209 C*********************************************************************
43212 C...Function to do Y integration over true interference contributions
43217 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43218 C...Second Dalitz variable for PYRVG4
43220 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
43221 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
43222 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
43224 EXTERNAL PYGAU2,PYRVG4
43225 SAVE/PYRVPM/,/PYG2DX/
43227 C1=2D0*SQRT(MAX(1D-9,X))
43229 IF (.NOT.MFLAG) THEN
43231 E3 = (RM(0)**2-X)/C1
43235 E2 = (X-RM(1)**2+RM(2)**2)/C1
43236 E3 = (RM(0)**2-X-RM(3)**2)/C1
43238 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
43239 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
43240 YMIN = SQ1-(SR1+SR2)**2
43241 YMAX = SQ1-(SR1-SR2)**2
43243 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
43247 C*********************************************************************
43250 C...Integrand for true intereference contributions
43255 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43257 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
43259 SAVE /PYRVPM/,/PYG2DX/
43261 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
43262 IF (.NOT.MFLAG) THEN
43263 PYRVG4 = RVS*B(1)*B(2)*X*Y
43265 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
43266 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
43267 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
43268 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
43273 C*********************************************************************
43276 C...Breit-Wigner for resonance contributions
43278 FUNCTION PYRVR(Mab2,RM,RW)
43281 DOUBLE PRECISION Mab2,RM,RW,PYRVR
43282 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
43286 C*********************************************************************
43289 C...Interference function
43291 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
43294 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
43295 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
43300 C*********************************************************************
43303 C...Stores one parton/particle in commonblock PYJETS.
43305 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
43307 C...Double precision and integer declarations.
43308 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43309 IMPLICIT INTEGER(I-N)
43310 INTEGER PYK,PYCHGE,PYCOMP
43312 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43313 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43314 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43315 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43317 C...Standard checks.
43319 IF(MSTU(12).GE.1) CALL PYLIST(0)
43320 IPA=MAX(1,IABS(IP))
43321 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
43322 &'(PY1ENT:) writing outside PYJETS memory')
43324 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
43326 C...Find mass. Reset K, P and V vectors.
43328 IF(MSTU(10).EQ.1) PM=P(IPA,5)
43329 IF(MSTU(10).GE.2) PM=PYMASS(KF)
43336 C...Store parton/particle in K and P vectors.
43338 IF(IP.LT.0) K(IPA,1)=2
43341 P(IPA,4)=MAX(PE,PM)
43342 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
43343 P(IPA,1)=PA*SIN(THE)*COS(PHI)
43344 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
43345 P(IPA,3)=PA*COS(THE)
43347 C...Set N. Optionally fragment/decay.
43349 IF(IP.EQ.0) CALL PYEXEC
43354 C*********************************************************************
43357 C...Stores two partons/particles in their CM frame,
43358 C...with the first along the +z axis.
43360 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
43362 C...Double precision and integer declarations.
43363 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43364 IMPLICIT INTEGER(I-N)
43365 INTEGER PYK,PYCHGE,PYCOMP
43367 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43368 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43369 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43370 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43372 C...Standard checks.
43374 IF(MSTU(12).GE.1) CALL PYLIST(0)
43375 IPA=MAX(1,IABS(IP))
43376 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
43377 &'(PY2ENT:) writing outside PYJETS memory')
43380 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
43381 &'(PY2ENT:) unknown flavour code')
43383 C...Find masses. Reset K, P and V vectors.
43385 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
43386 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
43388 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
43389 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
43398 C...Check flavours.
43399 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
43400 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
43401 IF(MSTU(19).EQ.1) THEN
43404 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
43405 & '(PY2ENT:) unphysical flavour combination')
43410 C...Store partons/particles in K vectors for normal case.
43413 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
43416 C...Store partons in K vectors for parton shower evolution.
43420 K(IPA,4)=MSTU(5)*(IPA+1)
43422 K(IPA+1,4)=MSTU(5)*IPA
43423 K(IPA+1,5)=K(IPA+1,4)
43426 C...Check kinematics and store partons/particles in P vectors.
43427 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
43428 &'(PY2ENT:) energy smaller than sum of masses')
43429 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
43432 P(IPA,4)=SQRT(PM1**2+PA**2)
43435 P(IPA+1,4)=SQRT(PM2**2+PA**2)
43438 C...Set N. Optionally fragment/decay.
43440 IF(IP.EQ.0) CALL PYEXEC
43445 C*********************************************************************
43448 C...Stores three partons or particles in their CM frame,
43449 C...with the first along the +z axis and the third in the (x,z)
43450 C...plane with x > 0.
43452 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
43454 C...Double precision and integer declarations.
43455 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43456 IMPLICIT INTEGER(I-N)
43457 INTEGER PYK,PYCHGE,PYCOMP
43459 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43460 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43461 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43462 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43464 C...Standard checks.
43466 IF(MSTU(12).GE.1) CALL PYLIST(0)
43467 IPA=MAX(1,IABS(IP))
43468 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
43469 &'(PY3ENT:) writing outside PYJETS memory')
43473 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
43474 &'(PY3ENT:) unknown flavour code')
43476 C...Find masses. Reset K, P and V vectors.
43478 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
43479 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
43481 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
43482 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
43484 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
43485 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
43494 C...Check flavours.
43495 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
43496 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
43497 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
43498 IF(MSTU(19).EQ.1) THEN
43500 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
43501 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
43502 & KQ1+KQ3.EQ.4)) THEN
43504 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
43510 C...Store partons/particles in K vectors for normal case.
43513 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
43515 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
43518 C...Store partons in K vectors for parton shower evolution.
43524 IF(KQ1.EQ.-1) KCS=5
43525 K(IPA,KCS)=MSTU(5)*(IPA+1)
43526 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
43527 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
43528 K(IPA+1,9-KCS)=MSTU(5)*IPA
43529 K(IPA+2,KCS)=MSTU(5)*IPA
43530 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
43533 C...Check kinematics.
43535 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
43536 &0.5D0*X3*PECM.LE.PM3) MKERR=1
43537 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
43538 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
43539 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
43540 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
43541 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
43542 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
43543 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
43544 IF(MKERR.NE.0) CALL PYERRM(13,
43545 &'(PY3ENT:) unphysical kinematical variable setup')
43547 C...Store partons/particles in P vectors.
43549 P(IPA,4)=SQRT(PA1**2+PM1**2)
43551 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
43552 P(IPA+2,3)=PA3*CTHE3
43553 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
43555 P(IPA+1,1)=-P(IPA+2,1)
43556 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
43557 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
43560 C...Set N. Optionally fragment/decay.
43562 IF(IP.EQ.0) CALL PYEXEC
43567 C*********************************************************************
43570 C...Stores four partons or particles in their CM frame, with
43571 C...the first along the +z axis, the last in the xz plane with x > 0
43572 C...and the second having y < 0 and y > 0 with equal probability.
43574 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
43576 C...Double precision and integer declarations.
43577 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43578 IMPLICIT INTEGER(I-N)
43579 INTEGER PYK,PYCHGE,PYCOMP
43581 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43582 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43583 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43584 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43586 C...Standard checks.
43588 IF(MSTU(12).GE.1) CALL PYLIST(0)
43589 IPA=MAX(1,IABS(IP))
43590 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
43591 &'(PY4ENT:) writing outside PYJETS momory')
43596 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
43597 &'(PY4ENT:) unknown flavour code')
43599 C...Find masses. Reset K, P and V vectors.
43601 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
43602 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
43604 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
43605 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
43607 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
43608 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
43610 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
43611 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
43620 C...Check flavours.
43621 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
43622 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
43623 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
43624 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
43625 IF(MSTU(19).EQ.1) THEN
43627 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
43628 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
43629 & KQ1+KQ4.EQ.4)) THEN
43630 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
43633 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
43640 C...Store partons/particles in K vectors for normal case.
43643 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
43645 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
43648 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
43651 C...Store partons for parton shower evolution from q-g-g-qbar or
43653 ELSEIF(KQ1+KQ2.NE.0) THEN
43659 IF(KQ1.EQ.-1) KCS=5
43660 K(IPA,KCS)=MSTU(5)*(IPA+1)
43661 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
43662 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
43663 K(IPA+1,9-KCS)=MSTU(5)*IPA
43664 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
43665 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
43666 K(IPA+3,KCS)=MSTU(5)*IPA
43667 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
43669 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
43675 K(IPA,4)=MSTU(5)*(IPA+1)
43677 K(IPA+1,4)=MSTU(5)*IPA
43678 K(IPA+1,5)=K(IPA+1,4)
43679 K(IPA+2,4)=MSTU(5)*(IPA+3)
43680 K(IPA+2,5)=K(IPA+2,4)
43681 K(IPA+3,4)=MSTU(5)*(IPA+2)
43682 K(IPA+3,5)=K(IPA+3,4)
43685 C...Check kinematics.
43687 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
43688 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
43690 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
43691 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
43692 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
43693 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
43694 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
43695 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
43696 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
43697 STHE4=SQRT(1D0-CTHE4**2)
43698 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
43699 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
43700 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
43701 STHE2=SQRT(1D0-CTHE2**2)
43702 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
43703 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
43704 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
43705 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
43706 IF(MKERR.EQ.1) CALL PYERRM(13,
43707 &'(PY4ENT:) unphysical kinematical variable setup')
43709 C...Store partons/particles in P vectors.
43711 P(IPA,4)=SQRT(PA1**2+PM1**2)
43713 P(IPA+3,1)=PA4*STHE4
43714 P(IPA+3,3)=PA4*CTHE4
43715 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
43717 P(IPA+1,1)=PA2*STHE2*CPHI2
43718 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
43719 P(IPA+1,3)=PA2*CTHE2
43720 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
43722 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
43723 P(IPA+2,2)=-P(IPA+1,2)
43724 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
43725 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
43728 C...Set N. Optionally fragment/decay.
43730 IF(IP.EQ.0) CALL PYEXEC
43735 C*********************************************************************
43738 C...An interface from a two-fermion generator to include
43739 C...parton showers and hadronization.
43741 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
43743 C...Double precision and integer declarations.
43744 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43745 IMPLICIT INTEGER(I-N)
43746 INTEGER PYK,PYCHGE,PYCOMP
43748 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43749 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43750 SAVE /PYJETS/,/PYDAT1/
43752 DIMENSION IJOIN(2),INTAU(2)
43754 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
43760 C...Loop through entries and pick up all final fermions/antifermions.
43764 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
43766 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
43767 IF(K(I,2).GT.0) THEN
43771 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
43777 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
43783 C...Check that event is arranged according to conventions.
43784 IF(I1.EQ.0.OR.I2.EQ.0) THEN
43785 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
43788 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
43791 C...Check whether fermion pair is quarks or leptons.
43792 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
43794 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
43797 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
43800 C...Decide whether to allow or not photon radiation in showers.
43802 IF(IRAD.EQ.0) MSTJ(41)=1
43804 C...Do colour joining and parton showers.
43807 IF(IQL12.EQ.1) THEN
43810 CALL PYJOIN(2,IJOIN)
43812 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
43813 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
43814 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
43815 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
43818 C...Do fragmentation and decays. Possibly except tau decay.
43822 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
43836 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
43844 C*********************************************************************
43847 C...An interface from a four-fermion generator to include
43848 C...parton showers and hadronization.
43850 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
43852 C...Double precision and integer declarations.
43853 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43854 IMPLICIT INTEGER(I-N)
43855 INTEGER PYK,PYCHGE,PYCOMP
43857 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43858 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43859 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43860 COMMON/PYINT1/MINT(400),VINT(400)
43861 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
43863 DIMENSION IJOIN(2),INTAU(4)
43865 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
43871 C...Loop through entries and pick up all final fermions/antifermions.
43877 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
43879 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
43880 IF(K(I,2).GT.0) THEN
43883 ELSEIF(I3.EQ.0) THEN
43886 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
43891 ELSEIF(I4.EQ.0) THEN
43894 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
43900 C...Check that event is arranged according to conventions.
43901 IF(I3.EQ.0.OR.I4.EQ.0) THEN
43902 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
43904 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
43905 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
43908 C...Check which fermion pairs are quarks and which leptons.
43909 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
43911 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
43914 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
43916 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
43918 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
43921 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
43924 C...Decide whether to allow or not photon radiation in showers.
43926 IF(IRAD.EQ.0) MSTJ(41)=1
43928 C...Decide on dipole pairing.
43933 IF(IQL12.EQ.IQL34) THEN
43936 DELTA=ATOTSQ-A1SQ-A2SQ
43937 IF(ISTRAT.EQ.1) THEN
43938 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
43939 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
43940 ELSEIF(ISTRAT.EQ.2) THEN
43941 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
43942 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
43944 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
43950 C...If colour reconnection then bookkeep W+W- or Z0Z0
43951 C...and copy q qbar q qbar consecutively.
43952 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
43961 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
43965 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
43979 P(N+1,J)=P(IP1,J)+P(IP2,J)
43980 P(N+2,J)=P(IP3,J)+P(IP4,J)
43992 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
43994 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44000 C...Remove original q qbar q qbar and update counters.
44001 K(IP1,1)=K(IP1,1)+10
44002 K(IP2,1)=K(IP2,1)+10
44003 K(IP3,1)=K(IP3,1)+10
44004 K(IP4,1)=K(IP4,1)+10
44015 C...Do colour joinings and parton showers.
44016 IF(IQL12.EQ.1) THEN
44019 CALL PYJOIN(2,IJOIN)
44021 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
44022 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
44023 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
44024 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
44027 IF(IQL34.EQ.1) THEN
44030 CALL PYJOIN(2,IJOIN)
44032 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
44033 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
44034 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
44035 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
44038 C...Optionally do colour reconnection.
44041 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
44042 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
44046 C...Do fragmentation and decays. Possibly except tau decay.
44050 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
44064 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
44072 C*********************************************************************
44075 C...An interface from a six-fermion generator to include
44076 C...parton showers and hadronization.
44078 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
44080 C...Double precision and integer declarations.
44081 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44082 IMPLICIT INTEGER(I-N)
44083 INTEGER PYK,PYCHGE,PYCOMP
44085 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44086 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44087 SAVE /PYJETS/,/PYDAT1/
44089 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
44091 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
44097 C...Loop through entries and pick up all final fermions/antifermions.
44105 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
44107 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
44108 IF(K(I,2).GT.0) THEN
44111 ELSEIF(I3.EQ.0) THEN
44113 ELSEIF(I5.EQ.0) THEN
44116 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
44121 ELSEIF(I4.EQ.0) THEN
44123 ELSEIF(I6.EQ.0) THEN
44126 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
44132 C...Check that event is arranged according to conventions.
44133 IF(I5.EQ.0.OR.I6.EQ.0) THEN
44134 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
44136 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
44137 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
44140 C...Check which fermion pairs are quarks and which leptons.
44141 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
44143 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
44146 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
44148 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
44150 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
44153 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
44155 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
44157 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
44160 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
44163 C...Decide whether to allow or not photon radiation in showers.
44165 IF(IRAD.EQ.0) MSTJ(41)=1
44167 C...Allow dipole pairings only among leptons and quarks separately.
44170 IF(IQL34.EQ.IQL56) P13D=P13
44172 IF(IQL12.EQ.IQL34) P21D=P21
44174 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
44176 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
44178 IF(IQL12.EQ.IQL56) P32D=P32
44180 C...Decide whether t+tbar.
44182 IF(PYR(0).LT.PTOP) THEN
44185 C...If t+tbar: reconstruct t's.
44191 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
44192 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
44200 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
44202 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
44206 C...If t+tbar: colour join t's and let them shower.
44209 CALL PYJOIN(2,IJOIN)
44210 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
44211 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
44212 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
44214 C...If t+tbar: pick up the t's after shower.
44218 IF(K(I,2).EQ.6) ITNEW=I
44219 IF(K(I,2).EQ.-6) ITBNEW=I
44222 C...If t+tbar: loop over two top systems.
44237 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
44238 & '(PY6FRM:) not b in t decay')
44240 C...If t+tbar: find boost from original to new top frame.
44242 BETAO(J)=P(ITO,J)/P(ITO,4)
44243 BETAN(J)=P(ITN,J)/P(ITN,4)
44246 C...If t+tbar: boost copy of b by t shower and connect it in colour.
44256 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
44257 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
44258 K(IB,4)=MSTU(5)*ITN
44259 K(IB,5)=MSTU(5)*ITN
44260 K(ITN,4)=K(ITN,4)+IB
44261 K(ITN,5)=K(ITN,5)+IB
44262 K(ITN,1)=K(ITN,1)+10
44263 K(IBO,1)=K(IBO,1)+10
44265 C...If t+tbar: construct W recoiling against b.
44273 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
44274 IF(IABS(KCHW).EQ.3) THEN
44275 K(IW,2)=ISIGN(24,KCHW)
44277 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
44281 C...If t+tbar: construct W momentum, including boost by t shower.
44283 P(IW,J)=P(IW1,J)+P(IW2,J)
44285 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
44287 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
44288 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
44290 C...If t+tbar: boost b and W to top rest frame.
44292 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
44294 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44295 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44297 C...If t+tbar: let b shower and pick up modified W.
44298 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
44299 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
44300 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
44302 IF(IABS(K(I,2)).EQ.24) IWM=I
44305 C...If t+tbar: take copy of W decay products.
44314 K(IW1,1)=K(IW1,1)+10
44315 K(IW2,1)=K(IW2,1)+10
44316 K(IWM,1)=K(IWM,1)+10
44330 C...If t+tbar: boost W decay products, first by effects of t shower,
44331 C...then by those of b shower. b and its shower simple boost back.
44332 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
44333 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
44334 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44335 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
44336 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
44337 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
44338 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
44339 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
44340 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
44344 C...Decide on dipole pairing.
44348 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
44349 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
44353 ELSEIF(PRN.LT.P12D+P13D) THEN
44357 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
44361 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
44365 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
44375 C...Do colour joinings and parton showers
44376 C...(except ones already made for t+tbar).
44378 IF(IQL12.EQ.1) THEN
44381 CALL PYJOIN(2,IJOIN)
44383 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
44384 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
44385 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
44386 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
44389 IF(IQL34.EQ.1) THEN
44392 CALL PYJOIN(2,IJOIN)
44394 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
44395 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
44396 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
44397 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
44399 IF(IQL56.EQ.1) THEN
44402 CALL PYJOIN(2,IJOIN)
44404 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
44405 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
44406 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
44407 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
44410 C...Do fragmentation and decays. Possibly except tau decay.
44414 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
44428 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
44436 C*********************************************************************
44439 C...An interface from a four-parton generator to include
44440 C...parton showers and hadronization.
44442 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
44444 C...Double precision and integer declarations.
44445 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44446 IMPLICIT INTEGER(I-N)
44447 INTEGER PYK,PYCHGE,PYCOMP
44449 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44450 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44451 SAVE /PYJETS/,/PYDAT1/
44453 DIMENSION IJOIN(2),PTOT(4),BETA(3)
44455 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
44461 C...Loop through entries and pick up all final partons.
44467 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
44469 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
44470 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
44473 ELSEIF(I3.EQ.0) THEN
44476 CALL PYERRM(16,'(PY4JET:) more than two quarks')
44478 ELSEIF(K(I,2).LT.0) THEN
44481 ELSEIF(I4.EQ.0) THEN
44484 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
44489 ELSEIF(I4.EQ.0) THEN
44492 CALL PYERRM(16,'(PY4JET:) more than two gluons')
44498 C...Check that event is arranged according to conventions.
44499 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
44500 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
44502 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
44503 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
44506 C...Check whether second pair are quarks or gluons.
44507 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
44509 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
44512 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
44515 C...Boost partons to their cm frame.
44517 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
44519 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
44521 BETA(J)=PTOT(J)/PTOT(4)
44523 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44524 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44525 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44526 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44529 C...Decide and set up shower history for q qbar q' qbar' events.
44530 IF(IQG34.EQ.1) THEN
44531 W1=PY4JTW(0,I1,I3,I4)
44532 W2=PY4JTW(0,I2,I3,I4)
44533 IF(W1.GT.PYR(0)*(W1+W2)) THEN
44534 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
44536 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
44539 C...Decide and set up shower history for q qbar g g events.
44541 W1=PY4JTW(I1,I3,I2,I4)
44542 W2=PY4JTW(I1,I4,I2,I3)
44543 W3=PY4JTW(0,I3,I1,I4)
44544 W4=PY4JTW(0,I4,I1,I3)
44545 W5=PY4JTW(0,I3,I2,I4)
44546 W6=PY4JTW(0,I4,I2,I3)
44547 W7=PY4JTW(0,I1,I3,I4)
44548 W8=PY4JTW(0,I2,I3,I4)
44549 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
44551 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
44552 ELSEIF(W1+W2.GT.WR) THEN
44553 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
44554 ELSEIF(W1+W2+W3.GT.WR) THEN
44555 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
44556 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
44557 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
44558 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
44559 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
44560 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
44561 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
44562 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
44563 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
44565 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
44569 C...Boost back original partons and mark them as deleted.
44570 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
44571 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
44572 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
44573 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
44579 C...Rotate shower initiating partons to be along z axis.
44580 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
44581 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
44582 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
44583 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
44585 C...Set up copy of shower initiating partons as on mass shell.
44595 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
44606 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
44607 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
44609 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
44611 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
44614 C...Decide whether to allow or not photon radiation in showers.
44615 C...Connect up colours.
44617 IF(IRAD.EQ.0) MSTJ(41)=1
44620 CALL PYJOIN(2,IJOIN)
44622 C...Decide on maximum virtuality and do parton shower.
44623 IF(PMAX.LT.PARJ(82)) THEN
44628 CALL PYSHOW(NSAV+1,-8,PQMAX)
44630 C...Rotate and boost back system.
44631 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
44633 C...Do fragmentation and decays.
44636 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
44645 C*********************************************************************
44648 C...Auxiliary to PY4JET, to evaluate weight of configuration.
44650 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
44652 C...Double precision and integer declarations.
44653 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44654 IMPLICIT INTEGER(I-N)
44655 INTEGER PYK,PYCHGE,PYCOMP
44657 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44660 C...First case: when both original partons radiate.
44661 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
44664 P(N+1,J)=P(IA1,J)+P(IA2,J)
44665 P(N+2,J)=P(IA3,J)+P(IA4,J)
44667 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44669 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44671 Z1=P(IA1,4)/P(N+1,4)
44672 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
44673 Z2=P(IA3,4)/P(N+2,4)
44674 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
44676 C...Second case: when one original parton radiates to three.
44677 C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
44680 P(N+2,J)=P(IA3,J)+P(IA4,J)
44681 P(N+1,J)=P(N+2,J)+P(IA2,J)
44683 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44685 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44687 IF(K(IA2,2).EQ.21) THEN
44688 Z1=P(N+2,4)/P(N+1,4)
44689 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
44692 Z1=P(IA2,4)/P(N+1,4)
44693 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
44696 Z2=P(IA3,4)/P(N+2,4)
44697 IF(K(IA2,2).EQ.21) THEN
44698 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
44700 ELSEIF(K(IA3,2).EQ.21) THEN
44701 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
44703 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
44713 C*********************************************************************
44716 C...Auxiliary to PY4JET, to set up chosen configuration.
44718 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
44720 C...Double precision and integer declarations.
44721 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44722 IMPLICIT INTEGER(I-N)
44723 INTEGER PYK,PYCHGE,PYCOMP
44725 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44737 C...First case: when both original partons radiate.
44738 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
44741 C...Set up flavour and history pointers for new partons.
44759 C...Set up momenta for new partons.
44761 P(N+1,J)=P(IA1,J)+P(IA2,J)
44762 P(N+2,J)=P(IA3,J)+P(IA4,J)
44768 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44770 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44772 QMAX=MIN(P(N+1,5),P(N+2,5))
44774 C...Second case: q radiates twice.
44775 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
44776 C...IA5=N+2 does not radiate.
44777 ELSEIF(K(IA2,2).EQ.21) THEN
44779 C...Set up flavour and history pointers for new partons.
44797 C...Set up momenta for new partons.
44799 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
44801 P(N+3,J)=P(IA3,J)+P(IA4,J)
44806 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44808 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
44812 C...Third case: q radiates g, g branches.
44813 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
44814 C...IA5=N+2 does not radiate.
44817 C...Set up flavour and history pointers for new partons.
44835 C...Set up momenta for new partons.
44837 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
44840 P(N+4,J)=P(IA3,J)+P(IA4,J)
44844 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44846 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
44856 C*********************************************************************
44859 C...Connects a sequence of partons with colour flow indices,
44860 C...as required for subsequent shower evolution (or other operations).
44862 SUBROUTINE PYJOIN(NJOIN,IJOIN)
44864 C...Double precision and integer declarations.
44865 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44866 IMPLICIT INTEGER(I-N)
44867 INTEGER PYK,PYCHGE,PYCOMP
44869 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44870 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44871 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44872 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
44876 C...Check that partons are of right types to be connected.
44877 IF(NJOIN.LT.2) GOTO 120
44881 IF(I.LE.0.OR.I.GT.N) GOTO 120
44882 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
44884 IF(KC.EQ.0) GOTO 120
44885 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
44886 IF(KQ.EQ.0) GOTO 120
44887 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
44888 IF(KQ.NE.2) KQSUM=KQSUM+KQ
44889 IF(IJN.EQ.1) KQS=KQ
44891 IF(KQSUM.NE.0) GOTO 120
44893 C...Connect the partons sequentially (closing for gluon loop).
44895 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
44899 IF(IJN.NE.1) IP=IJOIN(IJN-1)
44900 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
44901 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
44902 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
44903 K(I,KCS)=MSTU(5)*IN
44904 K(I,9-KCS)=MSTU(5)*IP
44905 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
44906 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
44909 C...Error exit: no action taken.
44911 120 CALL PYERRM(12,
44912 &'(PYJOIN:) given entries can not be joined by one string')
44917 C*********************************************************************
44920 C...Sets values of commonblock variables.
44922 SUBROUTINE PYGIVE(CHIN)
44924 C...Double precision and integer declarations.
44925 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44926 IMPLICIT INTEGER(I-N)
44927 INTEGER PYK,PYCHGE,PYCOMP
44929 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44930 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44931 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44932 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44933 COMMON/PYDAT4/CHAF(500,2)
44935 COMMON/PYDATR/MRPY(6),RRPY(100)
44936 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
44937 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44938 COMMON/PYINT1/MINT(400),VINT(400)
44939 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
44940 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
44941 COMMON/PYINT4/MWID(500),WIDS(500,5)
44942 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
44943 COMMON/PYINT6/PROC(0:500)
44945 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
44946 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
44948 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44949 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44950 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
44951 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
44952 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
44953 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/
44954 C...Local arrays and character variables.
44955 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
44956 &CHNEW2*28,CHNAM*6,CHVAR(54)*6,CHALP(2)*26,CHIND*8,CHINI*10,
44958 DIMENSION MSVAR(54,8)
44960 C...For each variable to be translated give: name,
44961 C...integer/real/character, no. of indices, lower&upper index bounds.
44962 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
44963 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
44964 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
44965 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
44966 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
44967 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
44969 DATA ((MSVAR(I,J),J=1,8),I=1,54)/ 1,7*0, 1,2,1,4000,1,5,2*0,
44970 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
44971 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
44972 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
44973 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
44974 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
44975 &1,1,1,6,4*0, 2,1,1,100,4*0,
44976 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
44977 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
44978 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
44979 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
44980 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
44981 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
44982 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
44983 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
44984 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
44985 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
44986 &1,1,0,99,4*0, 2,1,0,99,4*0/
44987 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
44988 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
44990 C...Length of character variable. Subdivide it into instructions.
44991 IF(MSTU(12).GE.1) CALL PYLIST(0)
44995 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
44998 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
45000 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
45005 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
45007 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
45009 C...Peel off any text following exclamation mark.
45011 DO 140 LLOW2=LHIG2,1,-1
45012 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
45014 IF(LBIT.EQ.0) RETURN
45016 C...Identify commonblock variable.
45019 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
45020 &LNAM.LE.6) GOTO 150
45021 CHNAM=CHBIT(1:LNAM-1)//' '
45022 DO 170 LCOM=1,LNAM-1
45024 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
45025 & CHALP(2)(LALP:LALP)
45030 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
45033 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
45035 IF(LLOW.LT.LTOT) GOTO 120
45039 C...Identify any indices.
45044 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
45047 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
45049 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
45050 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
45051 & IVAR.EQ.37)) THEN
45052 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
45053 READ(CHIND,'(I8)') KF
45055 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
45057 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
45060 IF(LLOW.LT.LTOT) GOTO 120
45063 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
45064 READ(CHIND,'(I8)') I1
45067 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
45070 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
45073 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
45075 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
45076 READ(CHIND,'(I8)') I2
45078 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
45081 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
45084 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
45086 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
45087 READ(CHIND,'(I8)') I3
45092 C...Check that indices allowed.
45094 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
45095 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
45097 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
45099 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
45101 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
45103 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
45106 IF(LLOW.LT.LTOT) GOTO 120
45110 C...Save old value of variable.
45113 ELSEIF(IVAR.EQ.2) THEN
45115 ELSEIF(IVAR.EQ.3) THEN
45117 ELSEIF(IVAR.EQ.4) THEN
45119 ELSEIF(IVAR.EQ.5) THEN
45121 ELSEIF(IVAR.EQ.6) THEN
45123 ELSEIF(IVAR.EQ.7) THEN
45125 ELSEIF(IVAR.EQ.8) THEN
45127 ELSEIF(IVAR.EQ.9) THEN
45129 ELSEIF(IVAR.EQ.10) THEN
45131 ELSEIF(IVAR.EQ.11) THEN
45133 ELSEIF(IVAR.EQ.12) THEN
45135 ELSEIF(IVAR.EQ.13) THEN
45137 ELSEIF(IVAR.EQ.14) THEN
45139 ELSEIF(IVAR.EQ.15) THEN
45141 ELSEIF(IVAR.EQ.16) THEN
45143 ELSEIF(IVAR.EQ.17) THEN
45145 ELSEIF(IVAR.EQ.18) THEN
45147 ELSEIF(IVAR.EQ.19) THEN
45149 ELSEIF(IVAR.EQ.20) THEN
45151 ELSEIF(IVAR.EQ.21) THEN
45153 ELSEIF(IVAR.EQ.22) THEN
45155 ELSEIF(IVAR.EQ.23) THEN
45157 ELSEIF(IVAR.EQ.24) THEN
45159 ELSEIF(IVAR.EQ.25) THEN
45161 ELSEIF(IVAR.EQ.26) THEN
45163 ELSEIF(IVAR.EQ.27) THEN
45165 ELSEIF(IVAR.EQ.28) THEN
45167 ELSEIF(IVAR.EQ.29) THEN
45169 ELSEIF(IVAR.EQ.30) THEN
45171 ELSEIF(IVAR.EQ.31) THEN
45173 ELSEIF(IVAR.EQ.32) THEN
45175 ELSEIF(IVAR.EQ.33) THEN
45176 IOLD=ICOL(I1,I2,I3)
45177 ELSEIF(IVAR.EQ.34) THEN
45179 ELSEIF(IVAR.EQ.35) THEN
45181 ELSEIF(IVAR.EQ.36) THEN
45183 ELSEIF(IVAR.EQ.37) THEN
45185 ELSEIF(IVAR.EQ.38) THEN
45187 ELSEIF(IVAR.EQ.39) THEN
45189 ELSEIF(IVAR.EQ.40) THEN
45191 ELSEIF(IVAR.EQ.41) THEN
45193 ELSEIF(IVAR.EQ.42) THEN
45194 ROLD=SIGT(I1,I2,I3)
45195 ELSEIF(IVAR.EQ.43) THEN
45197 ELSEIF(IVAR.EQ.44) THEN
45199 ELSEIF(IVAR.EQ.45) THEN
45201 ELSEIF(IVAR.EQ.46) THEN
45203 ELSEIF(IVAR.EQ.47) THEN
45205 ELSEIF(IVAR.EQ.48) THEN
45207 ELSEIF(IVAR.EQ.49) THEN
45209 ELSEIF(IVAR.EQ.50) THEN
45210 ROLD=RVLAM(I1,I2,I3)
45211 ELSEIF(IVAR.EQ.51) THEN
45212 ROLD=RVLAMP(I1,I2,I3)
45213 ELSEIF(IVAR.EQ.52) THEN
45214 ROLD=RVLAMB(I1,I2,I3)
45215 ELSEIF(IVAR.EQ.53) THEN
45217 ELSEIF(IVAR.EQ.54) THEN
45221 C...Print current value of variable. Loop back.
45222 IF(LNAM.GE.LBIT) THEN
45224 CHBIT(15:60)=' has the value '
45225 IF(MSVAR(IVAR,1).EQ.1) THEN
45226 WRITE(CHBIT(51:60),'(I10)') IOLD
45227 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
45228 WRITE(CHBIT(47:60),'(F14.5)') ROLD
45229 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
45234 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45236 IF(LLOW.LT.LTOT) GOTO 120
45240 C...Read in new variable value.
45241 IF(MSVAR(IVAR,1).EQ.1) THEN
45243 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
45244 READ(CHINI,'(I10)') INEW
45245 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
45247 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
45249 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
45250 CHNEW=CHBIT(LNAM+1:LBIT)//' '
45252 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
45255 C...Store new variable value.
45258 ELSEIF(IVAR.EQ.2) THEN
45260 ELSEIF(IVAR.EQ.3) THEN
45262 ELSEIF(IVAR.EQ.4) THEN
45264 ELSEIF(IVAR.EQ.5) THEN
45266 ELSEIF(IVAR.EQ.6) THEN
45268 ELSEIF(IVAR.EQ.7) THEN
45270 ELSEIF(IVAR.EQ.8) THEN
45272 ELSEIF(IVAR.EQ.9) THEN
45274 ELSEIF(IVAR.EQ.10) THEN
45276 ELSEIF(IVAR.EQ.11) THEN
45278 ELSEIF(IVAR.EQ.12) THEN
45280 ELSEIF(IVAR.EQ.13) THEN
45282 ELSEIF(IVAR.EQ.14) THEN
45284 ELSEIF(IVAR.EQ.15) THEN
45286 ELSEIF(IVAR.EQ.16) THEN
45288 ELSEIF(IVAR.EQ.17) THEN
45290 ELSEIF(IVAR.EQ.18) THEN
45292 ELSEIF(IVAR.EQ.19) THEN
45294 ELSEIF(IVAR.EQ.20) THEN
45296 ELSEIF(IVAR.EQ.21) THEN
45298 ELSEIF(IVAR.EQ.22) THEN
45300 ELSEIF(IVAR.EQ.23) THEN
45302 ELSEIF(IVAR.EQ.24) THEN
45304 ELSEIF(IVAR.EQ.25) THEN
45306 ELSEIF(IVAR.EQ.26) THEN
45308 ELSEIF(IVAR.EQ.27) THEN
45310 ELSEIF(IVAR.EQ.28) THEN
45312 ELSEIF(IVAR.EQ.29) THEN
45314 ELSEIF(IVAR.EQ.30) THEN
45316 ELSEIF(IVAR.EQ.31) THEN
45318 ELSEIF(IVAR.EQ.32) THEN
45320 ELSEIF(IVAR.EQ.33) THEN
45321 ICOL(I1,I2,I3)=INEW
45322 ELSEIF(IVAR.EQ.34) THEN
45324 ELSEIF(IVAR.EQ.35) THEN
45326 ELSEIF(IVAR.EQ.36) THEN
45328 ELSEIF(IVAR.EQ.37) THEN
45330 ELSEIF(IVAR.EQ.38) THEN
45332 ELSEIF(IVAR.EQ.39) THEN
45334 ELSEIF(IVAR.EQ.40) THEN
45336 ELSEIF(IVAR.EQ.41) THEN
45338 ELSEIF(IVAR.EQ.42) THEN
45339 SIGT(I1,I2,I3)=RNEW
45340 ELSEIF(IVAR.EQ.43) THEN
45342 ELSEIF(IVAR.EQ.44) THEN
45344 ELSEIF(IVAR.EQ.45) THEN
45346 ELSEIF(IVAR.EQ.46) THEN
45348 ELSEIF(IVAR.EQ.47) THEN
45350 ELSEIF(IVAR.EQ.48) THEN
45352 ELSEIF(IVAR.EQ.49) THEN
45354 ELSEIF(IVAR.EQ.50) THEN
45355 RVLAM(I1,I2,I3)=RNEW
45356 ELSEIF(IVAR.EQ.51) THEN
45357 RVLAMP(I1,I2,I3)=RNEW
45358 ELSEIF(IVAR.EQ.52) THEN
45359 RVLAMB(I1,I2,I3)=RNEW
45360 ELSEIF(IVAR.EQ.53) THEN
45362 ELSEIF(IVAR.EQ.54) THEN
45366 C...Write old and new value. Loop back.
45368 CHBIT(15:60)=' changed from to '
45369 IF(MSVAR(IVAR,1).EQ.1) THEN
45370 WRITE(CHBIT(33:42),'(I10)') IOLD
45371 WRITE(CHBIT(51:60),'(I10)') INEW
45372 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45373 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
45374 WRITE(CHBIT(29:42),'(F14.5)') ROLD
45375 WRITE(CHBIT(47:60),'(F14.5)') RNEW
45376 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45377 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
45380 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45382 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
45383 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
45386 IF(LLOW.LT.LTOT) GOTO 120
45388 C...Format statement for output on unit MSTU(11) (by default 6).
45389 5000 FORMAT(5X,A60)
45390 5100 FORMAT(5X,A88)
45395 C*********************************************************************
45398 C...Administrates the fragmentation and decay chain.
45402 C...Double precision and integer declarations.
45403 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45404 IMPLICIT INTEGER(I-N)
45405 INTEGER PYK,PYCHGE,PYCOMP
45407 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45408 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45409 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45410 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45411 COMMON/PYINT4/MWID(500),WIDS(500,5)
45412 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
45414 DIMENSION PS(2,6),IJOIN(100)
45415 C...Initialize and reset.
45417 IF(MSTU(12).GE.1) CALL PYLIST(0)
45419 MSTU(31)=MSTU(31)+1
45423 IF(MSTU(17).LE.0) MSTU(90)=0
45426 C...Sum up momentum, energy and charge for starting entries.
45434 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
45436 PS(1,J)=PS(1,J)+P(I,J)
45438 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
45442 C...Start by all decays of coloured resonances involved in shower.
45445 IF(K(I,1).EQ.3) THEN
45447 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
45451 C...Prepare system for subsequent fragmentation/decay.
45454 C...Loop through jet fragmentation and particle decays.
45460 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
45463 C...Deal with any remaining undecayed resonance
45464 C...(normally the task of PYEVNT, so seldom used).
45465 ELSEIF(MWID(KC).NE.0) THEN
45467 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
45470 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
45471 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
45474 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
45475 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
45478 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
45487 C...Particle decay if unstable and allowed. Save long-lived particle
45488 C...decays until second pass after Bose-Einstein effects.
45489 ELSEIF(KCHG(KC,2).EQ.0) THEN
45490 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
45491 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
45494 C...Decay products may develop a shower.
45495 IF(MSTJ(92).GT.0) THEN
45497 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
45498 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
45499 CALL PYSHOW(IP1,IP1+1,QMAX)
45502 ELSEIF(MSTJ(92).LT.0) THEN
45504 CALL PYSHOW(IP1,-3,P(IP,5))
45509 C...Jet fragmentation: string or independent fragmentation.
45510 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
45512 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
45513 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
45514 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
45515 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
45516 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
45519 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
45520 IF(MFRAG.EQ.2) CALL PYINDF(IP)
45521 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
45522 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
45525 C...Loop back if enough space left in PYJETS and no error abort.
45526 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
45527 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
45529 ELSEIF(IP.LT.N) THEN
45530 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
45533 C...Include simple Bose-Einstein effect parametrization if desired.
45534 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
45539 C...Check that momentum, energy and charge were conserved.
45541 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
45543 PS(2,J)=PS(2,J)+P(I,J)
45545 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
45547 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
45548 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
45549 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
45550 &'(PYEXEC:) four-momentum was not conserved')
45551 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
45552 &'(PYEXEC:) charge was not conserved')
45557 C*********************************************************************
45560 C...Rearranges partons along strings.
45561 C...Special considerations for systems with junctions, with
45562 C...possibility of junction-antijunction annihilation.
45563 C...Allows small systems to collapse into one or two particles.
45564 C...Checks flavours and colour singlet invariant masses.
45566 SUBROUTINE PYPREP(IP)
45568 C...Double precision and integer declarations.
45569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45570 INTEGER PYK,PYCHGE,PYCOMP
45572 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45573 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45574 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45575 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45576 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
45578 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
45579 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
45580 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
45581 &IJCP(0:6),TJUOLD(5)
45583 C...Function to give four-product.
45584 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)
45586 C...Rearrange parton shower product listing along strings: begin loop.
45594 DO 160 I=MAX(1,IP),N
45596 C...Special treatment for junctions
45597 IF(K(I,1).EQ.42) THEN
45598 C...First, just store positions
45599 IF (MQGST.EQ.1) THEN
45603 C...Then look for junction-junction strings (not detected in the
45604 C...main search below).
45605 ELSE IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
45606 IF (NJJSTR.EQ.0) THEN
45607 NJJSTR = (3*NJUNC-NPIECE)/2
45609 C...Check how many already identified strings end on this junction
45612 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
45614 C...If only 2, third one must be to another junction
45616 C...The colour information in the junction is unreadable for the
45617 C...colour space search further down in this routine, so we must
45618 C...start on the colour mother of this junction and then "artificially"
45619 C...prevent the colour mother from connecting here again.
45620 IA=MOD(K(I,4),MSTU(5))
45622 IF (MOD(MOD(K(I,4)/MSTU(5),MSTU(5)),2).EQ.1) KCS=5
45623 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
45624 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
45628 ELSE IF (ILC.NE.3) THEN
45629 C...This could happen if 2 legs of a junction connect to other
45632 & '(PYPREP:) Too many junction-junction strings.')
45637 C...Look for coloured string endpoint, or (later) leftover gluon.
45638 IF(K(I,1).NE.3) GOTO 160
45640 IF(KC.EQ.0) GOTO 160
45642 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 160
45644 C...Pick up loose string end.
45646 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
45652 IF(NSTP.GT.4*N) THEN
45653 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
45657 C...Copy undecayed parton. Finished if reached string endpoint.
45658 IF(K(IA,1).EQ.3) THEN
45659 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
45660 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
45665 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
45675 IF(K(I1,1).EQ.1) GOTO 160
45678 C...Also finished (for now) if reached junction; then copy to end.
45679 IF(K(IA,1).EQ.42) THEN
45681 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
45682 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
45685 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
45686 DO 140 ICOPY=1,NCOPY
45688 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
45689 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
45690 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
45696 IPIECE(NPIECE,1)=MSTU32+1
45697 IPIECE(NPIECE,2)=MSTU32+NCOPY
45698 IPIECE(NPIECE,3)=IB
45699 IPIECE(NPIECE,4)=IA
45700 MSTU32=MSTU32+NCOPY
45705 C...GOTO next parton in colour space.
45707 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
45709 IA=MOD(K(IB,KCS),MSTU(5))
45710 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
45713 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
45714 & MSTU(5)).EQ.0) KCS=9-KCS
45715 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
45716 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
45719 IF(IA.LE.0.OR.IA.GT.N) THEN
45720 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
45723 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
45724 & MSTU(5)).EQ.IB) THEN
45725 IF(MREV.EQ.1) KCS=9-KCS
45726 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
45727 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
45729 IF(MREV.EQ.0) KCS=9-KCS
45730 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
45731 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
45733 IF(IA.NE.I) GOTO 110
45738 C...Junction systems remain.
45744 180 IJUCNT=IJUCNT+1
45745 IF (IJUCNT.LE.NJUNC) THEN
45746 C...If we are not processing a j-j string, treat this junction as new.
45747 IF (IJJSTR.EQ.0) THEN
45748 IJU=IJUNC(IJUCNT,0)
45750 C...If junction has already been read, ignore it.
45751 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 180
45752 C...If we are on a j-j string, goto second j-j junction.
45757 C...Mark selected junction read.
45759 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
45762 C...Determine junction type
45763 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
45764 C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
45765 C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
45766 C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
45767 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
45770 C...Find which quarks belong to given junction.
45771 IF(IHK.EQ.1) IEND=MOD(K(IJU,5),MSTU(5))
45772 IF(IHK.EQ.2) IEND=MOD(K(IJU,5)/MSTU(5),MSTU(5))
45773 C...IHK = 3 is special. Either normal string piece, or j-j string.
45775 IEND=MOD(K(IJU,4),MSTU(5))
45776 IF (MREV.NE.1) THEN
45777 DO 210 IPC=1,NPIECE
45778 C...If there is a j-j string starting on the present junction which has
45779 C...zero length, insert next junction immediately.
45780 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
45781 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
45787 C...If MREV is 1 and IHK is 3 we are finished with this system.
45794 C...If we've gotten this far, then either IHK < 3, or
45795 C...an interjunction string exists, or just a third normal string.
45796 IJUNC(IJUCNT,IHK)=0
45798 C..Order pieces belonging to this junction. Also look for j-j.
45799 DO 220 IPC=1,NPIECE
45800 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
45801 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
45802 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
45803 IJUNC(IJUCNT,IHK)=IPC
45808 C...Copy back chains in proper order. MREV=0/1 : descending/ascending
45809 IPC=IJUNC(IJUCNT,IHK)
45810 DO 240 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
45813 K(I1,J)=K(MSTU(4)-ICP,J)
45814 P(I1,J)=P(MSTU(4)-ICP,J)
45815 V(I1,J)=V(MSTU(4)-ICP,J)
45819 C...Mark last quark.
45820 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
45821 C...Do not insert junctions at wrong places.
45822 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 270
45823 C...Insert junction.
45826 C...Shift to end junction if a j-j string has been processed.
45827 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
45837 K(IJUS,1)=K(IJUS,1)+10
45840 270 IF (IHK.LT.3) GOTO 200
45842 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
45844 IF (IJUCNT.NE.NJUNC) GOTO 180
45848 C...Rearrange three strings from junction, e.g. in case one has been
45849 C...shortened by shower, so the last is the largest-energy one.
45850 IF(NJUNC.GE.1) THEN
45851 C...Find systems with exactly one junction.
45855 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
45856 ELSEIF(K(I,1).EQ.41) THEN
45858 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
45863 C...Sum up energy-momentum in each junction string.
45870 DO 300 I1=NBEG,NEND
45871 IF(K(I1,2).NE.21) THEN
45876 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
45879 C...Find which of them has highest energy (minus mass) in rest frame.
45881 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
45883 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
45886 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
45887 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
45889 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
45890 C...Decide how to rearrange so that new last has highest energy.
45891 IF(PJU(1,6).LT.PJU(2,6)) THEN
45893 IRNG(1,2)=IJUR(2)-1
45895 IRNG(2,2)=IJUR(3)+1
45896 IRNG(4,1)=IJUR(3)-1
45900 IRNG(1,2)=IJUR(3)+1
45902 IRNG(2,2)=IJUR(3)-1
45903 IRNG(4,1)=IJUR(2)-1
45908 C...Copy in correct order below bottom of current event record.
45911 DO 340 I1=IRNG(II,1),IRNG(II,2),
45912 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
45919 IF(K(I2,1).EQ.1) K(I2,1)=2
45923 C...Copy back up, overwriting but now in correct order.
45924 DO 370 I1=NBEG,NEND
45938 C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
45939 C...to two q-qbar systems.
45940 C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
45941 IF (MSTJ(19).NE.1) THEN
45945 C...Force collapse when MSTJ(19)=2.
45946 IF (MSTJ(19).EQ.2) THEN
45950 C...Find systems with exactly two junctions.
45952 C...Count junctions
45953 IF (K(I,1).EQ.41) THEN
45955 C...Check for interjunction gluons
45956 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
45959 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
45960 C...If end of system reached with either zero or one junction, restart
45961 C...with next system.
45965 ELSEIF(K(I,1).EQ.1) THEN
45966 C...If end of system reached with exactly two junctions, compute string
45967 C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
45968 C...length measure for the (q-qbar)(q-qbar) topology.
45970 C...Loop down through chain.
45972 DO 390 I1=NBEG,NEND
45973 C...Store string piece division locations in event record
45974 IF (K(I1,2).NE.21) THEN
45979 C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
45981 IF (PYR(0).LT.0.5D0) ISW=1
45982 C...Randomly choose which qqbar string gets the jj gluons.
45984 IF (PYR(0).GT.0.5D0) IGS=2
45985 C...Only compute string lengths when no topology forced.
45986 IF (MSTJ(19).EQ.0) THEN
45987 C...Repeat following for each junction
45989 C...Initialize iterative procedure for finding JRF
45995 C...Start iteration. Sum up momenta in string pieces
45997 C...JD=-1 for first junction, +1 for second junction.
45998 C...Find out where piece starts and ends and which direction to go.
46001 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
46002 IB = IJCP((IJU-1)*7 - JD*IJS)
46003 ELSEIF (IJS.EQ.3) THEN
46005 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
46006 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
46008 C...Initialize junction pull 4-vector.
46012 C...Initialize weight
46015 C...Sum up (weighted) momenta along each string piece
46016 DO 440 ISP=IA,IB,JD
46017 C...If present parton not last in chain
46018 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
46019 C...If last parton was a junction, store present weight
46020 IF (K(ISP-JD,2).EQ.88) THEN
46022 C...If last parton was a quark, reset to stored weight.
46023 ELSEIF (K(ISP-JD,2).NE.21) THEN
46027 C...Skip next parton if weight already large
46028 IF (PWT.GT.10D0) GOTO 440
46029 C...Compute momentum in TJUOLD frame:
46030 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
46032 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
46034 TMP=P(ISP,J)+TJUOLD(J)*BFC
46035 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
46038 TMP=TJUOLD(4)*P(ISP,4)+TDP
46039 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
46041 PWT=PWT+TMP/PARJ(48)
46042 C...Put |p| rather than m in 5th slot
46043 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
46050 C...Combine new boost (T) with old boost (TJUOLD)
46051 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
46053 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
46056 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
46058 C...If last boost small, accept JRF, else iterate.
46059 C...Also prevent possibility of infinite loop.
46060 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
46061 & IJRFIT.LT.MSTJ(18))THEN
46063 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
46064 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
46066 C...Store final boost, with change of sign since TJJ motion vector.
46068 TJJ(IJU,IX)=-TJUOLD(IX)
46070 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
46073 C...String length measure for (q-qbar)(q-qbar) topology.
46074 C...Note only momenta of nearest partons used (since rest of system
46076 IF (JJGLUE.EQ.0) THEN
46077 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
46078 & -1,IJCP(5-ISW)+1)
46080 C...Put jj gluons on selected string (IGS selected randomly above).
46082 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
46083 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
46085 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
46086 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
46090 C...String length measure for q-q-j-j-q-q topology.
46099 C...Note only momenta of nearest partons used (since rest of system
46102 IF (IX.EQ.4) ISGN=1
46103 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
46104 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
46105 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
46106 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
46107 IF (JJGLUE.EQ.0) THEN
46108 C...Junction motion vector dot product gives length when inter-junction
46110 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
46112 C...Junction motion vector dot products with gluon momenta give length
46113 C...when inter-junction gluons present.
46114 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
46115 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
46118 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
46119 IF (JJGLUE.EQ.0) THEN
46120 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
46122 DELMJJ=DELMJJ*4D0*T1G1*T2G2
46125 C...If delmjj > delmqq collapse string system to q-qbar q-qbar
46126 C...(Always the case for MSTJ(19)=2 due to initialization above)
46127 IF (DELMJJ.GT.DELMQQ) THEN
46128 C...Put new system at end of event record
46131 DO 510 ICOP=IJCP(IST),IJCP(IST+1)-1
46134 P(NCOP,IX)=P(ICOP,IX)
46135 K(NCOP,IX)=K(ICOP,IX)
46138 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
46139 C...Insert inter-junction gluon string piece (reversed)
46141 DO 530 ICOP=IJCP(4)-1,IJCP(3)+1,-1
46145 P(NCOP,IX)=P(ICOP,IX)
46146 K(NCOP,IX)=K(ICOP,IX)
46151 DO 550 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
46154 P(NCOP,IX)=P(ICOP,IX)
46155 K(NCOP,IX)=K(ICOP,IX)
46160 C...Copy system back in right order
46161 DO 580 ICOP=NBEG,NEND-2
46163 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
46164 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
46167 C...Shift down rest of event record
46168 DO 600 ICOP=NEND+1,N
46170 P(ICOP-2,IX)=P(ICOP,IX)
46171 K(ICOP-2,IX)=K(ICOP,IX)
46174 C...Update length of event record.
46184 C...Done if no checks on small-mass systems.
46185 IF(MSTJ(14).LT.0) RETURN
46186 IF(MSTJ(14).EQ.0) GOTO 1050
46188 C...Find lowest-mass colour singlet jet system.
46193 DO 680 I=MAX(1,IP),N
46194 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
46195 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
46202 DPS(5)=PYMASS(K(I,2))
46203 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
46205 DPS(J)=DPS(J)+P(I,J)
46208 DPS(5)=DPS(5)+PYMASS(K(I,2))
46209 ELSEIF(K(I,1).EQ.2) THEN
46211 DPS(J)=DPS(J)+P(I,J)
46213 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
46215 DPS(J)=DPS(J)+P(I,J)
46218 DPS(5)=DPS(5)+PYMASS(K(I,2))
46219 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
46221 IF(PD.LT.PDMIN) THEN
46235 C...Done if lowest-mass system above threshold for string frag.
46236 IF(PDMIN.GE.PARJ(32)) GOTO 1050
46238 C...Fill small-mass system as cluster.
46240 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
46250 C...Set up history, assuming cluster -> 2 hadrons.
46256 IF(MSTU(16).NE.2) THEN
46271 C...Find total flavour content - complicated by presence of junctions.
46275 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
46278 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
46282 C...If several diquarks, split up one to give even number of flavours.
46283 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
46285 IF(IABS(KFQ(3)).LT.1000) I1=1
46286 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
46287 KFQ(I1)=KFQ(I1)/1000
46292 C...If four quark ends, join two to diquark.
46293 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
46296 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
46297 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
46298 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
46299 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
46300 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
46301 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
46307 C...If two quark ends, plus quark or diquark, join quarks to diquark.
46311 IF(IABS(KFQ(I1)).GT.1000) I1=3
46312 IF(IABS(KFQ(I2)).GT.1000) I2=3
46313 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
46314 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
46315 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
46316 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
46322 C...Form two particles from flavours of lowest-mass system, if feasible.
46324 700 NTRY = NTRY + 1
46326 C...Open string with two specified endpoint flavours.
46330 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1050
46331 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
46332 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
46333 IF(KQ1+KQ2.NE.0) GOTO 1050
46334 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
46336 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
46338 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
46339 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
46340 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 710
46342 C...Open string with four specified flavours.
46343 ELSEIF(NQ.EQ.4) THEN
46348 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1050
46349 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
46350 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
46351 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
46352 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
46353 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1050
46354 C...Combine flavours pairwise to form two hadrons.
46357 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
46358 & IABS(KFQ(2)).GT.1000)) I2=3
46359 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
46360 & IABS(KFQ(3)).GT.1000))) I2=4
46364 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
46365 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
46366 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 720
46370 IF(IABS(K(IC2,2)).NE.21) GOTO 1050
46371 C...No room for popcorn mesons in closed string -> 2 hadrons.
46373 730 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
46374 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
46375 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
46376 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 730
46378 P(N+2,5)=PYMASS(K(N+2,2))
46379 P(N+3,5)=PYMASS(K(N+3,2))
46381 C...If it does not work: try again (a number of times), give up (if no
46382 C...place to shuffle momentum or too many flavours), or form one hadron.
46383 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
46384 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
46386 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
46393 C...Perform two-particle decay of jet system.
46394 C...First step: find reference axis in decaying system rest frame.
46395 C...(Borrow slot N+2 for temporary direction.)
46399 DO 760 I=IC1+1,IC2-1
46400 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
46401 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
46402 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
46404 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
46408 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
46410 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
46411 PHI1=PYANGL(P(N+2,1),P(N+2,2))
46413 C...Second step: generate isotropic/anisotropic decay.
46414 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
46415 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
46417 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
46418 PT2=(1D0-UE(3)**2)*PA**2
46419 IF(MSTJ(16).LE.0) THEN
46422 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 770
46423 PR1=P(N+2,5)**2+PT2
46424 PR2=P(N+3,5)**2+PT2
46425 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
46427 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
46428 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
46430 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
46432 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
46433 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
46438 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
46439 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
46441 C...Third step: move back to event frame and set production vertex.
46442 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
46452 C...Else form one particle, if possible.
46460 C...Select hadron flavour from available quark flavours.
46461 820 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
46463 ELSEIF(NQ.EQ.2) THEN
46464 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
46466 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
46467 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
46469 IF(K(N+2,2).EQ.0) GOTO 820
46470 P(N+2,5)=PYMASS(K(N+2,2))
46472 C...Use old algorithm for E/p conservation? (EN)
46473 IF (MSTJ(16).LE.0) GOTO 990
46475 C...Find the string piece closest to the cluster by a loop
46476 C...over the undecayed partons not in present cluster. (EN)
46481 DO 850 I1=MAX(1,IP),N-1
46482 IF(K(I,1).EQ.1) NJUNC=0
46483 IF(K(I,1).EQ.41) NJUNC=NJUNC+1
46484 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
46486 ELSEIF(K(I1,1).EQ.2) THEN
46490 IF(K(I2,1).EQ.41) GOTO 850
46491 IF(K(I2,1).GT.10) GOTO 830
46492 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 830
46493 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
46494 & NJUNC.EQ.0) GOTO 850
46495 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 850
46497 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
46499 E1(J)=P(I1,J)/P(I1,4)
46500 E2(J)=P(I2,J)/P(I2,4)
46501 ECL(J)=P(N+1,J)/P(N+1,4)
46506 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
46507 E3S=E3(1)**2+E3(2)**2+E3(3)**2
46508 E4S=E4(1)**2+E4(2)**2+E4(3)**2
46509 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
46510 IF(E34.LE.0D0) THEN
46512 ELSEIF(E34.LT.E3S) THEN
46513 DDMIN=E4S-E34**2/E3S
46515 DDMIN=E4S-2D0*E34+E3S
46518 C...Is this the smallest so far?
46519 IF(DDMIN.LT.DGLOMI) THEN
46524 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
46529 C... Check if there are any strings to connect to the new gluon. (EN)
46530 IF (IBEG.EQ.0) GOTO 990
46532 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
46533 IF (P(N+1,5).GE.P(N+2,5)) THEN
46535 C...Construct 'gluon' that is needed to put hadron on the mass shell.
46536 FRAC=P(N+2,5)/P(N+1,5)
46538 P(N+2,J)=FRAC*P(N+1,J)
46539 PG(J)=(1D0-FRAC)*P(N+1,J)
46542 C... Copy string with new gluon put in.
46546 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 870
46547 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 870
46568 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 870
46571 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
46572 C...from string piece endpoints.
46575 C...Begin by copying string that should give energy to cluster.
46579 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 900
46580 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 900
46592 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 900
46595 C...Set initial Phad.
46597 P(NSAV+2,J)=P(NSAV+1,J)
46600 C...Calculate Pg, a part of which will be added to Phad later. (EN)
46601 930 IF(MSTJ(16).EQ.1) THEN
46605 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
46606 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
46609 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
46611 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
46613 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
46614 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
46616 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
46617 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
46618 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
46620 C...If all gluon energy eaten, zero it and take a step back.
46622 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3) THEN
46625 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
46631 IF(K(I1,1).EQ.41) ITER=-1
46633 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N) THEN
46636 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
46642 IF(K(I2,1).EQ.41) ITER=-1
46644 IF(ITER.EQ.1) GOTO 930
46646 C...If also all endpoint energy eaten, revert to old procedure.
46647 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
46648 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
46659 C... Construct the collapsed hadron and modified string partons.
46661 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
46662 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
46663 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
46665 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
46666 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
46668 C...Finished with string collapse in new scheme.
46672 C... Use old algorithm; by choice or when in trouble.
46674 C...Find parton/particle which combines to largest extra mass.
46679 IF(IR.NE.0) GOTO 1010
46680 DO 1000 I=MAX(1,IP),N
46681 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
46682 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1000
46683 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
46684 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1000
46685 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1000
46686 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
46688 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
46689 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
46690 IF(HSR.GT.HSM) THEN
46698 C...Shuffle energy and momentum to put new particle on mass shell.
46703 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
46704 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
46705 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
46707 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
46708 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
46712 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
46716 C...Mark collapsed system and store daughter pointers. Iterate.
46717 1030 DO 1040 I=IC1,IC2
46718 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
46719 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
46721 IF(MSTU(16).NE.2) THEN
46726 K(I,5)=NSAV+1+NBODY
46729 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
46731 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 620
46733 C...Check flavours and invariant masses in parton systems.
46741 DO 1090 I=MAX(1,IP),N
46742 IF(K(I,1).EQ.41) NJU=NJU+1
46743 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1090
46745 IF(KC.EQ.0) GOTO 1090
46746 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
46747 IF(KQ.EQ.0) GOTO 1090
46753 DPS(5)=DPS(5)+PYMASS(K(I,2))
46756 DPS(J)=DPS(J)+P(I,J)
46758 IF(K(I,1).EQ.1) THEN
46760 IF(NJU.EQ.0.AND.NP.NE.1) THEN
46761 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
46762 ELSEIF(NJU.EQ.1) THEN
46763 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
46764 ELSEIF(NJU.EQ.2) THEN
46765 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
46766 ELSEIF(NJU.GE.3) THEN
46769 IF(NFERR.EQ.1) CALL
46770 & PYERRM(2,'(PYPREP:) unphysical flavour combination')
46771 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
46772 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
46773 & '(PYPREP:) too small mass in jet system')
46787 C*********************************************************************
46790 C...Handles the fragmentation of an arbitrary colour singlet
46791 C...jet system according to the Lund string fragmentation model.
46793 SUBROUTINE PYSTRF(IP)
46795 C...Double precision and integer declarations.
46796 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46797 IMPLICIT INTEGER(I-N)
46798 INTEGER PYK,PYCHGE,PYCOMP
46800 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
46801 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46802 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46803 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
46804 C...Local arrays. All MOPS variables ends with MO
46805 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
46806 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
46807 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
46808 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
46809 &PBST(3,5),TJUOLD(5)
46811 C...Function: four-product of two vectors.
46812 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)
46813 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
46816 C...Reset counters.
46831 C...Identify parton system.
46834 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
46835 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
46836 IF(MSTU(21).GE.1) RETURN
46838 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
46840 IF(KC.EQ.0) GOTO 110
46841 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
46842 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
46843 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
46844 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
46845 IF(MSTU(21).GE.1) RETURN
46848 C...Take copy of partons to be considered. Check flavour sum.
46853 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
46855 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
46857 IF(KQ.NE.2) KQSUM=KQSUM+KQ
46858 IF(K(I,1).EQ.41) THEN
46859 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
46867 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
46868 IF(MOD(KQSUM,3).NE.0) THEN
46869 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
46870 IF(MSTU(21).GE.1) RETURN
46872 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
46874 C...Boost copied system to CM frame (for better numerical precision).
46875 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
46878 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
46882 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
46884 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
46885 IF(P(I,3).GT.0D0) THEN
46886 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
46887 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
46888 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
46890 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
46891 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
46892 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
46897 C...Search for very nearby partons that may be recombined.
46905 140 IF(NR.GE.3) THEN
46908 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
46910 IF(I.EQ.N+NR) I1=N+1
46911 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
46912 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
46914 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
46916 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
46917 & P(I1,2)**2+P(I1,3)**2))
46918 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
46919 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
46920 IF(PDR.LT.PDRMIN) THEN
46926 C...Recombine very nearby partons to avoid machine precision problems.
46927 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
46929 P(N+1,J)=P(N+1,J)+P(N+NR,J)
46931 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
46935 ELSEIF(PDRMIN.LT.PARU12) THEN
46937 P(IR,J)=P(IR,J)+P(IR+1,J)
46939 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
46941 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
46942 DO 190 I=IR+1,N+NR-1
46949 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
46951 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
46952 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
46958 C...Reset particle counter. Skip ahead if no junctions are present;
46959 C...this is usually the case!
46960 NRS=MAX(5*NR+11,NP)
46963 IF(NTRY.GT.100.AND.NTRYR.LE.8) THEN
46967 ELSEIF(NTRY.GT.100) THEN
46968 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
46969 IF(MSTU(21).GE.1) RETURN
46973 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 640
46974 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
46975 & ' junction strings not handled by MSTJ(12)>3 options')
46978 IF(MJU(JT).EQ.0) GOTO 630
46982 C...Find and sum up momentum on three sides of junction.
46983 C...Begin with previous boost = zero.
46990 C...Beginning and end of string system in event record.
46991 I1BEG=N+1+(JT-1)*(NR-1)
46992 I1END=N+NR+(JT-1)*(1-NR)
46993 C...Look for junction string piece end points
46994 DO 230 I1=I1BEG,I1END,JS
46995 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
46996 C...Store junction string piece end points.
46997 C 1-junction systems 2-junction systems
46998 C IU : 1 2 3 4 1 2 3 4 5 6
46999 C IJU(IU): q-g-g-q-g-g-j-g-q q-g-g-q-g-j-g-g-j-g-q-g-g-q
47003 C...Sum over momenta, from junction outwards.
47007 C...Initialize junction drag and string piece 4-vectors.
47012 C...First two branches. Inwards out means opposite direction to JS.
47013 C...(JS is 1 for JT=1, -1 for JT=2)
47018 C...Last branch (gq or gjgqgq). Direction now reversed.
47024 DO 270 I1=I1A,I1B,IDIR
47025 C...Sum up momentum directions with exponential suppression
47026 C...for use in finding junction rest frame below.
47027 IF (K(I1,2).EQ.88) THEN
47028 C...gjgqgq type system encountered. Use current PWT as start
47029 C...for both strings.
47032 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
47033 C...Sum up string piece (boosted) 4-momenta.
47035 PJU(IU,J)=PJU(IU,J)+P(I1,J)
47037 C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
47038 C...boost is zero, see above). Skip parton if suppression factor large.
47039 IF (PWT.GT.10D0) GOTO 270
47040 C...Compute momentum in current frame:
47041 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
47042 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
47044 PTMP=P(I1,J)+TJUOLD(J)*BFC
47045 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
47048 PTMP=TJUOLD(4)*P(I1,4)+TDP
47049 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
47050 PWT=PWT+PTMP/PARJ(48)
47053 C...Put |p| rather than m in 5th slot.
47054 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
47055 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
47058 C...Calculate boost from present frame to next JRF candidate.
47060 CALL PYJURF(PBST,TJU)
47062 C...Combine new boost (TJU) with old boost (TJUOLD)
47063 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
47065 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
47067 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
47069 C...If last boost small, accept JRF, else iterate.
47070 C...Also prevent possibility of infinite loop.
47071 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
47072 & IJRFIT.LT.MSTJ(18)) THEN
47074 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
47075 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
47078 C...Now store total boost in TJU and change perception.
47079 C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
47080 C...TJU = junction motion vector in string CM, so the sign changes.
47084 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
47088 C...Calculate string piece energies in junction rest frame.
47090 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
47092 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
47093 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
47096 C...Start preparing for fragmentation of two strings from junction.
47099 320 NTRYER=NTRYER+1
47102 NS=IABS(IJU(IU+1)-IJU(IU))
47104 C...Junction strings: find longitudinal string directions.
47106 IS1=IJU(IU)+JS*(IS-1)
47109 DP(1,J)=0.5D0*P(IS1,J)
47110 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
47111 DP(2,J)=0.5D0*P(IS2,J)
47112 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
47113 & (PJU(IU,5)/PBST(IU,5))
47115 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
47116 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
47120 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
47121 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47122 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47127 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
47128 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
47129 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
47131 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
47133 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
47134 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
47138 C...Junction strings: initialize flavour, momentum and starting pos.
47142 IF(NTRY.GT.100.AND.NTRYR.LE.8) THEN
47146 ELSEIF(NTRY.GT.100) THEN
47147 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
47148 IF(MSTU(21).GE.1) RETURN
47153 IE(1)=K(N+1+(JT/2)*(NP-1),3)
47158 DO 370 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
47164 KFL(1)=K(IJU(IU),2)
47172 C...Junction strings: find initial transverse directions.
47175 DP(2,J)=P(IN(4)+1,J)
47179 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47180 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47181 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47182 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47183 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47184 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47185 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47186 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47187 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47189 DHCX1=DFOUR(3,1)/DHC12
47190 DHCX2=DFOUR(3,2)/DHC12
47191 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47192 DHCY1=DFOUR(4,1)/DHC12
47193 DHCY2=DFOUR(4,2)/DHC12
47194 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47195 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47197 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47199 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47203 C...Junction strings: produce new particle, origin.
47205 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
47206 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
47207 IF(MSTU(21).GE.1) RETURN
47215 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
47216 430 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
47217 IF(K(I,2).EQ.0) GOTO 360
47218 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
47219 & IABS(KFL(3)).GT.10) THEN
47220 IF(PYR(0).GT.PARJ(19)) GOTO 430
47222 P(I,5)=PYMASS(K(I,2))
47223 CALL PYPTDI(KFL(1),PX(3),PY(3))
47224 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
47225 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
47226 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
47227 & MSTU(90).LT.8) THEN
47228 MSTU(90)=MSTU(90)+1
47229 MSTU(90+MSTU(90))=I
47230 PARU(90+MSTU(90))=Z
47232 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
47237 C...Junction strings: stepping within 'low' string region.
47238 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
47239 & P(IN(1),5)**2.GE.PR(1)) THEN
47240 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
47241 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
47243 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
47246 C...Has used up energy of junction string, i.e. no more hadrons in it.
47247 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
47252 C...Stepping from 'low' string region
47253 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
47254 P(IN(2)+2,4)=P(IN(2)+2,3)
47257 IF(IN(2).GT.N+NR+4*NS) GOTO 360
47258 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47259 P(IN(1)+2,4)=P(IN(1)+2,3)
47265 C...Junction strings: find new transverse directions.
47266 470 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
47267 & IN(1).GT.IN(2)) GOTO 360
47268 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
47275 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47276 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47278 IF(DHC12.LE.1D-2) THEN
47279 P(IN(1)+2,4)=P(IN(1)+2,3)
47285 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47286 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47287 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47288 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47289 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47290 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47291 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47292 DHCX1=DFOUR(3,1)/DHC12
47293 DHCX2=DFOUR(3,2)/DHC12
47294 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47295 DHCY1=DFOUR(4,1)/DHC12
47296 DHCY2=DFOUR(4,2)/DHC12
47297 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47298 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47300 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47302 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47305 C...Express pT with respect to new axes, if sensible.
47306 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
47307 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
47308 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
47314 C...Junction strings: sum up known four-momentum, coefficients for m2.
47317 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
47318 & PY(3)*P(IN(3)+1,J)
47319 DO 500 IN1=IN(4),IN(1)-4,4
47320 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
47322 DO 510 IN2=IN(5),IN(2)-4,4
47323 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
47327 DHM(2)=2D0*FOUR(I,IN(1))
47328 DHM(3)=2D0*FOUR(I,IN(2))
47329 DHM(4)=2D0*FOUR(IN(1),IN(2))
47331 C...Junction strings: find coefficients for Gamma expression.
47332 DO 540 IN2=IN(1)+1,IN(2),4
47333 DO 530 IN1=IN(1),IN2-1,4
47334 DHC=2D0*FOUR(IN1,IN2)
47335 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
47336 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
47337 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
47338 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
47342 C...Junction strings: solve (m2, Gamma) equation system for energies.
47343 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
47344 IF(ABS(DHS1).LT.1D-4) GOTO 360
47345 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
47346 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
47347 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
47348 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
47349 & ABS(DHS1)-DHS2/DHS1)
47350 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
47351 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
47352 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
47354 C...Junction strings: step to new region if necessary.
47355 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
47356 P(IN(2)+2,4)=P(IN(2)+2,3)
47359 IF(IN(2).GT.N+NR+4*NS) GOTO 360
47360 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47361 P(IN(1)+2,4)=P(IN(1)+2,3)
47366 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
47367 P(IN(1)+2,4)=P(IN(1)+2,3)
47373 C...Junction strings: particle four-momentum, remainder, loop back.
47375 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
47376 & P(IN(2)+2,4)*P(IN(2),J)
47377 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
47379 IF(P(I,4).LT.P(I,5)) GOTO 360
47380 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
47381 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
47382 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
47387 IF(IN(3).NE.IN(6)) THEN
47389 P(IN(6),J)=P(IN(3),J)
47390 P(IN(6)+1,J)=P(IN(3)+1,J)
47395 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
47396 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
47401 C...Junction strings: save quantities left after each string.
47402 IF(IABS(KFL(1)).GT.10) GOTO 360
47406 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
47409 C...Junction strings: loopback if much unused energy in both strings.
47410 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
47411 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
47412 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
47414 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
47415 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
47416 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
47417 & .AND.NTRYER.LT.10) GOTO 320
47419 C...Junction strings: put together to new effective string endpoint.
47421 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
47422 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
47423 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
47424 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
47426 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
47427 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
47429 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
47434 C...Open versus closed strings. Choose breakup region for latter.
47435 640 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
47438 ELSEIF(MJU(1).NE.0) THEN
47441 ELSEIF(MJU(2).NE.0) THEN
47444 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
47451 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
47452 W2SUM=W2SUM+P(N+NR+IS,1)
47457 W2SUM=W2SUM-P(N+NR+NB,1)
47458 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 660
47461 C...Find longitudinal string directions (i.e. lightlike four-vectors).
47463 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
47464 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
47467 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
47468 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
47470 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
47471 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
47473 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
47474 & DP(1,2)**2-DP(1,3)**2))
47475 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
47476 & DP(2,2)**2-DP(2,3)**2))
47480 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
47481 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
47482 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
47483 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
47485 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
47487 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
47488 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
47492 C...Begin initialization: sum up energy, set starting position.
47496 IF(NTRY.GT.100.AND.NTRYR.LE.8) THEN
47500 ELSEIF(NTRY.GT.100) THEN
47501 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
47502 IF(MSTU(21).GE.1) RETURN
47509 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
47514 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
47515 IF(NS.GT.NR) IRANK(JT)=1
47517 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
47518 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
47519 IN(3*JT+2)=IN(3*JT+1)+1
47520 IN(3*JT+3)=N+NR+4*NS+2*JT-1
47521 DO 730 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
47528 C.. MOPS variables and switches
47534 C...Initialize flavour and pT variables for open string.
47538 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
47542 KFL(JT)=K(IE(JT),2)
47543 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
47544 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
47546 PMQ(JT)=PYMASS(KFL(JT))
47550 C...Closed string: random initial breakup flavour, pT and vertex.
47552 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
47554 760 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
47555 C.. Closed string: first vertex diq attempt => enforced second
47557 IF(IABS(KFL(1)).GT.10)THEN
47562 IF(IBMO.EQ.1) MSTU(121)=-1
47564 CALL PYPTDI(KFL(1),PX(1),PY(1))
47567 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
47568 770 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
47569 ZR=PR3/(Z*P(N+NR+1,5)**2)
47570 IF(ZR.GE.1D0) GOTO 770
47573 PMQ(JT)=PYMASS(KFL(JT))
47574 GAM(JT)=PR3*(1D0-Z)/Z
47575 IN1=N+NR+3+4*(JT/2)*(NS-1)
47578 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
47581 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
47587 PM2QMO(JT)=PMQ(JT)**2
47588 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
47591 C...Find initial transverse directions (i.e. spacelike four-vectors).
47593 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
47602 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47603 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47604 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47605 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47606 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47607 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47608 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47609 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47610 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47612 DHCX1=DFOUR(3,1)/DHC12
47613 DHCX2=DFOUR(3,2)/DHC12
47614 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47615 DHCY1=DFOUR(4,1)/DHC12
47616 DHCY2=DFOUR(4,2)/DHC12
47617 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47618 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47620 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47622 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47627 P(IN3+2,J)=P(IN3,J)
47628 P(IN3+3,J)=P(IN3+1,J)
47633 C...Remove energy used up in junction string fragmentation.
47634 IF(MJU(1)+MJU(2).GT.0) THEN
47636 IF(NJS(JT).EQ.0) GOTO 850
47638 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
47642 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
47643 WMIN=PARJST+PMQ(1)+PMQ(2)
47644 WREM2=FOUR(N+NRS,N+NRS)
47645 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
47647 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
47652 C...Produce new particle: side, origin.
47654 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
47655 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
47656 IF(MSTU(21).GE.1) RETURN
47658 C.. New side priority for popcorn systems
47659 IF(MSTU(121).LE.0)THEN
47661 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
47662 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
47666 IRANK(JT)=IRANK(JT)+1
47671 C...Generate flavour, hadron and pT.
47673 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
47674 IF(K(I,2).EQ.0) GOTO 700
47676 IF(MSTU(121).EQ.-1) GOTO 900
47677 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
47678 &IABS(KFL(3)).GT.10) THEN
47679 IF(PYR(0).GT.PARJ(19)) GOTO 870
47681 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47683 P(I,5)=PYMASS(K(I,2))
47684 CALL PYPTDI(KFL(JT),PX(3),PY(3))
47685 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
47687 C...Final hadrons for small invariant mass.
47689 PMQ(3)=PYMASS(KFL(3))
47691 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
47692 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
47693 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
47694 &WMIN-0.5D0*PARJ(36)*PMQ(3)
47695 WREM2=FOUR(N+NRS,N+NRS)
47696 IF(WREM2.LT.0.10D0) GOTO 700
47697 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
47698 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1070
47700 C...Choose z, which gives Gamma. Shift z for heavy flavours.
47701 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
47702 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
47703 &MSTU(90).LT.8) THEN
47704 MSTU(90)=MSTU(90)+1
47705 MSTU(90+MSTU(90))=I
47706 PARU(90+MSTU(90))=Z
47710 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
47711 &MOD(KFL2A/1000,10)).GE.4) THEN
47712 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
47713 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
47714 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
47715 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
47716 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1070
47718 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
47720 C.. MOPS baryon model modification
47721 XTMO3=(1D0-Z)*XTMO(JT)
47722 IF(IABS(KFL(3)).LE.10) NRVMO=0
47723 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
47727 IF(IABS(KFL(JT)).LE.10)THEN
47728 XBMO=MIN(XTMO3,1D0-(2D-10))
47731 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
47732 GTSTMO=1D0-PARF(192)**PGMO
47734 IF(IRANK(JT).EQ.1) THEN
47739 IF(XBMO.LT.1D0-(1D-10))THEN
47740 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
47741 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
47744 IF(MSTJ(12).GE.5)THEN
47745 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
47746 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
47747 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
47752 C.. MOPS Accepting popcorn system hadron.
47753 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
47754 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
47756 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
47758 & '(PYSTRF:) no more memory left in PYJETS')
47759 IF(MSTU(21).GE.1) RETURN
47771 DO 880 LINE=1,I-N-NR
47772 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
47773 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
47780 C..Reject popcorn system, flag=-1 if enforcing new one
47782 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
47787 C..Lift restoring string outside MOPS block
47788 900 IF(MSTU(121).LT.0) THEN
47789 IF(MSTU(121).EQ.-2) MSTU(121)=0
47792 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 870
47803 DO 910 LINE=1,I-N-NR
47804 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
47805 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
47813 C.. MOPS end of modification
47819 C...Stepping within or from 'low' string region easy.
47820 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
47821 &P(IN(1),5)**2.GE.PR(JT)) THEN
47822 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
47823 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
47825 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
47828 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
47829 P(IN(JR)+2,4)=P(IN(JR)+2,3)
47832 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 700
47833 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47834 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47840 C...Find new transverse directions (i.e. spacelike string vectors).
47841 950 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
47842 &IN(1).GT.IN(2)) GOTO 700
47843 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
47850 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47851 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47853 IF(DHC12.LE.1D-2) THEN
47854 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47860 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47861 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47862 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47863 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47864 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47865 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47866 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47867 DHCX1=DFOUR(3,1)/DHC12
47868 DHCX2=DFOUR(3,2)/DHC12
47869 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47870 DHCY1=DFOUR(4,1)/DHC12
47871 DHCY2=DFOUR(4,2)/DHC12
47872 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47873 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47875 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47877 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47880 C...Express pT with respect to new axes, if sensible.
47881 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
47882 & FOUR(IN(3*JT+3)+1,IN(3)))
47883 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
47884 & FOUR(IN(3*JT+3)+1,IN(3)+1))
47885 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
47891 C...Sum up known four-momentum. Gives coefficients for m2 expression.
47894 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
47895 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
47896 DO 980 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
47897 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
47899 DO 990 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
47900 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
47904 DHM(2)=2D0*FOUR(I,IN(1))
47905 DHM(3)=2D0*FOUR(I,IN(2))
47906 DHM(4)=2D0*FOUR(IN(1),IN(2))
47908 C...Find coefficients for Gamma expression.
47909 DO 1020 IN2=IN(1)+1,IN(2),4
47910 DO 1010 IN1=IN(1),IN2-1,4
47911 DHC=2D0*FOUR(IN1,IN2)
47912 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
47913 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
47914 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
47915 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
47919 C...Solve (m2, Gamma) equation system for energies taken.
47920 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
47921 IF(ABS(DHS1).LT.1D-4) GOTO 700
47922 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
47923 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
47924 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
47925 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
47926 &ABS(DHS1)-DHS2/DHS1)
47927 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 700
47928 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
47929 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
47931 C...Step to new region if necessary.
47932 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
47933 P(IN(JR)+2,4)=P(IN(JR)+2,3)
47936 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 700
47937 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47938 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47943 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
47944 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47950 C...Four-momentum of particle. Remaining quantities. Loop back.
47952 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
47953 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
47955 IF(P(I,4).LT.P(I,5)) GOTO 700
47961 IF(IN(3).NE.IN(3*JT+3)) THEN
47963 P(IN(3*JT+3),J)=P(IN(3),J)
47964 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
47969 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
47970 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
47972 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47976 C...Final hadron: side, flavour, hadron, mass.
47982 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
47983 IF(K(I,2).EQ.0) GOTO 700
47984 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
47986 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47988 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47990 P(I,5)=PYMASS(K(I,2))
47991 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
47993 C...Final two hadrons: find common setup of four-vectors.
47995 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
47996 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
47997 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
47998 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
47999 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
48000 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
48001 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
48002 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
48003 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
48004 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
48007 C...Solve kinematics for final two hadrons, if possible.
48008 WREM2=2D0*DHR1*DHR2*DHC12
48009 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
48010 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
48011 IF(FD.GE.1D0) GOTO 700
48012 FA=WREM2+PR(JT)-PR(JR)
48013 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
48015 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
48016 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
48017 FB=SIGN(FB,JS*(PYR(0)-PREV))
48020 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
48021 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
48022 &4D0*WREM2*PR(JT))),DBLE(JS))
48024 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
48025 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
48026 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
48027 P(I,J)=P(N+NRS,J)-P(I-1,J)
48029 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 700
48030 DM2F1=P(I-1,4)**2-P(I-1,1)**2-P(I-1,2)**2-P(I-1,3)**2-P(I-1,5)**2
48031 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
48032 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
48034 IF(NTRYFN.LT.100) GOTO 140
48035 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
48038 C...Mark jets as fragmented and give daughter pointers.
48040 DO 1090 I=NSAV+1,NSAV+NP
48043 IF(MSTU(16).NE.2) THEN
48052 C...Document string system. Move up particles.
48063 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
48067 K(I,J)=K(I+NRS-1,J)
48068 P(I,J)=P(I+NRS-1,J)
48073 DO 1130 IZ=MSTU90+1,MSTU91
48074 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
48075 PARU9T(IZ)=PARU(90+IZ)
48079 C...Order particles in rank along the chain. Update mother pointer.
48082 K(I-NSAV+N,J)=K(I,J)
48083 P(I-NSAV+N,J)=P(I,J)
48087 DO 1180 I=N+1,2*N-NSAV
48088 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1180
48094 IF(MSTU(16).NE.2) K(I1,3)=NSAV
48095 DO 1170 IZ=MSTU90+1,MSTU91
48096 IF(MSTU9T(IZ).EQ.I) THEN
48097 MSTU(90)=MSTU(90)+1
48098 MSTU(90+MSTU(90))=I1
48099 PARU(90+MSTU(90))=PARU9T(IZ)
48103 DO 1210 I=2*N-NSAV,N+1,-1
48104 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1210
48110 IF(MSTU(16).NE.2) K(I1,3)=NSAV
48111 DO 1200 IZ=MSTU90+1,MSTU91
48112 IF(MSTU9T(IZ).EQ.I) THEN
48113 MSTU(90)=MSTU(90)+1
48114 MSTU(90+MSTU(90))=I1
48115 PARU(90+MSTU(90))=PARU9T(IZ)
48120 C...Boost back particle system. Set production vertices.
48123 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
48127 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
48128 IF(P(I,3).GT.0D0) THEN
48129 HHPEZ=(P(I,4)+P(I,3))*HHBZ
48130 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
48131 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
48133 HHPEZ=(P(I,4)-P(I,3))/HHBZ
48134 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
48135 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
48148 C*********************************************************************
48151 C...From three given input vectors in PJU the boost VJU from
48152 C...the "lab frame" to the junction rest frame is constructed.
48154 SUBROUTINE PYJURF(PJU,VJU)
48156 C...Double precision and integer declarations.
48157 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48158 IMPLICIT INTEGER(I-N)
48160 C...Input, output and local arrays.
48161 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
48162 DATA TWOPI/6.283186D0/
48164 C...Calculate masses and other invariants.
48166 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
48168 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
48169 PSUM(5)=SQRT(PSUM2)
48172 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
48173 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
48177 C...Pick I to be most massive parton and J to be the one closest to I.
48180 IF(A(2,2).GT.A(1,1)) I=2
48181 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
48185 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
48196 C...Trivial find new parton energies if all three partons are massless.
48197 IF(PMI2.LT.1D-4) THEN
48198 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
48199 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
48200 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
48202 C...Else find momentum range for parton I and values at extremes.
48208 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
48209 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
48210 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
48211 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
48212 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
48213 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
48214 HI=PEIMAX**2-0.25D0*PAIMAX**2
48215 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
48216 & 0.5D0*PAIMAX*AIJ)/HI
48217 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
48218 & 0.5D0*PAIMAX*AIK)/HI
48219 PEJMAX=SQRT(PAJMAX**2+PMJ2)
48220 PEKMAX=SQRT(PAKMAX**2+PMK2)
48221 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
48223 C...If unexpected values at upper endpoint then pick another parton.
48224 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
48226 IF(A(I1,I1).GE.1D-4) THEN
48232 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
48238 C..Start binary + linear search to find solution inside range.
48242 PAI=0.5D0*(PAIMIN+PAIMAX)
48245 C...Derive momentum of other two partons and distance to root.
48246 PEI=SQRT(PAI**2+PMI2)
48247 HI=PEI**2-0.25D0*PAI**2
48248 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
48249 PEJ=SQRT(PAJ**2+PMJ2)
48250 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
48251 PEK=SQRT(PAK**2+PMK2)
48252 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
48254 C...Pick next I momentum to explore, hopefully closer to root.
48255 IF(FNOW.GT.0D0) THEN
48264 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
48266 PAI=0.5D0*(PAIMIN+PAIMAX)
48268 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
48269 & ABS(FNOW).GT.1D-12*PSUM2) THEN
48270 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
48275 C...Now know energies in junction rest frame.
48280 C...Boost (copy of) partons to their rest frame.
48281 VXCM=-PSUM(1)/PSUM(5)
48282 VYCM=-PSUM(2)/PSUM(5)
48283 VZCM=-PSUM(3)/PSUM(5)
48284 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
48286 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
48287 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
48288 PCM(I,1)=PJU(I,1)+FAC2*VXCM
48289 PCM(I,2)=PJU(I,2)+FAC2*VYCM
48290 PCM(I,3)=PJU(I,3)+FAC2*VZCM
48291 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
48292 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
48295 C...Construct difference vectors and boost to junction rest frame.
48297 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
48298 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
48300 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
48301 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
48302 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
48303 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
48304 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
48305 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
48306 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
48307 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
48308 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
48309 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
48310 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
48312 C...Add two boosts, giving final result.
48313 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
48314 VJU(1)=VXJU+FCM*VXCM
48315 VJU(2)=VYJU+FCM*VYCM
48316 VJU(3)=VZJU+FCM*VZCM
48317 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
48320 C...In case of error in reconstruction: revert to CM frame of system.
48321 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
48322 &(PCM(1,5)*PCM(2,5))
48323 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
48324 &(PCM(1,5)*PCM(3,5))
48325 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
48326 &(PCM(2,5)*PCM(3,5))
48327 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
48328 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
48330 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
48331 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
48332 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
48333 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
48334 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
48335 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
48336 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
48338 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
48339 &(PCM(1,5)*PCM(2,5))
48340 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
48341 &(PCM(1,5)*PCM(3,5))
48342 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
48343 &(PCM(2,5)*PCM(3,5))
48344 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
48345 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
48346 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
48356 C*********************************************************************
48359 C...Handles the fragmentation of a jet system (or a single
48360 C...jet) according to independent fragmentation models.
48362 SUBROUTINE PYINDF(IP)
48364 C...Double precision and integer declarations.
48365 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48366 IMPLICIT INTEGER(I-N)
48367 INTEGER PYK,PYCHGE,PYCOMP
48369 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48370 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48371 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48372 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
48374 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
48375 &KFLO(2),PXO(2),PYO(2),WO(2)
48377 C.. MOPS error message
48378 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
48379 &' are not treated as expected in independent fragmentation')
48381 C...Reset counters. Identify parton system and take copy. Check flavour.
48391 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
48392 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
48393 IF(MSTU(21).GE.1) RETURN
48395 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
48397 IF(KC.EQ.0) GOTO 110
48398 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
48399 IF(KQ.EQ.0) GOTO 110
48401 IF(KQ.NE.2) KQSUM=KQSUM+KQ
48403 K(NSAV+NJET,J)=K(I,J)
48404 P(NSAV+NJET,J)=P(I,J)
48405 DPS(J)=DPS(J)+P(I,J)
48408 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
48409 &K(I+1,1).EQ.2)) GOTO 110
48410 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
48411 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
48412 IF(MSTU(21).GE.1) RETURN
48415 C...Boost copied system to CM frame. Find CM energy and sum flavours.
48418 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
48419 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
48425 DO 140 I=NSAV+1,NSAV+NJET
48429 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
48430 ELSEIF(KFA.GT.1000) THEN
48431 KFLA=MOD(KFA/1000,10)
48432 KFLB=MOD(KFA/100,10)
48433 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
48434 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
48438 C...Loop over attempts made. Reset counters.
48441 IF(NTRY.GT.200) THEN
48442 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
48443 IF(MSTU(21).GE.1) RETURN
48453 C...Loop over jets to be fragmented.
48454 DO 230 IP1=NSAV+1,NSAV+NJET
48459 C...Initial flavour and momentum values. Jet along +z axis.
48460 KFLH=IABS(K(IP1,2))
48461 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
48463 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
48465 C...Initial values for quark or diquark jet.
48466 170 IF(IABS(K(IP1,2)).NE.21) THEN
48469 CALL PYPTDI(0,PXO(1),PYO(1))
48472 C...Initial values for gluon treated like random quark jet.
48473 ELSEIF(MSTJ(2).LE.2) THEN
48475 IF(MSTJ(2).EQ.2) MSTJ(91)=1
48476 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
48477 CALL PYPTDI(0,PXO(1),PYO(1))
48480 C...Initial values for gluon treated like quark-antiquark jet pair,
48481 C...sharing energy according to Altarelli-Parisi splitting function.
48484 IF(MSTJ(2).EQ.4) MSTJ(91)=1
48485 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
48487 CALL PYPTDI(0,PXO(1),PYO(1))
48490 WO(1)=WF*PYR(0)**(1D0/3D0)
48494 C...Initial values for rank, flavour, pT and W+.
48504 C...New hadron. Generate flavour and hadron species.
48506 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
48507 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
48508 IF(MSTU(21).GE.1) RETURN
48515 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
48516 IF(K(I,2).EQ.0) GOTO 180
48517 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
48518 IF(PYR(0).GT.PARJ(19)) GOTO 200
48521 C...Find hadron mass. Generate four-momentum.
48522 P(I,5)=PYMASS(K(I,2))
48523 CALL PYPTDI(KFL1,PX2,PY2)
48526 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
48527 CALL PYZDIS(KFL1,KFL2,PR,Z)
48529 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
48531 MSTU(90)=MSTU(90)+1
48532 MSTU(90+MSTU(90))=I
48533 PARU(90+MSTU(90))=Z
48535 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
48536 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
48537 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
48538 & P(I,3).LE.0.001D0) THEN
48539 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
48545 C...Remaining flavour and momentum.
48554 C...Check if pL acceptable. Go back for new hadron if enough energy.
48555 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
48557 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
48559 IF(W.GT.PARJ(31)) GOTO 190
48562 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
48563 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
48565 C...Rotate jet to new direction.
48566 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
48567 PHI=PYANGL(P(IP1,1),P(IP1,2))
48569 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
48570 K(K(IP1,3),4)=NSAV1+1
48573 C...End of jet generation loop. Skip conservation in some cases.
48575 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
48576 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
48578 C...Subtract off produced hadron flavours, finished if zero.
48579 DO 240 I=NSAV+NJET+1,N
48581 KFLA=MOD(KFA/1000,10)
48582 KFLB=MOD(KFA/100,10)
48583 KFLC=MOD(KFA/10,10)
48585 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
48586 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
48588 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
48589 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
48590 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
48593 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
48594 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
48595 IF(NREQ.EQ.0) GOTO 320
48597 C...Take away flavour of low-momentum particles until enough freedom.
48601 DO 260 I=NSAV+NJET+1,N
48602 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
48603 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
48604 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
48606 IF(IREM.EQ.0) GOTO 150
48608 KFA=IABS(K(IREM,2))
48609 KFLA=MOD(KFA/1000,10)
48610 KFLB=MOD(KFA/100,10)
48611 KFLC=MOD(KFA/10,10)
48612 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
48613 IF(K(IREM,1).EQ.8) GOTO 250
48615 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
48616 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
48617 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
48619 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
48620 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
48621 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
48624 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
48625 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
48626 IF(NREQ.GT.NREM) GOTO 250
48627 DO 270 I=NSAV+NJET+1,N
48628 IF(K(I,1).EQ.8) K(I,1)=1
48631 C...Find combination of existing and new flavours for hadron.
48633 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
48634 IF(NREQ.LT.NREM) NFET=1
48635 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
48637 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
48638 KFLF(J)=ISIGN(1,NFL(1))
48639 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
48640 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
48642 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
48644 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
48645 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
48646 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
48647 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
48648 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
48649 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
48650 IF(NFET.LE.2) KFLF(3)=0
48651 IF(KFLF(3).NE.0) THEN
48652 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
48653 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
48654 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
48655 & KFLFC=KFLFC+ISIGN(2,KFLFC)
48659 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
48660 IF(KF.EQ.0) GOTO 280
48661 DO 300 J=1,MAX(2,NFET)
48662 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
48665 C...Store hadron at random among free positions.
48666 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
48667 DO 310 I=NSAV+NJET+1,N
48668 IF(K(I,1).EQ.7) NPOS=NPOS-1
48669 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
48672 P(I,5)=PYMASS(K(I,2))
48673 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48676 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
48677 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
48678 IF(NREM.GT.0) GOTO 280
48680 C...Compensate for missing momentum in global scheme (3 options).
48681 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
48684 DO 330 I=NSAV+NJET+1,N
48685 PSI(J)=PSI(J)+P(I,J)
48688 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
48690 DO 350 I=NSAV+NJET+1,N
48691 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
48692 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
48693 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
48694 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
48696 DO 370 I=NSAV+NJET+1,N
48697 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
48698 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
48699 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
48700 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
48702 P(I,J)=P(I,J)-PSI(J)*PW/PWS
48704 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48707 C...Compensate for missing momentum withing each jet separately.
48708 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
48709 DO 390 I=N+1,N+NJET
48715 DO 410 I=NSAV+NJET+1,N
48718 K(IR2,1)=K(IR2,1)+1
48719 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
48720 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
48722 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
48724 P(IR2,4)=P(IR2,4)+P(I,4)
48725 P(IR2,5)=P(IR2,5)+PLS
48728 DO 420 I=N+1,N+NJET
48729 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
48731 DO 440 I=NSAV+NJET+1,N
48734 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
48735 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
48737 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
48740 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48744 C...Scale momenta for energy conservation.
48745 IF(MOD(MSTJ(3),5).NE.0) THEN
48749 DO 450 I=NSAV+NJET+1,N
48752 PQS=PQS+P(I,5)**2/P(I,4)
48754 IF(PMS.GE.PECM) GOTO 150
48757 PFAC=(PECM-PQS)/(PES-PQS)
48760 DO 480 I=NSAV+NJET+1,N
48764 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48766 PQS=PQS+P(I,5)**2/P(I,4)
48768 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
48771 C...Origin of produced particles and parton daughter pointers.
48772 490 DO 500 I=NSAV+NJET+1,N
48773 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
48774 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
48776 DO 510 I=NSAV+1,NSAV+NJET
48779 IF(MSTU(16).NE.2) THEN
48783 K(I1,4)=K(I1,4)-NJET+1
48784 K(I1,5)=K(I1,5)-NJET+1
48785 IF(K(I1,5).LT.K(I1,4)) THEN
48792 C...Document independent fragmentation system. Remove copy of jets.
48803 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
48805 DO 540 I=NSAV+NJET,N
48807 K(I-NJET+1,J)=K(I,J)
48808 P(I-NJET+1,J)=P(I,J)
48809 V(I-NJET+1,J)=V(I,J)
48813 DO 550 IZ=MSTU90+1,MSTU(90)
48814 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
48817 C...Boost back particle system. Set production vertices.
48818 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
48819 &DPS(2)/DPS(4),DPS(3)/DPS(4))
48829 C*********************************************************************
48832 C...Handles the decay of unstable particles.
48834 SUBROUTINE PYDECY(IP)
48836 C...Double precision and integer declarations.
48837 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48838 IMPLICIT INTEGER(I-N)
48839 INTEGER PYK,PYCHGE,PYCOMP
48841 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48842 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48843 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48844 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
48845 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
48847 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
48848 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
48850 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
48852 C...Functions: momentum in two-particle decays and four-product.
48853 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
48854 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)
48856 C...Initial values.
48860 KFS=ISIGN(1,K(IP,2))
48864 C...Choose lifetime and determine decay vertex.
48865 IF(K(IP,1).EQ.5) THEN
48867 ELSEIF(K(IP,1).NE.4) THEN
48868 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
48871 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
48874 C...Determine whether decay allowed or not.
48876 IF(MSTJ(22).EQ.2) THEN
48877 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
48878 ELSEIF(MSTJ(22).EQ.3) THEN
48879 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
48880 ELSEIF(MSTJ(22).EQ.4) THEN
48881 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
48882 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
48884 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
48889 C...Interface to external tau decay library (for tau polarization).
48890 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
48892 C...Starting values for pointers and momenta.
48896 PCMTAU(J)=P(ITAU,J)
48899 C...Iterate to find position and code of mother of tau.
48901 120 IMTAU=K(IMTAU,3)
48903 IF(IMTAU.EQ.0) THEN
48904 C...If no known origin then impossible to do anything further.
48908 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
48909 C...If tau -> tau + gamma then add gamma energy and loop.
48910 IF(K(K(IMTAU,4),2).EQ.22) THEN
48912 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
48914 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
48916 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
48921 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
48922 C...If coming from weak decay of hadron then W is not stored in record,
48923 C...but can be reconstructed by adding neutrino momentum.
48924 KFORIG=-ISIGN(24,K(ITAU,2))
48926 DO 160 II=K(IMTAU,4),K(IMTAU,5)
48927 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
48929 PCMTAU(J)=PCMTAU(J)+P(II,J)
48935 C...If coming from resonance decay then find latest copy of this
48936 C...resonance (may not completely agree).
48939 DO 170 II=IMTAU+1,IP-1
48940 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
48941 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
48944 PCMTAU(J)=P(IORIG,J)
48948 C...Boost tau to rest frame of production process (where known)
48949 C...and rotate it to sit along +z axis.
48951 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
48953 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
48954 & -DBETAU(2),-DBETAU(3))
48955 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
48956 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
48957 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
48958 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
48960 C...Call tau decay routine (if meaningful) and fill extra info.
48961 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
48962 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
48963 DO 200 II=NSAV+1,NSAV+NDECAY
48972 C...Boost back decay tau and decay products.
48976 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
48977 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
48978 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
48979 & DBETAU(2),DBETAU(3))
48981 C...Skip past ordinary tau decay treatment.
48989 C...B-Bbar mixing: flip sign of meson appropriately.
48991 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
48993 IF(KFA.EQ.531) XBBMIX=PARJ(77)
48994 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
48995 IF(MMIX.EQ.1) KFS=-KFS
48998 C...Check existence of decay channels. Particle/antiparticle rules.
49000 IF(MDCY(KC,2).GT.0) THEN
49001 MDMDCY=MDME(MDCY(KC,2),2)
49002 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
49004 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
49005 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
49008 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
49009 IF(KCHG(KC,3).EQ.0) THEN
49012 IF(PYR(0).GT.0.5D0) KFS=-KFS
49013 ELSEIF(KFS.GT.0) THEN
49021 C...Sum branching ratios of allowed decay channels.
49024 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
49025 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
49026 & KFSN*MDME(IDL,1).NE.3) GOTO 230
49027 IF(MDME(IDL,2).GT.100) GOTO 230
49029 BRSU=BRSU+BRAT(IDL)
49032 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
49036 C...Select decay channel among allowed ones.
49037 240 RBR=BRSU*PYR(0)
49040 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
49041 &KFSN*MDME(IDL,1).NE.3) THEN
49042 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
49043 ELSEIF(MDME(IDL,2).GT.100) THEN
49044 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
49048 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
49051 C...Start readout of decay channel: matrix element, reset counters.
49054 IF(MOD(NTRY,200).EQ.0) THEN
49055 WRITE(CIDC,'(I4)') IDC
49056 C...Do not print warning for some well-known special cases.
49057 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
49058 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
49062 IF(NTRY.GT.1000) THEN
49063 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
49064 IF(MSTU(21).GE.1) RETURN
49070 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
49073 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
49075 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
49081 IF(KFA.GT.80) MHADDY=1
49082 C.. Random flavour and popcorn system memory.
49088 C...Read out decay products. Convert to standard flavour code.
49090 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
49092 IF(JT.LE.5) KP=KFDP(IDC,JT)
49093 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
49094 IF(KP.EQ.0) GOTO 280
49097 IF(KPA.GT.80) MHADDY=1
49098 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
49100 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
49102 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
49103 KFP=-KFS*MOD(KFA/10,10)
49104 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
49105 KFP=KFS*(100*MOD(KFA/10,100)+3)
49106 ELSEIF(KPA.EQ.81) THEN
49107 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
49108 ELSEIF(KP.EQ.82) THEN
49109 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
49110 IF(KFP.EQ.0) GOTO 260
49114 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
49115 ELSEIF(KP.EQ.-82) THEN
49118 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
49120 C...Add decay product to event record or to quark flavour list.
49123 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
49126 C...set rndmflav popcorn system pointer
49127 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
49129 PSQ=PSQ+PYMASS(KFLO(NQ))
49130 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
49131 & MOD(NQ,2).EQ.1) THEN
49136 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
49137 IF(K(I,2).EQ.0) GOTO 260
49139 P(I,5)=PYMASS(K(I,2))
49144 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
49145 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
49147 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
49148 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
49158 C...Check masses for resonance decays.
49159 IF(MHADDY.EQ.0) THEN
49160 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
49163 C...Choose decay multiplicity in phase space model.
49164 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
49166 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
49167 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
49169 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
49170 IF(IRNDMO.EQ.0) THEN
49173 ELSEIF(IRNDMO.EQ.1) THEN
49178 IF(NTRY.GT.1000) THEN
49179 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
49180 IF(MSTU(21).GE.1) RETURN
49182 IF(MMAT.LE.20) THEN
49183 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
49184 & SIN(PARU(2)*PYR(0))
49185 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
49186 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
49187 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
49188 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
49189 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
49193 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
49195 IF(MSTU(121).GT.MSTU(125)) GOTO 300
49197 C...Form hadrons from flavour content.
49201 IF(ND.EQ.NP+NQ/2) GOTO 330
49202 DO 320 I=N+NP+1,N+ND-NQ/2
49203 C.. Stick to started popcorn system, else pick side at random
49205 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
49206 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
49207 IF(K(I,2).EQ.0) GOTO 300
49208 MSTU(125)=MSTU(125)-1
49210 IF(MSTU(121).GT.0) JTMO=JT
49216 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
49217 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
49218 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
49221 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
49222 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
49223 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
49224 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
49226 C...Check that sum of decay product masses not too large.
49228 DO 340 I=N+NP+1,N+ND
49233 P(I,5)=PYMASS(K(I,2))
49236 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
49238 C...Rescale energy to subtract off spectator quark mass.
49239 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
49240 & .AND.NP.GE.3) THEN
49242 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
49244 P(N+NP,J)=PQT*PV(1,J)
49245 PV(1,J)=(1D0-PQT)*PV(1,J)
49247 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
49251 C...Fully specified final state: check mass broadening effects.
49253 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
49257 C...Determine position of grandmother, number of sisters.
49263 IF(IM.LT.0.OR.IM.GE.IP) IM=0
49264 IF(IM.NE.0) KFAM=IABS(K(IM,2))
49266 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
49267 IF(K(IL,3).EQ.IM) NM=NM+1
49268 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
49270 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
49271 & MOD(KFAM/1000,10).NE.0) NM=0
49273 KFAS=IABS(K(ISIS,2))
49274 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
49275 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
49280 C...Kinematics of one-particle decays.
49288 C...Calculate maximum weight ND-particle decay.
49291 WTMAX=1D0/WTCOR(ND-2)
49292 PMAX=PV(1,5)-PS+P(N+ND,5)
49294 DO 380 IL=ND-1,1,-1
49295 PMAX=PMAX+P(N+IL,5)
49296 PMIN=PMIN+P(N+IL+1,5)
49297 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
49301 C...Find virtual gamma mass in Dalitz decay.
49302 390 IF(ND.EQ.2) THEN
49303 ELSEIF(MMAT.EQ.2) THEN
49304 PMES=4D0*PMAS(11,1)**2
49305 PMRHO2=PMAS(131,1)**2
49306 PGRHO2=PMAS(131,2)**2
49307 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
49308 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
49309 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
49310 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
49311 IF(WT.LT.PYR(0)) GOTO 400
49312 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
49314 C...M-generator gives weight. If rejected, try again.
49319 DO 420 IL2=IL1-1,1,-1
49320 IF(RSAV.LE.RORD(IL2)) GOTO 430
49321 RORD(IL2+1)=RORD(IL2)
49323 430 RORD(IL2+1)=RSAV
49327 DO 450 IL=ND-1,1,-1
49328 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
49330 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
49332 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
49335 C...Perform two-particle decays in respective CM frame.
49336 460 DO 480 IL=1,ND-1
49337 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
49338 UE(3)=2D0*PYR(0)-1D0
49340 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
49341 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
49344 PV(IL+1,J)=-PA*UE(J)
49346 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
49347 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
49350 C...Lorentz transform decay products to lab frame.
49354 DO 530 IL=ND-1,1,-1
49356 BE(J)=PV(IL,J)/PV(IL,4)
49358 GA=PV(IL,4)/PV(IL,5)
49360 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
49362 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
49364 P(I,4)=GA*(P(I,4)+BEP)
49368 C...Check that no infinite loop in matrix element weight.
49370 IF(NTRY.GT.800) GOTO 560
49372 C...Matrix elements for omega and phi decays.
49374 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
49375 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
49376 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
49377 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
49379 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
49380 ELSEIF(MMAT.EQ.2) THEN
49381 FOUR12=FOUR(N+1,N+2)
49382 FOUR13=FOUR(N+1,N+3)
49383 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
49384 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
49385 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
49387 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
49388 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
49389 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
49390 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
49392 FOUR12=FOUR(IP,N+1)
49393 FOUR02=FOUR(IM,N+1)
49397 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
49398 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
49399 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
49400 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
49401 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
49402 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
49404 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
49405 ELSEIF(MMAT.EQ.4) THEN
49406 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
49407 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
49408 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
49409 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
49410 & ((1D0-HX3)/(HX1*HX2))**2
49411 IF(WT.LT.2D0*PYR(0)) GOTO 390
49412 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
49415 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
49416 ELSEIF(MMAT.EQ.41) THEN
49417 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
49418 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
49419 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
49421 C...Matrix elements for weak decays (only semileptonic for c and b)
49422 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
49423 & .AND.ND.EQ.3) THEN
49424 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
49425 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
49426 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
49427 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
49431 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
49434 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
49435 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
49436 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
49439 C...Scale back energy and reattach spectator.
49440 560 IF(MREM.EQ.1) THEN
49442 PV(1,J)=PV(1,J)/(1D0-PQT)
49448 C...Low invariant mass for system with spectator quark gives particle,
49449 C...not two jets. Readjust momenta accordingly.
49450 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
49452 PM2=PYMASS(K(N+2,2))
49454 PM3=PYMASS(K(N+3,2))
49455 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
49456 & (PARJ(32)+PM2+PM3)**2) GOTO 630
49459 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
49460 IF(K(N+2,2).EQ.0) GOTO 260
49461 P(N+2,5)=PYMASS(K(N+2,2))
49462 PS=P(N+1,5)+P(N+2,5)
49467 ELSEIF(MMAT.EQ.44) THEN
49469 PM3=PYMASS(K(N+3,2))
49471 PM4=PYMASS(K(N+4,2))
49472 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
49473 & (PARJ(32)+PM3+PM4)**2) GOTO 600
49476 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
49477 IF(K(N+3,2).EQ.0) GOTO 260
49478 P(N+3,5)=PYMASS(K(N+3,2))
49480 P(N+3,J)=P(N+3,J)+P(N+4,J)
49482 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)
49483 HA=P(N+1,4)**2-P(N+2,4)**2
49484 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
49485 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
49486 & (P(N+1,3)-P(N+2,3))**2
49487 HD=(PV(1,4)-P(N+3,4))**2
49488 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
49491 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
49493 PCOR=HH*(P(N+1,J)-P(N+2,J))
49494 P(N+1,J)=P(N+1,J)+PCOR
49495 P(N+2,J)=P(N+2,J)-PCOR
49497 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)
49498 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)
49502 C...Check invariant mass of W jets. May give one particle or start over.
49503 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
49504 &.AND.IABS(K(N+1,2)).LT.10) THEN
49505 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
49507 PM1=PYMASS(K(N+1,2))
49509 PM2=PYMASS(K(N+2,2))
49510 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
49511 KFLDUM=INT(1.5D0+PYR(0))
49512 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
49513 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
49514 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
49515 PSM=PYMASS(KF1)+PYMASS(KF2)
49516 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
49517 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
49518 IF(MMAT.EQ.48) GOTO 390
49519 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
49522 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
49523 IF(K(N+1,2).EQ.0) GOTO 260
49524 P(N+1,5)=PYMASS(K(N+1,2))
49527 PS=P(N+1,5)+P(N+2,5)
49528 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
49535 C...Phase space decay of partons from W decay.
49536 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
49542 PV(1,J)=P(N+1,J)+P(N+2,J)
49551 PSQ=PYMASS(KFLO(1))
49553 PSQ=PSQ+PYMASS(KFLO(2))
49558 C...Boost back for rapidly moving particle.
49562 BE(J)=P(IP,J)/P(IP,4)
49566 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
49568 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
49570 P(I,4)=GA*(P(I,4)+BEP)
49574 C...Fill in position of decay vertex.
49582 C...Set up for parton shower evolution from jets.
49583 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
49587 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
49588 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
49589 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
49590 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
49591 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
49592 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
49594 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
49597 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
49598 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
49599 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
49600 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
49602 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
49603 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
49606 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
49607 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
49608 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
49609 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
49611 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
49612 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
49614 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
49619 KCP=PYCOMP(K(NSAV+1,2))
49620 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
49622 IF(KQP.LT.0) JCON=5
49623 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
49624 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
49625 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
49626 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
49628 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
49631 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
49632 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
49633 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
49634 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
49638 C...Mark decayed particle; special option for B-Bbar mixing.
49639 IF(K(IP,1).EQ.5) K(IP,1)=15
49640 IF(K(IP,1).LE.10) K(IP,1)=11
49641 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
49649 C*********************************************************************
49652 C...Handles flavour production in the decay of unstable particles
49653 C...and small string clusters.
49655 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
49657 C...Double precision and integer declarations.
49658 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49659 IMPLICIT INTEGER(I-N)
49660 INTEGER PYK,PYCHGE,PYCOMP
49662 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49663 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49664 SAVE /PYDAT1/,/PYDAT2/
49667 C.. Call PYKFDI directly if no popcorn option is on
49668 IF(MSTJ(12).LT.2) THEN
49669 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
49676 IF(KFL1.EQ.0) RETURN
49681 NMAX=MIN(MSTU(125),10)
49683 C.. Identify rank 0 cluster qq
49685 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
49688 C.. Join jets: Fails if store not empty
49689 IF(MSTU(121).GT.0) THEN
49693 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
49694 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
49695 C.. Pick popcorn meson from store, return same qq, decrease store
49696 KF=MSTU(NSTO+MSTU(121))
49698 MSTU(121)=MSTU(121)-1
49700 C.. Generate new flavour. Then done if no diquark is generated
49701 100 CALL PYKFDI(KFL1,0,KFL3,KF)
49702 IF(MSTU(121).EQ.-1) GOTO 100
49704 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
49706 C.. Simple case if no dynamical popcorn suppressions are considered
49707 IF(MSTJ(12).LT.4) THEN
49708 IF(MSTU(121).EQ.0) RETURN
49711 CALL PYKFDI(KFPREV,0,KFL3,KFM)
49712 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
49713 IF(IABS(KFL3).LE.10)THEN
49720 C test output qq against fake Gamma, then return if no popcorn.
49723 CALL PYZDIS(1,2103,5D0,Z)
49725 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
49730 IF(MSTU(121).EQ.0) RETURN
49732 C..Set store size memory. Pick fake dynamical variables of qq.
49734 CALL PYPTDI(1,PX3,PY3)
49740 C.. Pick next popcorn meson, test with fake dynamical variables
49744 CALL PYKFDI(KFPREV,0,KFL3,KFM)
49745 IF(MSTU(121).EQ.-1) GOTO 100
49746 CALL PYPTDI(KFL3,PX3,PY3)
49747 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
49748 CALL PYZDIS(KFPREV,KFL3,PM,Z)
49755 IF(MSTJ(12).GT.4)THEN
49756 POPMN=SQRT((1D0-X)*(G/X-GB))
49757 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
49758 PTST=EXP((POPM-POPMN)*PARF(193))
49763 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
49766 IF(RTST.GT.PTST*GTST)THEN
49768 IF(RTST.GT.PTST) MSTU(121)=-1
49773 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
49774 IF(MSTU(121).GT.0) GOTO 110
49776 C.. Test accepted system size. If OK set global popcorn size variable.
49777 IF(NMES.GT.NMAX)THEN
49788 C********************************************************************
49791 C...Generates a new flavour pair and combines off a hadron
49793 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
49795 C...Double precision and integer declarations.
49796 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49797 IMPLICIT INTEGER(I-N)
49798 INTEGER PYK,PYCHGE,PYCOMP
49800 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49801 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49802 SAVE /PYDAT1/,/PYDAT2/
49806 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
49808 C...Default flavour values. Input consistency checks.
49813 IF(KF1A.EQ.0) RETURN
49815 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
49816 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
49817 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
49820 C...Check if tabulated flavour probabilities are to be used.
49821 IF(MSTJ(15).EQ.1) THEN
49822 IF(MSTJ(12).GE.5) CALL PYERRM(29,
49823 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
49824 & ' together with MSTJ(12)>=5 modification')
49826 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
49827 KFL1A=MOD(KF1A/1000,10)
49828 KFL1B=MOD(KF1A/100,10)
49830 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
49831 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
49832 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
49833 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
49837 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
49838 KFL2A=MOD(KF2A/1000,10)
49839 KFL2B=MOD(KF2A/100,10)
49841 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
49842 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
49843 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
49845 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
49848 C.. Recognize rank 0 diquark case
49850 KFDIQ=MAX(KF1A,KF2A)
49851 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
49853 C.. Join two flavours to meson or baryon. Test for popcorn.
49856 IF(KFDIQ.GT.10) THEN
49857 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
49858 & CALL PYNMES(KFDIQ)
49859 IF(MSTU(121).NE.0) THEN
49870 C.. Separate incoming flavours, curtain flavour consistency check
49876 KFL1A=MOD(KF1A/1000,10)
49877 KFL1B=MOD(KF1A/100,10)
49880 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
49881 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
49882 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
49884 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
49888 KFQOLD=KFL1A+KFL1B-KFQPOP
49891 C...Meson/baryon choice. Set number of mesons if starting a popcorn
49894 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
49895 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
49899 ELSEIF(KF1A.GT.10)THEN
49901 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
49902 IF(MSTU(121).GT.0) MBARY=-1
49905 C..x->H+q: Choose single vertex quark. Jump to form hadron.
49906 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
49907 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
49908 KFL3=ISIGN(KFQVER,-KFIN)
49912 C..x->H+qq: (IDW=proper PARF position for diquark weights)
49915 IF(MSTU(121).EQ.0) IDW=150
49917 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
49918 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
49919 C.. Shift to s-curtain parameters if needed
49920 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
49921 PARF(194)=PARF(138)*PARF(139)
49922 PARF(193)=PARJ(8)+PARJ(9)
49926 C.. x->H+qq: Get vertex quark
49927 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
49929 MSTU(121)=MSTU(121)-1
49930 IF(IDW.EQ.170) THEN
49931 IF(MSTU(121).EQ.0)THEN
49932 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
49934 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
49937 IF(MSTU(121).EQ.0)THEN
49938 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
49940 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
49946 RMES=PYR(0)*PARF(194)
49948 RMES=RMES-PARF(IPOS+IMES)
49949 IF(IMES.EQ.30) THEN
49954 IF(RMES.GT.0D0) GOTO 120
49957 IF(KMUL.EQ.2) KFJ=10003
49958 IF(KMUL.EQ.3) KFJ=10001
49959 IF(KMUL.EQ.4) KFJ=20003
49960 IF(KMUL.EQ.5) KFJ=5
49962 KFQVER=MOD(IMES,5)+1
49963 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
49964 IF(KFQVER.GT.3)THEN
49969 IF(MBARY.EQ.-1) IDW=170
49971 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
49972 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
49973 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
49974 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
49976 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
49980 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
49982 IF(KFQPOP.NE.KFQVER)THEN
49984 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
49985 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
49986 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
49988 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
49990 KFL3=ISIGN(KFDIQ,KFIN)
49992 C..x->M+y: flavour for meson.
49993 130 IF(MBARY.LE.0)THEN
49994 KFLA=MAX(KFQOLD,KFQVER)
49995 KFLB=MIN(KFQOLD,KFQVER)
49997 IF(KFLA.NE.KFQOLD) KFS=-KFS
49998 C... Form meson, with spin and flavour mixing for diagonal states.
49999 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
50000 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
50001 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
50004 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
50005 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
50006 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
50007 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
50008 IF(PYR(0).LT.PARJ(14)) KMUL=2
50009 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
50011 IF(RMUL.LT.PARJ(15)) KMUL=3
50012 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
50013 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
50016 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
50017 IF(KMUL.EQ.5) KFLS=5
50018 IF(KFLA.NE.KFLB)THEN
50019 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
50022 IMIX=2*KFLA+10*KMUL
50023 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
50024 & INT(RMIX+PARF(IMIX)))+KFLS
50025 IF(KFLA.GE.4) KF=110*KFLA+KFLS
50027 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
50028 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
50030 C..Optional extra suppression of eta and eta'.
50031 C..Allow shift to qq->B+q in old version (set IRANK to 0)
50032 IF(KF.EQ.221.OR.KF.EQ.331)THEN
50033 IF(PYR(0).GT.PARJ(25+KF/300))THEN
50034 IF(KF2A.GT.0) GOTO 130
50035 IF(MSTJ(12).LT.4) IRANK=0
50041 C.. x->B+y: Flavour for baryon
50044 IF(KF1A.LE.10) KFLA=KFQOLD
50045 KFLB=MOD(KFDIQ/1000,10)
50046 KFLC=MOD(KFDIQ/100,10)
50047 KFLDS=MOD(KFDIQ,10)
50048 KFLD=MAX(KFLA,KFLB,KFLC)
50049 KFLF=MIN(KFLA,KFLB,KFLC)
50050 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
50052 C... SU(6) factors for formation of baryon.
50056 IF(KFLB.NE.KFLC)THEN
50059 IF(KFLB.GT.2) KDMAX=KDMAX+2
50061 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
50066 SU6MAX=PARF(140+KDMAX)
50069 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
50074 SU6OCT=PARF(60+KBARY)
50075 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
50076 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
50077 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
50079 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
50081 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
50083 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
50084 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
50086 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
50090 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
50093 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
50094 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
50096 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
50098 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
50099 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
50101 C -------------------------------------------------------------------------
50102 C Extracted from a private e-mail exchange with Torbjorn Sjostrand
50104 C No, Lambda(1520) is not included and not foreseen.
50105 C So if you want it in Pythia, it would have to be a hack.
50106 C What you could do is:
50107 C 1) In PYKFDI, just before the RETURN above label 140, you could check if
50108 C a Lambda, Sigma0 or Sigma*0 has been produced, and with some small
50109 C probability switch such a particle to the Lambda(1520) code. That is,
50110 C if KF = 3122, 3212, or 3214 and a random number below some number, switch
50111 C to KF = 3124. (And correspondingly for anticparticles.)
50112 C 2) Use the PYUPDA routine (see manual) to include particle and decay data
50113 C for the Lambda(1520).
50114 C -------------------------------------------------------------------------
50116 IF (IABS(KF).EQ.3122) THEN
50117 C Converting a fraction (0.20) of Lambda0 to Lambda(1520) + c.c.
50118 C This fraction is based on the experimental measurement at ISR
50119 C Bobbink 83, NP B217,11 (1983)
50120 C The region 0.5 < XF < 1.0 has been extrapolated to XF=0
50121 IF(PYR(0).LE.0.20) KF=ISIGN(3124,KF)
50124 IF(IABS(KF).EQ.3212) THEN
50125 C Converting a fraction (0.20) of Sigma0 to Lambda(1520) + c.c.
50126 C We suppose the same fraction as for Lambda0
50127 IF(PYR(0).LE.0.20) KF=ISIGN(3124,KF)
50130 IF (IABS(KF).EQ.3214) THEN
50131 C Converting a fraction (0.30) of Sigma0(1385) to Lambda(1520) + c.c.
50132 C This is conservative extimate supposing that the ratio
50133 C scales as (M_Sigma1385/M_Lambda0)^2 ~ 1.5
50134 IF(PYR(0).LE.0.30) KF=ISIGN(3124,KF)
50138 C...Use tabulated probabilities to select new flavour and hadron.
50139 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
50142 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
50145 ELSEIF(KTAB2.EQ.0) THEN
50154 DO 150 KT3=KT3L,KT3U
50155 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
50161 DO 170 KT3=KT3L,KT3U
50163 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
50164 IF(RFL.LE.0D0) GOTO 190
50169 C...Reconstruct flavour of produced quark/diquark.
50170 IF(KTAB3.LE.6) THEN
50173 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
50176 IF(KTAB3.GE.8) KFL3A=2
50177 IF(KTAB3.GE.11) KFL3A=3
50178 IF(KTAB3.GE.16) KFL3A=4
50179 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
50180 KFL3=1000*KFL3A+100*KFL3B+1
50181 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
50183 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
50186 C...Reconstruct meson code.
50187 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
50189 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
50190 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
50192 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
50193 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
50194 & 25*KTABS)) KF=330+2*KTABS+1
50195 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
50196 KFLA=MAX(KTAB1,KTAB3)
50197 KFLB=MIN(KTAB1,KTAB3)
50199 IF(KFLA.NE.KF1A) KFS=-KFS
50200 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
50201 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
50203 IF(KFL1A.EQ.KFL3A) THEN
50204 KFLA=MAX(KFL1B,KFL3B)
50205 KFLB=MIN(KFL1B,KFL3B)
50206 IF(KFLA.NE.KFL1B) KFS=-KFS
50207 ELSEIF(KFL1A.EQ.KFL3B) THEN
50211 ELSEIF(KFL1B.EQ.KFL3A) THEN
50214 ELSEIF(KFL1B.EQ.KFL3B) THEN
50215 KFLA=MAX(KFL1A,KFL3A)
50216 KFLB=MIN(KFL1A,KFL3A)
50217 IF(KFLA.NE.KFL1A) KFS=-KFS
50219 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
50222 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
50224 C...Reconstruct baryon code.
50226 IF(KTAB1.GE.7) THEN
50235 KFLD=MAX(KFLA,KFLB,KFLC)
50236 KFLF=MIN(KFLA,KFLB,KFLC)
50237 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
50238 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
50239 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
50242 C...Check that constructed flavour code is an allowed one.
50243 IF(KFL2.NE.0) KFL3=0
50246 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
50254 C*********************************************************************
50257 C...Generates number of popcorn mesons and stores some relevant
50260 SUBROUTINE PYNMES(KFDIQ)
50262 C...Double precision and integer declarations.
50263 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50264 IMPLICIT INTEGER(I-N)
50265 INTEGER PYK,PYCHGE,PYCOMP
50267 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50268 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50269 SAVE /PYDAT1/,/PYDAT2/
50272 IF(MSTJ(12).LT.2) RETURN
50274 C..Old version: Get 1 or 0 popcorn mesons
50275 IF(MSTJ(12).LT.5)THEN
50277 IF(KFDIQ.NE.0) THEN
50279 KFA=MOD(KFDIQA/1000,10)
50280 KFB=MOD(KFDIQA/100,10)
50283 IF(KFA.EQ.3) POPWT=PARF(133)
50284 IF(KFB.EQ.3) POPWT=PARF(134)
50285 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
50287 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
50291 C..New version: Store popcorn- or rank 0 diquark parameters
50294 PARF(194)=PARF(139)
50295 IF(KFDIQ.NE.0) THEN
50298 PARF(194)=PARF(140)
50300 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
50301 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
50302 & '(PYNMES:) Neglecting too large popcorn possibility')
50306 C..New version: Get number of popcorn mesons
50309 110 MSTU(121)=MSTU(121)+1
50310 RTST=RTST/PARF(194)
50311 IF(RTST.LT.1D0) GOTO 110
50312 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
50313 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
50317 C***************************************************************
50320 C...Precalculates a set of diquark and popcorn weights.
50324 C...Double precision and integer declarations.
50325 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50326 IMPLICIT INTEGER(I-N)
50327 INTEGER PYK,PYCHGE,PYCOMP
50329 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50330 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50331 SAVE /PYDAT1/,/PYDAT2/
50333 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
50337 C..Diquark indices for dimensional variables
50346 C.. *** SU(6) factors **
50347 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
50349 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
50350 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
50351 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
50354 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
50356 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
50357 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
50359 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
50360 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
50363 C..SU(6)max q q' s,c,b
50364 SU6MUD =MAX(SU6(1) , SU6(8) )
50365 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
50366 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
50367 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
50368 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
50369 SU6M(IUS0)=SU6M(ISU0)
50370 SU6M(ISS1)=SU6M(IUU1)
50371 SU6M(IUS1)=SU6M(ISU1)
50373 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
50375 PARF(142)=SU6M(IUD1)
50376 PARF(143)=SU6M(ISU0)
50377 PARF(144)=SU6M(ISU1)
50378 PARF(145)=SU6M(ISS1)
50380 C..diquark SU(6) survival =
50381 C..sum over quark (quark tunnel weight)*(SU(6)).
50382 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
50383 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
50384 DMB(IUS0)=DMB(ISU0)
50385 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
50386 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
50387 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
50388 DMB(IUS1)=DMB(ISU1)
50389 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
50391 C.. *** Tunneling factors for Diquark production***
50392 C.. T: half a curtain pair = sqrt(curtain pair factor)
50393 IF(MSTJ(12).GE.5) THEN
50395 PMUD1=PYMASS(2103)-PMUD0
50396 PMUS0=PYMASS(3201)-PMUD0
50397 PMUS1=PYMASS(3203)-PMUS0-PMUD0
50398 PMSS1=PYMASS(3303)-PMUS0-PMUD0
50399 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
50400 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
50401 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
50402 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
50403 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
50404 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
50405 QBB(IUD1)=QBB(IUU1)
50407 PAR2M=SQRT(PARJ(2))
50408 PAR3M=SQRT(PARJ(3))
50409 PAR4M=SQRT(PARJ(4))
50410 QBB(ISU0)=PAR2M*PAR3M
50412 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
50414 QBB(ISU1)=PAR4M*QBB(ISU0)
50415 QBB(IUS1)=PAR4M*QBB(IUS0)
50419 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
50420 QBM(ISU0)=QBB(ISU0)
50421 QBM(IUS0)=PARJ(2)*QBB(IUS0)
50422 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
50423 QBM(IUU1)=6D0*QBB(IUU1)
50424 QBM(ISU1)=3D0*QBB(ISU1)
50425 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
50426 QBM(IUD1)=3D0*QBB(IUD1)
50428 C.. Combine T and tau to diquark weight for q-> B+B+..
50430 QBB(I)=QBB(I)*QBM(I)
50433 IF(MSTJ(12).GE.5)THEN
50434 C..New version: tau for rank 0 diquark.
50435 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
50436 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
50437 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
50438 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
50439 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
50440 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
50441 DMB(7+IUD1)=DMB(7+IUU1)/2D0
50443 C..New version: curtain flavour ratios.
50444 C.. s/u for q->B+M+...
50445 C.. s/u for rank 0 diquark: su -> ...M+B+...
50446 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
50447 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
50448 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
50449 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
50450 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
50451 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
50452 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
50454 C..Old version: reset unused rank 0 diquark weights and
50455 C.. unused diquark SU(6) survival weights
50457 IF(MSTJ(12).LT.3) DMB(I)=1D0
50461 C..Old version: Shuffle PARJ(7) into tau
50462 QBM(IUS0)=QBM(IUS0)*PARJ(7)
50463 QBM(ISS1)=QBM(ISS1)*PARJ(7)
50464 QBM(IUS1)=QBM(IUS1)*PARJ(7)
50466 C..Old version: curtain flavour ratios.
50467 C.. s/u for q->B+M+...
50468 C.. s/u for rank 0 diquark: su -> ...M+B+...
50469 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
50470 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
50471 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
50472 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
50473 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
50476 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
50477 C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
50479 DMB(7+I)=DMB(7+I)*DMB(I)
50480 DMB(I)=DMB(I)*QBM(I)
50481 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
50482 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
50485 C.. *** Popcorn factors ***
50487 IF(MSTJ(12).LT.5)THEN
50488 C.. Old version: Resulting popcorn weights.
50490 WS=PARF(135)*PARF(138)
50492 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
50494 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
50495 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
50496 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
50497 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
50498 & (1D0+QBB(IUD1)+QBB(IUU1)+
50499 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
50501 C..New version: Store weights for popcorn mesons,
50502 C..get prel. popcorn weights.
50503 DO 150 IPOS=201,1400
50512 IF(MR.EQ.7) PARF(193)=PARJ(10)
50513 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
50514 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
50515 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
50517 IF(NMES.EQ.1) SQWT=PARJ(2)
50519 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
50520 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
50521 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
50523 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
50524 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
50527 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
50529 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
50530 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
50536 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
50537 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
50538 IF(PJWT.LE.0D0) GOTO 190
50539 IF(PJWT.GT.1D0) PJWT=1D0
50541 IMIX=2*KFQOLD+10*KMUL
50543 IF(KMUL.EQ.2) KFJ=10003
50544 IF(KMUL.EQ.3) KFJ=10001
50545 IF(KMUL.EQ.4) KFJ=20003
50546 IF(KMUL.EQ.5) KFJ=5
50548 KFLA=MAX(KFQOLD,KFQVER)
50549 KFLB=MIN(KFQOLD,KFQVER)
50550 SWT=PARJ(11+KFLA/3+KFLA/4)
50551 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
50553 QWT=SQWT/(2D0+SQWT)
50554 IF(KFQVER.LT.3)THEN
50555 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
50556 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
50558 IF(KFQVER.NE.KFQOLD)THEN
50560 KFM=100*KFLA+10*KFLB+KFJ
50561 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
50562 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
50563 WTTOT=WTTOT+PARF(IPOS+IMES)
50566 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
50567 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
50568 IF(ID.EQ.5) DWT=PARF(IMIX)
50570 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
50571 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
50572 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
50573 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
50574 PARF(IPOS+5*KMUL+ID)=
50575 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
50577 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
50583 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
50585 IF(MR.EQ.7) PARF(140)=
50586 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
50587 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
50588 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
50594 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
50599 C..Recombine diquark weights to flavour and spin ratios
50600 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
50601 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
50602 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
50603 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
50604 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
50605 PARF(155)=QBB(ISU1)/QBB(ISU0)
50606 PARF(156)=QBB(IUS1)/QBB(IUS0)
50607 PARF(157)=QBB(IUD1)
50609 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
50610 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
50611 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
50612 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
50613 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
50614 PARF(165)=QBM(ISU1)/QBM(ISU0)
50615 PARF(166)=QBM(IUS1)/QBM(IUS0)
50616 PARF(167)=QBM(IUD1)
50618 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
50619 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
50620 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
50621 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
50622 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
50623 PARF(175)=DMB(ISU1)/DMB(ISU0)
50624 PARF(176)=DMB(IUS1)/DMB(IUS0)
50625 PARF(177)=DMB(IUD1)
50627 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
50628 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
50629 PARF(187)=DMB(7+IUD1)
50635 C*********************************************************************
50638 C...Generates transverse momentum according to a Gaussian.
50640 SUBROUTINE PYPTDI(KFL,PX,PY)
50642 C...Double precision and integer declarations.
50643 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50644 IMPLICIT INTEGER(I-N)
50645 INTEGER PYK,PYCHGE,PYCOMP
50647 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50650 C...Generate p_T and azimuthal angle, gives p_x and p_y.
50652 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
50653 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
50654 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
50655 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
50663 C*********************************************************************
50666 C...Generates the longitudinal splitting variable z.
50668 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
50670 C...Double precision and integer declarations.
50671 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50672 IMPLICIT INTEGER(I-N)
50673 INTEGER PYK,PYCHGE,PYCOMP
50675 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50676 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50677 SAVE /PYDAT1/,/PYDAT2/
50679 C...Check if heavy flavour fragmentation.
50683 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
50685 C...Lund symmetric scaling function: determine parameters of shape.
50686 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
50687 &MSTJ(11).GE.4) THEN
50689 IF(MSTJ(91).EQ.1) FA=PARJ(43)
50690 IF(KFLB.GE.10) FA=FA+PARJ(45)
50692 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
50695 IF(KFLA.GE.10) FC=FC-PARJ(45)
50696 IF(KFLB.GE.10) FC=FC+PARJ(45)
50697 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
50699 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
50700 FC=FC+FRED*FBB*PARF(100+KFLH)**2
50703 IF(ABS(FC-1D0).GT.0.01D0) MC=2
50705 C...Determine position of maximum. Special cases for a = 0 or a = c.
50706 IF(FA.LT.0.02D0) THEN
50709 IF(FC.GT.FB) ZMAX=FB/FC
50710 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
50715 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
50716 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
50719 C...Subdivide z range if distribution very peaked near endpoint.
50721 IF(ZMAX.LT.0.1D0) THEN
50727 ZDIVC=ZDIV**(1D0-FC)
50728 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
50730 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
50732 FSCB=SQRT(4D0+(FC/FB)**2)
50733 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
50734 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
50735 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
50736 FINT=1D0+FB*(1D0-ZDIV)
50739 C...Choice of z, preweighted for peaks at low or high z.
50743 IF(FINT*PYR(0).LE.1D0) THEN
50745 ELSEIF(MC.EQ.1) THEN
50749 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
50752 ELSEIF(MMAX.EQ.3) THEN
50753 IF(FINT*PYR(0).LE.1D0) THEN
50755 FPRE=EXP(FB*(Z-ZDIV))
50757 Z=ZDIV+Z*(1D0-ZDIV)
50761 C...Weighting according to correct formula.
50762 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
50763 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
50764 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
50765 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
50766 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
50768 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
50770 FC=PARJ(50+MAX(1,KFLH))
50771 IF(MSTJ(91).EQ.1) FC=PARJ(59)
50773 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
50774 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
50775 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
50776 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
50779 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
50780 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
50787 C*********************************************************************
50790 C...Generates timelike parton showers from given partons.
50792 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
50794 C...Double precision and integer declarations.
50795 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50796 IMPLICIT INTEGER(I-N)
50797 INTEGER PYK,PYCHGE,PYCOMP
50798 C...Parameter statement to help give large particle numbers.
50799 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50800 &KEXCIT=4000000,KDIMEN=5000000)
50802 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50803 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50804 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50805 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
50807 DIMENSION PMTH(5,50),PS(5),PMA(19),PMSD(10),IEP(10),IPA(10),
50808 &KFLA(10),KFLD(10),KFL(10),ITRY(10),ISI(10),ISL(10),DP(10),
50809 &DPT(5,4),KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
50810 &PHIIIS(2,2),ISII(2),ISSET(3),ISCOL(0:40),ISCHG(0:40),
50813 C...Check that QMAX not too low.
50814 IF(MSTJ(41).LE.0) THEN
50816 ELSEIF(MSTJ(41).EQ.1) THEN
50817 IF(QMAX.LE.PARJ(82).AND.IP2.GT.-8) RETURN
50819 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GT.-8)
50823 C...Initialization of cutoff masses etc.
50831 PMTH(1,21)=PYMASS(21)
50832 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
50833 PMTH(3,21)=2D0*PMTH(2,21)
50834 PMTH(4,21)=PMTH(3,21)
50835 PMTH(5,21)=PMTH(3,21)
50836 PMTH(1,22)=PYMASS(22)
50837 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
50838 PMTH(3,22)=2D0*PMTH(2,22)
50839 PMTH(4,22)=PMTH(3,22)
50840 PMTH(5,22)=PMTH(3,22)
50842 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
50843 PMQT1E=MIN(PMQTH1,PARJ(90))
50845 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
50846 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
50849 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
50851 PMTH(1,IFL)=PYMASS(IFL)
50852 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
50853 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
50854 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
50855 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
50858 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
50859 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
50860 PMTH(1,IFL)=PYMASS(IFL)
50861 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
50862 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
50863 PMTH(4,IFL)=PMTH(3,IFL)
50864 PMTH(5,IFL)=PMTH(3,IFL)
50866 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
50868 ALFM=LOG(PT2MIN/ALAMS)
50870 C...Store positions of shower initiating partons.
50872 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
50875 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
50880 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
50881 & .AND.IP2.GE.-7) THEN
50886 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
50894 & '(PYSHOW:) failed to reconstruct showering system')
50895 IF(MSTU(21).GE.1) RETURN
50898 C...Check on phase space available for emission.
50906 KFLA(I)=IABS(K(IPA(I),2))
50908 C...Special cutoff masses for initial partons (may be a heavy quark,
50909 C...squark, ..., and need not be on the mass shell).
50911 IF(NPA.LE.1) IREF(I)=IR
50912 IF(NPA.GE.2) IREF(I+1)=IR
50913 IF(KFLA(I).LE.8) THEN
50915 IF(MSTJ(41).GE.2) ISCHG(IR)=1
50916 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
50917 & KFLA(I).EQ.17) THEN
50918 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
50919 ELSEIF(KFLA(I).EQ.21) THEN
50921 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
50922 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
50924 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
50927 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
50929 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
50930 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
50931 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
50932 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
50933 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
50934 ELSEIF(ISCOL(IR).EQ.1) THEN
50935 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
50936 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
50937 PMTH(4,IR)=PMTH(3,IR)
50938 PMTH(5,IR)=PMTH(3,IR)
50939 ELSEIF(ISCHG(IR).EQ.1) THEN
50940 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
50941 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
50942 PMTH(4,IR)=PMTH(3,IR)
50943 PMTH(5,IR)=PMTH(3,IR)
50945 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
50947 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
50949 PS(J)=PS(J)+P(IPA(I),J)
50952 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
50953 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
50954 IF(NPA.EQ.1) PS(5)=PS(4)
50955 IF(PS(5).LE.PM+PMQT1E) RETURN
50957 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
50960 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
50961 KFSRCE=IABS(K(K(IP1,3),2))
50963 IPAR1=MAX(1,K(IP1,3))
50964 IPAR2=MAX(1,K(IP2,3))
50965 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
50966 & KFSRCE=IABS(K(K(IPAR1,3),2))
50969 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
50970 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
50971 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
50972 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
50973 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
50974 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
50975 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
50976 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
50978 C...Identify two primary showerers.
50980 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
50981 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
50982 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
50983 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
50984 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
50985 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
50986 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
50987 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
50989 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
50990 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
50991 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
50992 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
50993 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
50994 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
50995 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
50996 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
50998 C...Order of showerers. Presence of gluino.
50999 ITYPMN=MIN(ITYPE1,ITYPE2)
51000 ITYPMX=MAX(ITYPE1,ITYPE2)
51002 IF(ITYPE1.GT.ITYPE2) IORD=2
51004 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
51006 C...Check if 3-jet matrix elements to be used.
51009 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
51010 IF(MSTJ(38).NE.0) THEN
51014 ELSEIF(MSTJ(47).GE.6) THEN
51020 C...Vector/axial vector -> q + qbar; q -> q + V.
51021 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
51022 & ITYPES.EQ.3)) THEN
51024 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
51026 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
51027 & K(IP1,2)+K(IP2,2).EQ.0)) THEN
51028 C...gamma*/Z0: assume e+e- initial state if unknown.
51030 IF(KFSRCE.EQ.23) THEN
51031 IANNFL=K(K(IP1,3),3)
51032 IF(IANNFL.NE.0) THEN
51033 KANNFL=IABS(K(IANNFL,2))
51034 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
51037 AI=SIGN(1D0,EI+0.1D0)
51038 VI=AI-4D0*EI*PARU(102)
51039 EF=KCHG(KFLA(1),1)/3D0
51040 AF=SIGN(1D0,EF+0.1D0)
51041 VF=AF-4D0*EF*PARU(102)
51042 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
51045 SQWZ=PS(5)*PMAS(23,2)
51046 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
51047 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
51048 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
51049 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
51051 ALPHA=VECT/(VECT+AXIV)
51052 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
51055 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
51056 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
51058 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
51059 & ITYPES.EQ.1)) THEN
51062 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
51063 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
51065 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
51067 ELSEIF(KFSRCE.EQ.36) THEN
51070 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
51071 & ITYPES.EQ.1)) THEN
51074 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
51075 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
51076 & ITYPES.EQ.3)) THEN
51078 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
51079 & ITYPES.EQ.2)) THEN
51081 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
51083 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
51084 & ITYPES.EQ.2)) THEN
51087 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
51088 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
51089 & ITYPES.EQ.5)) THEN
51091 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
51092 & ITYPES.EQ.2)) THEN
51094 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
51095 & ITYPES.EQ.1)) THEN
51098 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
51099 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
51101 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
51102 & ITYPES.EQ.2)) THEN
51104 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
51105 & ITYPES.EQ.1)) THEN
51108 C...g -> ~g + ~g (eikonal approximation).
51109 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
51112 M3JC=5*ICLASS+ICOMBI
51116 C...Find if interference with initial state partons.
51118 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
51119 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
51120 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
51125 KCA=PYCOMP(KFLA(I))
51126 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
51128 IF(KCII(I).NE.0) THEN
51130 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
51131 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
51132 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
51134 IIIS(I,NIIS(I))=ICSI
51139 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
51142 C...Boost interfering initial partons to rest frame
51143 C...and reconstruct their polar and azimuthal angles.
51147 K(N+I,J)=K(IPA(I),J)
51148 P(N+I,J)=P(IPA(I),J)
51152 DO 220 I=3,2+NIIS(1)
51154 K(N+I,J)=K(IIIS(1,I-2),J)
51155 P(N+I,J)=P(IIIS(1,I-2),J)
51159 DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
51161 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
51162 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
51166 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
51167 & -PS(2)/PS(4),-PS(3)/PS(4))
51168 PHI=PYANGL(P(N+1,1),P(N+1,2))
51169 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
51170 THE=PYANGL(P(N+1,3),P(N+1,1))
51171 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
51172 DO 250 I=3,2+NIIS(1)
51173 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
51174 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
51176 DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
51177 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
51178 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
51179 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
51183 C...Boost 3 or more partons to their rest frame.
51184 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
51185 &-PS(2)/PS(4),-PS(3)/PS(4))
51187 C...Define imagined single initiator of shower for parton system.
51189 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
51190 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
51191 IF(MSTU(21).GE.1) RETURN
51210 C...Loop over partons that may branch.
51213 IF(NPA.EQ.1) IM=NS-1
51216 IF(IM.GT.N) GOTO 590
51219 IF(KSH(IR).EQ.0) GOTO 280
51220 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 280
51225 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
51226 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
51227 IF(MSTU(21).GE.1) RETURN
51230 C...Position of aunt (sister to branching parton).
51231 C...Origin and flavour of daughters.
51234 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
51235 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
51247 K(N+I,2)=K(IPA(I),2)
51249 ELSEIF(KFLM.NE.21) THEN
51252 IREF(N+1-NS)=IREF(IM-NS)
51253 IREF(N+2-NS)=IABS(K(N+2,2))
51254 ELSEIF(K(IM,5).EQ.21) THEN
51262 IREF(N+1-NS)=IABS(K(N+1,2))
51263 IREF(N+2-NS)=IABS(K(N+2,2))
51266 C...Reset flags on daughters and tries made.
51271 KFLD(IP)=IABS(K(N+IP,2))
51272 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
51276 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
51280 C...Maximum virtuality of daughters.
51283 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
51284 P(N+I,5)=MIN(QMAX,PS(5))
51286 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
51287 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
51290 IF(MSTJ(43).LE.2) PEM=V(IM,2)
51291 IF(MSTJ(43).GE.3) PEM=P(IM,4)
51292 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
51293 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
51294 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
51298 IF(ISI(I).EQ.1) THEN
51300 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
51302 V(N+I,5)=P(N+I,5)**2
51305 C...Choose one of the daughters for evolution.
51307 IF(NEP.EQ.1) INUM=1
51309 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
51312 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
51314 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
51320 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
51321 RPM=P(N+I,5)/PMSD(I)
51323 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
51331 C...Cancel choice of predetermined daughter already treated.
51334 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
51335 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
51336 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
51337 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
51338 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
51341 C...Store information on choice of evolving daughter.
51345 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
51348 KFL(I)=IABS(K(IEP(I),2))
51350 ITRY(INUM)=ITRY(INUM)+1
51351 IF(ITRY(INUM).GT.200) THEN
51352 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
51353 IF(MSTU(21).GE.1) RETURN
51357 IF(KSH(IR).EQ.0) GOTO 440
51358 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 440
51360 C...Check if evolution already predetermined for daughter.
51362 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
51363 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
51364 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
51365 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
51366 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
51369 IF(IPSPD.NE.0) ISSET(INUM)=1
51371 C...Select side for interference with initial state partons.
51372 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
51375 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
51377 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
51378 IF(PYR(0).GT.0.5D0) ISII(III)=1
51379 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
51381 IF(PYR(0).GT.0.5D0) ISII(III)=2
51385 C...Calculate allowed z range.
51388 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
51391 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
51392 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
51394 IF(MOD(MSTJ(43),2).EQ.1) THEN
51396 ZCE=PMTH(2,22)/PMED
51397 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
51399 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
51400 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
51402 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
51403 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
51404 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
51407 ZCE=MIN(ZCE,0.49991D0)
51408 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
51409 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
51410 P(IEP(1),5)=PMTH(1,IR)
51411 V(IEP(1),5)=P(IEP(1),5)**2
51415 C...Integral of Altarelli-Parisi z kernel for QCD.
51416 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
51418 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
51420 FBR=(1.D0+FMED)*6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
51421 ELSEIF(MSTJ(49).EQ.0) THEN
51423 FBR=(1.D0+FMED)*(8D0/3D0)*LOG((1D0-ZC)/ZC)
51424 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
51426 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
51427 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
51428 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
51429 ELSEIF(MSTJ(49).EQ.1) THEN
51430 FBR=(1D0-2D0*ZC)/3D0
51431 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
51433 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
51434 ELSEIF(KFL(1).EQ.21) THEN
51435 FBR=(1.D0+FMED)*6D0*MSTJ(45)*(0.5D0-ZC)
51437 FBR=(1.D0+FMED)*2D0*LOG((1D0-ZC)/ZC)
51440 C...Reset QCD probability for colourless.
51441 IF(ISCOL(IR).EQ.0) FBR=0D0
51443 C...Integral of Altarelli-Parisi kernel for photon emission.
51445 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
51446 IF(KFL(1).LE.18) THEN
51447 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
51449 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
51452 C...Inner veto algorithm starts. Find maximum mass for evolution.
51453 400 PMS=V(IEP(1),5)
51458 IRI=IREF(IEP(I)-NS)
51459 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
51462 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
51465 C...Select mass for daughter in QCD evolution.
51467 DO 420 IFF=4,MSTJ(45)
51468 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
51470 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
51471 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
51472 C...Already predetermined choice.
51473 IF(IPSPD.NE.0) THEN
51474 PMSQCD=P(IPSPD,5)**2
51475 ELSEIF(FBR.LT.1D-3) THEN
51477 ELSEIF(MSTJ(44).LE.0) THEN
51478 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
51479 ELSEIF(MSTJ(44).EQ.1) THEN
51480 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
51482 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
51484 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
51485 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
51486 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
51490 C...Select mass for daughter in QED evolution.
51491 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
51492 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
51493 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
51494 IF(FBRE.LT.1D-3) THEN
51497 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
51498 & (PARU(101)*FBRE)))
51500 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
51501 PMSQED=PMSQED+PMTH(1,IR)**2
51502 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
51504 IF(PMSQED.GT.PMSQCD) THEN
51510 C...Check whether daughter mass below cutoff.
51511 P(IEP(1),5)=SQRT(V(IEP(1),5))
51512 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
51513 P(IEP(1),5)=PMTH(1,IR)
51514 V(IEP(1),5)=P(IEP(1),5)**2
51518 C...Already predetermined choice of z, and flavour in g -> qqbar.
51519 IF(IPSPD.NE.0) THEN
51522 PMSGD1=P(IPSGD1,5)**2
51523 PMSGD2=P(IPSGD2,5)**2
51524 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
51525 & 4D0*PMSGD1*PMSGD2))
51526 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
51527 & PMSGD1+PMSGD2)/ALAMPS
51528 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
51529 IF(KFL(1).NE.21) THEN
51532 K(IEP(1),5)=IABS(K(IPSGD1,2))
51535 C...Select z value of branching: q -> qgamma.
51536 ELSEIF(MCE.EQ.2) THEN
51537 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
51538 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 400
51541 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
51542 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
51543 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
51544 C...Only do z weighting when no ME correction afterwards.
51545 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 400
51547 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
51548 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
51549 IF(PYR(0).GT.0.5D0) Z=1D0-Z
51550 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 400
51552 ELSEIF(MSTJ(49).NE.1) THEN
51554 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 400
51555 KFLB=1+INT(MSTJ(45)*PYR(0))
51556 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
51557 IF(PMQ.GE.1D0) GOTO 400
51558 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
51559 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 400
51560 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
51561 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
51562 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 400
51564 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 400
51568 C...Ditto for scalar gluon model.
51569 ELSEIF(KFL(1).NE.21) THEN
51570 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
51572 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
51573 Z=ZC+(1D0-2D0*ZC)*PYR(0)
51576 Z=ZC+(1D0-2D0*ZC)*PYR(0)
51577 KFLB=1+INT(MSTJ(45)*PYR(0))
51578 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
51579 IF(PMQ.GE.1D0) GOTO 400
51583 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
51584 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
51585 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
51586 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51587 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 400
51589 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
51590 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
51591 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
51592 IF(PT2APP.LT.PT2MIN) GOTO 400
51593 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 400
51597 C...Check if z consistent with chosen m.
51598 IF(KFL(1).EQ.21) THEN
51599 IRGD1=IABS(K(IEP(1),5))
51603 IRGD2=IABS(K(IEP(1),5))
51607 ELSEIF(NEP.GE.3) THEN
51609 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
51610 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
51612 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
51613 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
51615 IF(MOD(MSTJ(43),2).EQ.1) THEN
51616 PMQTH3=0.5D0*PARJ(82)
51617 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
51618 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
51619 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
51620 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
51621 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
51625 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
51628 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
51629 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51630 ELSEIF(IPSPD.NE.0) THEN
51634 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 400
51636 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
51638 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
51640 C...Width suppression for q -> q + g.
51641 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
51643 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
51647 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
51648 IF(MSTJ(40).EQ.1) THEN
51649 IF(CHI.LT.PYR(0)) GOTO 400
51650 ELSEIF(MSTJ(40).EQ.2) THEN
51651 IF(1D0-CHI.LT.PYR(0)) GOTO 400
51655 C...Three-jet matrix element correction.
51660 C...QED matrix elements: only for massless case so far.
51661 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
51662 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
51663 X2=1D0-V(IEP(1),5)/V(NS+1,5)
51664 X3=(1D0-X1)+(1D0-X2)
51666 KI2=K(IPA(3-INUM),2)
51667 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
51668 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
51669 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
51670 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
51671 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
51672 ELSEIF(MCE.EQ.2) THEN
51674 C...QCD matrix elements, including mass effects.
51675 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
51679 IF(IR.GE.31.AND.IGM.EQ.0) THEN
51680 C...QCD ME: original parton, first branching.
51681 PM2ME=PMTH(1,63-IR)
51683 ELSEIF(IR.GE.31) THEN
51684 C...QCD ME: original parton, subsequent branchings.
51685 PM2ME=PMTH(1,63-IR)
51686 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
51687 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
51688 ELSEIF(K(IM,2).EQ.21) THEN
51689 C...QCD ME: secondary partons, first branching.
51692 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
51693 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
51694 & 4D0*PS1ME*PM2ME**2))
51695 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
51697 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
51700 C...QCD ME: secondary partons, subsequent branchings.
51702 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
51703 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
51706 C...Construct ME variables.
51709 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
51710 X2=1D0+R2ME**2-PS1ME/ECMME**2
51711 C...Call ME, with right order important for two inequivalent showerers.
51712 IF(IR.EQ.IORD+30) THEN
51713 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
51715 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
51717 C...Split up total ME when two radiating partons.
51719 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
51720 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
51721 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
51722 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
51723 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
51724 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
51725 & MAX(1D-10,2D0-X1-X2)
51726 C...Evaluate shower rate to be compared with.
51727 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
51728 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
51729 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
51730 ELSEIF(MSTJ(49).NE.1) THEN
51732 C...Toy model scalar theory matrix elements; no mass effects.
51734 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
51735 X2=1D0-V(IEP(1),5)/V(NS+1,5)
51736 X3=(1D0-X1)+(1D0-X2)
51737 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
51739 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
51743 IF(WME.LT.PYR(0)*WSHOW) GOTO 400
51746 C...Impose angular ordering by rejection of nonordered emission.
51747 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
51748 PEMAO=V(IM,1)*P(IM,4)
51749 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
51750 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
51752 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
51753 & .OR.MSTJ(42).EQ.7)) THEN
51755 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
51756 & .OR.MSTJ(42).EQ.6)) THEN
51758 PMDAO=PMTH(2,K(IEP(1),5))
51759 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
51762 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
51763 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
51764 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
51768 430 IF(K(IAOM,5).EQ.22) THEN
51770 IF(K(IAOM,3).LE.NS) MAOM=0
51771 IF(MAOM.EQ.1) GOTO 430
51773 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
51774 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
51775 IF(THE2ID.LT.THE2IM) GOTO 400
51779 C...Impose user-defined maximum angle at first branching.
51780 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
51781 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
51782 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
51783 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400
51784 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
51785 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
51786 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400
51787 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
51788 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
51789 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 400
51793 C...Impose angular constraint in first branching from interference
51794 C...with initial state partons.
51795 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
51796 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
51797 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
51798 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 400
51799 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
51800 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 400
51804 C...End of inner veto algorithm. Check if only one leg evolved so far.
51808 IF(NEP.EQ.1) GOTO 480
51809 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 340
51812 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
51813 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 340
51817 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
51821 PMSUM=PMSUM+P(N+I,5)
51823 IF(PMSUM.GE.PS(5)) GOTO 340
51824 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
51827 IF(KSH(IRDA).EQ.0) GOTO 470
51828 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 470
51829 IF(IRDA.EQ.21) THEN
51830 IRGD1=IABS(K(I1,5))
51834 IRGD2=IABS(K(I1,5))
51837 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
51838 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
51840 IF(I1.EQ.N+1) ZM=V(IM,1)
51841 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
51842 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
51843 & 4D0*V(N+1,5)*V(N+2,5))
51844 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
51847 IF(MOD(MSTJ(43),2).EQ.1) THEN
51848 PMQTH3=0.5D0*PARJ(82)
51849 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
51850 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
51851 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
51852 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
51853 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
51857 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
51860 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
51861 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51865 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
51866 & ISSET(1).EQ.0) THEN
51868 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
51869 & ISSET(2).EQ.0) THEN
51873 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
51875 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
51877 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
51880 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
51881 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
51882 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
51883 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
51884 IF(ISL(1).EQ.1) ISL(2)=0
51885 IF(ISL(1).EQ.0) ISLM=1
51886 IF(ISL(2).EQ.0) ISLM=2
51888 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 340
51893 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
51894 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
51895 PMQ1=V(N+1,5)/V(IM,5)
51896 PMQ2=V(N+2,5)/V(IM,5)
51897 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
51902 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 340
51906 C...Accepted branch. Construct four-momentum for initial partons.
51912 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
51914 P(N+1,4)=P(IPA(1),4)
51916 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
51917 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
51920 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
51925 P(N+2,4)=P(IM,5)-PED1
51928 ELSEIF(NEP.GE.3) THEN
51929 C...Rescale all momenta for energy conservation.
51935 P(N+I,J)=P(IPA(I),J)
51938 PQS=PQS+P(N+I,5)**2/P(N+I,4)
51941 FAC=(PS(5)-PQS)/(PES-PQS)
51946 P(N+I,J)=FAC*P(N+I,J)
51948 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)
51951 PQS=PQS+P(N+I,5)**2/P(N+I,4)
51953 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 510
51955 C...Construct transverse momentum for ordinary branching in shower.
51959 540 LOOPPT=LOOPPT+1
51960 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
51961 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
51962 IF(PZM.LE.0D0) THEN
51964 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
51965 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51966 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
51967 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
51968 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
51969 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
51971 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
51973 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
51976 ELSEIF(PTS.LT.0D0) THEN
51979 PT=SQRT(MAX(0D0,PTS))
51981 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
51983 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
51984 & .AND.IAU.NE.0) THEN
51985 IF(K(IGM,3).NE.0) MAZIP=1
51987 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
51988 IF(MAZIP.EQ.0) ZAU=0D0
51989 IF(K(IGM,2).NE.21) THEN
51990 HAZIP=2D0*ZAU/(1D0+ZAU**2)
51992 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
51994 IF(K(N+1,2).NE.21) THEN
51995 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
51997 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
52001 C...Find coefficient of azimuthal asymmetry due to soft gluon
52004 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
52005 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
52006 IF(K(IGM,3).NE.0) MAZIC=N+1
52007 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
52008 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
52009 & ZM.GT.0.5D0) MAZIC=N+2
52010 IF(K(IAU,2).EQ.22) MAZIC=0
52012 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
52014 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
52015 IF(MAZIC.EQ.0) ZGM=1D0
52016 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
52017 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
52018 HAZIC=MIN(0.95D0,HAZIC)
52022 C...Construct energies for ordinary branching in shower.
52023 550 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
52024 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
52025 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
52026 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
52027 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
52028 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
52029 P(N+1,4)=PEM*V(IM,1)
52031 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
52032 & SQRT(PMLS)*ZM)/V(IM,5)
52035 C...Already predetermined choice of phi angle or not
52037 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
52039 IF(K(IPSPD,4).GT.0) THEN
52041 IF(IM.EQ.NS+2) THEN
52042 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
52044 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
52047 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
52049 IF(K(IPSPD,4).GT.0) THEN
52051 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
52052 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
52053 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
52054 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
52055 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
52056 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
52060 C...Construct momenta for ordinary branching in shower.
52061 P(N+1,1)=PT*COS(PHI)
52062 P(N+1,2)=PT*SIN(PHI)
52063 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
52064 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
52065 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
52066 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
52067 ELSEIF(PZM.GT.0D0) THEN
52068 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
52069 & 2D0*PEM*P(N+1,4))/PZM
52075 P(N+2,3)=PZM-P(N+1,3)
52076 P(N+2,4)=PEM-P(N+1,4)
52077 IF(MSTJ(43).LE.2) THEN
52078 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
52079 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
52083 C...Rotate and boost daughters.
52085 IF(MSTJ(43).LE.2) THEN
52086 BEX=P(IGM,1)/P(IGM,4)
52087 BEY=P(IGM,2)/P(IGM,4)
52088 BEZ=P(IGM,3)/P(IGM,4)
52089 GA=P(IGM,4)/P(IGM,5)
52090 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
52099 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
52100 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
52101 IF(PTIMB.GT.1D-4) THEN
52102 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
52107 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
52108 & SIN(THE)*COS(PHI)*P(I,3)
52109 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
52110 & SIN(THE)*SIN(PHI)*P(I,3)
52111 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
52113 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
52114 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
52115 P(I,1)=DP(1)+DGABP*BEX
52116 P(I,2)=DP(2)+DGABP*BEY
52117 P(I,3)=DP(3)+DGABP*BEZ
52118 P(I,4)=GA*(DP(4)+DBP)
52122 C...Weight with azimuthal distribution, if required.
52123 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
52129 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
52130 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
52131 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
52133 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
52134 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
52136 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
52137 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
52138 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
52139 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
52140 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
52141 IF(MAZIP.NE.0) THEN
52142 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
52145 IF(MAZIC.NE.0) THEN
52146 IF(MAZIC.EQ.N+2) CAD=-CAD
52147 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
52148 & .LT.PYR(0)) GOTO 550
52153 C...Azimuthal anisotropy due to interference with initial state partons.
52154 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
52155 &K(N+2,2).EQ.21)) THEN
52157 IF(ISII(III).GE.1) THEN
52159 IF(K(N+1,2).NE.21) IAZIID=N+2
52160 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
52161 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
52162 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
52163 IF(III.EQ.2) THEIID=PARU(1)-THEIID
52164 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
52165 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
52166 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
52167 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
52168 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
52169 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
52170 & .LT.PYR(0)) GOTO 550
52174 C...Continue loop over partons that may branch, until none left.
52175 IF(IGM.GE.0) K(IM,1)=14
52178 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
52179 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
52180 IF(MSTU(21).GE.1) N=NS
52181 IF(MSTU(21).GE.1) RETURN
52185 C...Set information on imagined shower initiator.
52186 590 IF(NPA.GE.2) THEN
52190 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
52198 C...Reconstruct string drawing information.
52199 DO 600 I=NS+1+IIM,N
52200 KQ=KCHG(PYCOMP(K(I,2)),2)
52201 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
52203 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
52204 & IABS(K(I,2)).LE.18) THEN
52206 ELSEIF(K(I,1).LE.10) THEN
52207 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
52208 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
52209 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
52210 ID1=MOD(K(I,4),MSTU(5))
52211 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
52212 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
52213 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
52214 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
52215 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
52216 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
52217 K(ID1,4)=K(ID1,4)+MSTU(5)*I
52218 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
52219 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
52220 K(ID2,5)=K(ID2,5)+MSTU(5)*I
52222 ID1=MOD(K(I,4),MSTU(5))
52224 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
52225 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
52226 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
52227 K(ID1,4)=K(ID1,4)+MSTU(5)*I
52228 K(ID1,5)=K(ID1,5)+MSTU(5)*I
52238 C...Transformation from CM frame.
52240 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
52241 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
52243 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
52244 ELSEIF(NPA.EQ.2) THEN
52249 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
52250 & /(1D0+GA)-P(IPA(1),4))
52251 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
52252 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
52253 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
52255 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
52257 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
52260 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
52263 C...Decay vertex of shower.
52270 C...Delete trivial shower, else connect initiators.
52271 IF(N.LE.NS+NPA+IIM) THEN
52276 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
52277 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
52278 K(NS+IIM+IP,3)=IPA(IP)
52279 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
52280 IF(K(NS+IIM+IP,1).NE.1) THEN
52281 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
52282 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
52290 C*********************************************************************
52293 C...Auxiliary to PYSHOW.
52294 C...Matrix elements for gluon (or photon) emission from
52295 C...a two-body state; to be used by the parton shower routine.
52296 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
52297 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
52298 C... = (alpha-strong/2 pi) * CF * PYMAEL,
52299 C...i.e. normalization is such that one recovers the familiar
52300 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
52301 C...Coupling structure:
52302 C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
52303 C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
52304 C... = 16-19 : q -> q V
52305 C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
52306 C... = 26-29 : q -> q S
52307 C... = 31-34 : V -> ~q ~qbar (~q = squark)
52308 C... = 36-39 : ~q -> ~q V
52309 C... = 41-44 : S -> ~q ~qbar
52310 C... = 46-49 : ~q -> ~q S
52311 C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
52312 C... = 56-59 : ~q -> q chi
52313 C... = 61-64 : q -> ~q chi
52314 C... = 66-69 : ~g -> q ~qbar
52315 C... = 71-74 : ~q -> q ~g
52316 C... = 76-79 : q -> ~q ~g
52317 C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
52318 C...Note that the order of the decay products is important.
52319 C...In each set of four, the variants are ordered as:
52320 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
52321 C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
52322 C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
52323 C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
52325 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
52327 C...Double precision and integer declarations.
52328 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52329 IMPLICIT INTEGER(I-N)
52331 C...Check input values. Return zero outside allowed phase space.
52333 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
52334 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
52335 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
52336 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
52337 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
52338 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
52340 C...Initial values and flags.
52348 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
52350 C...Eikonal expression; also acts as default.
52351 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
52353 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
52355 ELSEIF(ICOMBI.EQ.2) THEN
52356 ANUM=(2D0-X1-X2)**2
52357 ELSEIF(ICOMBI.EQ.3) THEN
52358 ANUM=ALPCOR*(2D0-X1-X2)**2
52360 ANUM=0.5D0*(2D0-X1-X2)**2
52362 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
52363 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
52364 & R1**2/(1D0+R2**2-R1**2-X2)**2-
52365 & R2**2/(1D0+R1**2-R2**2-X1)**2)
52368 C...V -> q qbar (V = gamma*/Z0/W+-/...).
52369 ELSEIF(ICLASS.EQ.2) THEN
52370 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52371 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
52372 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
52373 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
52374 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
52375 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
52376 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
52377 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
52378 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
52379 & (-1+R1**2-R2**2+X2)**2
52380 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
52381 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
52382 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
52383 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
52384 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
52385 & -X1-X2)**2+X1*(2-X1-X2)**2)/
52386 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52387 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
52388 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
52389 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
52390 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
52391 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
52395 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52396 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
52397 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
52398 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
52399 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
52400 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
52401 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
52402 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
52403 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
52404 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
52405 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
52406 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
52407 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
52408 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
52409 & -X1-X2)**2+X1*(2-X1-X2)**2)/
52410 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52411 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
52412 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
52413 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
52414 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
52415 & +X2)/(-1-R1**2+R2**2+X1)**2
52419 IF(ICOMBI.EQ.4) THEN
52420 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
52421 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
52422 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
52423 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
52424 & (-1-R1**2+R2**2+X1)**2
52426 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
52427 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
52428 & -R1**2*X2**2+X1*X2**2)/
52429 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52430 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
52431 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
52432 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
52433 & (-1+R1**2-R2**2+X2)**2
52439 ELSEIF(ICLASS.EQ.3) THEN
52440 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52441 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
52442 & +R1**2*R2**2-2D0*R2**4)
52443 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
52444 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
52445 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
52446 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
52447 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
52448 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
52449 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
52450 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
52451 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
52452 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
52453 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
52454 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
52455 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
52456 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
52457 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
52458 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
52459 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
52460 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
52461 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
52464 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52465 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
52466 & +R1**2*R2**2-2D0*R2**4)
52467 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
52468 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
52469 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
52470 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
52471 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
52472 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
52473 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52474 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
52475 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
52476 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
52477 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
52478 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
52479 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
52480 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
52481 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
52482 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
52483 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
52484 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
52485 & +X1*X2**2)/(-2+X1+X2)**2
52488 IF(ICOMBI.EQ.4) THEN
52489 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
52490 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
52491 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
52492 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
52493 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
52494 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52495 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
52496 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
52497 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
52498 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
52499 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
52500 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
52501 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
52502 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
52503 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
52504 & +X1*X2**2)/(2-X1-X2)**2
52508 C...S -> q qbar (S = h0/H0/A0/H+-/...).
52509 ELSEIF(ICLASS.EQ.4) THEN
52510 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52511 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
52512 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52513 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52514 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52515 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
52516 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
52517 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52518 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52519 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
52520 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52523 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52524 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
52525 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52526 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52527 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52528 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52529 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
52530 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52531 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
52532 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
52533 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
52534 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52537 IF(ICOMBI.EQ.4) THEN
52538 RLO4=PS*(1D0-R1**2-R2**2)
52539 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
52540 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52541 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
52542 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
52543 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52544 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
52545 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52550 ELSEIF(ICLASS.EQ.5) THEN
52551 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52552 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
52553 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
52554 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
52555 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
52556 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52557 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
52558 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
52559 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52560 & (-1+R1**2-R2**2+X2)**2
52563 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52564 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
52565 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
52566 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
52567 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
52568 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52569 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
52570 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
52571 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52572 & (-1+R1**2-R2**2+X2)**2
52575 IF(ICOMBI.EQ.4) THEN
52576 RLO4=PS*(1D0+R1**2-R2**2)
52577 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
52578 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
52579 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
52580 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
52581 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
52582 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
52586 C...V -> ~q ~qbar (~q = squark).
52587 ELSEIF(ICLASS.EQ.6) THEN
52588 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
52589 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
52590 & (-1-R1**2+R2**2+X1)**2
52591 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
52592 & (-1-R1**2+R2**2+X1)
52593 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
52594 & /(-1+R1**2-R2**2+X2)**2
52595 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
52596 & (-1+R1**2-R2**2+X2)
52597 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
52598 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
52599 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
52600 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52604 ELSEIF(ICLASS.EQ.7) THEN
52605 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
52606 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
52607 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
52608 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
52609 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
52610 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
52611 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
52612 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
52613 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
52614 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
52615 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
52621 ELSEIF(ICLASS.EQ.8) THEN
52623 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
52624 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
52625 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
52626 & -R1**2*X2**2+X1*X2**2)/
52627 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
52632 ELSEIF(ICLASS.EQ.9) THEN
52634 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
52635 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52636 & -(X1+X2)/(-2+X1+X2)**2
52639 C...chi -> q ~qbar (chi = neutralino/chargino).
52640 ELSEIF(ICLASS.EQ.10) THEN
52641 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52642 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
52643 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
52644 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
52645 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
52646 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52647 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
52648 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52649 & (-1+R1**2-R2**2+X2)**2
52652 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52653 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
52654 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
52655 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
52656 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
52657 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52658 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
52659 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52660 & (-1+R1**2-R2**2+X2)**2
52663 IF(ICOMBI.EQ.4) THEN
52664 RLO4=PS*(1+R1**2-R2**2)
52665 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
52666 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
52667 & +X2+R1**2*X2-X1*X2/2)/
52668 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52669 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
52670 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
52675 ELSEIF(ICLASS.EQ.11) THEN
52676 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52677 RLO1=PS*(1D0-(R1+R2)**2)
52678 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
52679 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52680 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
52681 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52682 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
52683 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
52684 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52687 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52688 RLO2=PS*(1D0-(R1-R2)**2)
52689 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
52691 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52692 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
52693 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52694 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
52695 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
52696 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52699 IF(ICOMBI.EQ.4) THEN
52700 RLO4=PS*(1D0-R1**2-R2**2)
52701 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
52702 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
52703 & +3*R1**2*X2-R2**2*X2-X1*X2)/
52704 & (-1+R1**2-R2**2+X2)**2
52705 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
52706 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
52707 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52712 ELSEIF(ICLASS.EQ.12) THEN
52713 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52714 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
52715 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
52716 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
52717 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
52718 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
52719 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
52720 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52723 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52724 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
52725 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
52726 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
52727 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
52728 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
52729 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
52730 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52733 IF(ICOMBI.EQ.4) THEN
52734 RLO4=PS*(1D0-R1**2+R2**2)
52735 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
52736 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
52737 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
52738 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
52739 & +R1**2*X2-X1*X2/2-X2**2/2)/
52740 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52745 ELSEIF(ICLASS.EQ.13) THEN
52746 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52747 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
52748 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
52749 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
52750 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
52751 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
52752 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
52753 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
52754 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
52755 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
52756 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
52757 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
52758 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
52759 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52760 & (3*(-1+R1**2-R2**2+X2)**2)
52764 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52765 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
52766 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
52767 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
52768 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
52769 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
52770 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
52771 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
52772 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
52773 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
52774 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
52775 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52776 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
52777 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
52778 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52779 & (3*(-1+R1**2-R2**2+X2)**2)
52783 IF(ICOMBI.EQ.4) THEN
52784 RLO4=PS*(1D0+R1**2-R2**2)
52785 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
52786 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
52787 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
52788 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
52789 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
52790 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52791 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
52792 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52793 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
52794 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52795 & (3*(-1+R1**2-R2**2+X2)**2)
52801 ELSEIF(ICLASS.EQ.14) THEN
52802 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52803 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
52804 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
52805 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52806 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52807 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
52808 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
52809 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
52810 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
52811 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52812 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
52813 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
52814 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
52815 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
52816 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
52818 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
52819 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
52820 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52824 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52825 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
52826 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
52827 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52828 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52829 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
52830 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
52831 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
52832 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
52833 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
52834 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
52835 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
52837 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
52838 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
52839 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
52840 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
52841 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
52842 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52846 IF(ICOMBI.EQ.4) THEN
52847 RLO4=PS*(1-R1**2-R2**2)
52848 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
52849 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
52850 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52851 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
52852 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
52853 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
52854 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
52855 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
52856 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
52857 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
52858 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
52859 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
52860 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
52861 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
52862 RFO4=9D0*RFO4/128D0
52867 ELSEIF(ICLASS.EQ.15) THEN
52868 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52869 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
52870 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
52871 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
52872 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
52873 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
52874 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
52875 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
52876 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
52877 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
52878 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
52879 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
52880 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
52881 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
52882 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
52883 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52887 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52888 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
52889 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
52890 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
52891 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
52892 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
52893 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
52894 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
52895 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
52896 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
52897 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
52898 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
52899 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
52900 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
52901 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
52902 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52906 IF(ICOMBI.EQ.4) THEN
52907 RLO4=PS*(1D0-R1**2+R2**2)
52908 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
52909 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
52910 & -R2**2*X2/2-X1*X2/2)/
52911 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
52912 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
52913 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
52914 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
52915 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
52916 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
52917 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
52918 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
52919 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52924 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
52925 ELSEIF(ICLASS.EQ.16) THEN
52927 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
52929 ELSEIF(ICOMBI.EQ.2) THEN
52930 ANUM=(2D0-X1-X2)**2
52931 ELSEIF(ICOMBI.EQ.3) THEN
52932 ANUM=ALPCOR*(2D0-X1-X2)**2
52934 ANUM=0.5D0*(2D0-X1-X2)**2
52936 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
52937 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
52938 & R1**2/(1D0+R2**2-R1**2-X2)**2-
52939 & R2**2/(1D0+R1**2-R2**2-X1)**2)
52944 C...Find relevant LO and FO expression.
52945 IF(ICOMBI.EQ.0) THEN
52946 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
52949 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
52952 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
52953 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
52954 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
52955 ELSEIF(ISSET4.EQ.1) THEN
52958 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
52959 RLO=0.5D0*(RLO1+RLO2)
52960 RFO=0.5D0*(RFO1+RFO2)
52961 ELSEIF(ISSET1.EQ.1) THEN
52965 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
52976 C*********************************************************************
52979 C...Modifies an event so as to approximately take into account
52980 C...Bose-Einstein effects according to a simple phenomenological
52981 C...parametrization.
52983 SUBROUTINE PYBOEI(NSAV)
52985 C...Double precision and integer declarations.
52986 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52987 IMPLICIT INTEGER(I-N)
52988 INTEGER PYK,PYCHGE,PYCOMP
52989 C...Parameter statement to help give large particle numbers.
52990 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52991 &KEXCIT=4000000,KDIMEN=5000000)
52993 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52994 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52995 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52996 COMMON/PYINT1/MINT(400),VINT(400)
52997 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
52998 C...Local arrays and data.
52999 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
53000 &BEIW(100),BEI3W(100)
53001 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
53002 C...Statement function: squared invariant mass.
53003 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
53004 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
53006 C...Boost event to overall CM frame. Calculate CM energy.
53007 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
53013 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
53014 & .AND.K(I,3).GT.0) THEN
53015 KFMA=IABS(K(K(I,3),2))
53016 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
53018 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
53020 DPS(J)=DPS(J)+P(I,J)
53023 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
53027 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
53030 C...Check if we have separated strings
53032 C...Reserve copy of particles by species at end of record.
53038 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
53039 NBE(IBE)=NBE(IBE-1)
53041 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
53042 DO 140 IIBE=1,IBE-1
53043 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
53046 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
53048 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
53049 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
53050 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
53053 NBE(IBE)=NBE(IBE)+1
53060 P(NBE(IBE),1)=0.0D0
53061 P(NBE(IBE),2)=0.0D0
53062 P(NBE(IBE),3)=0.0D0
53063 P(NBE(IBE),4)=0.0D0
53064 P(NBE(IBE),5)=0.0D0
53065 SMMIN=MIN(SMMIN,P(I,5))
53066 C...Check if particles comes from different W's or Z's
53067 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
53069 150 IF(K(IM,3).GT.0) THEN
53071 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
53073 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
53074 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
53075 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
53076 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
53079 C...Check if particles comes from different strings.
53080 IF(PARJ(94).GT.0.0D0) THEN
53082 160 IF(K(IM,3).GT.0) THEN
53084 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
53092 P(NBE(IBE),5)=-1.0D0
53095 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
53097 C...Calculate separation between W+ and W- or between two Z0's.
53098 C...No separation if there has been re-connections.
53100 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
53101 IF(K(IWP,2).EQ.23) THEN
53110 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
53111 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
53112 TAUP=-TAUPD*LOG(PYR(IDUM))
53113 TAUN=-TAUND*LOG(PYR(IDUM))
53114 DXP=TAUP*PYP(IWP,8)/DMP
53115 DXN=TAUN*PYP(IWN,8)/DMN
53117 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
53118 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
53121 C...Add separation between strings.
53122 IF(PARJ(94).GT.0.0D0) THEN
53123 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
53128 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
53129 DO 220 IBE=1,MIN(9,MSTJ(52))
53130 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
53133 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
53134 IF(I2M.EQ.I1M) GOTO 200
53136 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
53137 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
53138 & (P(I1,5)+P(I2,5))**2
53139 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
53148 C...Tabulate integral for subsequent momentum shift.
53149 DO 400 IBE=1,MIN(9,MSTJ(52))
53150 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
53151 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
53153 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
53154 & NBE(7)-NBE(6)).LE.1) GOTO 270
53155 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
53156 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
53157 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
53158 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
53159 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
53160 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
53161 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
53162 QDELW=0.1D0*MIN(PMHQ,SIGW)
53163 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
53164 IF(MSTJ(51).EQ.1) THEN
53165 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
53166 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
53167 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
53168 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
53169 BEEX=EXP(0.5D0*QDEL/PARJ(93))
53170 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
53171 BEEXW=EXP(0.5D0*QDELW/SIGW)
53172 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
53173 BERT=EXP(-QDEL/PARJ(93))
53174 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
53175 BERTW=EXP(-QDELW/SIGW)
53176 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
53178 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
53179 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
53180 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
53181 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
53184 QBIN=QDEL*(IBIN-0.5D0)
53185 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
53186 IF(MSTJ(51).EQ.1) THEN
53188 BEI(IBIN)=BEI(IBIN)*BEEX
53190 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
53192 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
53194 DO 240 IBIN=1,NBIN3
53195 QBIN=QDEL3*(IBIN-0.5D0)
53196 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
53197 IF(MSTJ(51).EQ.1) THEN
53199 BEI3(IBIN)=BEI3(IBIN)*BEEX3
53201 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
53203 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
53205 DO 250 IBIN=1,NBINW
53206 QBIN=QDELW*(IBIN-0.5D0)
53207 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
53208 IF(MSTJ(51).EQ.1) THEN
53210 BEIW(IBIN)=BEIW(IBIN)*BEEXW
53212 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
53214 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
53216 DO 260 IBIN=1,NBIN3W
53217 QBIN=QDEL3W*(IBIN-0.5D0)
53218 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
53219 & SQRT(QBIN**2+PMHQ**2)
53220 IF(MSTJ(51).EQ.1) THEN
53221 BEEX3W=BEEX3W*BERT3W
53222 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
53224 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
53226 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
53229 C...Loop through particle pairs and find old relative momentum.
53230 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
53232 DO 380 I2M=I1M+1,NBE(IBE)
53233 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
53234 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
53236 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
53237 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
53238 IF(Q2OLD.LE.0.0D0) GOTO 380
53241 C...Calculate new relative momentum.
53246 IF(QOLD.LT.1D-3*QDEL) THEN
53248 ELSEIF(QOLD.LE.QDEL) THEN
53250 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
53253 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
53254 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
53255 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
53257 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53259 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
53260 IF(QOLD.LT.1D-3*QDEL3) THEN
53262 ELSEIF(QOLD.LE.QDEL3) THEN
53264 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
53267 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
53268 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
53269 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
53271 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53273 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
53276 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
53277 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
53278 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
53280 IF(QOLD.LT.1D-3*QDELW) THEN
53282 ELSEIF(QOLD.LE.QDELW) THEN
53284 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
53287 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
53288 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
53289 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
53291 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53293 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
53294 IF(QOLD.LT.1D-3*QDEL3W) THEN
53296 ELSEIF(QOLD.LE.QDEL3W) THEN
53298 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
53301 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
53302 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
53303 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53305 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53307 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
53309 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
53311 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
53313 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
53314 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
53316 IF(MSTJ(54).GE.1) THEN
53317 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
53319 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
53320 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
53322 ELSEIF(MSTJ(54).LE.-1) THEN
53323 EDEL=P(I1,4)+P(I2,4)-
53324 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
53325 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
53326 & (P(I1,3)-P(I2,3))**2
53331 SM1=(P(I1,5)+SMMIN)**2
53332 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
53333 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
53334 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
53335 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
53336 & K(I3M,5).NE.K(I1M,5)) GOTO 360
53338 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
53341 SM3=(P(I3,5)+SMMIN)**2
53342 IF(MSTJ(54).EQ.-2) THEN
53343 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
53344 & S23*MIN(SM1,SM3))*SM1)
53346 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
53347 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
53348 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
53349 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
53351 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
53352 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
53355 IF(WMAX*WI.GE.1.0) GOTO 360
53357 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
53358 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
53359 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
53360 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
53361 & K(I4M,5).NE.K(I1M,5)) GOTO 350
53363 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
53365 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
53366 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
53367 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
53369 IF(MSTJ(54).EQ.-2) THEN
53373 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
53374 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
53375 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
53376 W=MIN(W,MIN(S23,S24)*S13*S14)
53379 C...weight=1-cos(theta)/mtot2
53380 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
53381 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
53382 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
53383 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
53385 IF(W.LE.WMAX) GOTO 350
53387 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
53388 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
53389 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
53390 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
53391 IF(W.LE.WMAX) GOTO 350
53397 IF(MI4.EQ.0) GOTO 380
53400 EOLD=P(I3,4)+P(I4,4)
53402 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
53403 & (P(I3,3)+P(I4,3))**2
53404 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
53405 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
53406 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
53408 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
53409 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
53416 C...Shift momenta and recalculate energies.
53420 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
53424 P(I,J)=P(I,J)+P(IM,J)
53426 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53429 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
53434 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
53435 440 ALPHA=(ESUMP-ESUM)/PROD
53436 PARJ(96)=PARJ(96)+ALPHA
53439 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
53442 P(I,J)=P(I,J)+ALPHA*V(IM,J)
53444 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53447 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
53450 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
53454 C...Rescale all momenta for energy conservation.
53458 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
53460 PQS=PQS+P(I,5)**2/P(I,4)
53463 FAC=(PECM-PQS)/(PES-PQS)
53465 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
53469 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53472 C...Boost back to correct reference frame.
53473 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
53475 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
53481 C*********************************************************************
53484 C...Calculates the momentum shift in a system of two particles assuming
53485 C...the relative momentum squared should be shifted to Q2NEW. NI is the
53486 C...last position occupied in /PYJETS/.
53488 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
53490 C...Double precision and integer declarations.
53491 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53492 IMPLICIT INTEGER(I-N)
53493 INTEGER PYK,PYCHGE,PYCOMP
53494 C...Parameter statement to help give large particle numbers.
53495 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53496 &KEXCIT=4000000,KDIMEN=5000000)
53498 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53499 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53500 SAVE /PYJETS/,/PYDAT1/
53501 C...Local arrays and data.
53505 IF(MSTJ(55).EQ.0) THEN
53507 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
53508 & (P(I1,3)-P(I2,3))**2
53509 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
53510 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
53514 DA=SE*DE*DP12-DP2*DQ2SE
53515 DB=DP2*DQ2SE-DP12**2
53516 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
53518 PD=HA*(P(I1,J)-P(I2,J))
53530 DP(J)=P(I1,J)+P(I2,J)
53533 C...Boost to cms and rotate first particle to z-axis
53534 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
53535 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
53536 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
53537 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
53538 S=Q2NEW+(P(I1,5)+P(I2,5))**2
53539 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
53543 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
53547 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
53548 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
53549 CALL PYROBO(NI+1,NI+2,THE,PHI,
53550 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
53553 P(NI+1,J)=P(NI+1,J)-P(I1,J)
53554 P(NI+2,J)=P(NI+2,J)-P(I2,J)
53560 C*********************************************************************
53563 C...Gives the mass of a particle/parton.
53565 FUNCTION PYMASS(KF)
53567 C...Double precision and integer declarations.
53568 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53569 IMPLICIT INTEGER(I-N)
53570 INTEGER PYK,PYCHGE,PYCOMP
53572 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53573 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53574 SAVE /PYDAT1/,/PYDAT2/
53576 C...Reset variables. Compressed code. Special case for popcorn diquarks.
53585 C...Guarantee use of constituent masses for internal checks.
53586 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
53587 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
53589 PYMASS=PARF(100+KFA)
53590 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
53591 ELSEIF(KFA.LE.10) THEN
53593 ELSEIF(MSTJ(93).EQ.1) THEN
53594 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
53596 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
53599 C...Other masses can be read directly off table.
53604 C...Optional mass broadening according to truncated Breit-Wigner
53605 C...(either in m or in m^2).
53606 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
53607 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
53608 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
53609 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
53612 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
53613 & (PM0*PMAS(KC,2)))
53614 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
53615 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
53616 & (PMUPP-PMLOW)*PYR(0))))
53624 C*********************************************************************
53627 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
53628 C...for Higgs couplings. Everything else sent on to PYMASS.
53630 FUNCTION PYMRUN(KF,Q2)
53632 C...Double precision and integer declarations.
53633 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53634 IMPLICIT INTEGER(I-N)
53635 INTEGER PYK,PYCHGE,PYCOMP
53637 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53638 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53639 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53640 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
53642 C...Most masses not handled here.
53644 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
53647 C...Current-algebra masses, but no Q2 dependence.
53648 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
53649 PYMRUN=PARF(90+KFA)
53651 C...Running current-algebra masses.
53654 PYMRUN=PARF(90+KFA)*
53655 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
53656 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
53662 C*********************************************************************
53665 C...Gives the particle/parton name as a character string.
53667 SUBROUTINE PYNAME(KF,CHAU)
53669 C...Double precision and integer declarations.
53670 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53671 IMPLICIT INTEGER(I-N)
53672 INTEGER PYK,PYCHGE,PYCOMP
53674 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53675 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53676 COMMON/PYDAT4/CHAF(500,2)
53678 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
53679 C...Local character variable.
53682 C...Read out code with distinction particle/antiparticle.
53685 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
53691 C*********************************************************************
53694 C...Gives three times the charge for a particle/parton.
53696 FUNCTION PYCHGE(KF)
53698 C...Double precision and integer declarations.
53699 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53700 IMPLICIT INTEGER(I-N)
53701 INTEGER PYK,PYCHGE,PYCOMP
53703 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53706 C...Read out charge and change sign for antiparticle.
53709 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
53714 C*********************************************************************
53717 C...Compress the standard KF codes for use in mass and decay arrays;
53718 C...also checks whether a given code actually is defined.
53720 FUNCTION PYCOMP(KF)
53722 C...Double precision and integer declarations.
53723 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53724 IMPLICIT INTEGER(I-N)
53725 INTEGER PYK,PYCHGE,PYCOMP
53727 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53728 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53729 SAVE /PYDAT1/,/PYDAT2/
53730 C...Local arrays and saved data.
53731 DIMENSION KFORD(100:500),KCORD(101:500)
53732 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
53734 C...Whenever necessary reorder codes for faster search.
53735 IF(MSTU(20).EQ.0) THEN
53740 IF(KFA.LE.100) GOTO 120
53742 DO 100 I1=NFORD-1,0,-1
53743 IF(KFA.GE.KFORD(I1)) GOTO 110
53744 KFORD(I1+1)=KFORD(I1)
53745 KCORD(I1+1)=KCORD(I1)
53747 110 KFORD(I1+1)=KFA
53755 C...Fast action if same code as in latest call.
53756 IF(KF.EQ.KFLAST) THEN
53761 C...Starting values. Remove internal diquark flags.
53764 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
53765 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
53767 C...Simple cases: direct translation.
53768 IF(KFA.GT.KFORD(NFORD)) THEN
53769 ELSEIF(KFA.LE.100) THEN
53772 C...Else binary search.
53776 130 IAVG=(IMIN+IMAX)/2
53777 IF(KFORD(IAVG).GT.KFA) THEN
53779 IF(IMAX.GT.IMIN+1) GOTO 130
53780 ELSEIF(KFORD(IAVG).LT.KFA) THEN
53782 IF(IMAX.GT.IMIN+1) GOTO 130
53788 C...Check if antiparticle allowed.
53789 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
53790 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
53793 C...Save codes for possible future fast action.
53800 C*********************************************************************
53803 C...Informs user of errors in program execution.
53805 SUBROUTINE PYERRM(MERR,CHMESS)
53807 C...Double precision and integer declarations.
53808 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53809 IMPLICIT INTEGER(I-N)
53810 INTEGER PYK,PYCHGE,PYCOMP
53812 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53813 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53814 SAVE /PYJETS/,/PYDAT1/
53815 C...Local character variable.
53816 CHARACTER CHMESS*(*)
53818 C...Write first few warnings, then be silent.
53819 IF(MERR.LE.10) THEN
53820 MSTU(27)=MSTU(27)+1
53822 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
53823 & MERR,MSTU(31),CHMESS
53825 C...Write first few errors, then be silent or stop program.
53826 ELSEIF(MERR.LE.20) THEN
53827 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
53829 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
53830 & MERR-10,MSTU(31),CHMESS
53831 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
53832 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
53833 WRITE(MSTU(11),5200)
53834 IF(MERR.NE.17) CALL PYLIST(2)
53838 C...Stop program in case of irreparable error.
53840 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
53844 C...Formats for output.
53845 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
53846 &' PYEXEC calls:'/5X,A)
53847 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
53848 &' PYEXEC calls:'/5X,A)
53849 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
53851 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
53852 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
53857 C*********************************************************************
53860 C...Calculates the running alpha_electromagnetic.
53862 FUNCTION PYALEM(Q2)
53864 C...Double precision and integer declarations.
53865 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53866 IMPLICIT INTEGER(I-N)
53867 INTEGER PYK,PYCHGE,PYCOMP
53869 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53872 C...Calculate real part of photon vacuum polarization.
53873 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
53874 C...For hadrons use parametrization of H. Burkhardt et al.
53875 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
53876 AEMPI=PARU(101)/(3D0*PARU(1))
53877 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
53879 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
53881 ELSEIF(MSTU(101).EQ.2) THEN
53882 RPIGG=1D0-PARU(101)/PARU(103)
53883 ELSEIF(Q2.LT.0.09D0) THEN
53884 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
53885 ELSEIF(Q2.LT.9D0) THEN
53886 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
53887 & 0.00238D0*LOG(1D0+3.927D0*Q2)
53888 ELSEIF(Q2.LT.1D4) THEN
53889 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
53890 & 0.00299D0*LOG(1D0+Q2)
53892 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
53893 & 0.00293D0*LOG(1D0+Q2)
53896 C...Calculate running alpha_em.
53897 PYALEM=PARU(101)/(1D0-RPIGG)
53903 C*********************************************************************
53906 C...Gives the value of alpha_strong.
53908 FUNCTION PYALPS(Q2)
53910 C...Double precision and integer declarations.
53911 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53912 IMPLICIT INTEGER(I-N)
53913 INTEGER PYK,PYCHGE,PYCOMP
53915 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53916 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53917 SAVE /PYDAT1/,/PYDAT2/
53919 C...Constant alpha_strong trivial. Pick artificial Lambda.
53920 IF(MSTU(111).LE.0) THEN
53922 MSTU(118)=MSTU(112)
53924 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
53925 & ((33D0-2D0*MSTU(112))*PARU(111)))
53926 PARU(118)=PARU(111)
53930 C...Find effective Q2, number of flavours and Lambda.
53932 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
53935 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
53936 Q2THR=PARU(113)*PMAS(NF,1)**2
53937 IF(Q2EFF.LT.Q2THR) THEN
53939 ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF))
53943 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
53944 Q2THR=PARU(113)*PMAS(NF+1,1)**2
53945 IF(Q2EFF.GT.Q2THR) THEN
53947 ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF))
53951 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
53952 PARU(117)=SQRT(ALAM2)
53954 C...Evaluate first or second order alpha_strong.
53955 B0=(33D0-2D0*NF)/6D0
53956 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
53957 IF(MSTU(111).EQ.1) THEN
53958 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
53960 B1=(153D0-19D0*NF)/6D0
53961 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
53970 C*********************************************************************
53973 C...Reconstructs an angle from given x and y coordinates.
53975 FUNCTION PYANGL(X,Y)
53977 C...Double precision and integer declarations.
53978 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53979 IMPLICIT INTEGER(I-N)
53980 INTEGER PYK,PYCHGE,PYCOMP
53982 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53987 IF(R.LT.1D-20) RETURN
53988 IF(ABS(X)/R.LT.0.8D0) THEN
53989 PYANGL=SIGN(ACOS(X/R),Y)
53992 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
53993 PYANGL=PARU(1)-PYANGL
53994 ELSEIF(X.LT.0D0) THEN
53995 PYANGL=-PARU(1)-PYANGL
54002 C*********************************************************************
54005 C...Performs rotations and boosts.
54007 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
54009 C...Double precision and integer declarations.
54010 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54011 IMPLICIT INTEGER(I-N)
54012 INTEGER PYK,PYCHGE,PYCOMP
54014 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54015 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54016 SAVE /PYJETS/,/PYDAT1/
54018 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
54020 C...Find and check range of rotation/boost.
54022 IF(IMIN.LE.0) IMIN=1
54023 IF(MSTU(1).GT.0) IMIN=MSTU(1)
54025 IF(IMAX.LE.0) IMAX=N
54026 IF(MSTU(2).GT.0) IMAX=MSTU(2)
54027 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
54028 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
54032 C...Optional resetting of V (when not set before.)
54033 IF(MSTU(33).NE.0) THEN
54034 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
54042 C...Rotate, typically from z axis to direction (theta,phi).
54043 IF(THE**2+PHI**2.GT.1D-20) THEN
54044 ROT(1,1)=COS(THE)*COS(PHI)
54046 ROT(1,3)=SIN(THE)*COS(PHI)
54047 ROT(2,1)=COS(THE)*SIN(PHI)
54049 ROT(2,3)=SIN(THE)*SIN(PHI)
54054 IF(K(I,1).LE.0) GOTO 140
54060 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
54061 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
54066 C...Boost, typically from rest to momentum/energy=beta.
54067 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
54071 DB=SQRT(DBX**2+DBY**2+DBZ**2)
54073 IF(DB.GT.EPS1) THEN
54074 C...Rescale boost vector if too close to unity.
54075 CALL PYERRM(3,'(PYROBO:) boost vector too large')
54081 DGA=1D0/SQRT(1D0-DB**2)
54083 IF(K(I,1).LE.0) GOTO 160
54088 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
54089 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
54090 P(I,1)=DP(1)+DGABP*DBX
54091 P(I,2)=DP(2)+DGABP*DBY
54092 P(I,3)=DP(3)+DGABP*DBZ
54093 P(I,4)=DGA*(DP(4)+DBP)
54094 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
54095 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
54096 V(I,1)=DV(1)+DGABV*DBX
54097 V(I,2)=DV(2)+DGABV*DBY
54098 V(I,3)=DV(3)+DGABV*DBZ
54099 V(I,4)=DGA*(DV(4)+DBV)
54106 C*********************************************************************
54109 C...Performs global manipulations on the event record, in particular
54110 C...to exclude unstable or undetectable partons/particles.
54112 SUBROUTINE PYEDIT(MEDIT)
54114 C...Double precision and integer declarations.
54115 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54116 IMPLICIT INTEGER(I-N)
54117 INTEGER PYK,PYCHGE,PYCOMP
54119 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54120 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54121 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54122 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
54124 DIMENSION NS(2),PTS(2),PLS(2)
54126 C...Remove unwanted partons/particles.
54127 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
54129 IF(MSTU(2).GT.0) IMAX=MSTU(2)
54130 I1=MAX(1,MSTU(1))-1
54131 DO 110 I=MAX(1,MSTU(1)),IMAX
54132 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
54133 IF(MEDIT.EQ.1) THEN
54134 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
54135 ELSEIF(MEDIT.EQ.2) THEN
54136 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
54138 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
54140 ELSEIF(MEDIT.EQ.3) THEN
54141 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
54143 IF(KC.EQ.0) GOTO 110
54144 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
54145 ELSEIF(MEDIT.EQ.5) THEN
54146 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
54148 IF(KC.EQ.0) GOTO 110
54149 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
54150 & KCHG(KC,2).EQ.0) GOTO 110
54153 C...Pack remaining partons/particles. Origin no longer known.
54162 IF(I1.LT.N) MSTU(3)=0
54163 IF(I1.LT.N) MSTU(70)=0
54166 C...Selective removal of class of entries. New position of retained.
54167 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
54170 K(I,3)=MOD(K(I,3),MSTU(5))
54171 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
54172 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
54173 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
54174 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
54175 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
54176 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
54177 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
54179 K(I,3)=K(I,3)+MSTU(5)*I1
54182 C...Find new event history information and replace old.
54184 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
54185 & K(I,3)/MSTU(5).EQ.0) GOTO 140
54187 130 IM=MOD(K(ID,3),MSTU(5))
54188 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
54189 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
54190 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
54194 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
54195 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
54196 & K(IM,2).EQ.94) THEN
54201 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
54202 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
54203 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
54204 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
54205 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
54206 & K(K(I,4),3)/MSTU(5)
54207 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
54208 & K(K(I,5),3)/MSTU(5)
54210 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
54211 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
54212 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
54213 KCD=MOD(K(I,4),MSTU(5))
54214 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
54215 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
54216 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
54217 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
54218 KCD=MOD(K(I,5),MSTU(5))
54219 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
54220 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
54224 C...Pack remaining entries.
54229 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
54236 K(I1,3)=MOD(K(I1,3),MSTU(5))
54238 IF(I.EQ.MSTU(90+IZ)) THEN
54239 MSTU(90)=MSTU(90)+1
54240 MSTU(90+MSTU(90))=I1
54241 PARU(90+MSTU(90))=PARU(90+IZ)
54245 IF(I1.LT.N) MSTU(3)=0
54246 IF(I1.LT.N) MSTU(70)=0
54249 C...Fill in some missing daughter pointers (lost in colour flow).
54250 ELSEIF(MEDIT.EQ.16) THEN
54252 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
54253 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
54254 C...Find daughters who point to mother.
54256 IF(K(I1,3).NE.I) THEN
54257 ELSEIF(K(I,4).EQ.0) THEN
54263 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
54264 IF(K(I,4).NE.0) GOTO 220
54265 C...Find daughters who point to documentation version of mother.
54267 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
54268 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
54269 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
54271 IF(K(I1,3).NE.IM) THEN
54272 ELSEIF(K(I,4).EQ.0) THEN
54278 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
54279 IF(K(I,4).NE.0) GOTO 220
54280 C...Find daughters who point to documentation daughters who,
54281 C...in their turn, point to documentation mother.
54285 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
54287 IF(ID1.EQ.IM) ID1=I1
54291 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
54292 ELSEIF(K(I,4).EQ.0) THEN
54298 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
54301 C...Save top entries at bottom of PYJETS commonblock.
54302 ELSEIF(MEDIT.EQ.21) THEN
54303 IF(2*N.GE.MSTU(4)) THEN
54304 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
54309 K(MSTU(4)-I,J)=K(I,J)
54310 P(MSTU(4)-I,J)=P(I,J)
54311 V(MSTU(4)-I,J)=V(I,J)
54316 C...Restore bottom entries of commonblock PYJETS to top.
54317 ELSEIF(MEDIT.EQ.22) THEN
54318 DO 260 I=1,MSTU(32)
54320 K(I,J)=K(MSTU(4)-I,J)
54321 P(I,J)=P(MSTU(4)-I,J)
54322 V(I,J)=V(MSTU(4)-I,J)
54327 C...Mark primary entries at top of commonblock PYJETS as untreated.
54328 ELSEIF(MEDIT.EQ.23) THEN
54333 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
54335 IF(KH.NE.0) GOTO 280
54337 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
54338 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
54342 C...Place largest axis along z axis and second largest in xy plane.
54343 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
54344 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
54345 & P(MSTU(61),2)),0D0,0D0,0D0)
54346 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
54347 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
54348 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
54349 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
54350 IF(MEDIT.EQ.31) RETURN
54352 C...Rotate to put slim jet along +z axis.
54359 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
54360 IF(MSTU(41).GE.2) THEN
54362 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
54363 & KC.EQ.18) GOTO 300
54364 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
54367 IS=2D0-SIGN(0.5D0,P(I,3))
54369 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
54371 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
54372 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
54374 C...Rotate to put second largest jet into -z,+x quadrant.
54376 IF(P(I,3).GE.0D0) GOTO 310
54377 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
54378 IF(MSTU(41).GE.2) THEN
54380 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
54381 & KC.EQ.18) GOTO 310
54382 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
54385 IS=2D0-SIGN(0.5D0,P(I,1))
54386 PLS(IS)=PLS(IS)-P(I,3)
54388 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
54395 C*********************************************************************
54398 C...Gives program heading, or lists an event, or particle
54399 C...data, or current parameter values.
54401 SUBROUTINE PYLIST(MLIST)
54403 C...Double precision and integer declarations.
54404 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54405 IMPLICIT INTEGER(I-N)
54406 INTEGER PYK,PYCHGE,PYCOMP
54407 C...Parameter statement to help give large particle numbers.
54408 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54409 &KEXCIT=4000000,KDIMEN=5000000)
54411 C...HEPEVT commonblock.
54412 PARAMETER (NMXHEP=4000)
54413 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
54414 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
54415 DOUBLE PRECISION PHEP,VHEP
54418 C...User process event common block.
54420 PARAMETER (MAXNUP=500)
54421 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
54422 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
54423 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
54424 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
54425 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
54429 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54430 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54431 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54432 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54433 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
54434 C...Local arrays, character variables and data.
54435 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
54437 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
54439 C...Initialization printout: version number and date of last change.
54440 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
54443 IF(MLIST.EQ.0) RETURN
54446 C...List event data, including additional lines after N.
54447 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
54448 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
54449 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
54450 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
54452 IF(MLIST.GE.2) LMX=16
54455 IF(MSTU(2).GT.0) IMAX=MSTU(2)
54456 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
54457 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
54458 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
54459 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
54461 C...Get particle name, pad it and check it is not too long.
54462 CALL PYNAME(K(I,2),CHAP)
54465 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
54469 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
54471 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
54474 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
54476 CHAC=CHDL(MDL)(1:2*LDL)//' '
54478 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
54479 & CHDL(MDL)(LDL+1:2*LDL)//' '
54480 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
54484 C...Add information on string connection.
54485 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
54489 IF(KC.NE.0) KCC=KCHG(KC,2)
54490 IF(IABS(K(I,2)).EQ.39) THEN
54491 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
54492 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
54494 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
54495 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
54496 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
54497 ELSEIF(KCC.NE.0) THEN
54499 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
54502 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
54503 & CHAC(LMX-1:LMX-1)='I'
54505 C...Write data for particle/jet.
54506 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
54507 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
54509 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
54510 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
54512 ELSEIF(MLIST.EQ.1) THEN
54513 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
54515 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
54516 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
54517 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
54518 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
54519 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
54522 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),
54525 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
54527 C...Insert extra separator lines specified by user.
54528 IF(MSTU(70).GE.1) THEN
54530 DO 110 J=1,MIN(10,MSTU(70))
54531 IF(I.EQ.MSTU(70+J)) ISEP=1
54533 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
54534 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
54538 C...Sum of charges and momenta.
54542 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
54543 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
54544 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
54545 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
54546 ELSEIF(MLIST.EQ.1) THEN
54547 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
54549 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
54552 C...Simple listing of HEPEVT entries (mainly for test purposes).
54553 ELSEIF(MLIST.EQ.5) THEN
54554 WRITE(MSTU(11),7500)
54556 IF(ISTHEP(I).EQ.0) GOTO 140
54557 WRITE(MSTU(11),7600) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
54558 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
54562 C...Simple listing of user-process entries (mainly for test purposes).
54563 ELSEIF(MLIST.EQ.7) THEN
54564 WRITE(MSTU(11),7300)
54566 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
54567 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
54570 C...Give simple list of KF codes defined in program.
54571 ELSEIF(MLIST.EQ.11) THEN
54572 WRITE(MSTU(11),6600)
54574 CALL PYNAME(KF,CHAP)
54575 CALL PYNAME(-KF,CHAN)
54576 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
54577 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54581 DO 170 KFLB=1,KFLA-(3-KFLS)/2
54582 KF=1000*KFLA+100*KFLB+KFLS
54583 CALL PYNAME(KF,CHAP)
54584 CALL PYNAME(-KF,CHAN)
54585 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54591 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
54592 IF(KMUL.EQ.5) KFLS=5
54594 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
54595 IF(KMUL.EQ.4) KFLR=2
54597 DO 200 KFLC=1,KFLB-1
54598 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
54599 CALL PYNAME(KF,CHAP)
54600 CALL PYNAME(-KF,CHAN)
54601 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54604 CALL PYNAME(KFK,CHAP)
54605 WRITE(MSTU(11),6700) KFK,CHAP
54607 CALL PYNAME(KFK,CHAP)
54608 WRITE(MSTU(11),6700) KFK,CHAP
54611 KF=10000*KFLR+110*KFLB+KFLS
54612 CALL PYNAME(KF,CHAP)
54613 WRITE(MSTU(11),6700) KF,CHAP
54617 CALL PYNAME(KF,CHAP)
54618 WRITE(MSTU(11),6700) KF,CHAP
54620 CALL PYNAME(KF,CHAP)
54621 WRITE(MSTU(11),6700) KF,CHAP
54627 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
54629 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
54630 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
54631 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
54632 CALL PYNAME(KF,CHAP)
54633 CALL PYNAME(-KF,CHAN)
54634 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54641 IF(KF.LT.1000000) GOTO 270
54642 CALL PYNAME(KF,CHAP)
54643 CALL PYNAME(-KF,CHAN)
54644 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
54645 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54648 C...List parton/particle data table. Check whether to be listed.
54649 ELSEIF(MLIST.EQ.12) THEN
54650 WRITE(MSTU(11),6800)
54651 DO 300 KC=1,MSTU(6)
54653 IF(KF.EQ.0) GOTO 300
54654 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
54657 C...Find particle name and mass. Print information.
54658 CALL PYNAME(KF,CHAP)
54659 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
54660 CALL PYNAME(-KF,CHAN)
54661 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
54662 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
54664 C...Particle decay: channel number, branching ratios, matrix element,
54665 C...decay products.
54666 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
54668 CALL PYNAME(KFDP(IDC,J),CHAD(J))
54670 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
54675 C...List parameter value table.
54676 ELSEIF(MLIST.EQ.13) THEN
54677 WRITE(MSTU(11),7100)
54679 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
54683 C...Format statements for output on unit MSTU(11) (by default 6).
54684 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
54685 &5X,'KF orig p_x p_y p_z E m'/)
54686 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
54687 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
54688 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
54689 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
54690 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
54691 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
54692 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
54693 5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
54694 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
54695 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
54696 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
54697 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
54698 5900 FORMAT(66X,5(1X,F12.3))
54699 6000 FORMAT(1X,78('='))
54700 6100 FORMAT(1X,130('='))
54701 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
54702 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
54703 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
54704 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
54706 6600 FORMAT(///20X,'List of KF codes in program'/)
54707 6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
54708 6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
54709 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
54710 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
54711 &1X,'ME',3X,'Br.rat.',4X,'decay products')
54712 6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
54713 &1X,1P,E13.5,3X,I2)
54714 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
54715 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
54716 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
54717 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
54718 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
54719 &//' I IST ID Mothers Colours p_x p_y p_z',
54721 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
54722 7500 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
54723 &//' I IST ID Mothers Daughters p_x p_y p_z',
54725 7600 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
54730 C*********************************************************************
54733 C...Writes a logo for the program.
54737 C...Double precision and integer declarations.
54738 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54739 IMPLICIT INTEGER(I-N)
54740 INTEGER PYK,PYCHGE,PYCOMP
54741 C...Parameter for length of information block.
54742 PARAMETER (IREFER=24)
54744 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54745 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54746 SAVE /PYDAT1/,/PYPARS/
54747 C...Local arrays and character variables.
54749 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
54750 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
54752 C...Data on months, logo, titles, and references.
54753 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
54754 &'Oct','Nov','Dec'/
54755 DATA (LOGO(J),J=1,19)/
54757 &' *:::!!:::::::::::* ',
54758 &' *::::::!!::::::::::::::* ',
54759 &' *::::::::!!::::::::::::::::* ',
54760 &' *:::::::::!!:::::::::::::::::* ',
54761 &' *:::::::::!!:::::::::::::::::* ',
54762 &' *::::::::!!::::::::::::::::*! ',
54763 &' *::::::!!::::::::::::::* !! ',
54764 &' !! *:::!!:::::::::::* !! ',
54765 &' !! !* -><- * !! ',
54775 DATA (LOGO(J),J=20,38)/
54776 &'Welcome to the Lund Monte Carlo!',
54778 &'PPP Y Y TTTTT H H III A ',
54779 &'P P Y Y T H H I A A ',
54780 &'PPP Y T HHHHH I AAAAA',
54781 &'P Y T H H I A A',
54782 &'P Y T H H III A A',
54784 &'This is PYTHIA version x.xxx ',
54785 &'Last date of change: xx xxx 199x',
54787 &'Now is xx xxx 199x at xx:xx:xx ',
54789 &'Disclaimer: this program comes ',
54790 &'without any guarantees. Beware ',
54791 &'of errors and use common sense ',
54792 &'when interpreting results. ',
54794 &'Copyright T. Sjostrand (2003) '/
54795 DATA (REFER(J),J=1,18)/
54796 &'An archive of program versions and d',
54797 &'ocumentation is found on the web: ',
54798 &'http://www.thep.lu.se/~torbjorn/Pyth',
54802 &'When you cite this program, currentl',
54803 &'y the official reference is ',
54804 &'T. Sjostrand, P. Eden, C. Friberg, L',
54805 &'. Lonnblad, G. Miu, S. Mrenna and ',
54806 &'E. Norrbin, Computer Physics Commun.',
54807 &' 135 (2001) 238. ',
54808 &'The large manual is ',
54810 &'T. Sjostrand, L. Lonnblad and S. Mre',
54811 &'nna, LU TP 01-21 [hep-ph/0108264]. ',
54812 &'Also remember that the program, to a',
54813 &' large extent, represents original '/
54814 DATA (REFER(J),J=19,36)/
54815 &'physics research. Other publications',
54816 &' of special relevance to your ',
54817 &'studies may therefore deserve separa',
54821 &'Main author: Torbjorn Sjostrand; Dep',
54822 &'artment of Theoretical Physics 2, ',
54823 &' Lund University, Solvegatan 14A, S',
54824 &'-223 62 Lund, Sweden; ',
54825 &' phone: + 46 - 46 - 222 48 16; e-ma',
54826 &'il: torbjorn@thep.lu.se ',
54827 &'Author: Leif Lonnblad; Department of',
54828 &' Theoretical Physics 2, ',
54829 &' Lund University, Solvegatan 14A, S',
54830 &'-223 62 Lund, Sweden; ',
54831 &' phone: + 46 - 46 - 222 77 80; e-ma',
54832 &'il: leif@thep.lu.se '/
54833 DATA (REFER(J),J=37,2*IREFER)/
54834 &'Author: Stephen Mrenna; Computing Di',
54835 &'vision, Simulations Group, ',
54836 &' Fermi National Accelerator Laborat',
54837 &'ory, MS 234, Batavia, IL 60510, USA;',
54838 &' phone: + 1 - 630 - 840 - 2556; e-m',
54839 &'ail: mrenna@fnal.gov ',
54840 &'Author: Peter Skands; Department of ',
54841 &'Theoretical Physics 2, ',
54842 &' Lund University, Solvegatan 14A, S',
54843 &'-223 62 Lund, Sweden; ',
54844 &' phone: + 46 - 46 - 222 31 92; e-ma',
54845 &'il: zeiler@thep.lu.se '/
54847 C...Check that PYDATA linked.
54848 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
54850 & 'Error: PYDATA has not been linked.'
54851 WRITE(*,'(1X,A)') 'Execution stopped!'
54854 C...Write current version number and current date+time.
54856 WRITE(VERS,'(I1)') MSTP(181)
54857 LOGO(28)(24:24)=VERS
54858 WRITE(SUBV,'(I3)') MSTP(182)
54859 LOGO(28)(26:28)=SUBV
54860 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
54861 WRITE(DATE,'(I2)') MSTP(185)
54862 LOGO(29)(22:23)=DATE
54863 LOGO(29)(25:27)=MONTH(MSTP(184))
54864 WRITE(YEAR,'(I4)') MSTP(183)
54865 LOGO(29)(29:32)=YEAR
54867 IF(IDATI(1).LE.0) THEN
54870 WRITE(DATE,'(I2)') IDATI(3)
54872 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
54873 WRITE(YEAR,'(I4)') IDATI(1)
54874 LOGO(31)(15:18)=YEAR
54875 WRITE(HOUR,'(I2)') IDATI(4)
54876 LOGO(31)(23:24)=HOUR
54877 WRITE(MINU,'(I2)') IDATI(5)
54878 LOGO(31)(26:27)=MINU
54879 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
54880 WRITE(SECO,'(I2)') IDATI(6)
54881 LOGO(31)(29:30)=SECO
54882 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
54886 C...Loop over lines in header. Define page feed and side borders.
54887 DO 100 ILIN=1,29+IREFER
54896 C...Separator lines and logos.
54897 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
54898 LINE(4:77)='***********************************************'//
54899 & '***************************'
54900 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
54901 LINE(6:37)=LOGO(ILIN-5)
54902 LINE(44:75)=LOGO(ILIN+14)
54903 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
54904 LINE(5:40)=REFER(2*ILIN-51)
54905 LINE(41:76)=REFER(2*ILIN-50)
54908 C...Write lines to appropriate unit.
54909 WRITE(MSTU(11),'(A79)') LINE
54915 C*********************************************************************
54918 C...Facilitates the updating of particle and decay data
54919 C...by allowing it to be done in an external file.
54921 SUBROUTINE PYUPDA(MUPDA,LFN)
54923 C...Double precision and integer declarations.
54924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54925 IMPLICIT INTEGER(I-N)
54926 INTEGER PYK,PYCHGE,PYCOMP
54928 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54929 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54930 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54931 COMMON/PYDAT4/CHAF(500,2)
54933 COMMON/PYINT4/MWID(500),WIDS(500,5)
54934 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
54935 C...Local arrays, character variables and data.
54936 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
54937 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
54938 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
54939 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
54940 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
54941 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
54942 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
54944 C...Write header if not yet done.
54945 IF(MSTU(12).GE.1) CALL PYLIST(0)
54947 C...Write information on file for editing.
54948 IF(MUPDA.EQ.1) THEN
54950 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
54951 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
54952 & MWID(KC),MDCY(KC,1)
54953 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
54954 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
54955 & (KFDP(IDC,J),J=1,5)
54959 C...Read complete set of information from edited file or
54960 C...read partial set of new or updated information from edited file.
54961 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
54963 C...Reset counters.
54967 IF(MUPDA.EQ.2) THEN
54972 DO 130 KC=1,MSTU(6)
54973 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
54974 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
54978 C...Begin of loop: read new line; unknown whether particle or
54980 140 READ(LFN,5200,END=190) CHINL
54982 C...Identify particle code and whether already defined (for MUPDA=3).
54983 IF(CHINL(2:10).NE.' ') THEN
54986 IF(MUPDA.EQ.2) THEN
54999 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
55002 C...Remove duplicate old decay data.
55003 IF(KCREP.NE.0) THEN
55004 IF(MDCY(KCREP,3).GT.0) THEN
55005 IDCREP=MDCY(KCREP,2)
55006 NDCREP=MDCY(KCREP,3)
55008 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
55010 DO 180 I=IDCREP,NDC-NDCREP
55011 MDME(I,1)=MDME(I+NDCREP,1)
55012 MDME(I,2)=MDME(I+NDCREP,2)
55013 BRAT(I)=BRAT(I+NDCREP)
55015 KFDP(I,J)=KFDP(I+NDCREP,J)
55029 C...Study line with particle data.
55030 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
55031 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
55032 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
55033 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
55034 & MWID(KC),MDCY(KC,1)
55038 C...Study line with decay data.
55041 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
55042 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
55043 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
55044 MDCY(KC,3)=MDCY(KC,3)+1
55045 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
55046 & (KFDP(NDC,J),J=1,5)
55049 C...End of loop; ensure that PYCOMP tables are updated.
55054 C...Perform possible tests that new information is consistent.
55055 DO 220 KC=1,MSTU(6)
55057 IF(KF.EQ.0) GOTO 220
55058 WRITE(CHKF,5300) KF
55059 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
55060 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
55061 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
55063 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
55064 IF(MDME(IDC,2).GT.80) GOTO 210
55066 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
55070 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
55072 ELSEIF(PYCOMP(KP).EQ.0) THEN
55077 PMS=PMS-PMAS(KPC,1)
55078 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
55082 IF(KQ.NE.0) MERR=MAX(2,MERR)
55083 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
55085 IF(MERR.EQ.3) CALL PYERRM(17,
55086 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
55087 IF(MERR.EQ.2) CALL PYERRM(17,
55088 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
55089 IF(MERR.EQ.1) CALL PYERRM(7,
55090 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
55091 BRSUM=BRSUM+BRAT(IDC)
55093 WRITE(CHTMP,5500) BRSUM
55094 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
55095 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
55096 & CHTMP(9:16)//' for KF ='//CHKF)
55099 C...Write DATA statements for inclusion in program.
55100 ELSEIF(MUPDA.EQ.4) THEN
55102 C...Find out how many codes and decay channels are actually used.
55106 IF(KCHG(I,4).NE.0) THEN
55108 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
55112 C...Initialize writing of DATA statements for inclusion in program.
55115 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
55118 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
55122 C...Loop through variables for conversion to characters.
55124 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
55125 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
55126 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
55127 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
55128 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
55129 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
55130 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
55131 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
55132 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
55133 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
55134 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
55135 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
55136 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
55137 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
55138 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
55139 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
55140 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
55141 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
55142 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
55143 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
55144 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
55145 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
55147 C...Replace variables beyond what is properly defined.
55149 IF(IDIM.GT.KCC) CHTMP=' 0'
55150 ELSEIF(IVAR.LE.8) THEN
55151 IF(IDIM.GT.KCC) CHTMP=' 0.0'
55152 ELSEIF(IVAR.LE.11) THEN
55153 IF(IDIM.GT.KCC) CHTMP=' 0'
55154 ELSEIF(IVAR.LE.13) THEN
55155 IF(IDIM.GT.NDC) CHTMP=' 0'
55156 ELSEIF(IVAR.LE.14) THEN
55157 IF(IDIM.GT.NDC) CHTMP=' 0.0'
55158 ELSEIF(IVAR.LE.19) THEN
55159 IF(IDIM.GT.NDC) CHTMP=' 0'
55160 ELSEIF(IVAR.LE.21) THEN
55161 IF(IDIM.GT.KCC) CHTMP=' '
55163 IF(IDIM.GT.KCC) CHTMP=' 0'
55166 C...Length of variable, trailing decimal zeros, quotation marks.
55170 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
55171 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
55173 CHNEW=CHTMP(LLOW:LHIG)//' '
55175 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
55178 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
55179 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
55184 CHNEW(LNEW+1:LNEW+2)='D0'
55187 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
55188 DO 260 LL=LNEW,1,-1
55189 IF(CHNEW(LL:LL).EQ.'''') THEN
55191 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
55197 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
55201 C...Form composite character string, often including repetition counter.
55202 IF(CHNEW.NE.CHOLD) THEN
55209 IF(NRPT.GE.2) LRPT=LNEW+3
55210 IF(NRPT.GE.10) LRPT=LNEW+4
55211 IF(NRPT.GE.100) LRPT=LNEW+5
55212 IF(NRPT.GE.1000) LRPT=LNEW+6
55215 WRITE(CHTMP,5400) NRPT
55217 IF(NRPT.GE.10) LRPT=2
55218 IF(NRPT.GE.100) LRPT=3
55219 IF(NRPT.GE.1000) LRPT=4
55220 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
55224 C...Add characters to end of line, to new line (after storing old line),
55225 C...or to new block of lines (after writing old block).
55226 IF(LLIN+LCOM.LE.70) THEN
55227 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
55229 ELSEIF(NLIN.LE.19) THEN
55230 CHLIN(LLIN+1:72)=' '
55233 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
55236 CHLIN(LLIN:72)='/'//' '
55238 WRITE(CHTMP,5400) IDIM-NRPT
55239 CHBLK(1)(30:33)=CHTMP(13:16)
55241 WRITE(LFN,5700) CHBLK(ILIN)
55245 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
55246 & ',I= , )/'//CHCOM(1:LCOM)//','
55247 WRITE(CHTMP,5400) IDIM-NRPT+1
55248 CHLIN(25:28)=CHTMP(13:16)
55253 C...Write final block of lines.
55254 CHLIN(LLIN:72)='/'//' '
55256 WRITE(CHTMP,5400) NDIM
55257 CHBLK(1)(30:33)=CHTMP(13:16)
55259 WRITE(LFN,5700) CHBLK(ILIN)
55264 C...Formats for reading and writing particle data.
55265 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
55266 5100 FORMAT(10X,2I5,F12.6,5I10)
55277 C*********************************************************************
55280 C...Provides various integer-valued event related data.
55284 C...Double precision and integer declarations.
55285 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55286 IMPLICIT INTEGER(I-N)
55287 INTEGER PYK,PYCHGE,PYCOMP
55289 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55290 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55291 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55292 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55294 C...Default value. For I=0 number of entries, number of stable entries
55295 C...or 3 times total charge.
55297 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
55298 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
55300 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
55302 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
55303 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
55306 ELSEIF(I.EQ.0) THEN
55308 C...For I > 0 direct readout of K matrix or charge.
55309 ELSEIF(J.LE.5) THEN
55311 ELSEIF(J.EQ.6) THEN
55314 C...Status (existing/fragmented/decayed), parton/hadron separation.
55315 ELSEIF(J.LE.8) THEN
55316 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
55317 IF(J.EQ.8) PYK=PYK*K(I,2)
55318 ELSEIF(J.LE.12) THEN
55322 IF(KC.NE.0) KQ=KCHG(KC,2)
55323 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
55324 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
55326 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
55328 C...Heaviest flavour in hadron/diquark.
55329 ELSEIF(J.EQ.13) THEN
55331 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
55332 IF(KFA.LT.10) PYK=KFA
55333 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
55334 PYK=PYK*ISIGN(1,K(I,2))
55336 C...Particle history: generation, ancestor, rank.
55337 ELSEIF(J.LE.15) THEN
55344 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
55347 ELSEIF(J.EQ.16) THEN
55349 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
55350 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
55357 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
55358 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
55360 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
55361 IF(ILP.EQ.1) GOTO 120
55363 IF(K(I1,1).EQ.12) THEN
55365 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
55366 & .AND.K(I3,2).NE.93) PYK=PYK+1
55372 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
55376 C...Particle coming from collapsing jet system or not.
55377 ELSEIF(J.EQ.17) THEN
55384 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
55385 IF(PYK.EQ.1) PYK=-1
55389 IF(KCHG(KC,2).EQ.0) GOTO 150
55390 IF(K(I1,1).NE.12) PYK=0
55391 IF(K(I1,1).NE.12) RETURN
55394 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
55396 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
55398 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
55400 C...Number of decay products. Colour flow.
55401 ELSEIF(J.EQ.18) THEN
55402 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
55403 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
55404 ELSEIF(J.LE.22) THEN
55405 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
55406 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
55407 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
55408 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
55409 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
55416 C*********************************************************************
55419 C...Provides various real-valued event related data.
55423 C...Double precision and integer declarations.
55424 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55425 IMPLICIT INTEGER(I-N)
55426 INTEGER PYK,PYCHGE,PYCOMP
55428 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55429 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55430 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55431 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55435 C...Set default value. For I = 0 sum of momenta or charges,
55436 C...or invariant mass of system.
55438 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
55439 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
55441 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
55443 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
55447 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
55451 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
55452 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
55454 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
55456 ELSEIF(I.EQ.0) THEN
55458 C...Direct readout of P matrix.
55459 ELSEIF(J.LE.5) THEN
55462 C...Charge, total momentum, transverse momentum, transverse mass.
55463 ELSEIF(J.LE.12) THEN
55464 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
55465 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
55466 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
55467 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
55468 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
55470 C...Theta and phi angle in radians or degrees.
55471 ELSEIF(J.LE.16) THEN
55472 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
55473 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
55474 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
55476 C...True rapidity, rapidity with pion mass, pseudorapidity.
55477 ELSEIF(J.LE.19) THEN
55479 IF(J.EQ.17) PMR=P(I,5)
55480 IF(J.EQ.18) PMR=PYMASS(211)
55481 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
55482 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
55485 C...Energy and momentum fractions (only to be used in CM frame).
55486 ELSEIF(J.LE.25) THEN
55487 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
55488 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
55489 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
55490 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
55491 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
55492 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
55498 C*********************************************************************
55501 C...Performs sphericity tensor analysis to give sphericity,
55502 C...aplanarity and the related event axes.
55504 SUBROUTINE PYSPHE(SPH,APL)
55506 C...Double precision and integer declarations.
55507 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55508 IMPLICIT INTEGER(I-N)
55509 INTEGER PYK,PYCHGE,PYCOMP
55511 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55512 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55513 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55514 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55516 DIMENSION SM(3,3),SV(3,3)
55518 C...Calculate matrix to be diagonalized.
55527 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
55528 IF(MSTU(41).GE.2) THEN
55530 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
55531 & KC.EQ.18) GOTO 140
55532 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
55536 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55538 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
55539 & MAX(1D-10,PA)**(PARU(41)-2D0)
55542 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
55548 C...Very low multiplicities (0 or 1) not considered.
55550 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
55557 SM(J1,J2)=SM(J1,J2)/PS
55561 C...Find eigenvalues to matrix (third degree equation).
55562 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
55563 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
55564 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
55565 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
55566 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
55567 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
55568 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
55569 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
55570 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
55571 IF(P(N+2,4).LT.1D-5) THEN
55572 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
55578 C...Find first and last eigenvector by solving equation system.
55581 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
55583 SV(J1,J2)=SM(J1,J2)
55584 SV(J2,J1)=SM(J1,J2)
55590 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
55593 SMAX=ABS(SV(J1,J2))
55597 DO 220 J3=JA+1,JA+2
55599 RL=SV(J1,JB)/SV(JA,JB)
55601 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
55602 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
55604 SMAX=ABS(SV(J1,J2))
55608 JB2=JB+2-3*((JB+1)/3)
55609 P(N+I,JB1)=-SV(JC,JB2)
55610 P(N+I,JB2)=SV(JC,JB1)
55611 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
55613 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
55614 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55616 P(N+I,J)=SGN*P(N+I,J)/PA
55620 C...Middle axis orthogonal to other two. Fill other codes.
55621 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55622 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
55623 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
55624 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
55637 C...Calculate sphericity and aplanarity. Select storing option.
55638 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
55642 IF(MSTU(43).LE.1) MSTU(3)=3
55643 IF(MSTU(43).GE.2) N=N+3
55648 C*********************************************************************
55651 C...Performs thrust analysis to give thrust, oblateness
55652 C...and the related event axes.
55654 SUBROUTINE PYTHRU(THR,OBL)
55656 C...Double precision and integer declarations.
55657 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55658 IMPLICIT INTEGER(I-N)
55659 INTEGER PYK,PYCHGE,PYCOMP
55661 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55662 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55663 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55664 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55666 DIMENSION TDI(3),TPR(3)
55668 C...Take copy of particles that are to be considered in thrust analysis.
55672 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
55673 IF(MSTU(41).GE.2) THEN
55675 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
55676 & KC.EQ.18) GOTO 100
55677 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
55680 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
55681 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
55691 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55693 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
55694 & P(N+NP,4)**(PARU(42)-1D0)
55695 PS=PS+P(N+NP,4)*P(N+NP,5)
55698 C...Very low multiplicities (0 or 1) not considered.
55700 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
55706 C...Loop over thrust and major. T axis along z direction in latter case.
55710 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
55712 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
55713 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
55714 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
55717 C...Find and order particles with highest p (pT for major).
55718 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
55722 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
55723 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
55724 IF(P(I,4).LE.P(ILF,4)) GOTO 140
55726 P(ILF+1,J)=P(ILF,J)
55735 C...Find and order initial axes with highest thrust (major).
55736 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
55739 NC=2**(MIN(MSTU(44),NP)-1)
55744 DO 200 ILF=1,MIN(MSTU(44),NP)
55745 SGN=P(N+NP+ILF+3,5)
55746 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
55748 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
55751 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
55752 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
55753 IF(TDS.LE.P(ILG,4)) GOTO 230
55755 P(ILG+1,J)=P(ILG,J)
55758 ILG=N+NP+MSTU(44)+4
55765 C...Iterate direction of axis until stable maximum.
55772 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
55773 IF(THP.GT.1D-10) TDI(J)=TPR(J)
55777 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
55779 TPR(J)=TPR(J)+SGN*P(I,J)
55782 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
55783 IF(THP.GE.THPS+PARU(48)) GOTO 270
55785 C...Save good axis. Try new initial axis until a number of tries agree.
55786 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
55787 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
55789 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55791 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
55797 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
55800 C...Find minor axis and value by orthogonality.
55801 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55802 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
55803 P(N+NP+3,2)=SGN*P(N+NP+2,1)
55807 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
55812 C...Fill axis information. Rotate back to original coordinate system.
55820 P(N+ILD,J)=P(N+NP+ILD,J)
55824 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
55826 C...Calculate thrust and oblateness. Select storing option.
55828 OBL=P(N+2,4)-P(N+3,4)
55831 IF(MSTU(43).LE.1) MSTU(3)=3
55832 IF(MSTU(43).GE.2) N=N+3
55837 C*********************************************************************
55840 C...Subdivides the particle content of an event into jets/clusters.
55842 SUBROUTINE PYCLUS(NJET)
55844 C...Double precision and integer declarations.
55845 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55846 IMPLICIT INTEGER(I-N)
55847 INTEGER PYK,PYCHGE,PYCOMP
55849 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55850 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55851 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55852 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55853 C...Local arrays and saved variables.
55855 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
55857 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
55858 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
55859 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
55860 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
55861 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
55862 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
55863 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
55865 C...If first time, reset. If reentering, skip preliminaries.
55866 IF(MSTU(48).LE.0) THEN
55872 PIMASS=PMAS(PYCOMP(211),1)
55875 IF(MSTU(43).GE.2) N=N-NJET
55876 DO 110 I=N+1,N+NJET
55877 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55879 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
55882 R2ACC=PARU(45)*PS(5)**2
55888 C...Find which particles are to be considered in cluster search.
55890 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
55891 IF(MSTU(41).GE.2) THEN
55893 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
55894 & KC.EQ.18) GOTO 140
55895 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
55898 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
55899 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
55904 C...Take copy of these particles, with space left for jets later on.
55910 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
55911 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
55912 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
55913 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55915 PS(J)=PS(J)+P(N+NP,J)
55925 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
55927 C...Very low multiplicities not considered.
55928 IF(NP.LT.MSTU(47)) THEN
55929 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
55934 C...Find precluster configuration. If too few jets, make harder cuts.
55936 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
55939 R2ACC=PARU(45)*PS(5)**2
55941 RINIT=1.25D0*PARU(43)
55942 IF(NP.LE.MSTU(47)+2) RINIT=0D0
55943 170 RINIT=0.8D0*RINIT
55946 DO 180 I=N+NP+1,N+2*NP
55950 C...Sum up small momentum region. Jet if enough absolute momentum.
55951 IF(MSTU(46).LE.2) THEN
55955 DO 210 I=N+NP+1,N+2*NP
55956 IF(P(I,5).GT.2D0*RINIT) GOTO 210
55960 P(N+1,J)=P(N+1,J)+P(I,J)
55963 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
55964 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
55965 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
55966 IF(NREM.EQ.0) GOTO 170
55969 C...Find fastest remaining particle.
55972 DO 230 I=N+NP+1,N+2*NP
55973 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
55978 P(N+NPRE,J)=P(IMAX,J)
55983 C...Sum up precluster around it according to pT separation.
55984 IF(MSTU(46).LE.2) THEN
55985 DO 260 I=N+NP+1,N+2*NP
55986 IF(K(I,4).NE.0) GOTO 260
55988 IF(R2.GT.RINIT**2) GOTO 260
55992 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
55995 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
55997 C...Sum up precluster around it according to mass or
55998 C...Durham pT separation.
56002 DO 280 I=N+NP+1,N+2*NP
56003 IF(K(I,4).NE.0) GOTO 280
56004 IF(MSTU(46).LE.4) THEN
56009 IF(R2.GE.R2MIN) GOTO 280
56015 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
56017 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
56024 C...Check if more preclusters to be found. Start over if too few.
56025 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
56026 IF(NREM.GT.0) GOTO 220
56029 C...Reassign all particles to nearest jet. Sum up new jet momenta.
56032 310 IF(MSTU(46).LE.1) THEN
56033 DO 330 I=N+1,N+NJET
56038 DO 360 I=N+NP+1,N+2*NP
56040 DO 340 IJET=N+1,N+NJET
56041 IF(P(IJET,5).LT.RINIT) GOTO 340
56043 IF(R2.GE.R2MIN) GOTO 340
56049 V(IMIN,J)=V(IMIN,J)+P(I,J)
56053 DO 380 I=N+1,N+NJET
56057 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
56062 C...Find two closest jets.
56063 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
56064 DO 400 ITRY1=N+1,N+NJET-1
56065 DO 390 ITRY2=ITRY1+1,N+NJET
56066 IF(MSTU(46).LE.2) THEN
56067 R2=R2T(ITRY1,ITRY2)
56068 ELSEIF(MSTU(46).LE.4) THEN
56069 R2=R2M(ITRY1,ITRY2)
56071 R2=R2D(ITRY1,ITRY2)
56073 IF(R2.GE.R2MIN) GOTO 390
56080 C...If allowed, join two closest jets and start over.
56081 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
56082 IREC=MIN(IMIN1,IMIN2)
56083 IDEL=MAX(IMIN1,IMIN2)
56085 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
56087 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
56088 DO 430 I=IDEL+1,N+NJET
56093 IF(MSTU(46).GE.2) THEN
56094 DO 440 I=N+NP+1,N+2*NP
56096 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
56097 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
56103 C...Divide up broad jet if empty cluster in list of final ones.
56104 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
56105 DO 450 I=N+1,N+NJET
56108 DO 460 I=N+NP+1,N+2*NP
56109 K(N+K(I,4),5)=K(N+K(I,4),5)+1
56112 DO 470 I=N+1,N+NJET
56113 IF(K(I,5).EQ.0) IEMP=I
56119 DO 480 I=N+NP+1,N+2*NP
56120 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
56123 IF(R2.LE.R2MAX) GOTO 480
56130 P(IEMP,J)=P(ISPL,J)
56131 P(IJET,J)=P(IJET,J)-P(ISPL,J)
56133 P(IEMP,5)=P(ISPL,5)
56134 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
56135 IF(NLOOP.LE.2) GOTO 300
56140 C...If generalized thrust has not yet converged, continue iteration.
56141 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
56147 C...Reorder jets according to energy.
56148 DO 510 I=N+1,N+NJET
56153 DO 540 INEW=N+1,N+NJET
56155 DO 520 ITRY=N+1,N+NJET
56156 IF(V(ITRY,4).LE.PEMAX) GOTO 520
56165 P(INEW,J)=V(IMAX,J)
56171 C...Clean up particle-jet assignments and jet information.
56172 DO 550 I=N+NP+1,N+2*NP
56175 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
56176 K(IORI,4)=K(IORI,4)+1
56180 DO 570 I=N+1,N+NJET
56183 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
56187 IF(K(I,4).EQ.0) IEMP=I
56190 C...Select storing option. Output variables. Check for failure.
56196 PARU(63)=SQRT(R2MIN)
56197 IF(NJET.LE.1) PARU(63)=0D0
56199 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
56203 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
56204 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
56210 C*********************************************************************
56213 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
56214 C...as used for calorimeters at hadron colliders.
56216 SUBROUTINE PYCELL(NJET)
56218 C...Double precision and integer declarations.
56219 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56220 IMPLICIT INTEGER(I-N)
56221 INTEGER PYK,PYCHGE,PYCOMP
56223 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56224 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56225 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56226 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56228 C...Loop over all particles. Find cell that was hit by given particle.
56229 PTLRAT=1D0/SINH(PARU(51))**2
56233 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
56234 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
56235 IF(MSTU(41).GE.2) THEN
56237 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56238 & KC.EQ.18) GOTO 110
56239 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
56243 PT=SQRT(P(I,1)**2+P(I,2)**2)
56244 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
56245 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
56246 & (ETA/PARU(51)+1D0))))
56247 PHI=PYANGL(P(I,1),P(I,2))
56248 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
56249 & (PHI/PARU(1)+1D0))))
56250 IETPH=MSTU(52)*IETA+IPHI
56252 C...Add to cell already hit, or book new cell.
56254 IF(IETPH.EQ.K(IC,3)) THEN
56260 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
56261 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
56269 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
56270 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
56274 C...Smear true bin content by calorimeter resolution.
56275 IF(MSTU(53).GE.1) THEN
56278 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
56279 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
56280 & COS(PARU(2)*PYR(0))
56281 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
56283 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
56287 C...Remove cells below threshold.
56288 IF(PARU(58).GT.0D0) THEN
56292 IF(P(IC,5).GT.PARU(58)) THEN
56304 C...Find initiator cell: the one with highest pT of not yet used ones.
56308 IF(K(IC,5).NE.2) GOTO 160
56309 IF(P(IC,5).LE.ETMAX) GOTO 160
56315 IF(ETMAX.LT.PARU(52)) GOTO 220
56316 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
56317 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
56331 C...Sum up unused cells within required distance of initiator.
56333 IF(K(IC,5).EQ.0) GOTO 170
56334 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
56335 DPHIA=ABS(P(IC,2)-PHI)
56336 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
56338 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
56339 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
56341 K(NJ,4)=K(NJ,4)+K(IC,4)
56342 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
56343 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
56344 P(NJ,5)=P(NJ,5)+P(IC,5)
56347 C...Reject cluster below minimum ET, else accept.
56348 IF(P(NJ,5).LT.PARU(53)) THEN
56351 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
56353 ELSEIF(MSTU(54).LE.2) THEN
56354 P(NJ,3)=P(NJ,3)/P(NJ,5)
56355 P(NJ,4)=P(NJ,4)/P(NJ,5)
56356 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
56359 IF(K(IC,5).LT.0) K(IC,5)=0
56366 IF(K(IC,5).GE.0) GOTO 210
56367 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
56368 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
56369 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
56370 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
56376 C...Arrange clusters in falling ET sequence.
56377 220 DO 250 I=1,NJ-NC
56380 IF(K(IJ,5).EQ.0) GOTO 230
56381 IF(P(IJ,5).LT.ETMAX) GOTO 230
56389 K(N+I,4)=K(IJMAX,4)
56392 P(N+I,J)=P(IJMAX,J)
56398 C...Convert to massless or massive four-vectors.
56399 IF(MSTU(54).EQ.2) THEN
56400 DO 260 I=N+1,N+NJET
56402 P(I,1)=P(I,5)*COS(P(I,4))
56403 P(I,2)=P(I,5)*SIN(P(I,4))
56404 P(I,3)=P(I,5)*SINH(ETA)
56405 P(I,4)=P(I,5)*COSH(ETA)
56408 ELSEIF(MSTU(54).GE.3) THEN
56409 DO 270 I=N+1,N+NJET
56410 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
56414 C...Information about storage.
56418 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
56419 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
56424 C*********************************************************************
56427 C...Determines, approximately, the two jet masses that minimize
56428 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
56430 SUBROUTINE PYJMAS(PMH,PML)
56432 C...Double precision and integer declarations.
56433 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56434 IMPLICIT INTEGER(I-N)
56435 INTEGER PYK,PYCHGE,PYCOMP
56437 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56438 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56439 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56440 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56442 DIMENSION SM(3,3),SAX(3),PS(3,5)
56455 PIMASS=PMAS(PYCOMP(211),1)
56457 C...Take copy of particles that are to be considered in mass analysis.
56459 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
56460 IF(MSTU(41).GE.2) THEN
56462 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56463 & KC.EQ.18) GOTO 170
56464 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
56467 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
56468 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
56477 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
56478 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
56479 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
56481 C...Fill information in sphericity tensor and total momentum vector.
56484 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
56487 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
56489 PS(3,J)=PS(3,J)+P(N+NP,J)
56493 C...Very low multiplicities (0 or 1) not considered.
56495 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
56500 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
56503 C...Find largest eigenvalue to matrix (third degree equation).
56506 SM(J1,J2)=SM(J1,J2)/PSS
56509 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
56510 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
56511 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
56512 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
56513 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
56514 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
56515 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
56517 C...Find largest eigenvector by solving equation system.
56519 SM(J1,J1)=SM(J1,J1)-SMA
56521 SM(J2,J1)=SM(J1,J2)
56527 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
56530 SMAX=ABS(SM(J1,J2))
56534 DO 250 J3=JA+1,JA+2
56536 RL=SM(J1,JB)/SM(JA,JB)
56538 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
56539 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
56541 SMAX=ABS(SM(J1,J2))
56545 JB2=JB+2-3*((JB+1)/3)
56546 SAX(JB1)=-SM(JC,JB2)
56547 SAX(JB2)=SM(JC,JB1)
56548 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
56550 C...Divide particles into two initial clusters by hemisphere.
56552 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
56554 IF(PSAX.LT.0D0) IS=2
56557 PS(IS,J)=PS(IS,J)+P(I,J)
56560 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
56561 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
56563 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
56567 PS(3,J)=PS(1,J)-PS(2,J)
56570 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)
56571 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
56572 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
56573 IF(PMDI.LT.PMD) THEN
56579 C...Loop back if significant reduction in sum of m^2.
56580 IF(PMD.LT.-PARU(48)*PMS) THEN
56584 PS(IS,J)=PS(IS,J)-P(IM,J)
56585 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
56591 C...Final masses and output.
56594 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
56595 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
56596 PMH=MAX(PS(1,5),PS(2,5))
56597 PML=MIN(PS(1,5),PS(2,5))
56602 C*********************************************************************
56605 C...Calculates the first few Fox-Wolfram moments.
56607 SUBROUTINE PYFOWO(H10,H20,H30,H40)
56609 C...Double precision and integer declarations.
56610 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56611 IMPLICIT INTEGER(I-N)
56612 INTEGER PYK,PYCHGE,PYCOMP
56614 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56615 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56616 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56617 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56619 C...Copy momenta for particles and calculate H0.
56624 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
56625 IF(MSTU(41).GE.2) THEN
56627 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56628 & KC.EQ.18) GOTO 110
56629 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
56632 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
56633 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
56644 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
56650 C...Very low multiplicities (0 or 1) not considered.
56652 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
56660 C...Calculate H1 - H4.
56666 DO 120 I2=I1+1,N+NP
56667 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
56668 & (P(I1,4)*P(I2,4))
56669 H10=H10+P(I1,4)*P(I2,4)*CTHE
56670 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
56671 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
56672 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
56677 C...Calculate H1/H0 - H4/H0. Output.
56680 H10=(HD+2D0*H10)/H0
56681 H20=(HD+2D0*H20)/H0
56682 H30=(HD+2D0*H30)/H0
56683 H40=(HD+2D0*H40)/H0
56688 C*********************************************************************
56691 C...Evaluates various properties of an event, with statistics
56692 C...accumulated during the course of the run and
56693 C...printed at the end.
56695 SUBROUTINE PYTABU(MTABU)
56697 C...Double precision and integer declarations.
56698 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56699 IMPLICIT INTEGER(I-N)
56700 INTEGER PYK,PYCHGE,PYCOMP
56702 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56703 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56704 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56705 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
56706 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
56707 C...Local arrays, character variables, saved variables and data.
56708 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
56709 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
56710 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
56711 &KFDM(8),KFDC(200,0:8),NPDC(200)
56712 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
56713 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
56714 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
56715 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
56716 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
56717 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
56718 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
56719 &NEVDC/0/,NKFDC/0/,NREDC/0/
56721 C...Reset statistics on initial parton state.
56722 IF(MTABU.EQ.10) THEN
56726 C...Identify and order flavour content of initial state.
56727 ELSEIF(MTABU.EQ.11) THEN
56729 KFM1=2*IABS(MSTU(161))
56730 IF(MSTU(161).GT.0) KFM1=KFM1-1
56731 KFM2=2*IABS(MSTU(162))
56732 IF(MSTU(162).GT.0) KFM2=KFM2-1
56733 KFMN=MIN(KFM1,KFM2)
56734 KFMX=MAX(KFM1,KFM2)
56736 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
56739 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
56740 & KFMX.LT.KFIS(I,2))) THEN
56746 110 IF(IKFIS.LT.0) THEN
56749 IF(NKFIS.GE.100) RETURN
56750 DO 130 I=NKFIS,IKFIS,-1
56751 KFIS(I+1,1)=KFIS(I,1)
56752 KFIS(I+1,2)=KFIS(I,2)
56754 NPIS(I+1,J)=NPIS(I,J)
56764 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
56766 C...Count number of partons in initial state.
56769 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
56770 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
56771 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
56776 IF(IM.LE.0.OR.IM.GT.N) THEN
56778 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
56780 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
56781 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
56791 IF(NP.GE.11) NPCO=8
56792 IF(NP.GE.16) NPCO=9
56793 IF(NP.GE.26) NPCO=10
56794 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
56797 C...Write statistics on initial parton state.
56798 ELSEIF(MTABU.EQ.12) THEN
56799 FAC=1D0/MAX(1,NEVIS)
56800 WRITE(MSTU(11),5000) NEVIS
56803 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
56805 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
56806 CALL PYNAME(KFM1,CHAU)
56808 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
56810 IF(KFIS(I,1).EQ.0) KFMX=0
56812 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
56813 CALL PYNAME(KFM2,CHAU)
56815 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
56816 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
56817 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
56820 C...Copy statistics on initial parton state into /PYJETS/.
56821 ELSEIF(MTABU.EQ.13) THEN
56822 FAC=1D0/MAX(1,NEVIS)
56825 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
56827 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
56829 IF(KFIS(I,1).EQ.0) KFMX=0
56831 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
56838 P(I,J)=FAC*NPIS(I,J)
56839 V(I,J)=FAC*NPIS(I,J+5)
56853 C...Reset statistics on number of particles/partons.
56854 ELSEIF(MTABU.EQ.20) THEN
56861 C...Identify whether particle/parton is primary or not.
56862 ELSEIF(MTABU.EQ.21) THEN
56866 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
56867 MSTU(62)=MSTU(62)+1
56870 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
56872 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
56874 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
56876 ELSEIF(KC.EQ.0) THEN
56877 ELSEIF(K(K(I,3),1).EQ.13) THEN
56879 IF(IM.LE.0.OR.IM.GT.N) THEN
56881 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
56884 ELSEIF(KCHG(KC,2).EQ.0) THEN
56885 KCM=PYCOMP(K(K(I,3),2))
56887 IF(KCHG(KCM,2).NE.0) MPRI=1
56890 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
56891 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
56893 IF(K(I,1).LE.10) THEN
56895 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
56898 C...Fill statistics on number of particles/partons in event.
56900 KFS=3-ISIGN(1,K(I,2))-MPRI
56902 IF(KFA.EQ.KFFS(IP)) THEN
56905 ELSEIF(KFA.LT.KFFS(IP)) THEN
56911 220 IF(IKFFS.LT.0) THEN
56914 IF(NKFFS.GE.400) RETURN
56915 DO 240 IP=NKFFS,IKFFS,-1
56916 KFFS(IP+1)=KFFS(IP)
56918 NPFS(IP+1,J)=NPFS(IP,J)
56927 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
56930 C...Write statistics on particle/parton composition of events.
56931 ELSEIF(MTABU.EQ.22) THEN
56932 FAC=1D0/MAX(1,NEVFS)
56933 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
56935 CALL PYNAME(KFFS(I),CHAU)
56938 IF(KC.NE.0) MDCYF=MDCY(KC,1)
56939 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
56940 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
56943 C...Copy particle/parton composition information into /PYJETS/.
56944 ELSEIF(MTABU.EQ.23) THEN
56945 FAC=1D0/MAX(1,NEVFS)
56951 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
56953 P(I,J)=FAC*NPFS(I,J)
56973 C...Reset factorial moments statistics.
56974 ELSEIF(MTABU.EQ.30) THEN
56980 FM1FM(IM,IB,IP)=0D0
56981 FM2FM(IM,IB,IP)=0D0
56986 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
56987 ELSEIF(MTABU.EQ.31) THEN
56992 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
56993 IF(MSTU(41).GE.2) THEN
56995 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56996 & KC.EQ.18) GOTO 410
56997 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
56998 & PYCHGE(K(I,2)).EQ.0) GOTO 410
57001 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
57002 IF(MSTU(42).GE.2) PMR=P(I,5)
57003 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
57004 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
57006 IF(ABS(YETA).GT.PARU(57)) GOTO 410
57007 PHI=PYANGL(P(I,1),P(I,2))
57008 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
57009 IYETA=MAX(0,MIN(511,IYETA))
57010 IPHI=512D0*(PHI+PARU(1))/PARU(2)
57011 IPHI=MAX(0,MIN(511,IPHI))
57014 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
57017 C...Order particles in (pseudo)rapidity and/or azimuth.
57018 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
57019 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
57023 IF(NUPP.EQ.NLOW+1) THEN
57028 DO 350 I1=NUPP-1,NLOW+1,-1
57029 IF(IYETA.GE.K(I1,1)) GOTO 360
57032 360 K(I1+1,1)=IYETA
57033 DO 370 I1=NUPP-1,NLOW+1,-1
57034 IF(IPHI.GE.K(I1,2)) GOTO 380
57038 DO 390 I1=NUPP-1,NLOW+1,-1
57039 IF(IYEP.GE.K(I1,3)) GOTO 400
57049 C...Calculate sum of factorial moments in event.
57057 IF(IM.LE.2) IBIN=2**(10-IB)
57058 IF(IM.EQ.3) IBIN=4**(10-IB)
57059 IAGR=K(NLOW+1,IM)/IBIN
57061 DO 440 I=NLOW+2,NUPP+1
57063 IF(ICUT.EQ.IAGR) THEN
57067 ELSEIF(NAGR.EQ.2) THEN
57068 FEVFM(IB,1)=FEVFM(IB,1)+2D0
57069 ELSEIF(NAGR.EQ.3) THEN
57070 FEVFM(IB,1)=FEVFM(IB,1)+6D0
57071 FEVFM(IB,2)=FEVFM(IB,2)+6D0
57072 ELSEIF(NAGR.EQ.4) THEN
57073 FEVFM(IB,1)=FEVFM(IB,1)+12D0
57074 FEVFM(IB,2)=FEVFM(IB,2)+24D0
57075 FEVFM(IB,3)=FEVFM(IB,3)+24D0
57077 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
57078 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
57079 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
57081 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
57082 & (NAGR-3D0)*(NAGR-4D0)
57090 C...Add results to total statistics.
57093 IF(FEVFM(1,IP).LT.0.5D0) THEN
57095 ELSEIF(IM.LE.2) THEN
57096 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
57098 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
57100 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
57101 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
57105 NMUFM=NMUFM+(NUPP-NLOW)
57108 C...Write accumulated statistics on factorial moments.
57109 ELSEIF(MTABU.EQ.32) THEN
57110 FAC=1D0/MAX(1,NEVFM)
57111 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
57112 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
57113 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
57115 WRITE(MSTU(11),5500)
57118 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
57120 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
57121 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
57122 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
57124 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
57125 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
57128 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
57133 C...Copy statistics on factorial moments into /PYJETS/.
57134 ELSEIF(MTABU.EQ.33) THEN
57135 FAC=1D0/MAX(1,NEVFM)
57142 IF(IM.NE.2) K(I,3)=2**(IB-1)
57144 IF(IM.NE.1) K(I,4)=2**(IB-1)
57146 P(I,1)=2D0*PARU(57)/K(I,3)
57147 V(I,1)=PARU(2)/K(I,4)
57149 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
57150 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
57166 C...Reset statistics on Energy-Energy Correlation.
57167 ELSEIF(MTABU.EQ.40) THEN
57178 C...Find particles to include, with proper assumed mass.
57179 ELSEIF(MTABU.EQ.41) THEN
57185 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
57186 IF(MSTU(41).GE.2) THEN
57188 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
57189 & KC.EQ.18) GOTO 570
57190 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
57191 & PYCHGE(K(I,2)).EQ.0) GOTO 570
57194 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
57195 IF(MSTU(42).GE.2) PMR=P(I,5)
57196 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
57197 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
57204 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
57205 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
57208 IF(NUPP.EQ.NLOW) RETURN
57210 C...Analyze Energy-Energy Correlation in event.
57211 FAC=(2D0/ECM**2)*50D0/PARU(1)
57215 DO 600 I1=NLOW+2,NUPP
57216 DO 590 I2=NLOW+1,I1-1
57217 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
57218 & (P(I1,5)*P(I2,5))
57219 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
57220 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
57221 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
57225 FE1EC(J)=FE1EC(J)+FEVEE(J)
57226 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
57227 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
57228 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
57229 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
57230 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
57234 C...Write statistics on Energy-Energy Correlation.
57235 ELSEIF(MTABU.EQ.42) THEN
57236 FAC=1D0/MAX(1,NEVEE)
57237 WRITE(MSTU(11),5700) NEVEE
57240 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
57241 FEEC2=FAC*FE1EC(51-J)
57242 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
57244 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
57245 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
57246 & FEEC2,FEES2,FEECA,FEESA
57249 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
57250 ELSEIF(MTABU.EQ.43) THEN
57251 FAC=1D0/MAX(1,NEVEE)
57258 P(I,1)=FAC*FE1EC(I)
57259 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
57260 P(I,2)=FAC*FE1EC(51-I)
57261 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
57262 P(I,3)=FAC*FE1EA(I)
57263 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
57264 P(I,4)=PARU(1)*(I-1)/50D0
57265 P(I,5)=PARU(1)*I/50D0
57280 C...Reset statistics on decay channels.
57281 ELSEIF(MTABU.EQ.50) THEN
57286 C...Identify and order flavour content of final state.
57287 ELSEIF(MTABU.EQ.51) THEN
57291 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
57298 IF(K(I,2).LT.0) KFM=KFM-1
57299 DO 650 IDS=NDS-1,1,-1
57301 IF(KFM.LT.KFDM(IDS)) GOTO 660
57302 KFDM(IDS+1)=KFDM(IDS)
57308 C...Find whether old or new final state.
57310 IF(NDS.LT.KFDC(IDC,0)) THEN
57313 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
57315 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
57318 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
57327 700 IF(IKFDC.LT.0) THEN
57329 ELSEIF(NKFDC.GE.200) THEN
57333 DO 720 IDC=NKFDC,IKFDC,-1
57334 NPDC(IDC+1)=NPDC(IDC)
57336 KFDC(IDC+1,I)=KFDC(IDC,I)
57342 KFDC(IKFDC,I)=KFDM(I)
57346 NPDC(IKFDC)=NPDC(IKFDC)+1
57348 C...Write statistics on decay channels.
57349 ELSEIF(MTABU.EQ.52) THEN
57350 FAC=1D0/MAX(1,NEVDC)
57351 WRITE(MSTU(11),5900) NEVDC
57353 DO 740 I=1,KFDC(IDC,0)
57356 IF(2*KF.NE.KFM) KF=-KF
57357 CALL PYNAME(KF,CHAU)
57359 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
57361 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
57363 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
57365 C...Copy statistics on decay channels into /PYJETS/.
57366 ELSEIF(MTABU.EQ.53) THEN
57367 FAC=1D0/MAX(1,NEVDC)
57373 K(IDC,5)=KFDC(IDC,0)
57378 DO 770 I=1,KFDC(IDC,0)
57381 IF(2*KF.NE.KFM) KF=-KF
57382 IF(I.LE.5) P(IDC,I)=KF
57383 IF(I.GE.6) V(IDC,I-5)=KF
57385 V(IDC,5)=FAC*NPDC(IDC)
57400 C...Format statements for output on unit MSTU(11) (default 6).
57401 5000 FORMAT(///20X,'Event statistics - initial state'/
57402 &20X,'based on an analysis of ',I6,' events'//
57403 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
57404 &'according to fragmenting system multiplicity'/
57405 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
57406 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
57407 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
57408 5200 FORMAT(///20X,'Event statistics - final state'/
57409 &20X,'based on an analysis of ',I7,' events'//
57410 &5X,'Mean primary multiplicity =',F10.4/
57411 &5X,'Mean final multiplicity =',F10.4/
57412 &5X,'Mean charged multiplicity =',F10.4//
57413 &5X,'Number of particles produced per event (directly and via ',
57414 &'decays/branchings)'/
57415 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
57416 &8X,'Total'/35X,'prim seco prim seco'/)
57417 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
57418 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
57419 &20X,'based on an analysis of ',I6,' events'//
57420 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
57421 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
57423 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
57424 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
57425 &20X,'based on an analysis of ',I6,' events'//
57426 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
57427 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
57428 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
57429 5900 FORMAT(///20X,'Decay channel analysis - final state'/
57430 &20X,'based on an analysis of ',I6,' events'//
57431 &2X,'Probability',10X,'Complete final state'/)
57432 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
57433 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
57434 &'or table overflow)')
57439 C*********************************************************************
57442 C...Handles the generation of an e+e- annihilation jet event.
57444 SUBROUTINE PYEEVT(KFL,ECM)
57446 C...Double precision and integer declarations.
57447 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57448 IMPLICIT INTEGER(I-N)
57449 INTEGER PYK,PYCHGE,PYCOMP
57451 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57452 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57453 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57454 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
57456 C...Check input parameters.
57457 IF(MSTU(12).GE.1) CALL PYLIST(0)
57458 IF(KFL.LT.0.OR.KFL.GT.8) THEN
57459 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
57460 IF(MSTU(21).GE.1) RETURN
57462 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
57463 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
57464 IF(ECM.LT.ECMMIN) THEN
57465 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
57466 IF(MSTU(21).GE.1) RETURN
57469 C...Check consistency of MSTJ options set.
57470 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
57472 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
57475 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
57477 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
57481 C...Initialize alpha_strong and total cross-section.
57482 MSTU(111)=MSTJ(108)
57483 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
57485 PARU(112)=PARJ(121)
57486 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
57487 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
57488 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
57490 IF(MSTJ(116).GE.3) MSTJ(116)=1
57493 C...Add initial e+e- to event record (documentation only).
57496 IF(NTRY.GT.100) THEN
57497 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
57502 IF(MSTJ(115).GE.2) THEN
57504 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
57506 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
57510 C...Radiative photon (in initial state).
57513 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
57515 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
57516 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
57518 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
57519 K(NC,3)=MIN(MSTJ(115)/2,1)
57522 C...Virtual exchange boson (gamma or Z0).
57523 IF(MSTJ(115).GE.3) THEN
57526 IF(MSTJ(102).EQ.2) KF=23
57530 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
57536 C...Choice of flavour and jet configuration.
57537 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
57538 IF(KFLC.EQ.0) GOTO 100
57539 CALL PYXJET(ECMC,NJET,CUT)
57541 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
57543 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
57544 IF(NJET.EQ.2) MSTJ(120)=1
57546 C...Fill jet configuration and origin.
57547 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
57548 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
57550 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
57551 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
57552 &-KFLC,ECMC,X1,X2,X4,X12,X14)
57553 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
57554 &-KFLC,ECMC,X1,X2,X4,X12,X14)
57555 IF(MSTU(24).NE.0) GOTO 100
57557 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
57560 C...Angular orientation according to matrix element.
57561 IF(MSTJ(106).EQ.1) THEN
57562 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
57563 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
57564 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
57567 C...Rotation and boost from radiative photon.
57569 DBEK=-PAK/(ECM-PAK)
57570 NMIN=NC+1-MSTJ(115)/3
57571 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
57572 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
57573 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
57576 C...Generate parton shower. Rearrange along strings and check.
57577 IF(MSTJ(101).EQ.5) THEN
57578 CALL PYSHOW(N-1,N,ECMC)
57580 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
57581 IF(MSTJ(105).GE.0) MSTU(28)=0
57584 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
57587 C...Fragmentation/decay generation. Information for PYTABU.
57588 IF(MSTJ(105).EQ.1) CALL PYEXEC
57595 C*********************************************************************
57598 C...Calculates total cross-section, including initial state
57599 C...radiation effects.
57601 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
57603 C...Double precision and integer declarations.
57604 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57605 IMPLICIT INTEGER(I-N)
57606 INTEGER PYK,PYCHGE,PYCOMP
57608 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57609 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57610 SAVE /PYDAT1/,/PYDAT2/
57612 C...Status, (optimized) Q^2 scale, alpha_strong.
57614 MSTJ(119)=10*MSTJ(102)+KFL
57615 IF(MSTJ(111).EQ.0) THEN
57617 ELSEIF(MSTU(111).EQ.0) THEN
57618 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
57619 & ((33D0-2D0*MSTU(112))*PARU(111)))))
57620 Q2R=PARJ(168)*ECM**2
57622 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
57623 & (2D0*PARU(112)/ECM)**2))
57624 Q2R=PARJ(168)*ECM**2
57626 ALSPI=PYALPS(Q2R)/PARU(1)
57628 C...QCD corrections factor in R.
57629 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
57631 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
57633 ELSEIF(MSTJ(109).EQ.0) THEN
57634 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
57635 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
57636 & LOG(PARJ(168))*ALSPI**2)
57637 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
57638 RQCD=1D0+(3D0/4D0)*ALSPI
57640 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
57643 C...Calculate Z0 width if default value not acceptable.
57644 IF(MSTJ(102).GE.3) THEN
57645 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
57646 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
57649 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
57650 & (2D0*PYMASS(KFLC)/ ECM)**2))
57651 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
57652 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
57653 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
57655 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
57659 C...Calculate propagator and related constants for QFD case.
57660 POLL=1D0-PARJ(131)*PARJ(132)
57661 IF(MSTJ(102).GE.2) THEN
57662 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
57663 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
57664 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
57665 VE=4D0*PARU(102)-1D0
57666 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
57667 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
57672 C...Loop over different flavours: charge, velocity.
57677 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
57678 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
57681 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
57682 QF=KCHG(KFLC,1)/3D0
57684 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
57686 C...Calculate R and sum of charges for QED or QFD case.
57687 RQQ=RQQ+3D0*QF**2*POLL
57688 IF(MSTJ(102).LE.1) THEN
57689 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
57691 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
57692 RQV=RQV-6D0*QF*VF*SF1I
57693 RVA=RVA+3D0*(VF**2+1D0)*SF1W
57694 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
57695 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
57699 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
57701 C...Calculate cross-section, including QCD corrections.
57704 PARJ(143)=RTOT*RQCD
57705 PARJ(144)=PARJ(143)
57706 PARJ(145)=PARJ(141)*86.8D0/ECM**2
57707 PARJ(146)=PARJ(142)*86.8D0/ECM**2
57708 PARJ(147)=PARJ(143)*86.8D0/ECM**2
57709 PARJ(148)=PARJ(147)
57710 PARJ(157)=RSUM*RQCD
57714 IF(MSTJ(107).LE.0) RETURN
57716 C...Virtual cross-section.
57718 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
57719 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
57720 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
57721 &1.526D0*LOG(ECM**2/0.932D0)
57723 C...Soft and hard radiative cross-section in QED case.
57724 IF(MSTJ(102).LE.1) THEN
57725 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
57726 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
57727 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
57729 C...Soft and hard radiative cross-section in QFD case.
57731 SZM=1D0-(PARJ(123)/ECM)**2
57732 SZW=PARJ(123)*PARJ(124)/ECM**2
57733 PARJ(161)=-RQQ/RSUM
57734 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
57735 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
57736 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
57737 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
57738 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
57739 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
57740 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
57741 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
57742 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
57743 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
57744 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
57745 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
57746 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
57749 C...Total cross-section and fraction of hard photon events.
57750 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
57751 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
57752 PARJ(144)=PARJ(157)
57753 PARJ(148)=PARJ(144)*86.8D0/ECM**2
57759 C*********************************************************************
57762 C...Generates initial state photon radiation.
57764 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
57766 C...Double precision and integer declarations.
57767 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57768 IMPLICIT INTEGER(I-N)
57769 INTEGER PYK,PYCHGE,PYCOMP
57771 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57774 C...Function: cumulative hard photon spectrum in QFD case.
57775 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
57776 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
57778 C...Determine whether radiative photon or not.
57781 IF(PARJ(160).LT.PYR(0)) RETURN
57784 C...Photon energy range. Find photon momentum in QED case.
57786 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
57787 IF(MSTJ(102).LE.1) THEN
57788 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
57789 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
57791 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
57793 SZM=1D0-(PARJ(123)/ECM)**2
57794 SZW=PARJ(123)*PARJ(124)/ECM**2
57797 FXKD=1D-4*(FXKU-FXKL)
57798 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
57803 IF(FXKV.GT.FXKR) THEN
57810 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
57811 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
57815 C...Photon polar and azimuthal angle.
57816 PME=2D0*(PYMASS(11)/ECM)**2
57817 120 CTHM=PME*(2D0/PME)**PYR(0)
57818 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
57819 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
57821 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
57822 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
57823 THEK=PYANGL(CTHE,STHE)
57824 PHIK=PARU(2)*PYR(0)
57826 C...Rotation angle for hadronic system.
57828 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
57830 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
57831 &(2D0-XK*(1D0-SGN*CTHE)))
57836 C*********************************************************************
57839 C...Selects flavour for produced qqbar pair.
57841 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
57843 C...Double precision and integer declarations.
57844 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57845 IMPLICIT INTEGER(I-N)
57846 INTEGER PYK,PYCHGE,PYCOMP
57848 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57849 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57850 SAVE /PYDAT1/,/PYDAT2/
57852 C...Calculate maximum weight in QED or QFD case.
57853 IF(MSTJ(102).LE.1) THEN
57856 POLL=1D0-PARJ(131)*PARJ(132)
57857 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
57858 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
57859 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
57860 VE=4D0*PARU(102)-1D0
57861 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
57862 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
57863 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
57864 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
57865 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
57869 C...Choose flavour. Gives charge and velocity.
57872 IF(NTRY.GT.100) THEN
57873 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
57878 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
57881 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
57882 QF=KCHG(KFLC,1)/3D0
57884 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
57886 C...Calculate weight in QED or QFD case.
57887 IF(MSTJ(102).LE.1) THEN
57889 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
57891 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
57892 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
57893 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
57895 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
57898 C...Weighting or new event (radiative photon). Cross-section update.
57899 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
57900 PARJ(158)=PARJ(158)+1D0
57901 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
57902 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
57903 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
57904 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
57905 PARJ(148)=PARJ(144)*86.8D0/ECM**2
57910 C*********************************************************************
57913 C...Selects number of jets in matrix element approach.
57915 SUBROUTINE PYXJET(ECM,NJET,CUT)
57917 C...Double precision and integer declarations.
57918 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57919 IMPLICIT INTEGER(I-N)
57920 INTEGER PYK,PYCHGE,PYCOMP
57922 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57924 C...Local array and data.
57926 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
57928 C...Trivial result for two-jets only, including parton shower.
57929 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
57932 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
57933 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
57935 IF(MSTJ(109).EQ.2) CF=1D0
57936 IF(MSTJ(111).EQ.0) THEN
57939 ELSEIF(MSTU(111).EQ.0) THEN
57940 PARJ(169)=MIN(1D0,PARJ(129))
57941 Q2=PARJ(169)*ECM**2
57942 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
57943 & ((33D0-2D0*MSTU(112))*PARU(111)))))
57944 Q2R=PARJ(168)*ECM**2
57946 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
57947 Q2=PARJ(169)*ECM**2
57948 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
57949 & (2D0*PARU(112)/ECM)**2))
57950 Q2R=PARJ(168)*ECM**2
57953 C...alpha_strong for R and R itself.
57954 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
57955 IF(IABS(MSTJ(101)).EQ.1) THEN
57957 ELSEIF(MSTJ(109).EQ.0) THEN
57958 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
57959 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
57960 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
57962 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
57965 C...alpha_strong for jet rate. Initial value for y cut.
57966 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
57967 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
57968 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
57969 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
57970 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
57972 C...Parametrization of first order three-jet cross-section.
57973 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
57976 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
57977 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
57978 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
57979 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
57980 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
57984 C...Parametrization of second order three-jet cross-section.
57985 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
57986 & CUT.GE.0.25D0) THEN
57988 ELSEIF(MSTJ(110).LE.1) THEN
57989 CT=LOG(1D0/CUT-2D0)
57990 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
57991 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
57993 C...Interpolation in second/first order ratio for Zhu parametrization.
57994 ELSEIF(MSTJ(110).EQ.2) THEN
57997 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
58003 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
58005 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
58008 C...Shift in second order three-jet cross-section with optimized Q^2.
58009 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
58010 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
58011 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
58013 C...Parametrization of second order four-jet cross-section.
58014 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
58017 CT=LOG(1D0/CUT-5D0)
58018 IF(CUT.LE.0.018D0) THEN
58019 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
58020 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
58022 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
58023 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
58025 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
58026 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
58027 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
58028 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
58029 & 0.002093D0*CT**3)
58030 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
58032 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
58033 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
58036 C...If negative three-jet rate, change y' optimization parameter.
58037 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
58038 & PARJ(169).LT.0.99D0) THEN
58039 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
58040 Q2=PARJ(169)*ECM**2
58041 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
58045 C...If too high cross-section, use harder cuts, or fail.
58046 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
58047 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
58048 & PARJ(169).LT.0.99D0) THEN
58049 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
58050 Q2=PARJ(169)*ECM**2
58051 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
58053 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
58055 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
58057 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
58058 & PARJ(154))**(-1D0/3D0)
58059 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
58063 C...Scalar gluon (first order only).
58065 ALSPI=PYALPS(ECM**2)/PARU(1)
58066 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
58068 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
58069 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
58074 C...Select number of jets.
58076 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
58078 ELSEIF(MSTJ(101).LE.0) THEN
58079 NJET=MIN(4,2-MSTJ(101))
58083 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
58084 IF(PARJ(154).GT.RNJ) NJET=4
58090 C*********************************************************************
58093 C...Selects the kinematical variables of three-jet events.
58095 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
58097 C...Double precision and integer declarations.
58098 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58099 IMPLICIT INTEGER(I-N)
58100 INTEGER PYK,PYCHGE,PYCOMP
58102 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58105 DIMENSION ZHUP(5,12)
58107 C...Coefficients of Zhu second order parametrization.
58108 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
58109 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
58110 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
58111 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
58112 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
58113 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
58114 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
58115 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
58116 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
58117 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
58118 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
58120 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
58121 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
58124 C...Event type. Mass effect factors and other common constants.
58128 QME=(2D0*PMQ/ECM)**2
58129 IF(MSTJ(109).NE.1) THEN
58131 CUTD=LOG(1D0/CUT-2D0)
58132 IF(MSTJ(109).EQ.0) THEN
58136 WTMX=MIN(20D0,37D0-6D0*CUTD)
58137 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
58145 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
58146 ALS2PI=PARU(118)/PARU(2)
58148 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
58149 & LOG(PARJ(169))*ALS2PI
58150 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
58152 C...Choose three-jet events in allowed region.
58154 110 Y13L=CUTL+CUTD*PYR(0)
58155 Y23L=CUTL+CUTD*PYR(0)
58159 IF(Y12.LE.CUT) GOTO 110
58160 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
58162 C...Second order corrections.
58163 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
58168 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
58169 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
58170 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
58171 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
58172 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
58173 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
58174 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
58175 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
58176 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
58177 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
58178 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
58179 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
58180 & TR*(2D0*CUTL/3D0-10D0/9D0)+
58181 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
58182 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
58183 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
58184 & Y13*Y23)/(Y12+Y13)**2)/WT1+
58185 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
58186 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
58187 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
58188 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
58189 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
58190 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
58191 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
58192 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
58193 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
58194 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
58196 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
58197 C...Second order corrections; Zhu parametrization of ERT.
58202 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
58206 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
58207 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
58208 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
58209 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
58212 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
58213 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
58214 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
58215 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
58217 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
58218 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
58219 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
58220 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
58221 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
58223 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
58224 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
58225 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
58228 C...Impose mass cuts (gives two jets). For fixed jet number new try.
58232 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
58233 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
58234 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
58235 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
58236 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
58238 C...Scalar gluon model (first order only, no mass effects).
58241 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
58242 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
58243 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
58244 X1=1D0-0.5D0*(X3+YD)
58245 X2=1D0-0.5D0*(X3-YD)
58246 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
58247 IF(MSTJ(102).GE.2) THEN
58248 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
58249 & X3**2*PYR(0)) NJET=2
58251 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
58257 C*********************************************************************
58260 C...Selects the kinematical variables of four-jet events.
58262 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
58264 C...Double precision and integer declarations.
58265 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58266 IMPLICIT INTEGER(I-N)
58267 INTEGER PYK,PYCHGE,PYCOMP
58269 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58272 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
58274 C...Common constants. Colour factors for QCD and Abelian gluon theory.
58276 QME=(2D0*PMQ/ECM)**2
58277 CT=LOG(1D0/CUT-5D0)
58278 IF(MSTJ(109).EQ.0) THEN
58288 C...Choice of process (qqbargg or qqbarqqbar).
58291 IF(PARJ(155).GT.PYR(0)) IT=2
58292 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
58293 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
58294 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
58295 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
58298 C...Sample the five kinematical variables (for qqgg preweighted in y34).
58299 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
58300 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
58301 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
58302 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
58303 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
58305 CP=COS(PARU(1)*PYR(0))
58308 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
58309 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
58310 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
58312 Y12=1D0-Y134-Y23-Y24
58313 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
58317 C...Calculate matrix elements for qqgg or qqqq process.
58322 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
58323 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
58324 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
58325 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
58326 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
58327 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
58328 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
58329 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
58330 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
58331 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
58332 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
58333 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
58334 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
58335 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
58336 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
58337 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
58338 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
58339 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
58340 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
58341 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
58342 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
58343 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
58344 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
58345 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
58346 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
58347 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
58348 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
58349 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
58350 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
58351 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
58352 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
58353 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
58354 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
58355 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
58356 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
58357 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
58358 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
58359 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
58360 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
58361 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
58362 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
58365 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
58366 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
58367 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
58368 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
58369 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
58370 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
58371 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
58372 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
58373 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
58374 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
58375 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
58376 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
58377 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
58378 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
58379 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
58380 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
58381 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
58382 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
58385 C...Permutations of momenta in matrix element. Weighting.
58386 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
58397 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
58408 IF(IC.LE.3) GOTO 120
58409 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
58412 C...qqgg events: string configuration and event type.
58414 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
58415 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
58416 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
58417 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
58418 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
58419 IF(ID.EQ.2) GOTO 130
58420 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
58421 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
58422 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
58423 IF(ID.EQ.2) GOTO 130
58426 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
58427 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
58430 C...Mass cuts. Kinematical variables out.
58431 IF(Y12.LE.CUT+QME) NJET=2
58432 IF(NJET.EQ.2) GOTO 150
58433 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
58434 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
58435 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
58437 X12=(1D0-Q12)*Y13+Q12*Y23
58439 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
58441 C...qqbarqqbar events: string configuration, choose new flavour.
58444 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
58445 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
58446 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
58447 IF(WTR.LT.WTD(4)) ID=4
58448 IF(ID.GE.2) GOTO 130
58451 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
58452 140 KFLN=1+INT(5D0*PYR(0))
58453 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
58454 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
58455 IF(KFLN.GT.MSTJ(104)) NJET=2
58457 QMEN=(2D0*PMQN/ECM)**2
58459 C...Mass cuts. Kinematical variables out.
58460 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
58461 IF(NJET.EQ.2) GOTO 150
58462 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
58463 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
58464 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
58465 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
58466 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
58467 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
58470 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
58472 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
58473 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
58474 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
58476 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
58481 C*********************************************************************
58484 C...Gives the angular orientation of events.
58486 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
58488 C...Double precision and integer declarations.
58489 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58490 IMPLICIT INTEGER(I-N)
58491 INTEGER PYK,PYCHGE,PYCOMP
58493 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58494 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58495 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58496 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58498 C...Charge. Factors depending on polarization for QED case.
58500 POLL=1D0-PARJ(131)*PARJ(132)
58501 POLD=PARJ(132)-PARJ(131)
58502 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
58508 C...Factors depending on flavour, energy and polarization for QFD case.
58510 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
58511 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
58512 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
58514 VE=4D0*PARU(102)-1D0
58516 VF=AF-4D0*QF*PARU(102)
58517 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
58518 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
58519 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
58520 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
58521 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
58522 & SFW*SFF**2*(VE**2-AE**2))
58523 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
58527 C...Mass factor. Differential cross-sections for two-jet events.
58530 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
58531 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
58533 SIGU=4D0*SQRT(1D0-QME)
58534 SIGL=2D0*QME*SQRT(1D0-QME)
58540 C...Kinematical variables. Reduce four-jet event to three-jet one.
58543 X1=2D0*P(NC+1,4)/ECM
58544 X2=2D0*P(NC+3,4)/ECM
58546 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
58547 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
58548 X1=2D0*P(NC+1,4)/ECMR
58549 X2=2D0*P(NC+4,4)/ECMR
58552 C...Differential cross-sections for three-jet (or reduced four-jet).
58553 XQ=(1D0-X1)/(1D0-X2)
58554 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
58555 ST12=SQRT(1D0-CT12**2)
58556 IF(MSTJ(109).NE.1) THEN
58557 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
58558 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
58559 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
58560 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
58562 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
58563 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
58564 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
58565 SIGA=X2**2*ST12/SQ2
58566 SIGP=2D0*(X1**2-X2**2*CT12)
58568 C...Differential cross-sect for scalar gluons (no mass effects).
58572 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
58573 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
58574 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
58575 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
58576 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
58577 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
58578 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
58579 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
58580 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
58581 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
58582 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
58586 C...Upper bounds for differential cross-section.
58591 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
58592 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
58593 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
58594 &2D0*HF2A*ABS(SIGP)
58596 C...Generate angular orientation according to differential cross-sect.
58597 100 CHI=PARU(2)*PYR(0)
58598 CTHE=2D0*PYR(0)-1D0
58606 C2PHI=COS(2D0*(PHI-PARJ(134)))
58607 S2PHI=SIN(2D0*(PHI-PARJ(134)))
58608 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
58609 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
58610 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
58611 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
58612 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
58613 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
58614 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
58615 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
58620 C*********************************************************************
58623 C...Generates Upsilon and toponium decays into three gluons
58624 C...or two gluons and a photon.
58626 SUBROUTINE PYONIA(KFL,ECM)
58628 C...Double precision and integer declarations.
58629 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58630 IMPLICIT INTEGER(I-N)
58631 INTEGER PYK,PYCHGE,PYCOMP
58633 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58634 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58635 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58636 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58638 C...Printout. Check input parameters.
58639 IF(MSTU(12).GE.1) CALL PYLIST(0)
58640 IF(KFL.LT.0.OR.KFL.GT.8) THEN
58641 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
58642 IF(MSTU(21).GE.1) RETURN
58644 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
58645 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
58646 IF(MSTU(21).GE.1) RETURN
58649 C...Initial e+e- and onium state (optional).
58651 IF(MSTJ(115).GE.2) THEN
58653 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
58655 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
58659 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
58665 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
58671 C...Choose x1 and x2 according to matrix element.
58676 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
58677 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
58680 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
58681 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
58683 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
58684 MSTU(111)=MSTJ(108)
58685 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
58687 PARU(112)=PARJ(121)
58688 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
58690 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
58691 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
58694 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
58695 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
58697 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
58698 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
58701 ECMC=SQRT(1D0-X1)*ECM
58702 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
58707 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
58708 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
58709 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
58710 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
58712 IF(ECMC.LT.4D0*PARJ(127)) THEN
58716 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
58722 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
58725 C...Differential cross-sections. Upper limit for cross-section.
58726 IF(MSTJ(106).EQ.1) THEN
58728 HF1=1D0-PARJ(131)*PARJ(132)
58730 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
58731 ST13=SQRT(1D0-CT13**2)
58732 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
58733 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
58735 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
58736 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
58737 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
58739 C...Angular orientation of event.
58740 120 CHI=PARU(2)*PYR(0)
58741 CTHE=2D0*PYR(0)-1D0
58749 C2PHI=COS(2D0*(PHI-PARJ(134)))
58750 S2PHI=SIN(2D0*(PHI-PARJ(134)))
58751 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
58752 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
58753 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
58754 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
58755 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
58756 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
58757 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
58758 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
58761 C...Generate parton shower. Rearrange along strings and check.
58762 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
58763 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
58765 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
58766 IF(MSTJ(105).GE.0) MSTU(28)=0
58769 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
58772 C...Generate fragmentation. Information for PYTABU:
58773 IF(MSTJ(105).EQ.1) CALL PYEXEC
58774 MSTU(161)=110*KFLC+3
58780 C*********************************************************************
58783 C...Books a histogram.
58785 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
58787 C...Double precision declaration.
58788 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58789 IMPLICIT INTEGER(I-N)
58791 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58793 C...Local character variables.
58794 CHARACTER TITLE*(*), TITFX*60
58796 C...Check that input is sensible. Find initial address in memory.
58797 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
58798 &'(PYBOOK:) not allowed histogram number')
58799 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
58800 &'(PYBOOK:) not allowed number of bins')
58801 IF(XL.GE.XU) CALL PYERRM(28,
58802 &'(PYBOOK:) x limits in wrong order')
58804 IHIST(4)=IHIST(4)+28+NX
58805 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
58806 &'(PYBOOK:) out of histogram space')
58809 C...Store histogram size and reset contents.
58813 BIN(IS+4)=(XU-XL)/NX
58816 C...Store title by conversion to integer to double precision.
58819 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
58820 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
58826 C*********************************************************************
58829 C...Fills entry in histogram.
58831 SUBROUTINE PYFILL(ID,X,W)
58833 C...Double precision declaration.
58834 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58835 IMPLICIT INTEGER(I-N)
58837 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58840 C...Find initial address in memory. Increase number of entries.
58841 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
58842 &'(PYFILL:) not allowed histogram number')
58844 IF(IS.EQ.0) CALL PYERRM(28,
58845 &'(PYFILL:) filling unbooked histogram')
58846 BIN(IS+5)=BIN(IS+5)+1D0
58848 C...Find bin in x, including under/overflow, and fill.
58849 IF(X.LT.BIN(IS+2)) THEN
58850 BIN(IS+6)=BIN(IS+6)+W
58851 ELSEIF(X.GE.BIN(IS+3)) THEN
58852 BIN(IS+8)=BIN(IS+8)+W
58854 BIN(IS+7)=BIN(IS+7)+W
58855 IX=(X-BIN(IS+2))/BIN(IS+4)
58856 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
58857 BIN(IS+9+IX)=BIN(IS+9+IX)+W
58863 C*********************************************************************
58866 C...Multiplies histogram contents by factor.
58868 SUBROUTINE PYFACT(ID,F)
58870 C...Double precision declaration.
58871 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58872 IMPLICIT INTEGER(I-N)
58874 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58877 C...Find initial address in memory. Multiply all contents bins.
58878 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
58879 &'(PYFACT:) not allowed histogram number')
58881 IF(IS.EQ.0) CALL PYERRM(28,
58882 &'(PYFACT:) scaling unbooked histogram')
58883 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
58890 C*********************************************************************
58893 C...Performs operations between histograms.
58895 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
58897 C...Double precision declaration.
58898 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58899 IMPLICIT INTEGER(I-N)
58901 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58903 C...Character variable.
58906 C...Find initial addresses in memory, and histogram size.
58907 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
58908 &'(PYFACT:) not allowed histogram number')
58910 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
58911 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
58912 NX=NINT(BIN(IS3+1))
58913 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
58915 C...Update info on number of histogram entries.
58916 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
58917 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
58918 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
58919 BIN(IS3+5)=BIN(IS1+5)
58922 C...Operations on pair of histograms: addition, subtraction,
58923 C...multiplication, division.
58924 IF(OPER.EQ.'+') THEN
58926 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
58928 ELSEIF(OPER.EQ.'-') THEN
58930 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
58932 ELSEIF(OPER.EQ.'*') THEN
58934 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
58936 ELSEIF(OPER.EQ.'/') THEN
58939 IF(ABS(FA2).LE.1D-20) THEN
58942 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
58946 C...Operations on single histogram: multiplication+addition,
58947 C...square root+addition, logarithm+addition.
58948 ELSEIF(OPER.EQ.'A') THEN
58950 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
58952 ELSEIF(OPER.EQ.'S') THEN
58954 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
58956 ELSEIF(OPER.EQ.'L') THEN
58959 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
58960 & ZMIN=0.8D0*BIN(IS1+IX)
58963 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
58966 C...Operation on two or three histograms: average and
58967 C...standard deviation.
58968 ELSEIF(OPER.EQ.'M') THEN
58970 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
58973 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
58976 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
58979 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
58983 BIN(IS1+IX)=F1*BIN(IS1+IX)
58990 C*********************************************************************
58993 C...Prints and resets all histograms.
58997 C...Double precision declaration.
58998 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58999 IMPLICIT INTEGER(I-N)
59001 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
59004 C...Loop over histograms, print and reset used ones.
59005 DO 100 ID=1,IHIST(1)
59007 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
59016 C*********************************************************************
59019 C...Prints a histogram (but does not reset it).
59021 SUBROUTINE PYPLOT(ID)
59023 C...Double precision declaration.
59024 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59025 IMPLICIT INTEGER(I-N)
59027 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59028 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
59029 SAVE /PYDAT1/,/PYBINS/
59030 C...Local arrays and character variables.
59031 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
59032 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
59034 C...Steps in histogram scale. Character sequence.
59035 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
59036 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
59038 C...Find initial address in memory; skip if empty histogram.
59039 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
59042 IF(NINT(BIN(IS+5)).LE.0) THEN
59043 WRITE(MSTU(11),5000) ID
59047 C...Number of histogram lines and x bins.
59051 C...Extract title by conversion from double precision via integer.
59053 IEQ=NINT(BIN(IS+8+NX+IT))
59054 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
59055 & //CHAR(MOD(IEQ,256))
59058 C...Find time; print title.
59060 IF(IDATI(1).GT.0) THEN
59061 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
59063 WRITE(MSTU(11),5200) ID, TITLE
59066 C...Find minimum and maximum bin content.
59069 DO 110 IX=IS+10,IS+8+NX
59070 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
59071 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
59074 C...Determine scale and step size for y axis.
59075 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
59076 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
59077 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
59078 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
59079 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
59080 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
59083 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
59087 C...Convert bin contents to integer form; fractional fill in top row.
59089 CTA=ABS(BIN(IS+8+IX))/DY
59090 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
59091 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
59093 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
59094 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
59096 C...Print histogram row by row.
59097 DO 150 IR=IRMA,IRMI,-1
59098 IF(IR.EQ.0) GOTO 150
59101 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
59102 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
59104 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
59107 C...Print sign and value of bin contents.
59108 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
59111 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
59112 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
59114 WRITE(MSTU(11),5400) OUT
59117 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
59119 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
59122 C...Print sign and value of lower bin edge.
59123 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
59127 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
59128 & OUT(IX:IX)=CHA(11)
59129 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
59131 WRITE(MSTU(11),5600) OUT
59134 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
59136 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
59140 C...Calculate and print statistics.
59145 CTA=ABS(BIN(IS+8+IX))
59146 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
59149 CXXSUM=CXXSUM+CTA*X**2
59151 XMEAN=CXSUM/MAX(CSUM,1D-20)
59152 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
59153 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
59154 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
59156 C...Formats for output.
59157 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
59158 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
59160 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
59161 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
59162 5400 FORMAT(/8X,'Contents',3X,A100)
59163 5500 FORMAT(9X,'*10**',I2,3X,A100)
59164 5600 FORMAT(/8X,'Low edge',3X,A100)
59165 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
59166 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
59167 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
59172 C*********************************************************************
59175 C...Resets bin contents of a histogram.
59177 SUBROUTINE PYNULL(ID)
59179 C...Double precision declaration.
59180 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59181 IMPLICIT INTEGER(I-N)
59183 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
59186 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
59189 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
59196 C*********************************************************************
59199 C...Dumps histogram contents on file for reading by other program.
59200 C...Can also read back own dump.
59202 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
59204 C...Double precision declaration.
59205 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59206 IMPLICIT INTEGER(I-N)
59208 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
59210 C...Local arrays and character variables.
59211 DIMENSION IHI(*),ISS(100),VAL(5)
59212 CHARACTER TITLE*60,FORMAT*13
59214 C...Dump all histograms that have been booked,
59215 C...including titles and ranges, one after the other.
59216 IF(MDUMP.EQ.1) THEN
59218 C...Loop over histograms and find which are wanted and booked.
59233 C...Write title, histogram size, filling statistics.
59236 IEQ=NINT(BIN(IS+8+NX+IT))
59237 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
59238 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
59240 WRITE(LFN,5100) ID,TITLE
59241 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
59242 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
59246 C...Write histogram contents, in groups of five.
59247 DO 120 IXG=1,(NX+4)/5
59251 VAL(IXV)=BIN(IS+8+IX)
59256 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
59259 C...Go to next histogram; finish.
59260 ELSEIF(NHI.GT.0) THEN
59261 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
59265 C...Read back in histograms dumped MDUMP=1.
59266 ELSEIF(MDUMP.EQ.2) THEN
59268 C...Read histogram number, title and range, and book.
59269 140 READ(LFN,5100,END=170) ID,TITLE
59270 READ(LFN,5200) NX,XL,XU
59271 CALL PYBOOK(ID,TITLE,NX,XL,XU)
59274 C...Read filling statistics.
59275 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
59276 BIN(IS+5)=DBLE(NENTRY)
59278 C...Read histogram contents, in groups of five.
59279 DO 160 IXG=1,(NX+4)/5
59280 READ(LFN,5400) (VAL(IXV),IXV=1,5)
59283 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
59287 C...Go to next histogram; finish.
59291 C...Write histogram contents in column format,
59292 C...convenient e.g. for GNUPLOT input.
59293 ELSEIF(MDUMP.EQ.3) THEN
59295 C...Find addresses to wanted histograms.
59309 IF(IS.NE.0.AND.NSS.LT.100) THEN
59312 ELSEIF(NSS.GE.100) THEN
59313 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
59314 ELSEIF(NHI.GT.0) THEN
59315 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
59319 C...Check that they have common number of x bins. Fix format.
59320 NX=NINT(BIN(ISS(1)+1))
59322 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
59323 CALL PYERRM(8,'(PYDUMP:) different number of bins')
59327 FORMAT='(1P,000E12.4)'
59328 WRITE(FORMAT(5:7),'(I3)') NSS+1
59330 C...Write histogram contents; first column x values.
59332 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
59333 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
59338 C...Formats for output.
59339 5100 FORMAT(I5,5X,A60)
59340 5200 FORMAT(I5,1P,2D12.4)
59341 5300 FORMAT(I12,1P,3D12.4)
59342 5400 FORMAT(1P,5D12.4)
59347 C*********************************************************************
59350 C...Dummy routine, which the user can replace in order to make cuts on
59351 C...the kinematics on the parton level before the matrix elements are
59352 C...evaluated and the event is generated. The cross-section estimates
59353 C...will automatically take these cuts into account, so the given
59354 C...values are for the allowed phase space region only. MCUT=0 means
59355 C...that the event has passed the cuts, MCUT=1 that it has failed.
59357 SUBROUTINE PYKCUT(MCUT)
59359 C...Double precision and integer declarations.
59360 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59361 IMPLICIT INTEGER(I-N)
59362 INTEGER PYK,PYCHGE,PYCOMP
59364 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59365 COMMON/PYINT1/MINT(400),VINT(400)
59366 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
59367 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
59369 C...Set default value (accepting event) for MCUT.
59372 C...Read out subprocess number.
59376 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
59380 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
59382 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
59384 C...Calculate x_1, x_2, x_F.
59385 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
59386 X1=SQRT(TAU)*EXP(YST)
59387 X2=SQRT(TAU)*EXP(-YST)
59389 X1=SQRT(TAUP)*EXP(YST)
59390 X2=SQRT(TAUP)*EXP(-YST)
59394 C...Calculate shat, that, uhat, p_T^2.
59400 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
59401 RPTS=4D0*VINT(71)**2/SHAT
59402 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
59405 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
59406 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
59407 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
59408 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
59410 C...Decisions by user to be put here.
59412 C...Stop program if this routine is ever called.
59413 C...You should not copy these lines to your own routine.
59414 WRITE(MSTU(11),5000)
59415 IF(PYR(0).LT.10D0) STOP
59417 C...Format for error printout.
59418 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
59419 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
59420 &1X,'Execution stopped!')
59425 C*********************************************************************
59428 C...Dummy routine, which the user can replace in order to multiply the
59429 C...standard PYTHIA differential cross-section by a process- and
59430 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
59431 C...to generation of weighted events, with weight 1/WTXS, while for
59432 C...MSTP(142)=2 it corresponds to a modification of the underlying
59435 SUBROUTINE PYEVWT(WTXS)
59437 C...Double precision and integer declarations.
59438 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59439 IMPLICIT INTEGER(I-N)
59440 INTEGER PYK,PYCHGE,PYCOMP
59442 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59443 COMMON/PYINT1/MINT(400),VINT(400)
59444 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
59445 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
59447 C...Set default weight for WTXS.
59450 C...Read out subprocess number.
59454 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
59458 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
59460 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
59462 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
59471 C...Modifications by user to be put here.
59473 C...Stop program if this routine is ever called.
59474 C...You should not copy these lines to your own routine.
59475 WRITE(MSTU(11),5000)
59476 IF(PYR(0).LT.10D0) STOP
59478 C...Format for error printout.
59479 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
59480 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
59481 &1X,'Execution stopped!')
59486 C*********************************************************************
59489 C...Dummy routine, to be replaced by a user implementing external
59490 C...processes. Is supposed to fill the HEPRUP commonblock with info
59491 C...on incoming beams and allowed processes.
59495 C...Double precision and integer declarations.
59496 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59497 IMPLICIT INTEGER(I-N)
59499 C...User process initialization commonblock.
59501 PARAMETER (MAXPUP=100)
59502 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
59503 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
59504 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
59505 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
59512 C*********************************************************************
59515 C...Dummy routine, to be replaced by a user implementing external
59516 C...processes. Depending on cross section model chosen, it either has
59517 C...to generate a process of the type IDPRUP requested, or pick a type
59518 C...itself and generate this event. The event is to be stored in the
59519 C...HEPEUP commonblock, including (often) an event weight.
59523 C...Double precision and integer declarations.
59524 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59525 IMPLICIT INTEGER(I-N)
59527 C...User process event common block.
59529 PARAMETER (MAXNUP=500)
59530 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
59531 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
59532 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
59533 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
59534 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
59540 C*********************************************************************
59542 C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
59544 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
59545 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59546 IMPLICIT INTEGER(I-N)
59547 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
59550 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59553 C...Stop program if this routine is ever called.
59554 WRITE(MSTU(11),5000)
59555 IF(PYR(0).LT.10D0) STOP
59557 C...Format for error printout.
59558 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
59559 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
59560 &1X,'Execution stopped!')
59565 C*********************************************************************
59568 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
59571 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59572 IMPLICIT INTEGER(I-N)
59573 CHARACTER*40 VISAJE
59576 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59579 C...Assign default value.
59582 C...Stop program if this routine is ever called.
59583 WRITE(MSTU(11),5000)
59584 IF(PYR(0).LT.10D0) STOP
59586 C...Format for error printout.
59587 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
59588 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
59589 &1X,'Execution stopped!')
59594 C*********************************************************************
59597 C...Dummy routine, to be replaced by user, to handle the decay of a
59598 C...polarized tau lepton.
59600 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
59601 C...IORIG is the position where the mother of the tau is stored;
59602 C... is 0 when the mother is not stored.
59603 C...KFORIG is the flavour of the mother of the tau;
59604 C... is 0 when the mother is not known.
59605 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
59606 C... e.g. in B hadron semileptonic decays the W propagator
59607 C... is not explicitly stored but the W code is still unambiguous.
59609 C...NDECAY is the number of decay products in the current tau decay.
59610 C...These decay products should be added to the /PYJETS/ common block,
59611 C...in positions N+1 through N+NDECAY. For each product I you must
59612 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
59613 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
59615 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
59617 C...Double precision and integer declarations.
59618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59619 IMPLICIT INTEGER(I-N)
59620 INTEGER PYK,PYCHGE,PYCOMP
59622 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59623 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59624 SAVE /PYJETS/,/PYDAT1/
59626 C...Stop program if this routine is ever called.
59627 C...You should not copy these lines to your own routine.
59628 NDECAY=ITAU+IORIG+KFORIG
59629 WRITE(MSTU(11),5000)
59630 IF(PYR(0).LT.10D0) STOP
59632 C...Format for error printout.
59633 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
59634 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
59635 &1X,'Execution stopped!')
59640 C*********************************************************************
59643 C...Finds current date and time.
59644 C...Since this task is not standardized in Fortran 77, the routine
59645 C...is dummy, to be replaced by the user. Examples are given for
59646 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
59647 C...you do not have access to suitable routines.
59649 SUBROUTINE PYTIME(IDATI)
59651 C...Double precision and integer declarations.
59652 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59653 IMPLICIT INTEGER(I-N)
59654 INTEGER PYK,PYCHGE,PYCOMP
59657 INTEGER IDATI(6),IDTEMP(3)
59659 C...Example 0: if you do not have suitable routines.
59664 C...Example 1: Fortran 90 routine.
59666 C CALL DATE_AND_TIME(VALUES=IVAL)
59674 C...Example 2: DEC Fortran 77. AIX.
59675 C CALL IDATE(IMON,IDAY,IYEAR)
59679 C CALL ITIME(IHOUR,IMIN,ISEC)
59684 C...Example 3: DEC Fortran, IRIX, IRIX64.
59685 C CALL IDATE(IMON,IDAY,IYEAR)
59693 C READ(ATIME(1:2),'(I2)') IHOUR
59694 C READ(ATIME(4:5),'(I2)') IMIN
59695 C READ(ATIME(7:8),'(I2)') ISEC
59700 C...Example 4: GNU LINUX libU77, SunOS.
59701 c CALL IDATE(IDTEMP)
59702 c IDATI(1)=IDTEMP(3)
59703 c IDATI(2)=IDTEMP(2)
59704 c IDATI(3)=IDTEMP(1)
59705 c CALL ITIME(IDTEMP)
59706 c IDATI(4)=IDTEMP(1)
59707 c IDATI(5)=IDTEMP(2)
59708 c IDATI(6)=IDTEMP(3)
59710 C...Common code to ensure right century.
59711 IDATI(1)=2000+MOD(IDATI(1),100)
git://git.uio.no / u / mrichter / AliRoot.git / blob