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 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/W50512/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.
3982 IF(KCHG(KC,3).EQ.0) THEN
3983 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
3984 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3985 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3986 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3991 IF(MWID(KC).EQ.3) MINT(63)=1
3992 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
3994 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
3995 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
3996 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
3997 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
3998 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3999 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
4000 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
4001 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
4002 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
4003 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
4004 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
4005 & 2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
4008 C...Set resonance widths and branching ratios;
4009 C...also on/off switch for decays.
4010 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
4012 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
4013 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
4014 DO 170 J=1,MDCY(KC,3)
4017 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
4022 C...Flavours of leptoquark: redefine charge and name.
4023 KFLQQ=KFDP(MDCY(42,2),1)
4024 KFLQL=KFDP(MDCY(42,2),2)
4025 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
4026 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
4028 IF(IABS(KFLQL).EQ.13) LL=2
4029 IF(IABS(KFLQL).EQ.15) LL=3
4030 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
4031 &CHAF(IABS(KFLQL),1)(1:LL)//' '
4032 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
4034 C...Special cases in treatment of gamma*/Z0: redefine process name.
4035 IF(MSTP(43).EQ.1) THEN
4036 PROC(1)='f + fbar -> gamma*'
4037 PROC(15)='f + fbar -> g + gamma*'
4038 PROC(19)='f + fbar -> gamma + gamma*'
4039 PROC(30)='f + g -> f + gamma*'
4040 PROC(35)='f + gamma -> f + gamma*'
4041 ELSEIF(MSTP(43).EQ.2) THEN
4042 PROC(1)='f + fbar -> Z0'
4043 PROC(15)='f + fbar -> g + Z0'
4044 PROC(19)='f + fbar -> gamma + Z0'
4045 PROC(30)='f + g -> f + Z0'
4046 PROC(35)='f + gamma -> f + Z0'
4047 ELSEIF(MSTP(43).EQ.3) THEN
4048 PROC(1)='f + fbar -> gamma*/Z0'
4049 PROC(15)='f + fbar -> g + gamma*/Z0'
4050 PROC(19)='f + fbar -> gamma + gamma*/Z0'
4051 PROC(30)='f + g -> f + gamma*/Z0'
4052 PROC(35)='f + gamma -> f + gamma*/Z0'
4055 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
4056 IF(MSTP(44).EQ.1) THEN
4057 PROC(141)='f + fbar -> gamma*'
4058 ELSEIF(MSTP(44).EQ.2) THEN
4059 PROC(141)='f + fbar -> Z0'
4060 ELSEIF(MSTP(44).EQ.3) THEN
4061 PROC(141)='f + fbar -> Z''0'
4062 ELSEIF(MSTP(44).EQ.4) THEN
4063 PROC(141)='f + fbar -> gamma*/Z0'
4064 ELSEIF(MSTP(44).EQ.5) THEN
4065 PROC(141)='f + fbar -> gamma*/Z''0'
4066 ELSEIF(MSTP(44).EQ.6) THEN
4067 PROC(141)='f + fbar -> Z0/Z''0'
4068 ELSEIF(MSTP(44).EQ.7) THEN
4069 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
4072 C...Special cases in treatment of WW -> WW: redefine process name.
4073 IF(MSTP(45).EQ.1) THEN
4074 PROC(77)='W+ + W+ -> W+ + W+'
4075 ELSEIF(MSTP(45).EQ.2) THEN
4076 PROC(77)='W+ + W- -> W+ + W-'
4077 ELSEIF(MSTP(45).EQ.3) THEN
4078 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
4081 C...Format for error information.
4082 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
4083 &'combination'/1X,'Execution stopped!')
4088 C*********************************************************************
4091 C...Identifies the two incoming particles and the choice of frame.
4093 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
4095 C...Double precision and integer declarations.
4096 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4097 IMPLICIT INTEGER(I-N)
4098 INTEGER PYK,PYCHGE,PYCOMP
4100 C...User process initialization commonblock.
4102 PARAMETER (MAXPUP=100)
4103 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4104 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4105 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4106 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4111 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4112 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4113 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4114 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4115 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4116 COMMON/PYINT1/MINT(400),VINT(400)
4117 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
4119 C...Local arrays, character variables and data.
4120 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
4121 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
4122 DIMENSION LEN(3),KCDE(39),PM(2)
4123 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
4124 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
4125 DATA CHCDE/ 'e- ','e+ ','nu_e ',
4126 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
4127 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
4128 &'nu_taubar ','pi+ ','pi- ','n0 ',
4129 &'nbar0 ','p+ ','pbar- ','gamma ',
4130 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
4131 &'xi- ','xi0 ','omega- ','pi0 ',
4132 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
4133 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
4134 &'k+ ','k- ','ks0 ','kl0 '/
4135 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
4136 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
4137 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
4139 C...Store initial energy. Default frame.
4143 C...Special user process initialization; convert to normal input.
4144 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
4146 CALL PYNAME(IDBMUP(1),CHNAME)
4148 CALL PYNAME(IDBMUP(2),CHNAME)
4152 C...Convert character variables to lowercase and find their length.
4159 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
4161 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
4167 C...Fix up bar, underscore and charge in particle name (if needed).
4169 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
4171 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
4174 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
4176 CHIDNT(I)='nu_'//CHTEMP(3:7)
4177 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
4178 CHIDNT(I)(1:3)='n0 '
4179 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
4180 CHIDNT(I)(1:5)='nbar0'
4181 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
4182 CHIDNT(I)(1:3)='p+ '
4183 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
4184 & CHIDNT(I)(1:2).EQ.'p-') THEN
4185 CHIDNT(I)(1:5)='pbar-'
4186 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
4188 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
4189 CHIDNT(I)(1:7)='reggeon'
4190 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
4191 CHIDNT(I)(1:7)='pomeron'
4195 C...Identify free initialization.
4196 IF(CHCOM(1)(1:2).EQ.'no') THEN
4201 C...Identify incoming beam and target particles.
4204 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
4206 PM(I)=PYMASS(MINT(10+I))
4209 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
4210 CHTEMP=CHIDNT(I+1)(7:12)//' '
4212 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
4214 PM(I)=PYMASS(MINT(140+I))
4218 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
4219 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
4220 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
4222 C...Identify choice of frame and input energies.
4225 C...Events defined in the CM frame.
4226 IF(CHCOM(1)(1:2).EQ.'cm') THEN
4229 IF(MSTP(122).GE.1) THEN
4230 IF(CHCOM(2)(1:1).NE.'e') THEN
4231 LOFFS=(31-(LEN(2)+LEN(3)))/2
4232 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
4233 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4236 LOFFS=(30-(LEN(2)+LEN(3)))/2
4237 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
4238 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4241 WRITE(MSTU(11),5200) CHINIT
4242 WRITE(MSTU(11),5300) WIN
4245 C...Events defined in fixed target frame.
4246 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
4248 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
4249 IF(MSTP(122).GE.1) THEN
4250 LOFFS=(29-(LEN(2)+LEN(3)))/2
4251 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4252 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4253 & ' fixed target'//' '
4254 WRITE(MSTU(11),5200) CHINIT
4255 WRITE(MSTU(11),5400) WIN
4256 WRITE(MSTU(11),5500) SQRT(S)
4259 C...Frame defined by user three-vectors.
4260 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
4264 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4265 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4266 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4267 & (P(1,3)+P(2,3))**2
4268 IF(MSTP(122).GE.1) THEN
4269 LOFFS=(22-(LEN(2)+LEN(3)))/2
4270 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4271 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4272 & ' user configuration'//' '
4273 WRITE(MSTU(11),5200) CHINIT
4274 WRITE(MSTU(11),5600)
4275 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4276 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4277 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4280 C...Frame defined by user four-vectors.
4281 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
4283 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4284 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4285 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4286 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4287 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4288 & (P(1,3)+P(2,3))**2
4289 IF(MSTP(122).GE.1) THEN
4290 LOFFS=(22-(LEN(2)+LEN(3)))/2
4291 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4292 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4293 & ' user configuration'//' '
4294 WRITE(MSTU(11),5200) CHINIT
4295 WRITE(MSTU(11),5600)
4296 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4297 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4298 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4301 C...Frame defined by user five-vectors.
4302 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
4304 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4305 & (P(1,3)+P(2,3))**2
4306 IF(MSTP(122).GE.1) THEN
4307 LOFFS=(22-(LEN(2)+LEN(3)))/2
4308 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4309 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4310 & ' user configuration'//' '
4311 WRITE(MSTU(11),5200) CHINIT
4312 WRITE(MSTU(11),5600)
4313 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4314 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4315 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4318 C...Frame defined by HEPRUP common block.
4319 ELSEIF(MINT(111).EQ.11) THEN
4320 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
4321 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
4322 IF(MSTP(122).GE.1) THEN
4323 LOFFS=(22-(LEN(2)+LEN(3)))/2
4324 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4325 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4326 & ' user configuration'//' '
4327 WRITE(MSTU(11),5200) CHINIT
4328 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
4329 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4332 C...Unknown frame. Error for too low CM energy.
4334 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
4337 IF(S.LT.PARP(2)**2) THEN
4338 WRITE(MSTU(11),5900) SQRT(S)
4342 C...Formats for initialization and error information.
4343 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
4344 &1X,'Execution stopped!')
4345 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
4346 &1X,'Execution stopped!')
4347 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
4348 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
4349 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
4350 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
4351 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
4352 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
4353 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
4354 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
4355 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
4356 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
4357 &1X,'Execution stopped!')
4358 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
4359 &'generation.'/1X,'Execution stopped!')
4360 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
4361 &'GeV beam energies',13X,'I')
4366 C*********************************************************************
4369 C...Sets up kinematics, including rotations and boosts to/from CM frame.
4371 SUBROUTINE PYINKI(MODKI)
4373 C...Double precision and integer declarations.
4374 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4375 IMPLICIT INTEGER(I-N)
4376 INTEGER PYK,PYCHGE,PYCOMP
4378 C...User process initialization commonblock.
4380 PARAMETER (MAXPUP=100)
4381 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4382 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4383 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4384 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4389 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4390 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4391 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4392 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4393 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4394 COMMON/PYINT1/MINT(400),VINT(400)
4395 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
4397 C...Set initial flavour state.
4402 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
4405 C...Reset boost. Do kinematics for various cases.
4410 C...Set up kinematics for events defined in CM frame.
4411 IF(MINT(111).EQ.1) THEN
4413 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4417 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4418 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4423 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
4426 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4427 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
4429 C...Set up kinematics for fixed target events.
4430 ELSEIF(MINT(111).EQ.2) THEN
4432 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4435 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4436 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4442 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4445 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
4446 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
4447 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4449 C...Set up kinematics for events in user-defined frame.
4450 ELSEIF(MINT(111).EQ.3) THEN
4453 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4454 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4455 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4456 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4458 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4460 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4461 VINT(7)=PYANGL(P(1,1),P(1,2))
4462 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4463 VINT(6)=PYANGL(P(1,3),P(1,1))
4464 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4465 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
4467 C...Set up kinematics for events with user-defined four-vectors.
4468 ELSEIF(MINT(111).EQ.4) THEN
4469 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4470 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4471 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4472 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4474 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4476 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4477 VINT(7)=PYANGL(P(1,1),P(1,2))
4478 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4479 VINT(6)=PYANGL(P(1,3),P(1,1))
4480 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4481 S=(P(1,4)+P(2,4))**2
4483 C...Set up kinematics for events with user-defined five-vectors.
4484 ELSEIF(MINT(111).EQ.5) THEN
4486 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4488 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4489 VINT(7)=PYANGL(P(1,1),P(1,2))
4490 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4491 VINT(6)=PYANGL(P(1,3),P(1,1))
4492 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4493 S=(P(1,4)+P(2,4))**2
4495 C...Set up kinematics for events with external user processes.
4496 ELSEIF(MINT(111).EQ.11) THEN
4499 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4500 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4505 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
4506 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
4509 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
4510 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4511 S=(P(1,4)+P(2,4))**2
4514 C...Return or error for too low CM energy.
4515 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
4516 IF(MSTP(172).LE.1) THEN
4518 & '(PYINKI:) too low invariant mass in this event')
4525 C...Save information on incoming particles.
4528 IF(MINT(111).GE.4) THEN
4529 IF(MINT(141).EQ.0) THEN
4531 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
4535 IF(MINT(142).EQ.0) THEN
4537 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
4543 IF(MODKI.EQ.0) VINT(289)=S
4551 C...Store pT cut-off and related constants to be used in generation.
4552 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
4553 IF(MSTP(82).LE.1) THEN
4554 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4556 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4558 VINT(149)=4D0*PTMN**2/S
4564 C*********************************************************************
4567 C...Selects partonic subprocesses to be included in the simulation.
4571 C...Double precision and integer declarations.
4572 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4573 IMPLICIT INTEGER(I-N)
4574 INTEGER PYK,PYCHGE,PYCOMP
4576 C...User process initialization commonblock.
4578 PARAMETER (MAXPUP=100)
4579 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4580 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4581 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4582 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4586 C...Commonblocks and character variables.
4587 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4588 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4589 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4590 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4591 COMMON/PYINT1/MINT(400),VINT(400)
4592 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4593 COMMON/PYINT6/PROC(0:500)
4595 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
4599 C...Reset processes to be included.
4606 C...Set running pTmin scale.
4607 IF(MSTP(82).LE.1) THEN
4608 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4610 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4613 C...Begin by assuming incoming photon to enter subprocess.
4614 IF(MINT(11).EQ.22) MINT(15)=22
4615 IF(MINT(12).EQ.22) MINT(16)=22
4617 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
4618 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4620 MINT(123)=MINT(122)+1
4622 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
4624 C...Here also set a few parameters otherwise normally not touched.
4625 ELSEIF(MINT(121).GT.1) THEN
4627 C...Parton distributions dampened at small Q2; go to low energies,
4628 C...alpha_s <1; no minimum pT cut-off a priori.
4629 IF(MSTP(18).EQ.2) THEN
4637 C...Define pT cut-off parameters and whether run involves low-pT.
4641 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
4643 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
4644 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
4646 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
4647 IF(MSEL.EQ.2) IPTL=1
4649 C...Set up for p/gamma * gamma; real or virtual photons.
4650 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
4651 & MSTP(14).EQ.30)) THEN
4653 C...Set up for p/VMD * VMD.
4654 IF(MINT(122).EQ.1) THEN
4662 IF(IPTL.EQ.1) MSUB(95)=1
4669 IF(IPTL.EQ.1) CKIN(3)=0D0
4671 C...Set up for p/VMD * direct gamma.
4672 ELSEIF(MINT(122).EQ.2) THEN
4674 IF(MINT(121).EQ.6) MINT(123)=5
4679 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4681 C...Set up for p/VMD * anomalous gamma.
4682 ELSEIF(MINT(122).EQ.3) THEN
4684 IF(MINT(121).EQ.6) MINT(123)=7
4691 IF(IPTL.EQ.1) MSUB(95)=1
4698 IF(IPTL.EQ.1) CKIN(3)=0D0
4700 C...Set up for DIS * p.
4701 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
4702 & IABS(MINT(12)).GT.100)) THEN
4704 IF(IPTL.EQ.1) MSUB(99)=1
4706 C...Set up for direct * direct gamma (switch off leptons).
4707 ELSEIF(MINT(122).EQ.4) THEN
4713 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4714 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4716 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4718 C...Set up for direct * anomalous gamma.
4719 ELSEIF(MINT(122).EQ.5) THEN
4725 IF(IPTL.EQ.1) CKIN(3)=PTMANO
4727 C...Set up for anomalous * anomalous gamma.
4728 ELSEIF(MINT(122).EQ.6) THEN
4736 IF(IPTL.EQ.1) MSUB(95)=1
4743 IF(IPTL.EQ.1) CKIN(3)=0D0
4746 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
4747 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4749 C...Set up for direct * direct gamma (switch off leptons).
4750 IF(MINT(122).EQ.1) THEN
4756 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4757 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4759 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4761 C...Set up for direct * VMD and VMD * direct gamma.
4762 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
4768 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4770 C...Set up for direct * anomalous and anomalous * direct gamma.
4771 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
4777 IF(IPTL.EQ.1) CKIN(3)=PTMANO
4779 C...Set up for VMD*VMD.
4780 ELSEIF(MINT(122).EQ.5) THEN
4788 IF(IPTL.EQ.1) MSUB(95)=1
4795 IF(IPTL.EQ.1) CKIN(3)=0D0
4797 C...Set up for VMD * anomalous and anomalous * VMD gamma.
4798 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
4806 IF(IPTL.EQ.1) MSUB(95)=1
4813 IF(IPTL.EQ.1) CKIN(3)=0D0
4815 C...Set up for anomalous * anomalous gamma.
4816 ELSEIF(MINT(122).EQ.9) THEN
4824 IF(IPTL.EQ.1) MSUB(95)=1
4831 IF(IPTL.EQ.1) CKIN(3)=0D0
4833 C...Set up for DIS * VMD and VMD * DIS gamma.
4834 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
4836 IF(IPTL.EQ.1) MSUB(99)=1
4838 C...Set up for DIS * anomalous and anomalous * DIS gamma.
4839 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
4841 IF(IPTL.EQ.1) MSUB(99)=1
4844 C...Set up for gamma* * p; virtual photons = dir, res.
4845 ELSEIF(MINT(121).EQ.2) THEN
4847 C...Set up for direct * p.
4848 IF(MINT(122).EQ.1) THEN
4854 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4856 C...Set up for resolved * p.
4857 ELSEIF(MINT(122).EQ.2) THEN
4865 IF(IPTL.EQ.1) MSUB(95)=1
4872 IF(IPTL.EQ.1) CKIN(3)=0D0
4875 C...Set up for gamma* * gamma*; virtual photons = dir, res.
4876 ELSEIF(MINT(121).EQ.4) THEN
4878 C...Set up for direct * direct gamma (switch off leptons).
4879 IF(MINT(122).EQ.1) THEN
4885 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4886 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4888 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4890 C...Set up for direct * resolved and resolved * direct gamma.
4891 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
4897 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4899 C...Set up for resolved * resolved gamma.
4900 ELSEIF(MINT(122).EQ.4) THEN
4908 IF(IPTL.EQ.1) MSUB(95)=1
4915 IF(IPTL.EQ.1) CKIN(3)=0D0
4918 C...End of special set up for gamma-p and gamma-gamma.
4923 C...Flavour information for individual beams.
4926 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
4927 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
4928 MINT(44+I)=MINT(40+I)
4929 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
4930 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
4933 C...If two real gammas, whereof one direct, pick the first.
4934 C...For two virtual photons, keep requested order.
4935 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4936 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
4939 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
4940 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
4943 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
4944 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
4947 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
4948 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
4951 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
4952 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
4955 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
4958 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
4962 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
4963 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
4964 IF(MINT(11).EQ.22) THEN
4972 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
4973 & '(PYINPR:) unallowed MSTP(14) code for single photon')
4976 C...Flavour information on combination of incoming particles.
4977 MINT(43)=2*MINT(41)+MINT(42)-2
4979 IF(MINT(123).LE.0) THEN
4980 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
4981 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
4982 ELSEIF(MINT(123).LE.3) THEN
4983 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
4984 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
4985 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4989 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
4990 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
4991 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
4992 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
4994 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
4997 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4998 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
5000 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
5002 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
5003 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
5004 & MINT(122).EQ.10) MINT(108)=2
5005 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
5006 & MINT(122).EQ.11) MINT(108)=3
5007 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
5008 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
5009 IF(MINT(122).GE.3) MINT(107)=1
5010 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
5011 ELSEIF(MINT(121).EQ.2) THEN
5012 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
5013 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
5015 IF(MINT(11).EQ.22) THEN
5017 IF(MINT(123).GE.4) MINT(107)=0
5018 IF(MINT(123).EQ.7) MINT(107)=2
5019 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
5020 IF(MSTP(14).EQ.28) MINT(107)=2
5021 IF(MSTP(14).EQ.29) MINT(107)=3
5022 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
5025 IF(MINT(12).EQ.22) THEN
5027 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
5028 IF(MINT(123).EQ.7) MINT(108)=3
5029 IF(MSTP(14).EQ.26) MINT(108)=2
5030 IF(MSTP(14).EQ.27) MINT(108)=3
5031 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
5032 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
5035 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
5036 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
5042 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
5043 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
5045 C...Select default processes according to incoming beams
5046 C...(already done for gamma-p and gamma-gamma with
5047 C...MSTP(14) = 10, 20, 25 or 30).
5048 IF(MINT(121).GT.1) THEN
5049 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
5051 IF(MINT(43).EQ.1) THEN
5052 C...Lepton + lepton -> gamma/Z0 or W.
5053 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
5054 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
5056 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
5057 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
5058 C...Unresolved photon + lepton: Compton scattering.
5062 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
5063 & .OR.MINT(12).EQ.22)) THEN
5064 C...DIS as pure gamma* + f -> f process.
5067 ELSEIF(MINT(43).LE.3) THEN
5068 C...Lepton + hadron: deep inelastic scattering.
5071 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
5072 & MINT(12).EQ.22) THEN
5073 C...Two unresolved photons: fermion pair production,
5074 C...exclude lepton pairs.
5078 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5079 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5082 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
5083 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
5084 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
5086 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
5087 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
5088 & MINT(12).EQ.22)) THEN
5089 C...Unresolved photon + hadron: photon-parton scattering.
5094 ELSEIF(MSEL.EQ.1) THEN
5095 C...High-pT QCD processes:
5104 IF(CKIN(3).LT.PTMN) MSUB(95)=1
5105 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
5108 C...All QCD processes:
5122 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
5123 C...Heavy quark production.
5127 DO 180 J=1,MIN(8,MDCY(21,3))
5128 MDME(MDCY(21,2)+J-1,1)=0
5130 MDME(MDCY(21,2)+MSEL-1,1)=1
5132 DO 190 J=1,MIN(12,MDCY(22,3))
5133 MDME(MDCY(22,2)+J-1,1)=0
5135 MDME(MDCY(22,2)+MSEL-1,1)=1
5137 ELSEIF(MSEL.EQ.10) THEN
5138 C...Prompt photon production:
5143 ELSEIF(MSEL.EQ.11) THEN
5144 C...Z0/gamma* production:
5147 ELSEIF(MSEL.EQ.12) THEN
5148 C...W+/- production:
5151 ELSEIF(MSEL.EQ.13) THEN
5156 ELSEIF(MSEL.EQ.14) THEN
5161 ELSEIF(MSEL.EQ.15) THEN
5162 C...Z0 & W+/- pair production:
5169 ELSEIF(MSEL.EQ.16) THEN
5177 ELSEIF(MSEL.EQ.17) THEN
5178 C...h0 & Z0 or W+/- pair production:
5182 ELSEIF(MSEL.EQ.18) THEN
5183 C...h0 production; interesting processes in e+e-.
5189 ELSEIF(MSEL.EQ.19) THEN
5190 C...h0, H0 and A0 production; interesting processes in e+e-.
5204 ELSEIF(MSEL.EQ.21) THEN
5208 ELSEIF(MSEL.EQ.22) THEN
5209 C...W'+/- production:
5212 ELSEIF(MSEL.EQ.23) THEN
5213 C...H+/- production:
5216 ELSEIF(MSEL.EQ.24) THEN
5220 ELSEIF(MSEL.EQ.25) THEN
5221 C...LQ (leptoquark) production.
5227 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
5228 C...Production of one heavy quark (W exchange):
5230 DO 200 J=1,MIN(8,MDCY(21,3))
5231 MDME(MDCY(21,2)+J-1,1)=0
5233 MDME(MDCY(21,2)+MSEL-31,1)=1
5235 CMRENNA++Define SUSY alternatives.
5236 ELSEIF(MSEL.EQ.39) THEN
5237 C...Turn on all SUSY processes.
5238 IF(MINT(43).EQ.4) THEN
5239 C...Hadron-hadron processes.
5241 IF(ISET(I).GE.0) MSUB(I)=1
5243 ELSEIF(MINT(43).EQ.1) THEN
5244 C...Lepton-lepton processes: QED production of squarks.
5261 ELSEIF(MSEL.EQ.40) THEN
5262 C...Gluinos and squarks.
5263 IF(MINT(43).EQ.4) THEN
5275 ELSEIF(MINT(43).EQ.1) THEN
5280 ELSEIF(MSEL.EQ.41) THEN
5281 C...Stop production.
5285 IF(MINT(43).EQ.4) THEN
5290 ELSEIF(MSEL.EQ.42) THEN
5291 C...Slepton production.
5295 IF(MINT(43).NE.4) THEN
5301 ELSEIF(MSEL.EQ.43) THEN
5302 C...Neutralino/Chargino + Gluino/Squark.
5303 IF(MINT(43).EQ.4) THEN
5312 ELSEIF(MSEL.EQ.44) THEN
5313 C...Neutralino/Chargino pair production.
5314 IF(MINT(43).EQ.4) THEN
5318 ELSEIF(MINT(43).EQ.1) THEN
5324 ELSEIF(MSEL.EQ.45) THEN
5325 C...Sbottom production.
5328 IF(MINT(43).EQ.4) THEN
5334 ELSEIF(MSEL.EQ.50) THEN
5335 C...Pair production of technipions and gauge bosons.
5339 IF(MINT(43).EQ.4) THEN
5345 ELSEIF(MSEL.EQ.51) THEN
5346 C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
5352 C...Find heaviest new quark flavour allowed in processes 81-84.
5354 DO 350 I=1,MIN(8,MDCY(21,3))
5356 IF(MDME(IDC,1).LE.0) GOTO 350
5359 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
5370 C...Find heaviest new fermion flavour allowed in process 85.
5372 DO 360 I=1,MIN(12,MDCY(22,3))
5374 IF(MDME(IDC,1).LE.0) GOTO 360
5377 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
5378 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
5383 C...Import relevant information on external user processes.
5384 IF(MINT(111).EQ.11) THEN
5387 C...Find next empty PYTHIA process number slot and enable it.
5389 IF(IPYPR.GT.500) CALL PYERRM(26,
5390 & '(PYINPR.) no more empty slots for user processes')
5391 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
5392 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
5394 C...Overwrite KFPR with references back to process number and ID.
5396 KFPR(IPYPR,2)=LPRUP(IUP)
5398 WRITE(CHIPR,'(I10)') LPRUP(IUP)
5401 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
5403 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
5404 C...Switch on process.
5412 C*********************************************************************
5415 C...Parametrizes total, elastic and diffractive cross-sections
5416 C...for different energies and beams. Donnachie-Landshoff for
5417 C...total and Schuler-Sjostrand for elastic and diffractive.
5418 C...Process code IPROC:
5425 C...= 7 : J/psi + p;
5426 C...= 11 : rho + rho;
5427 C...= 12 : rho + phi;
5428 C...= 13 : rho + J/psi;
5429 C...= 14 : phi + phi;
5430 C...= 15 : phi + J/psi;
5431 C...= 16 : J/psi + J/psi;
5432 C...= 21 : gamma + p (DL);
5433 C...= 22 : gamma + p (VDM).
5434 C...= 23 : gamma + pi (DL);
5435 C...= 24 : gamma + pi (VDM);
5436 C...= 25 : gamma + gamma (DL);
5437 C...= 26 : gamma + gamma (VDM).
5441 C...Double precision and integer declarations.
5442 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5443 IMPLICIT INTEGER(I-N)
5444 INTEGER PYK,PYCHGE,PYCOMP
5446 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5447 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5448 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5449 COMMON/PYINT1/MINT(400),VINT(400)
5450 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5451 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5452 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
5454 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
5455 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
5456 &CEFFD(10,9),SIGTMP(6,0:5)
5458 C...Common constants.
5459 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
5460 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
5463 C...Number of multiple processes to be evaluated (= 0 : undefined).
5464 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
5465 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
5466 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
5467 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
5468 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
5470 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
5471 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
5472 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
5474 C...Beam and target hadron class:
5475 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
5476 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
5477 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
5478 C...Characteristic class masses, slope parameters, beta = sqrt(X).
5479 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
5480 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
5481 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
5483 C...Fitting constants used in parametrizations of diffractive results.
5484 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5485 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5486 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
5487 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
5488 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
5489 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
5490 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
5491 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
5492 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
5493 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
5494 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
5495 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
5496 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
5497 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
5498 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
5499 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
5500 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
5501 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
5502 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
5503 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
5504 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
5505 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
5506 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
5507 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
5508 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
5509 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
5510 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
5511 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
5512 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
5514 C...Parameters. Combinations of the energy.
5523 C...Ratio of gamma/pi (for rescaling in parton distributions).
5524 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
5525 &(XPAR(5)*SEPS+YPAR(5)*SETA)
5527 IF(MINT(50).NE.1) RETURN
5529 C...Order flavours of incoming particles: KF1 < KF2.
5530 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
5539 ISGN12=ISIGN(1,MINT(11)*MINT(12))
5541 C...Find process number (for lookup tables).
5542 IF(KF1.GT.1000) THEN
5544 IF(ISGN12.LT.0) IPROC=2
5545 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
5547 IF(ISGN12.LT.0) IPROC=4
5548 IF(KF1.EQ.111) IPROC=5
5549 ELSEIF(KF1.GT.100) THEN
5551 ELSEIF(KF2.GT.1000) THEN
5553 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
5554 ELSEIF(KF2.GT.100) THEN
5556 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
5559 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
5562 C... Number of multiple processes to be stored; beam/target side.
5568 ELSEIF(NPR.EQ.6) THEN
5573 IF(MINT(101).EQ.4) N1=4
5575 IF(MINT(102).EQ.4) N2=4
5577 C...Do not do any more for user-set or undefined cross-sections.
5578 IF(MSTP(31).LE.0) RETURN
5579 IF(NPR.EQ.0) CALL PYERRM(26,
5580 &'(PYXTOT:) cross section for this process not yet implemented')
5582 C...Parameters. Combinations of the energy.
5591 C...Loop over multiple processes (for VDM).
5595 ELSEIF(NPR.EQ.3) THEN
5597 IF(KF2.LT.1000) IPR=I+10
5598 ELSEIF(NPR.EQ.6) THEN
5602 C...Evaluate hadron species, mass, slope contribution and fit number.
5612 C...Skip if energy too low relative to masses.
5616 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
5618 C...Total cross-section. Elastic slope parameter and cross-section.
5619 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
5620 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
5621 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
5623 C...Diffractive scattering A + B -> X + B.
5626 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
5627 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5628 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5629 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
5630 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
5631 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
5632 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
5634 C...Diffractive scattering A + B -> A + X.
5637 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
5638 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5639 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5640 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
5641 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
5642 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
5643 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
5645 C...Order single diffractive correctly.
5648 SIGTMP(I,2)=SIGTMP(I,3)
5652 C...Double diffractive scattering A + B -> X1 + X2.
5653 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
5654 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
5655 SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
5656 IF(YEFF.LE.0) SUM1=0D0
5657 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
5658 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
5659 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
5660 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
5662 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
5663 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
5664 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
5666 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
5667 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
5668 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
5669 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
5670 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
5672 C...Non-diffractive by unitarity.
5673 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
5677 C...Put temporary results in output array: only one process.
5678 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
5680 SIGT(0,0,J)=SIGTMP(1,J)
5683 C...Beam multiple processes.
5684 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
5685 IF(MINT(107).EQ.2) THEN
5686 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5688 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5689 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5691 IF(MSTP(20).GT.0) THEN
5692 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
5695 IF(MINT(107).EQ.2) THEN
5696 CONV=(AEM/PARP(160+I))*VINT(317)
5697 ELSEIF(VINT(154).GT.PARP(15)) THEN
5698 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5699 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5705 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
5709 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5712 C...Target multiple processes.
5713 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
5714 IF(MINT(108).EQ.2) THEN
5715 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5717 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5718 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5720 IF(MSTP(20).GT.0) THEN
5721 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
5724 IF(MINT(108).EQ.2) THEN
5725 CONV=(AEM/PARP(160+I))*VINT(317)
5726 ELSEIF(VINT(154).GT.PARP(15)) THEN
5727 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5728 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5734 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
5738 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
5741 C...Both beam and target multiple processes.
5743 IF(MINT(107).EQ.2) THEN
5744 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5746 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5747 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5749 IF(MINT(108).EQ.2) THEN
5750 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5752 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
5753 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5755 IF(MSTP(20).GT.0) THEN
5756 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
5757 & VINT(308)))**MSTP(20)
5761 IF(MINT(107).EQ.2) THEN
5762 CONV=(AEM/PARP(160+I1))*VINT(317)
5763 ELSEIF(VINT(154).GT.PARP(15)) THEN
5764 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
5765 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5769 IF(MINT(108).EQ.2) THEN
5770 CONV=CONV*(AEM/PARP(160+I2))
5771 ELSEIF(VINT(154).GT.PARP(15)) THEN
5772 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
5773 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
5779 ELSEIF(I2.LE.2) THEN
5781 ELSEIF(I1.EQ.I2) THEN
5788 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
5789 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
5795 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
5796 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
5798 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5802 C...Scale up uniformly for Donnachie-Landshoff parametrization.
5803 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
5804 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
5808 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
5817 C*********************************************************************
5820 C...Finds optimal set of coefficients for kinematical variable selection
5821 C...and the maximum of the part of the differential cross-section used
5822 C...in the event weighting.
5826 C...Double precision and integer declarations.
5827 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5828 IMPLICIT INTEGER(I-N)
5829 INTEGER PYK,PYCHGE,PYCOMP
5830 C...Parameter statement to help give large particle numbers.
5831 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5832 &KEXCIT=4000000,KDIMEN=5000000)
5834 C...User process initialization commonblock.
5836 PARAMETER (MAXPUP=100)
5837 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5838 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5839 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5840 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5845 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5846 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5847 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5848 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5849 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5850 COMMON/PYINT1/MINT(400),VINT(400)
5851 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5852 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
5853 COMMON/PYINT4/MWID(500),WIDS(500,5)
5854 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5855 COMMON/PYINT6/PROC(0:500)
5857 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5858 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
5859 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
5860 C...Local arrays, character variables and data.
5862 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
5863 &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
5864 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
5865 DATA CVAR/'tau ','tau''','y* ','cth '/
5868 C...Initial values and loop over subprocesses.
5877 C...Find maximum weight factors for photon flux.
5878 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
5879 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
5882 C...Select subprocess to study: skip cases not applicable.
5883 IF(ISET(ISUB).EQ.11) THEN
5884 IF(MSUB(ISUB).NE.1) GOTO 460
5885 C...User process intialization: cross section model dependent.
5886 IF(IABS(IDWTUP).EQ.1) THEN
5887 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5888 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5889 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
5891 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
5892 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
5893 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
5894 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5895 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5896 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
5898 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5899 & WTGAGA*XSEC(ISUB,1)
5902 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
5903 CALL PYSIGH(NCHN,SIGS)
5905 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5906 & WTGAGA*XSEC(ISUB,1)
5907 IF(MSUB(ISUB).NE.1) GOTO 460
5910 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
5911 CALL PYSIGH(NCHN,SIGS)
5913 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5914 & WTGAGA*XSEC(ISUB,1)
5915 IF(XSEC(ISUB,1).EQ.0D0) THEN
5921 ELSEIF(ISUB.EQ.96) THEN
5922 IF(MINT(50).EQ.0) GOTO 460
5923 IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
5925 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
5926 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
5927 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
5928 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
5929 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
5930 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
5932 IF(MSUB(ISUB).NE.1) GOTO 460
5935 IF(ISUB.EQ.96) ISTSB=2
5936 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
5938 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
5939 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
5941 C...Find resonances (explicit or implicit in cross-section).
5944 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
5946 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
5947 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
5949 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
5950 & .OR.ISUB.EQ.177) THEN
5952 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
5954 IF(MSTP(46).EQ.5) THEN
5957 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
5959 ELSEIF(ISUB.EQ.194) THEN
5961 ELSEIF(ISUB.EQ.195) THEN
5963 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
5965 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
5969 IF(CKMX.LE.0D0) CKMX=VINT(1)
5972 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
5973 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
5976 TAUR1=PMAS(KCR1,1)**2/VINT(2)
5977 IF(KFR1.EQ.KTECHN+113) THEN
5981 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
5988 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
5991 IF(ISUB.EQ.194) THEN
5993 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
5997 TAUR2=PMAS(KCR2,1)**2/VINT(2)
5998 IF(KFR2.EQ.KTECHN+223) THEN
6002 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
6003 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
6004 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
6005 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
6010 ELSEIF(KFR2.NE.0) THEN
6022 C...Find product masses and minimum pT of process.
6028 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
6032 IF(KFPR(ISUB,I).EQ.0) THEN
6033 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
6035 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
6036 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
6039 C...This prevents SUSY/t particles from becoming too light.
6041 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
6044 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
6045 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
6046 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
6047 & PMAS(PYCOMP(KFDP(IDC,2)),1)
6048 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
6049 & PMAS(PYCOMP(KFDP(IDC,3)),1)
6050 PMMN(I)=MIN(PMMN(I),PMSUM)
6053 ELSEIF(KFLW.EQ.6) THEN
6054 PMMN(I)=PMAS(24,1)+PMAS(5,1)
6061 CKIN(41)=MAX(PMMN(1),CKIN(41))
6062 CKIN(43)=MAX(PMMN(2),CKIN(43))
6063 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
6066 IF(MINT(51).EQ.1) THEN
6067 WRITE(MSTU(11),5100) ISUB
6074 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
6075 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
6076 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
6077 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6078 ELSEIF(ISUB.EQ.96) THEN
6079 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6085 C...Prepare for additional variable choices in 2 -> 3.
6088 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
6090 VINT(204)=PMAS(23,1)
6091 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
6092 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
6093 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
6094 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
6098 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
6099 NPTS(1)=2+2*MINT(72)
6100 IF(MINT(47).EQ.1) THEN
6101 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
6102 ELSEIF(MINT(47).GE.5) THEN
6103 IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
6106 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
6107 IF(MINT(47).GE.2) NPTS(2)=2
6108 IF(MINT(47).GE.5) NPTS(2)=3
6111 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
6113 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
6114 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
6117 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
6118 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
6120 C...Reset coefficients of cross-section weighting.
6136 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
6137 C...in grid of phase space points.
6143 IF(METAU.EQ.1) GOTO 150
6144 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
6145 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
6146 IF(MTAU.GT.2+2*MINT(72)) MTAU=7
6148 C...Special case when both resonances have same mass,
6149 C...as is often the case in process 194.
6150 IF(MINT(72).EQ.2) THEN
6151 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
6152 & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
6153 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
6155 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
6160 CALL PYKMAP(1,MTAU,RTAU)
6161 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
6164 IF(METAUP.EQ.1) GOTO 150
6165 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
6167 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
6168 CALL PYKMAP(4,MTAUP,0.5D0)
6170 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
6174 IF(MEYST.EQ.1) GOTO 150
6175 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
6176 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
6177 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
6178 CALL PYKMAP(2,MYST,0.5D0)
6182 IF(MECTH.EQ.1) GOTO 150
6183 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
6184 MCTH=1+MOD(ITRY-1,NPTS(4))
6185 CALL PYKMAP(3,MCTH,0.5D0)
6187 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
6189 C...Store position and limits.
6192 IF(MINT(51).EQ.1) GOTO 150
6195 MVARPT(NACC,2)=MTAUP
6199 VINTPT(NACC,J)=VINT(10+J)
6202 C...Normal case: calculate cross-section.
6204 CALL PYSIGH(NCHN,SIGS)
6210 C..2 -> 3: find highest value out of a number of tries.
6213 DO 140 IKIN3=1,MSTP(129)
6214 CALL PYKMAP(5,0,0D0)
6215 IF(MINT(51).EQ.1) GOTO 140
6216 CALL PYSIGH(NCHN,SIGTMP)
6221 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6225 C...Store cross-section.
6227 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6228 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
6229 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6232 WRITE(MSTU(11),5100) ISUB
6235 ELSEIF(SIGSAM.EQ.0D0) THEN
6236 WRITE(MSTU(11),5300) ISUB
6240 IF(ISUB.NE.96) NPOSI=NPOSI+1
6242 C...Calculate integrals in tau over maximal phase space limits.
6245 ATAU1=LOG(TAUMAX/TAUMIN)
6246 IF(NPTS(1).GE.2) THEN
6247 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
6249 IF(NPTS(1).GE.4) THEN
6250 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
6251 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
6254 IF(NPTS(1).GE.6) THEN
6255 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
6256 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
6259 IF(NPTS(1).GT.2+2*MINT(72)) THEN
6260 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
6263 C...Reset. Sum up cross-sections in points calculated.
6265 IF(NPTS(IVAR).EQ.1) GOTO 320
6266 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
6277 IBIN=MVARPT(IACC,IVAR)
6278 IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
6279 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
6280 NAREL(IBIN)=NAREL(IBIN)+1
6281 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
6283 C...Sum up tau cross-section pieces in points used.
6286 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6287 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
6289 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
6290 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
6291 & ((TAU-TAUR1)**2+GAMR1**2)
6294 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
6295 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
6296 & ((TAU-TAUR2)**2+GAMR2**2)
6298 IF(NBIN.GT.2+2*MINT(72)) THEN
6299 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
6300 & TAU/MAX(2D-10,1D0-TAU)
6303 C...Sum up tau' cross-section pieces in points used.
6304 ELSEIF(IVAR.EQ.2) THEN
6306 TAUP=VINTPT(IACC,16)
6307 TAUPMN=VINTPT(IACC,6)
6308 TAUPMX=VINTPT(IACC,26)
6309 ATAUP1=LOG(TAUPMX/TAUPMN)
6310 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
6311 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6312 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
6313 & (1D0-TAU/TAUP)**3/TAUP
6315 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
6316 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
6317 & TAUP/MAX(2D-10,1D0-TAUP)
6320 C...Sum up y* cross-section pieces in points used.
6321 ELSEIF(IVAR.EQ.3) THEN
6323 YSTMIN=VINTPT(IACC,2)
6324 YSTMAX=VINTPT(IACC,22)
6326 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
6328 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
6329 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
6330 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
6331 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
6332 IF(MINT(45).EQ.3) THEN
6333 TAUE=VINTPT(IACC,11)
6334 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6335 YST0=-0.5D0*LOG(TAUE)
6336 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
6337 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
6338 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
6339 & MAX(1D-10,1D0-EXP(YST-YST0))
6341 IF(MINT(46).EQ.3) THEN
6342 TAUE=VINTPT(IACC,11)
6343 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6344 YST0=-0.5D0*LOG(TAUE)
6345 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
6346 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
6347 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
6348 & MAX(1D-10,1D0-EXP(-YST-YST0))
6351 C...Sum up cos(theta-hat) cross-section pieces in points used.
6353 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
6355 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
6357 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
6360 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
6361 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
6362 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
6363 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
6365 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6366 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
6367 & MAX(RM34,RSQM-CTH)
6368 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
6369 & MAX(RM34,RSQM+CTH)
6370 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
6371 & MAX(RM34,RSQM-CTH)**2
6372 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
6373 & MAX(RM34,RSQM+CTH)**2
6377 C...Check that equation system solvable.
6378 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
6382 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
6383 & IRED=1,NBIN),WTREL(IBIN)
6384 IF(NAREL(IBIN).EQ.0) MSOLV=0
6385 WTRELS=WTRELS+WTREL(IBIN)
6387 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
6389 C...Solve to find relative importance of cross-section pieces.
6392 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
6394 DO 230 IRED=1,NBIN-1
6395 DO 220 IBIN=IRED+1,NBIN
6396 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
6400 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
6401 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
6402 DO 210 ICOE=IRED,NBIN
6403 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
6407 DO 250 IRED=NBIN,1,-1
6408 DO 240 ICOE=IRED+1,NBIN
6409 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
6411 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
6415 C...Share evenly if failure.
6416 260 IF(MSOLV.EQ.0) THEN
6420 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
6421 & WTREL(IBIN)/WTRELS)
6425 C...Normalize coefficients, with piece shared democratically.
6429 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
6430 COEFSU=COEFSU+COEFU(IBIN)
6431 WTRELS=WTRELS+WTRELN(IBIN)
6433 IF(COEFSU.GT.0D0) THEN
6435 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
6436 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
6440 COEFO(IBIN)=1D0/NBIN
6443 IF(IVAR.EQ.1) IOFF=0
6444 IF(IVAR.EQ.2) IOFF=17
6445 IF(IVAR.EQ.3) IOFF=7
6446 IF(IVAR.EQ.4) IOFF=12
6449 IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
6450 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
6451 COEF(ISUB,ICOF)=COEFO(IBIN)
6453 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
6454 & (COEFO(IBIN),IBIN=1,NBIN)
6457 C...Find two most promising maxima among points previously determined.
6465 VINT(10+J)=VINTPT(IACC,J)
6468 CALL PYSIGH(NCHN,SIGS)
6475 DO 350 IKIN3=1,MSTP(129)
6476 CALL PYKMAP(5,0,0D0)
6477 IF(MINT(51).EQ.1) GOTO 350
6478 CALL PYSIGH(NCHN,SIGTMP)
6483 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6488 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
6491 DO 370 IMV=NMAX,1,-1
6493 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
6494 IACCMX(IMV+1)=IACCMX(IMV)
6495 SIGSMX(IMV+1)=SIGSMX(IMV)
6498 380 IACCMX(IIN)=IACC
6500 IF(NMAX.LE.1) NMAX=NMAX+1
6504 C...Read out starting position for search.
6505 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
6510 MTAUP=MVARPT(IACC,2)
6518 C...Starting point and step size in parameter space.
6521 IF(NPTS(IVAR).EQ.1) GOTO 420
6522 IF(IVAR.EQ.1) VVAR=VTAU
6523 IF(IVAR.EQ.2) VVAR=VTAUP
6524 IF(IVAR.EQ.3) VVAR=VYST
6525 IF(IVAR.EQ.4) VVAR=VCTH
6526 IF(IVAR.EQ.1) MVAR=MTAU
6527 IF(IVAR.EQ.2) MVAR=MTAUP
6528 IF(IVAR.EQ.3) MVAR=MYST
6529 IF(IVAR.EQ.4) MVAR=MCTH
6530 IF(IRPT.EQ.1) VDEL=0.1D0
6531 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
6533 IF(IRPT.EQ.1) VMAR=0.02D0
6534 IF(IRPT.EQ.2) VMAR=0.002D0
6536 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
6539 C...Define new point in parameter space.
6543 ELSEIF(IMOV.EQ.1) THEN
6546 ELSEIF(IMOV.EQ.2) THEN
6549 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
6550 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
6556 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
6557 & VVAR-2D0*VDEL.GT.VMAR) THEN
6563 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
6577 C...Convert to relevant variables and find derived new limits.
6581 CALL PYKMAP(1,MTAU,VTAU)
6582 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
6584 IF(MINT(51).EQ.1) ILERR=1
6587 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
6589 IF(IVAR.EQ.2) VTAUP=VNEW
6590 CALL PYKMAP(4,MTAUP,VTAUP)
6592 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
6594 IF(MINT(51).EQ.1) ILERR=1
6596 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
6597 IF(IVAR.EQ.3) VYST=VNEW
6598 CALL PYKMAP(2,MYST,VYST)
6600 IF(MINT(51).EQ.1) ILERR=1
6602 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
6604 IF(IVAR.EQ.4) VCTH=VNEW
6605 CALL PYKMAP(3,MCTH,VCTH)
6607 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
6609 C...Evaluate cross-section. Save new maximum. Final maximum.
6612 ELSEIF(ISTSB.NE.5) THEN
6613 CALL PYSIGH(NCHN,SIGS)
6620 DO 400 IKIN3=1,MSTP(129)
6621 CALL PYKMAP(5,0,0D0)
6622 IF(MINT(51).EQ.1) GOTO 400
6623 CALL PYSIGH(NCHN,SIGTMP)
6628 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6632 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6633 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
6634 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6639 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
6640 XSEC(ISUB,1)=1.05D0*SIGSAM
6641 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
6642 & WTGAGA*XSEC(ISUB,1)
6644 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
6645 & PARP(174)*XSEC(ISUB,1)
6646 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
6650 C...Print summary table.
6651 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
6652 IF(MSTP(127).NE.1) THEN
6653 WRITE(MSTU(11),5900)
6656 WRITE(MSTU(11),6400)
6660 IF(MSTP(122).GE.1) THEN
6661 WRITE(MSTU(11),6000)
6662 WRITE(MSTU(11),6100)
6664 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
6665 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
6666 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
6667 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
6668 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
6669 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
6670 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
6671 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
6673 WRITE(MSTU(11),6300)
6676 C...Format statements for maximization results.
6677 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
6678 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
6679 &'cth',9X,'tau''',7X,'sigma')
6680 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
6681 &'phase space.'/1X,'Process switched off!')
6682 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
6683 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
6684 &'cross-section.'/1X,'Process switched off!')
6685 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
6686 5500 FORMAT(1X,1P,8D11.3)
6687 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
6688 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
6689 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
6690 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
6691 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
6692 &'cross-section.'/1X,'Execution stopped!')
6693 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
6694 &'cross-section maximum search',1X,8('*'))
6695 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
6696 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
6697 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
6698 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
6699 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
6700 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
6702 &1X,'Execution will stop if you try to generate events.')
6707 C*********************************************************************
6710 C...Initializes multiplicity distribution and selects mutliplicity
6711 C...of pileup events, i.e. several events occuring at the same
6714 SUBROUTINE PYPILE(MPILE)
6716 C...Double precision and integer declarations.
6717 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6718 IMPLICIT INTEGER(I-N)
6719 INTEGER PYK,PYCHGE,PYCOMP
6721 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6722 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6723 COMMON/PYINT1/MINT(400),VINT(400)
6724 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6725 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
6726 C...Local arrays and saved variables.
6727 DIMENSION WTI(0:200)
6728 SAVE IMIN,IMAX,WTI,WTS
6730 C...Sum of allowed cross-sections for pileup events.
6732 VINT(131)=SIGT(0,0,5)
6733 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
6734 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
6735 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
6736 IF(MSTP(133).LE.0) RETURN
6738 C...Initialize multiplicity distribution at maximum.
6739 XNAVE=VINT(131)*PARP(131)
6740 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
6741 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
6744 WTN=WTI(INAVE)*INAVE
6746 C...Find shape of multiplicity distribution below maximum.
6748 DO 100 I=INAVE-1,1,-1
6749 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
6750 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
6751 IF(WTI(I).LT.1D-6) GOTO 110
6757 C...Find shape of multiplicity distribution above maximum.
6759 DO 120 I=INAVE+1,200
6760 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
6761 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
6762 IF(WTI(I).LT.1D-6) GOTO 130
6769 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
6770 & WTS/(WTS+WTI(1)/XNAVE)
6771 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
6772 IF(MSTP(133).GE.2) VINT(134)=XNAVE
6774 C...Pick multiplicity of pileup events.
6776 IF(MSTP(133).LE.0) THEN
6777 MINT(81)=MAX(1,MSTP(134))
6783 IF(WTR.LE.0D0) GOTO 150
6789 C...Format statement for error message.
6790 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
6791 &'crossing too large, ',1P,D12.4)
6796 C*********************************************************************
6799 C...Saves and restores parameter and cross section values for the
6800 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
6801 C...Also makes random choice between alternatives.
6803 SUBROUTINE PYSAVE(ISAVE,IGA)
6805 C...Double precision and integer declarations.
6806 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6807 IMPLICIT INTEGER(I-N)
6808 INTEGER PYK,PYCHGE,PYCOMP
6810 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6811 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6812 COMMON/PYINT1/MINT(400),VINT(400)
6813 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6814 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6815 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6816 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
6817 C...Local arrays and saved variables.
6818 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
6819 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
6820 &INTCP(15,20),RECP(15,20)
6821 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
6823 C...Save list of subprocesses and cross-section information.
6827 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
6830 MSUBCP(IGA,ICP)=MSUB(I)
6832 COEFCP(IGA,ICP,J)=COEF(I,J)
6835 NGENCP(IGA,ICP,J)=NGEN(I,J)
6836 XSECCP(IGA,ICP,J)=XSEC(I,J)
6841 NGENCP(IGA,0,J)=NGEN(0,J)
6842 XSECCP(IGA,0,J)=XSEC(0,J)
6847 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
6852 C...Save various common process variables.
6854 INTCP(IGA,J)=MINT(40+J)
6856 INTCP(IGA,11)=MINT(101)
6857 INTCP(IGA,12)=MINT(102)
6858 INTCP(IGA,13)=MINT(107)
6859 INTCP(IGA,14)=MINT(108)
6860 INTCP(IGA,15)=MINT(123)
6862 RECP(IGA,2)=VINT(318)
6864 C...Save cross-section information only.
6865 ELSEIF(ISAVE.EQ.2) THEN
6866 DO 190 ICP=1,NCP(IGA)
6869 NGENCP(IGA,ICP,J)=NGEN(I,J)
6870 XSECCP(IGA,ICP,J)=XSEC(I,J)
6874 NGENCP(IGA,0,J)=NGEN(0,J)
6875 XSECCP(IGA,0,J)=XSEC(0,J)
6878 C...Choose between allowed alternatives.
6879 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
6882 DO 210 IG=1,MINT(121)
6883 XSUMCP=XSUMCP+XSECCP(IG,0,1)
6885 XSUMCP=XSUMCP*PYR(0)
6886 DO 220 IG=1,MINT(121)
6888 XSUMCP=XSUMCP-XSECCP(IG,0,1)
6889 IF(XSUMCP.LE.0D0) GOTO 230
6894 C...Restore cross-section information.
6898 DO 270 ICP=1,NCP(IGA)
6900 MSUB(I)=MSUBCP(IGA,ICP)
6902 COEF(I,J)=COEFCP(IGA,ICP,J)
6905 NGEN(I,J)=NGENCP(IGA,ICP,J)
6906 XSEC(I,J)=XSECCP(IGA,ICP,J)
6910 NGEN(0,J)=NGENCP(IGA,0,J)
6911 XSEC(0,J)=XSECCP(IGA,0,J)
6916 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
6921 C...Restore various common process variables.
6923 MINT(40+J)=INTCP(IGA,J)
6925 MINT(101)=INTCP(IGA,11)
6926 MINT(102)=INTCP(IGA,12)
6927 MINT(107)=INTCP(IGA,13)
6928 MINT(108)=INTCP(IGA,14)
6929 MINT(123)=INTCP(IGA,15)
6932 VINT(318)=RECP(IGA,2)
6934 C...Sum up cross-section info (for PYSTAT).
6935 ELSEIF(ISAVE.EQ.5) THEN
6946 DO 350 IG=1,MINT(121)
6947 DO 340 ICP=1,NCP(IG)
6949 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
6950 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
6951 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
6952 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
6954 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
6955 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
6956 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
6957 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
6964 C*********************************************************************
6967 C...For lepton beams it gives photon-hadron or photon-photon systems
6968 C...to be treated with the ordinary machinery and combines this with a
6969 C...description of the lepton -> lepton + photon branching.
6971 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
6973 C...Double precision and integer declarations.
6974 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6975 IMPLICIT INTEGER(I-N)
6976 INTEGER PYK,PYCHGE,PYCOMP
6978 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
6979 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6980 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6981 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6982 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6983 COMMON/PYINT1/MINT(400),VINT(400)
6984 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6985 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
6987 C...Local variables and data statement.
6988 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
6989 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
6990 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
6993 C...Initialize generation of photons inside leptons.
6996 C...Save quantities on incoming lepton system.
7000 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
7002 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
7003 PMC(3)=VINT(302)-PMS(1)-PMS(2)
7004 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
7006 C...Calculate range of x and Q2 values allowed in generation.
7008 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
7009 IF(MINT(140+I).NE.0) THEN
7010 XMIN(I)=MAX(CKIN(59+2*I),EPS)
7011 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
7013 YMIN=MAX(CKIN(71+2*I),EPS)
7014 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
7015 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
7016 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
7017 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
7018 THEMIN=MAX(CKIN(67+2*I),0D0)
7019 THEMAX=MIN(CKIN(68+2*I),PARU(1))
7020 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
7021 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
7022 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
7023 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
7024 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
7025 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
7026 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
7027 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
7028 C...W limits when lepton on one side only.
7029 IF(MINT(143-I).EQ.0) THEN
7030 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
7031 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
7032 & (CKIN(78)**2-PMS(3-I))/PMC(I))
7037 C...W limits when lepton on both sides.
7038 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7039 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
7040 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
7041 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
7042 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
7043 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
7044 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
7045 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
7046 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
7047 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
7049 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
7050 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
7054 C...Q2 and W values and photon flux weight factors for initialization.
7055 ELSEIF(IGAGA.EQ.2) THEN
7060 C...W value for photon on one or both sides, and for processes
7061 C...with gamma-gamma cross section peaked at small shat.
7062 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
7063 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
7064 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
7065 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
7066 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
7067 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
7068 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
7070 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
7071 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
7073 VINT(1)=SQRT(MAX(0D0,VINT(2)))
7075 C...Upper estimate of photon flux weight factor.
7076 C...Initialization Q2 scale. Flag incoming unresolved photon.
7079 IF(MINT(140+I).NE.0) THEN
7080 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
7081 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
7082 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
7084 Q2INIT=5D0+Q2MIN(3-I)
7085 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
7086 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
7087 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
7088 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
7089 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
7090 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
7092 ELSEIF(ISUB.EQ.140) THEN
7097 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
7098 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
7100 VINT(306+I)=VINT(2+I)**2
7105 C...Update pTmin and cross section information.
7106 IF(MSTP(82).LE.1) THEN
7107 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7109 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7111 VINT(149)=4D0*PTMN**2/VINT(2)
7116 C...Generate photons inside leptons and
7117 C...calculate photon flux weight factors.
7118 ELSEIF(IGAGA.EQ.3) THEN
7123 C...Generate phase space point and check against cuts.
7127 IF(MINT(140+I).NE.0) THEN
7129 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
7130 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
7131 C...Cuts on internal consistency in x and Q2.
7132 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
7133 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
7134 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
7135 C...Cuts on y and theta.
7136 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
7137 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
7138 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
7139 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
7140 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
7141 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
7142 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
7145 C...Phi angle isotropic. Reconstruct pT.
7146 PHI(I)=PARU(2)*PYR(0)
7147 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
7148 & PMS(I))*SIN(THETA(I))
7150 C...Store info on variables selected, for documentation purposes.
7151 VINT(2+I)=-SQRT(Q2(I))
7155 VINT(310+I)=THETA(I)
7166 C...Cut on W combines info from two sides.
7167 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7168 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
7169 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
7170 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
7171 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
7172 IF(W2.LT.W2MIN) GOTO 120
7173 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
7176 ELSEIF(MINT(141).NE.0) THEN
7177 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
7180 ELSEIF(MINT(142).NE.0) THEN
7181 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
7186 C...Store kinematics info for photon(s) in subsystem cm frame.
7191 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
7192 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
7193 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
7196 VINT(298)=-VINT(293)
7197 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
7198 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
7200 C...Assign weight for photon flux; different for transverse and
7201 C...longitudinal photons. Flag incoming unresolved photon.
7204 IF(MINT(140+I).NE.0) THEN
7205 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
7206 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
7207 IF(MSTP(16).EQ.0) THEN
7210 WTGAGA=WTGAGA*X(I)/Y(I)
7213 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
7214 WTGAGA=WTGAGA*(1D0-XY)
7215 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
7216 WTGAGA=WTGAGA*(1D0-XY)
7217 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
7218 WTGAGA=WTGAGA*(1D0-XY)
7220 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
7221 & PMS(I)*XY**2/Q2(I))
7223 IF(MINT(106+I).EQ.0) MINT(14+I)=22
7229 C...Update pTmin and cross section information.
7230 IF(MSTP(82).LE.1) THEN
7231 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7233 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7235 VINT(149)=4D0*PTMN**2/VINT(2)
7239 C...Reconstruct kinematics of photons inside leptons.
7240 ELSEIF(IGAGA.EQ.4) THEN
7242 C...Make place for incoming particles and scattered leptons.
7244 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
7245 MINT(4)=MINT(4)+MOVE
7246 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
7247 IF(K(I,1).EQ.21) THEN
7253 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7254 & K(I+MOVE,3)=K(I,3)+MOVE
7255 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
7256 & K(I+MOVE,4)=K(I,4)+MOVE
7257 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
7258 & K(I+MOVE,5)=K(I,5)+MOVE
7261 DO 170 I=MINT(84)+1,N
7262 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7263 & K(I,3)=K(I,3)+MOVE
7266 C...Fill in incoming particles.
7267 DO 190 I=MINT(83)+1,MINT(83)+MOVE
7276 IF(MINT(140+I).NE.0) THEN
7277 K(MINT(83)+I,2)=MINT(140+I)
7278 P(MINT(83)+I,5)=VINT(302+I)
7280 K(MINT(83)+I,2)=MINT(10+I)
7281 P(MINT(83)+I,5)=VINT(2+I)
7283 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
7284 & VINT(302))*(-1D0)**(I+1)
7285 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
7288 C...New mother-daughter relations in documentation section.
7289 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7290 K(MINT(83)+1,4)=MINT(83)+3
7291 K(MINT(83)+1,5)=MINT(83)+5
7292 K(MINT(83)+2,4)=MINT(83)+4
7293 K(MINT(83)+2,5)=MINT(83)+6
7294 K(MINT(83)+3,3)=MINT(83)+1
7295 K(MINT(83)+5,3)=MINT(83)+1
7296 K(MINT(83)+4,3)=MINT(83)+2
7297 K(MINT(83)+6,3)=MINT(83)+2
7298 ELSEIF(MINT(141).NE.0) THEN
7299 K(MINT(83)+1,4)=MINT(83)+3
7300 K(MINT(83)+1,5)=MINT(83)+4
7301 K(MINT(83)+2,4)=MINT(83)+5
7302 K(MINT(83)+3,3)=MINT(83)+1
7303 K(MINT(83)+4,3)=MINT(83)+1
7304 K(MINT(83)+5,3)=MINT(83)+2
7305 ELSEIF(MINT(142).NE.0) THEN
7306 K(MINT(83)+1,4)=MINT(83)+4
7307 K(MINT(83)+2,4)=MINT(83)+3
7308 K(MINT(83)+2,5)=MINT(83)+5
7309 K(MINT(83)+3,3)=MINT(83)+2
7310 K(MINT(83)+4,3)=MINT(83)+1
7311 K(MINT(83)+5,3)=MINT(83)+2
7314 C...Fill scattered lepton(s).
7316 IF(MINT(140+I).NE.0) THEN
7317 LSC=MINT(83)+MIN(I+2,MOVE)
7319 K(LSC,2)=MINT(140+I)
7320 P(LSC,1)=PT(I)*COS(PHI(I))
7321 P(LSC,2)=PT(I)*SIN(PHI(I))
7322 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
7323 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
7325 P(LSC,5)=VINT(302+I)
7329 C...Find incoming four-vectors to subprocess.
7331 IF(MINT(141).NE.0) THEN
7333 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
7337 P(N+1,J)=P(MINT(83)+1,J)
7341 IF(MINT(142).NE.0) THEN
7343 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
7347 P(N+2,J)=P(MINT(83)+2,J)
7351 C...Define boost and rotation between hadronic subsystem and
7352 C...collision rest frame; boost hadronic subsystem to this frame.
7354 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
7356 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
7357 BPHI=PYANGL(P(N+1,1),P(N+1,2))
7358 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
7359 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
7360 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
7363 C...Add on scattered leptons to final state.
7365 IF(MINT(140+I).NE.0) THEN
7366 LSC=MINT(83)+MIN(I+2,MOVE)
7382 C*********************************************************************
7385 C...Generates quantities characterizing the high-pT scattering at the
7386 C...parton level according to the matrix elements. Chooses incoming,
7387 C...reacting partons, their momentum fractions and one of the possible
7392 C...Double precision and integer declarations.
7393 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7394 IMPLICIT INTEGER(I-N)
7395 INTEGER PYK,PYCHGE,PYCOMP
7396 C...Parameter statement to help give large particle numbers.
7397 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7398 &KEXCIT=4000000,KDIMEN=5000000)
7400 C...User process initialization and event commonblocks.
7402 PARAMETER (MAXPUP=100)
7403 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7404 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7405 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7406 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7409 PARAMETER (MAXNUP=500)
7410 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
7411 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
7412 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
7413 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
7414 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
7415 SAVE /HEPRUP/,/HEPEUP/
7418 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7419 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7420 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7421 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7422 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7423 COMMON/PYINT1/MINT(400),VINT(400)
7424 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7425 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7426 COMMON/PYINT4/MWID(500),WIDS(500,5)
7427 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7428 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7429 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
7430 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7431 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/
7433 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
7435 C...Parameters and data used in elastic/diffractive treatment.
7436 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
7437 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
7439 C...Initial values, specifically for (first) semihard interaction.
7449 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
7457 C...Start by assuming incoming photon is entering subprocess.
7458 IF(MINT(11).EQ.22) THEN
7460 VINT(307)=VINT(3)**2
7462 IF(MINT(12).EQ.22) THEN
7464 VINT(308)=VINT(4)**2
7469 C...Choice of process type - first event of pileup.
7471 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
7472 ELSEIF(MINT(82).EQ.1) THEN
7474 C...For gamma-p or gamma-gamma first pick between alternatives.
7476 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
7479 C...For real gamma + gamma with different nature, flip at random.
7480 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
7481 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
7491 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
7494 C...Pick process type, possibly by user process machinery.
7495 C...(If the latter, also event will be picked here.)
7496 IF(MINT(111).EQ.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
7498 ELSEIF(MINT(111).EQ.11.AND.IABS(IDWTUP).GE.3) THEN
7502 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
7503 & ISUB.LT.500) GOTO 110
7505 RSUB=XSEC(0,1)*PYR(0)
7507 IF(MSUB(I).NE.1) GOTO 120
7510 IF(RSUB.LE.0D0) GOTO 130
7512 130 IF(ISUB.EQ.95) ISUB=96
7513 IF(ISUB.EQ.96) INMULT=1
7514 IF(ISET(ISUB).EQ.11) THEN
7520 C...Choice of inclusive process type - pileup events.
7521 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
7522 RSUB=VINT(131)*PYR(0)
7524 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
7525 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
7526 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
7527 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
7529 IF(ISUB.EQ.96) INMULT=1
7532 C...Choice of photon energy and flux factor inside lepton.
7533 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
7534 CALL PYGAGA(3,WTGAGA)
7535 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
7536 CKIN(3)=MAX(VINT(285),VINT(154))
7539 C...When necessary set direct/resolved photon by hand.
7540 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
7541 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
7542 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
7545 C...Restrict direct*resolved processes to pTmin >= Q,
7546 C...to avoid doublecounting with DIS.
7547 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
7548 IF(MINT(15).EQ.22) THEN
7549 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
7551 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
7556 C...Set up for multiple interactions.
7557 IF(INMULT.EQ.1) CALL PYMULT(2)
7559 C...Loopback point for minimum bias in photon physics.
7562 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
7563 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
7564 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
7565 &NGEN(97,1)=NGEN(97,1)+MINT(143)
7569 C...Random choice of flavour for some SUSY processes.
7570 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
7571 C...~e_L ~nu_e or ~mu_L ~nu_mu.
7572 IF(ISUB.EQ.210) THEN
7573 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
7574 KFPR(ISUB,2)=KFPR(ISUB,1)+1
7575 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
7576 ELSEIF(ISUB.EQ.213) THEN
7577 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
7578 KFPR(ISUB,2)=KFPR(ISUB,1)
7579 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
7580 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
7581 IF(ISUB.GE.258) THEN
7586 IF(MOD(ISUB,2).EQ.0) THEN
7587 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
7589 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
7591 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7592 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
7593 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
7596 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
7599 ELSEIF(PYR(0).LT.0.5D0) THEN
7606 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
7607 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
7608 C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
7609 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
7610 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
7611 KFPR(ISUB,2)=KFPR(ISUB,1)
7612 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
7613 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
7614 KFPR(ISUB,2)=KFPR(ISUB,1)
7615 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7616 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
7617 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
7620 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
7623 ELSEIF(PYR(0).LT.0.5D0) THEN
7630 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
7635 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
7639 C...Find resonances (explicit or implicit in cross-section).
7642 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7644 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
7645 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7647 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
7650 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7652 IF(MSTP(46).EQ.5) THEN
7655 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7657 ELSEIF(ISUB.EQ.194) THEN
7659 ELSEIF(ISUB.EQ.195) THEN
7661 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
7663 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
7667 IF(CKMX.LE.0D0) CKMX=VINT(1)
7670 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7671 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7674 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7675 IF(KFR1.EQ.KTECHN+113) THEN
7679 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7685 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
7688 IF(ISUB.EQ.194) THEN
7690 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
7694 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7695 IF(KFR2.EQ.KTECHN+223) THEN
7699 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7700 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7701 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
7702 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7707 ELSEIF(KFR2.NE.0) THEN
7718 C...Find product masses and minimum pT of process,
7719 C...optionally with broadening according to a truncated Breit-Wigner.
7724 IF(MINT(82).GE.2) VINT(71)=0D0
7726 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7730 IF(KFPR(ISUB,I).EQ.0) THEN
7731 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7733 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7736 C...This prevents SUSY/t particles from becoming too light.
7738 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7741 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7742 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7743 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7744 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7745 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7746 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7747 PMMN(I)=MIN(PMMN(I),PMSUM)
7750 ELSEIF(KFLW.EQ.6) THEN
7751 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7758 CKIN(41)=MAX(PMMN(1),CKIN(41))
7759 CKIN(43)=MAX(PMMN(2),CKIN(43))
7760 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7763 IF(MINT(51).EQ.1) THEN
7764 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7774 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
7775 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7778 C...Prepare for additional variable choices in 2 -> 3.
7781 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7783 VINT(204)=PMAS(23,1)
7784 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7785 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7786 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
7787 & ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
7791 C...Select incoming VDM particle (rho/omega/phi/J/psi).
7792 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
7793 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
7794 VRN=PYR(0)*SIGT(0,0,5)
7795 IF(MINT(101).LE.1) THEN
7802 IF(MINT(102).LE.1) THEN
7813 VRN=VRN-SIGT(I1,I2,5)
7814 IF(VRN.LE.0D0) GOTO 190
7817 190 IF(MINT(101).GE.2) MINT(103)=KFV1
7818 IF(MINT(102).GE.2) MINT(104)=KFV2
7822 C...Elastic scattering or single or double diffractive scattering.
7824 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
7829 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
7831 VRN=PYR(0)*SIGT(0,0,JJ)
7832 IF(MINT(101).LE.1) THEN
7839 IF(MINT(102).LE.1) THEN
7850 VRN=VRN-SIGT(I1,I2,JJ)
7851 IF(VRN.LE.0D0) GOTO 220
7854 220 IF(MINT(101).GE.2) THEN
7858 IF(MINT(102).GE.2) THEN
7866 C...Select mass for GVMD states (rejecting previous assignment).
7868 Q1S=4D0*VINT(154)**2
7872 IF(MINT(106+JT).EQ.3) THEN
7874 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
7875 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
7876 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
7877 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
7880 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
7881 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
7886 C...Side/sides of diffractive system.
7889 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
7890 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
7892 C...Find masses of particles and minimal masses of diffractive states.
7895 VINT(68+JT)=PDIF(JT)
7896 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
7903 SMRES1=(PMM(1)+PMRC)**2
7904 SMRES2=(PMM(2)+PMRC)**2
7906 C...Find elastic slope and lower limit diffractive slope.
7907 IHA=MAX(2,IABS(MINT(103))/110)
7909 IHB=MAX(2,IABS(MINT(104))/110)
7912 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
7913 ELSEIF(ISUB.EQ.92) THEN
7914 BMN=MAX(2D0,2D0*BHAD(IHB))
7915 ELSEIF(ISUB.EQ.93) THEN
7916 BMN=MAX(2D0,2D0*BHAD(IHA))
7917 ELSEIF(ISUB.EQ.94) THEN
7921 C...Determine maximum possible t range and coefficient of generation.
7922 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
7923 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7924 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7925 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7926 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7927 & (SQM1*SQM4-SQM2*SQM3)/SH
7928 THL=-0.5D0*(THA+THB)
7930 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
7932 C...Select diffractive mass/masses according to dm^2/m^2.
7936 IF(MINT(16+JT).EQ.0) THEN
7940 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
7941 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
7947 C..Additional mass factors, including resonance enhancement.
7948 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
7949 IF(LOOP3.LT.100) GOTO 260
7953 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
7954 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7955 ELSEIF(ISUB.EQ.93) THEN
7956 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
7957 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7958 ELSEIF(ISUB.EQ.94) THEN
7959 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
7960 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
7961 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
7962 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
7965 C...Select t according to exp(Bmn*t) and correct to right slope.
7966 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
7969 BADD=2D0*ALP*LOG(SH/SQM3)
7970 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
7971 ELSEIF(ISUB.EQ.93) THEN
7972 BADD=2D0*ALP*LOG(SH/SQM4)
7973 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
7974 ELSEIF(ISUB.EQ.94) THEN
7975 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
7977 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
7980 C...Check whether m^2 and t choices are consistent.
7981 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7982 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7983 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7984 IF(THB.LE.1D-8) GOTO 260
7985 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7986 & (SQM1*SQM4-SQM2*SQM3)/SH
7987 THLM=-0.5D0*(THA+THB)
7989 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
7991 C...Information to output.
7994 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
7996 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
7999 VINT(283)=PMM(1)**2/4D0
8000 VINT(284)=PMM(2)**2/4D0
8002 C...Note: in the following, by In is meant the integral over the
8003 C...quantity multiplying coefficient cn.
8004 C...Choose tau according to h1(tau)/tau, where
8005 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
8006 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
8007 C...I1/I5*c5*1/(tau+tau_R') +
8008 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
8009 C...I1/I7*c7*tau/(1.-tau), and
8010 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
8011 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
8013 IF(MINT(51).NE.0) THEN
8014 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8023 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
8024 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
8025 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
8026 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
8028 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
8029 & COEF(ISUB,5)) MTAU=6
8030 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
8031 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
8032 CALL PYKMAP(1,MTAU,PYR(0))
8034 C...2 -> 3, 4 processes:
8035 C...Choose tau' according to h4(tau,tau')/tau', where
8036 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
8037 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
8038 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8040 IF(MINT(51).NE.0) THEN
8041 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8050 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
8051 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
8052 CALL PYKMAP(4,MTAUP,PYR(0))
8055 C...Choose y* according to h2(y*), where
8056 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
8057 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
8058 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
8059 C...and c1 + c2 + c3 + c4 + c5 = 1.
8061 IF(MINT(51).NE.0) THEN
8062 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8071 IF(RYST.GT.COEF(ISUB,8)) MYST=2
8072 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
8073 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
8074 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
8075 & COEF(ISUB,11)) MYST=5
8076 CALL PYKMAP(2,MYST,PYR(0))
8078 C...2 -> 2 processes:
8079 C...Choose cos(theta-hat) (cth) according to h3(cth), where
8080 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
8081 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
8082 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
8083 C...and c0 + c1 + c2 + c3 + c4 = 1.
8085 IF(MINT(51).NE.0) THEN
8086 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8093 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
8096 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
8097 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
8098 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
8099 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
8100 & COEF(ISUB,16)) MCTH=5
8101 CALL PYKMAP(3,MCTH,PYR(0))
8104 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
8106 CALL PYKMAP(5,0,0D0)
8107 IF(MINT(51).NE.0) THEN
8108 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8117 C...DIS as f + gamma* -> f process: set dummy values.
8118 ELSEIF(ISTSB.EQ.8) THEN
8125 C...Low-pT or multiple interactions (first semihard interaction).
8126 ELSEIF(ISTSB.EQ.9) THEN
8130 C...Study user-defined process: kinematics plus weight.
8131 ELSEIF(ISTSB.EQ.11) THEN
8132 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
8133 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
8138 IF(MINT(82).EQ.1) THEN
8139 NGEN(0,1)=NGEN(0,1)-1
8140 NGEN(ISUB,1)=NGEN(ISUB,1)-1
8142 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8146 C...Extract cross section event weight.
8147 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
8150 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
8152 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
8153 VINT(97)=SIGN(1D0,XWGTUP)
8155 VINT(97)=1D-9*XWGTUP
8158 C...Construct 'trivial' kinematical variables needed.
8161 VINT(41)=PUP(4,1)/EBMUP(1)
8162 VINT(42)=PUP(4,2)/EBMUP(2)
8163 VINT(21)=VINT(41)*VINT(42)
8164 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
8165 VINT(44)=VINT(21)*VINT(2)
8166 VINT(43)=SQRT(MAX(0D0,VINT(44)))
8168 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
8169 VINT(56)=VINT(55)**2
8173 C...Construct other kinematical variables needed (approximately).
8176 VINT(45)=-0.5D0*VINT(44)
8177 VINT(46)=-0.5D0*VINT(44)
8186 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
8187 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
8189 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
8190 & '(PYRAND:) unacceptable ISTUP code for particles')
8191 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
8192 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
8193 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
8196 VINT(47)=SQRT(VINT(48))
8199 C...Choose azimuthal angle.
8201 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
8203 C...Check against user cuts on kinematics at parton level.
8205 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
8206 IF(MINT(51).NE.0) THEN
8207 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8214 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
8216 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
8219 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8228 C...Calculate differential cross-section for different subprocesses.
8229 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
8231 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
8233 C...Multiply cross section by lepton -> photon flux factor.
8234 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
8237 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
8239 SIGLPT=WTGAGA*SIGLPT
8242 C...Multiply cross-section by user-defined weights.
8243 IF(MSTP(173).EQ.1) THEN
8246 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
8248 SIGLPT=PARP(173)*SIGLPT
8254 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
8255 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
8256 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
8259 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
8262 C...Calculations for Monte Carlo estimate of all cross-sections.
8263 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
8264 IF(MSTP(142).LE.1) THEN
8265 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8267 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
8269 ELSEIF(MINT(82).EQ.1) THEN
8270 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8272 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
8273 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
8275 C...Multiple interactions: store results of cross-section calculation.
8276 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
8281 C...Ratio of actual to maximum cross section.
8282 IF(ISTSB.NE.11) THEN
8283 VIOL=SIGSWT/XSEC(ISUB,1)
8284 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
8285 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
8286 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
8287 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
8288 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
8293 C...Check that weight not negative.
8294 IF(MSTP(123).LE.0) THEN
8295 IF(VIOL.LT.-1D-3) THEN
8296 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
8297 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8298 & VINT(22),VINT(23),VINT(26)
8302 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
8304 WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
8305 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8306 & VINT(22),VINT(23),VINT(26)
8310 C...Weighting using estimate of maximum of differential cross-section.
8311 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
8312 IF(VIOL.LT.PYR(0)) THEN
8313 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8314 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
8317 ELSEIF(MFAIL.EQ.0) THEN
8318 RATND=SIGLPT/XSEC(95,1)
8320 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
8321 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
8322 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
8323 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8327 IF(VIOL.LT.PYR(0)) THEN
8330 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
8331 IF(VIOL.LT.PYR(0)) THEN
8333 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8337 RATND=SIGLPT/XSEC(95,1)
8338 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
8340 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8344 IF(VIOL.LT.PYR(0)) THEN
8345 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8350 C...Check for possible violation of estimated maximum of differential
8351 C...cross-section used in weighting.
8352 IF(MSTP(123).LE.0) THEN
8353 IF(VIOL.GT.1D0) THEN
8354 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
8355 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8356 & VINT(22),VINT(23),VINT(26)
8359 ELSEIF(MSTP(123).EQ.1) THEN
8360 IF(VIOL.GT.VINT(108)) THEN
8362 IF(VIOL.GT.1.0001D0) THEN
8364 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8365 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8366 & VINT(22),VINT(23),VINT(26)
8369 ELSEIF(VIOL.GT.VINT(108)) THEN
8371 IF(VIOL.GT.1D0) THEN
8373 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8374 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
8376 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
8377 IF(KFPR(ISUB,1).LE.9) THEN
8378 WRITE(MSTU(11),5800) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8379 ELSEIF(KFPR(ISUB,1).LE.99) THEN
8380 WRITE(MSTU(11),5900) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8382 WRITE(MSTU(11),6000) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8385 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
8386 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
8387 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
8388 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
8389 & XSEC(0,1)=XSEC(0,1)+XDIF
8390 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8391 & VINT(22),VINT(23),VINT(26)
8393 WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
8394 ELSEIF(ISUB.LE.99) THEN
8395 WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
8397 WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
8404 C...Multiple interactions: choose impact parameter.
8406 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
8407 &MSTP(82).GE.3) THEN
8409 IF(VINT(150).LT.PYR(0)) THEN
8410 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8418 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
8419 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
8420 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
8421 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
8423 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
8425 C...Choose flavour of reacting partons (and subprocess).
8426 IF(ISTSB.GE.11) GOTO 320
8429 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
8430 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
8431 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
8432 &PYR(0).GT.RQQBAR)) THEN
8436 MINT(2)=ISIG(ICHN,3)
8437 RSIGS=RSIGS-SIGH(ICHN)
8438 IF(RSIGS.LE.0D0) GOTO 320
8441 C...Multiple interactions: choose qqbar preferentially at small pT.
8442 ELSEIF(ISUB.EQ.96) THEN
8445 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
8448 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
8451 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
8453 C...Low-pT: choose string drawing configuration.
8459 IF(RSIGS.GT.1D0) MINT(2)=2
8460 IF(RSIGS.GT.2D0) MINT(2)=3
8463 C...Reassign QCD process. Partons before initial state radiation.
8464 320 IF(MINT(2).GT.10) THEN
8466 MINT(2)=MOD(MINT(2),10)
8468 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
8479 C...Calculate x value of photon for parton inside photon inside e.
8484 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
8485 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
8486 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
8491 MINT(105)=MINT(102+JT)
8492 MINT(109)=MINT(106+JT)
8493 VINT(120)=VINT(2+JT)
8494 IF(MSTP(57).LE.1) THEN
8495 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
8497 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
8500 IF(MSTP(13).EQ.2) THEN
8501 Q2PMS=Q2HRD/PMAS(11,1)**2
8502 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
8505 XG=MIN(1D0-1D-10,XHRD/XE)
8506 IF(MSTP(57).LE.1) THEN
8507 CALL PYPDFU(22,XG,Q2HRD,XPQ)
8509 CALL PYPDFL(22,XG,Q2HRD,XPQ)
8511 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
8512 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
8513 IF(WT.LT.PYR(0)*WTMX) GOTO 330
8517 XSFX(JT,KFLS)=XPQ(KFLS)
8522 C...Pick scale where photon is resolved.
8526 IF(MINT(107).EQ.3) THEN
8527 IF(MSTP(66).EQ.1) THEN
8528 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
8529 ELSEIF(MSTP(66).EQ.2) THEN
8531 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8532 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8533 Q2INT=SQRT(Q0S*Q2EFF)
8534 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8535 ELSEIF(MSTP(66).EQ.3) THEN
8536 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
8537 ELSEIF(MSTP(66).GE.4) THEN
8538 PS=0.25D0*VINT(3)**2
8539 VINT(283)=(Q0S+PS)*(Q1S+PS)/
8540 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8544 IF(MINT(108).EQ.3) THEN
8545 IF(MSTP(66).EQ.1) THEN
8546 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
8547 ELSEIF(MSTP(66).EQ.2) THEN
8549 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8550 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8551 Q2INT=SQRT(Q0S*Q2EFF)
8552 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8553 ELSEIF(MSTP(66).EQ.3) THEN
8554 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
8555 ELSEIF(MSTP(66).GE.4) THEN
8556 PS=0.25D0*VINT(4)**2
8557 VINT(284)=(Q0S+PS)*(Q1S+PS)/
8558 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8561 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8563 C...Format statements for differential cross-section maximum violations.
8564 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
8565 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8566 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
8567 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
8568 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
8570 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
8571 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8572 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
8574 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
8575 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
8576 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
8577 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
8578 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
8579 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
8584 C*********************************************************************
8587 C...Finds outgoing flavours and event type; sets up the kinematics
8588 C...and colour flow of the hard scattering
8592 C...Double precision and integer declarations
8593 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8594 IMPLICIT INTEGER(I-N)
8595 INTEGER PYK,PYCHGE,PYCOMP
8596 C...Parameter statement to help give large particle numbers.
8597 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
8598 &KEXCIT=4000000,KDIMEN=5000000)
8600 C...User process event common block.
8602 PARAMETER (MAXNUP=500)
8603 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
8604 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
8605 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
8606 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
8607 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
8611 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8612 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8613 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8614 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
8615 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8616 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8617 COMMON/PYINT1/MINT(400),VINT(400)
8618 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8619 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8620 COMMON/PYINT4/MWID(500),WIDS(500,5)
8621 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8622 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
8623 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
8624 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
8625 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
8626 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,/PYTCSM/
8627 C...Local arrays and saved variables
8628 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
8629 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
8632 C...Read out process
8636 C...Restore information for low-pT processes
8637 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
8639 100 VINT(J)=VINTSV(J)
8642 C...Convert H' or A process into equivalent H one
8645 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
8648 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
8650 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
8651 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
8652 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
8653 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
8654 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
8655 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
8656 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
8657 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
8658 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
8659 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
8660 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
8661 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
8664 C...Choice of subprocess, number of documentation lines
8666 IF(ISUB.EQ.95) IDOC=8
8667 IF(ISET(ISUB).EQ.5) IDOC=9
8668 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
8670 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
8679 C...Reset K, P and V vectors. Store incoming particles
8680 DO 120 JT=1,MSTP(126)+100
8682 IF(I.GT.MSTU(4)) GOTO 120
8694 P(I,J)=VINT(285+5*JT+J)
8700 C...Store incoming partons in their CM-frame
8703 SHP=VINT(26)*VINT(2)
8706 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
8711 K(I,3)=MINT(83)+2+JT
8712 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
8716 C...Copy incoming partons to documentation lines
8728 C...Choose new quark/lepton flavour for relevant annihilation graphs
8729 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
8730 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
8732 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
8733 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
8734 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
8735 DO 190 I=1,MDCY(IGLGA,3)
8736 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
8737 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
8738 IF(RKFL.LE.0D0) GOTO 200
8741 IF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.2) THEN
8742 IF(KFLF.GE.4) GOTO 180
8743 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.4) THEN
8746 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385) THEN
8749 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
8750 & .AND.IABS(KFLF).GE.3) THEN
8751 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
8753 FACCIB=VINT(46)**2/RTCM(41)**4
8754 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
8755 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
8758 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
8759 IF(KFLF.EQ.5) GOTO 180
8760 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
8761 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
8762 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
8763 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
8767 C...Final state flavours and colour flow: default values
8774 KCS=ISIGN(1,MINT(15))
8776 IF(ISET(ISUB).EQ.11) THEN
8777 C...User-defined processes: find products
8780 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
8781 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
8782 MINT(21+IUP)=IDUP(IUP)
8783 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
8784 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
8785 ELSEIF(IDUP(IUP).EQ.0) THEN
8788 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
8792 ELSEIF(ISUB.LE.10) THEN
8794 C...f + fbar -> gamma*/Z0
8797 ELSEIF(ISUB.EQ.2) THEN
8798 C...f + fbar' -> W+/-
8799 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8800 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8801 KFRES=ISIGN(24,KCH1+KCH2)
8803 ELSEIF(ISUB.EQ.3) THEN
8804 C...f + fbar -> h0 (or H0, or A0)
8807 ELSEIF(ISUB.EQ.4) THEN
8808 C...gamma + W+/- -> W+/-
8810 ELSEIF(ISUB.EQ.5) THEN
8815 PMQ(1)=PYMASS(MINT(21))
8816 PMQ(2)=PYMASS(MINT(22))
8817 220 JT=INT(1.5D0+PYR(0))
8818 ZMIN=2D0*PMQ(JT)/SHPR
8819 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8820 & (SHPR*(SHPR-PMQ(3-JT)))
8821 ZMAX=MIN(1D0-XH,ZMAX)
8822 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8823 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8824 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
8825 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8826 IF(SQC1.LT.1D-8) GOTO 220
8828 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8829 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8830 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8831 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8832 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8833 IF(SQC1.LT.1D-8) GOTO 220
8835 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8836 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8837 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8840 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8841 & SQRT(1D0-CTHE(2)**2)*CPHI
8843 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8844 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8845 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8846 & PMQ(3-JT)**2/SHP))
8847 ZMIN=2D0*PMQ(3-JT)/SHPR
8848 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8849 ZMAX=MIN(1D0-XH,ZMAX)
8850 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
8854 ELSEIF(ISUB.EQ.6) THEN
8855 C...Z0 + W+/- -> W+/-
8857 ELSEIF(ISUB.EQ.7) THEN
8860 ELSEIF(ISUB.EQ.8) THEN
8867 RVCKM=VINT(180+I)*PYR(0)
8870 IPM=(5-ISIGN(1,I))/2
8872 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
8873 MINT(20+JT)=ISIGN(IB,I)
8874 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8875 IF(RVCKM.LE.0D0) GOTO 250
8878 IB=2*((IA+1)/2)-1+MOD(IA,2)
8879 MINT(20+JT)=ISIGN(IB,I)
8881 250 PMQ(JT)=PYMASS(MINT(20+JT))
8883 JT=INT(1.5D0+PYR(0))
8884 ZMIN=2D0*PMQ(JT)/SHPR
8885 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8886 & (SHPR*(SHPR-PMQ(3-JT)))
8887 ZMAX=MIN(1D0-XH,ZMAX)
8888 IF(ZMIN.GE.ZMAX) GOTO 230
8889 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8890 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8891 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
8892 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8893 IF(SQC1.LT.1D-8) GOTO 230
8895 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8896 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8897 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8898 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8899 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8900 IF(SQC1.LT.1D-8) GOTO 230
8902 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8903 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8904 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8907 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8908 & SQRT(1D0-CTHE(2)**2)*CPHI
8910 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8911 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8912 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8913 & PMQ(3-JT)**2/SHP))
8914 ZMIN=2D0*PMQ(3-JT)/SHPR
8915 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8916 ZMAX=MIN(1D0-XH,ZMAX)
8917 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
8921 ELSEIF(ISUB.EQ.10) THEN
8922 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
8923 IF(MINT(2).EQ.1) THEN
8926 C...W exchange: need to mix flavours according to CKM matrix
8931 RVCKM=VINT(180+I)*PYR(0)
8934 IPM=(5-ISIGN(1,I))/2
8936 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
8937 MINT(20+JT)=ISIGN(IB,I)
8938 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8939 IF(RVCKM.LE.0D0) GOTO 280
8942 IB=2*((IA+1)/2)-1+MOD(IA,2)
8943 MINT(20+JT)=ISIGN(IB,I)
8950 ELSEIF(ISUB.LE.20) THEN
8952 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
8954 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8956 ELSEIF(ISUB.EQ.12) THEN
8957 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
8958 MINT(21)=ISIGN(KFLF,MINT(15))
8962 ELSEIF(ISUB.EQ.13) THEN
8963 C...f + fbar -> g + g; th arbitrary
8968 ELSEIF(ISUB.EQ.14) THEN
8969 C...f + fbar -> g + gamma; th arbitrary
8970 IF(PYR(0).GT.0.5D0) JS=2
8975 ELSEIF(ISUB.EQ.15) THEN
8976 C...f + fbar -> g + Z0; th arbitrary
8977 IF(PYR(0).GT.0.5D0) JS=2
8982 ELSEIF(ISUB.EQ.16) THEN
8983 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8984 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8985 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8986 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8988 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8991 ELSEIF(ISUB.EQ.17) THEN
8992 C...f + fbar -> g + h0; th arbitrary
8993 IF(PYR(0).GT.0.5D0) JS=2
8998 ELSEIF(ISUB.EQ.18) THEN
8999 C...f + fbar -> gamma + gamma; th arbitrary
9003 ELSEIF(ISUB.EQ.19) THEN
9004 C...f + fbar -> gamma + Z0; th arbitrary
9005 IF(PYR(0).GT.0.5D0) JS=2
9009 ELSEIF(ISUB.EQ.20) THEN
9010 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
9011 C...(p(fbar')-p(W+))**2
9012 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9013 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9014 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
9016 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
9019 ELSEIF(ISUB.LE.30) THEN
9021 C...f + fbar -> gamma + h0; th arbitrary
9022 IF(PYR(0).GT.0.5D0) JS=2
9026 ELSEIF(ISUB.EQ.22) THEN
9027 C...f + fbar -> Z0 + Z0; th arbitrary
9031 ELSEIF(ISUB.EQ.23) THEN
9032 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
9033 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9034 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9035 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
9037 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
9039 ELSEIF(ISUB.EQ.24) THEN
9040 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
9041 IF(PYR(0).GT.0.5D0) JS=2
9045 ELSEIF(ISUB.EQ.25) THEN
9046 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
9047 MINT(21)=-ISIGN(24,MINT(15))
9050 ELSEIF(ISUB.EQ.26) THEN
9051 C...f + fbar' -> W+/- + h0 (or H0, or A0);
9052 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
9053 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9054 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9055 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
9056 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
9059 ELSEIF(ISUB.EQ.27) THEN
9060 C...f + fbar -> h0 + h0
9062 ELSEIF(ISUB.EQ.28) THEN
9063 C...f + g -> f + g; th = (p(f)-p(f))**2
9064 IF(MINT(15).EQ.21) JS=2
9066 IF(MINT(15).EQ.21) KCC=KCC+2
9067 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
9068 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
9070 ELSEIF(ISUB.EQ.29) THEN
9071 C...f + g -> f + gamma; th = (p(f)-p(f))**2
9072 IF(MINT(15).EQ.21) JS=2
9075 KCS=ISIGN(1,MINT(14+JS))
9077 ELSEIF(ISUB.EQ.30) THEN
9078 C...f + g -> f + Z0; th = (p(f)-p(f))**2
9079 IF(MINT(15).EQ.21) JS=2
9082 KCS=ISIGN(1,MINT(14+JS))
9085 ELSEIF(ISUB.LE.40) THEN
9087 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
9088 IF(MINT(15).EQ.21) JS=2
9091 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
9092 RVCKM=VINT(180+I)*PYR(0)
9095 IPM=(5-ISIGN(1,I))/2
9097 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
9098 MINT(20+JS)=ISIGN(IB,I)
9099 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9100 IF(RVCKM.LE.0D0) GOTO 300
9103 KCS=ISIGN(1,MINT(14+JS))
9105 ELSEIF(ISUB.EQ.32) THEN
9106 C...f + g -> f + h0; th = (p(f)-p(f))**2
9107 IF(MINT(15).EQ.21) JS=2
9110 KCS=ISIGN(1,MINT(14+JS))
9112 ELSEIF(ISUB.EQ.33) THEN
9113 C...f + gamma -> f + g; th=(p(f)-p(f))**2
9114 IF(MINT(15).EQ.22) JS=2
9117 KCS=ISIGN(1,MINT(14+JS))
9119 ELSEIF(ISUB.EQ.34) THEN
9120 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
9121 IF(MINT(15).EQ.22) JS=2
9123 KCS=ISIGN(1,MINT(14+JS))
9125 ELSEIF(ISUB.EQ.35) THEN
9126 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
9127 IF(MINT(15).EQ.22) JS=2
9131 ELSEIF(ISUB.EQ.36) THEN
9132 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
9133 IF(MINT(15).EQ.22) JS=2
9136 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
9138 RVCKM=VINT(180+I)*PYR(0)
9141 IPM=(5-ISIGN(1,I))/2
9143 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
9144 MINT(20+JS)=ISIGN(IB,I)
9145 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9146 IF(RVCKM.LE.0D0) GOTO 320
9149 IB=2*((IA+1)/2)-1+MOD(IA,2)
9150 MINT(20+JS)=ISIGN(IB,I)
9154 ELSEIF(ISUB.EQ.37) THEN
9155 C...f + gamma -> f + h0
9157 ELSEIF(ISUB.EQ.38) THEN
9160 ELSEIF(ISUB.EQ.39) THEN
9161 C...f + Z0 -> f + gamma
9163 ELSEIF(ISUB.EQ.40) THEN
9164 C...f + Z0 -> f + Z0
9167 ELSEIF(ISUB.LE.50) THEN
9169 C...f + Z0 -> f' + W+/-
9171 ELSEIF(ISUB.EQ.42) THEN
9172 C...f + Z0 -> f + h0
9174 ELSEIF(ISUB.EQ.43) THEN
9175 C...f + W+/- -> f' + g
9177 ELSEIF(ISUB.EQ.44) THEN
9178 C...f + W+/- -> f' + gamma
9180 ELSEIF(ISUB.EQ.45) THEN
9181 C...f + W+/- -> f' + Z0
9183 ELSEIF(ISUB.EQ.46) THEN
9184 C...f + W+/- -> f' + W+/-
9186 ELSEIF(ISUB.EQ.47) THEN
9187 C...f + W+/- -> f' + h0
9189 ELSEIF(ISUB.EQ.48) THEN
9192 ELSEIF(ISUB.EQ.49) THEN
9193 C...f + h0 -> f + gamma
9195 ELSEIF(ISUB.EQ.50) THEN
9196 C...f + h0 -> f + Z0
9199 ELSEIF(ISUB.LE.60) THEN
9201 C...f + h0 -> f' + W+/-
9203 ELSEIF(ISUB.EQ.52) THEN
9204 C...f + h0 -> f + h0
9206 ELSEIF(ISUB.EQ.53) THEN
9207 C...g + g -> f + fbar; th arbitrary
9208 KCS=(-1)**INT(1.5D0+PYR(0))
9209 MINT(21)=ISIGN(KFLF,KCS)
9213 ELSEIF(ISUB.EQ.54) THEN
9214 C...g + gamma -> f + fbar; th arbitrary
9215 KCS=(-1)**INT(1.5D0+PYR(0))
9216 MINT(21)=ISIGN(KFLF,KCS)
9219 IF(MINT(16).EQ.21) KCC=28
9221 ELSEIF(ISUB.EQ.55) THEN
9222 C...g + Z0 -> f + fbar
9224 ELSEIF(ISUB.EQ.56) THEN
9225 C...g + W+/- -> f + fbar'
9227 ELSEIF(ISUB.EQ.57) THEN
9228 C...g + h0 -> f + fbar
9230 ELSEIF(ISUB.EQ.58) THEN
9231 C...gamma + gamma -> f + fbar; th arbitrary
9232 KCS=(-1)**INT(1.5D0+PYR(0))
9233 MINT(21)=ISIGN(KFLF,KCS)
9237 ELSEIF(ISUB.EQ.59) THEN
9238 C...gamma + Z0 -> f + fbar
9240 ELSEIF(ISUB.EQ.60) THEN
9241 C...gamma + W+/- -> f + fbar'
9244 ELSEIF(ISUB.LE.70) THEN
9246 C...gamma + h0 -> f + fbar
9248 ELSEIF(ISUB.EQ.62) THEN
9249 C...Z0 + Z0 -> f + fbar
9251 ELSEIF(ISUB.EQ.63) THEN
9252 C...Z0 + W+/- -> f + fbar'
9254 ELSEIF(ISUB.EQ.64) THEN
9255 C...Z0 + h0 -> f + fbar
9257 ELSEIF(ISUB.EQ.65) THEN
9258 C...W+ + W- -> f + fbar
9260 ELSEIF(ISUB.EQ.66) THEN
9261 C...W+/- + h0 -> f + fbar'
9263 ELSEIF(ISUB.EQ.67) THEN
9264 C...h0 + h0 -> f + fbar
9266 ELSEIF(ISUB.EQ.68) THEN
9267 C...g + g -> g + g; th arbitrary
9269 KCS=(-1)**INT(1.5D0+PYR(0))
9271 ELSEIF(ISUB.EQ.69) THEN
9272 C...gamma + gamma -> W+ + W-; th arbitrary
9277 ELSEIF(ISUB.EQ.70) THEN
9278 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
9279 IF(MINT(15).EQ.22) MINT(21)=23
9280 IF(MINT(16).EQ.22) MINT(22)=23
9284 ELSEIF(ISUB.LE.80) THEN
9285 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
9286 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
9290 PMQ(1)=PYMASS(MINT(21))
9291 PMQ(2)=PYMASS(MINT(22))
9292 330 JT=INT(1.5D0+PYR(0))
9293 ZMIN=2D0*PMQ(JT)/SHPR
9294 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9295 & (SHPR*(SHPR-PMQ(3-JT)))
9296 ZMAX=MIN(1D0-XH,ZMAX)
9297 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9298 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9299 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
9300 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9301 IF(SQC1.LT.1D-8) GOTO 330
9303 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9304 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9305 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9306 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9307 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9308 IF(SQC1.LT.1D-8) GOTO 330
9310 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9311 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9312 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9315 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9316 & SQRT(1D0-CTHE(2)**2)*CPHI
9318 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9319 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9320 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9321 & PMQ(3-JT)**2/SHP))
9322 ZMIN=2D0*PMQ(3-JT)/SHPR
9323 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9324 ZMAX=MIN(1D0-XH,ZMAX)
9325 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
9328 ELSEIF(ISUB.EQ.73) THEN
9329 C...Z0 + W+/- -> Z0 + W+/-
9336 RVCKM=VINT(180+I)*PYR(0)
9339 IPM=(5-ISIGN(1,I))/2
9341 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
9342 MINT(20+JT)=ISIGN(IB,I)
9343 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9344 IF(RVCKM.LE.0D0) GOTO 360
9347 IB=2*((IA+1)/2)-1+MOD(IA,2)
9348 MINT(20+JT)=ISIGN(IB,I)
9350 360 PMQ(JT)=PYMASS(MINT(20+JT))
9351 MINT(23-JT)=MINT(17-JT)
9352 PMQ(3-JT)=PYMASS(MINT(23-JT))
9353 JT=INT(1.5D0+PYR(0))
9354 ZMIN=2D0*PMQ(JT)/SHPR
9355 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9356 & (SHPR*(SHPR-PMQ(3-JT)))
9357 ZMAX=MIN(1D0-XH,ZMAX)
9358 IF(ZMIN.GE.ZMAX) GOTO 340
9359 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9360 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9361 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
9362 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9363 IF(SQC1.LT.1D-8) GOTO 340
9365 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9366 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9367 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9368 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9369 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9370 IF(SQC1.LT.1D-8) GOTO 340
9372 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9373 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9374 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9377 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9378 & SQRT(1D0-CTHE(2)**2)*CPHI
9380 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9381 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9382 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9383 & PMQ(3-JT)**2/SHP))
9384 ZMIN=2D0*PMQ(3-JT)/SHPR
9385 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9386 ZMAX=MIN(1D0-XH,ZMAX)
9387 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
9390 ELSEIF(ISUB.EQ.74) THEN
9391 C...Z0 + h0 -> Z0 + h0
9393 ELSEIF(ISUB.EQ.75) THEN
9394 C...W+ + W- -> gamma + gamma
9396 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
9397 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
9403 RVCKM=VINT(180+I)*PYR(0)
9406 IPM=(5-ISIGN(1,I))/2
9408 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
9409 MINT(20+JT)=ISIGN(IB,I)
9410 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9411 IF(RVCKM.LE.0D0) GOTO 390
9414 IB=2*((IA+1)/2)-1+MOD(IA,2)
9415 MINT(20+JT)=ISIGN(IB,I)
9417 390 PMQ(JT)=PYMASS(MINT(20+JT))
9419 JT=INT(1.5D0+PYR(0))
9420 ZMIN=2D0*PMQ(JT)/SHPR
9421 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9422 & (SHPR*(SHPR-PMQ(3-JT)))
9423 ZMAX=MIN(1D0-XH,ZMAX)
9424 IF(ZMIN.GE.ZMAX) GOTO 370
9425 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9426 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9427 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
9428 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9429 IF(SQC1.LT.1D-8) GOTO 370
9431 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9432 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9433 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9434 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9435 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9436 IF(SQC1.LT.1D-8) GOTO 370
9438 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9439 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9440 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9443 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9444 & SQRT(1D0-CTHE(2)**2)*CPHI
9446 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9447 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9448 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9449 & PMQ(3-JT)**2/SHP))
9450 ZMIN=2D0*PMQ(3-JT)/SHPR
9451 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9452 ZMAX=MIN(1D0-XH,ZMAX)
9453 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
9456 ELSEIF(ISUB.EQ.78) THEN
9457 C...W+/- + h0 -> W+/- + h0
9459 ELSEIF(ISUB.EQ.79) THEN
9460 C...h0 + h0 -> h0 + h0
9462 ELSEIF(ISUB.EQ.80) THEN
9463 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
9464 IF(MINT(15).EQ.22) JS=2
9467 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
9469 MINT(20+JS)=ISIGN(IB,I)
9473 ELSEIF(ISUB.LE.90) THEN
9475 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
9476 MINT(21)=ISIGN(MINT(55),MINT(15))
9480 ELSEIF(ISUB.EQ.82) THEN
9481 C...g + g -> Q + Qbar; th arbitrary
9482 KCS=(-1)**INT(1.5D0+PYR(0))
9483 MINT(21)=ISIGN(MINT(55),KCS)
9487 ELSEIF(ISUB.EQ.83) THEN
9488 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
9490 IF(MINT(2).EQ.2) KFOLD=MINT(15)
9492 IF(KFAOLD.GT.10) THEN
9493 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
9495 RCKM=VINT(180+KFOLD)*PYR(0)
9496 IPM=(5-ISIGN(1,KFOLD))/2
9497 KFANEW=-MOD(KFAOLD+1,2)
9499 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
9500 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
9501 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
9502 & VCKM(KFAOLD/2,(KFANEW+1)/2)
9503 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
9504 & VCKM(KFANEW/2,(KFAOLD+1)/2)
9506 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
9508 IF(MINT(2).EQ.1) THEN
9509 MINT(21)=ISIGN(MINT(55),MINT(15))
9510 MINT(22)=ISIGN(KFANEW,MINT(16))
9512 MINT(21)=ISIGN(KFANEW,MINT(15))
9513 MINT(22)=ISIGN(MINT(55),MINT(16))
9518 ELSEIF(ISUB.EQ.84) THEN
9519 C...g + gamma -> Q + Qbar; th arbitary
9520 KCS=(-1)**INT(1.5D0+PYR(0))
9521 MINT(21)=ISIGN(MINT(55),KCS)
9524 IF(MINT(16).EQ.21) KCC=28
9526 ELSEIF(ISUB.EQ.85) THEN
9527 C...gamma + gamma -> F + Fbar; th arbitary
9528 KCS=(-1)**INT(1.5D0+PYR(0))
9529 MINT(21)=ISIGN(MINT(56),KCS)
9533 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
9534 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
9535 MINT(21)=KFPR(ISUB,1)
9536 MINT(22)=KFPR(ISUB,2)
9538 KCS=(-1)**INT(1.5D0+PYR(0))
9541 ELSEIF(ISUB.LE.100) THEN
9543 C...Low-pT ( = energyless g + g -> g + g)
9545 KCS=(-1)**INT(1.5D0+PYR(0))
9547 ELSEIF(ISUB.EQ.96) THEN
9548 C...Multiple interactions (should be reassigned to QCD process)
9551 ELSEIF(ISUB.LE.110) THEN
9552 IF(ISUB.EQ.101) THEN
9553 C...g + g -> gamma*/Z0
9557 ELSEIF(ISUB.EQ.102) THEN
9558 C...g + g -> h0 (or H0, or A0)
9562 ELSEIF(ISUB.EQ.103) THEN
9563 C...gamma + gamma -> h0 (or H0, or A0)
9567 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
9568 C...g + g -> chi_0c or chi_2c.
9572 ELSEIF(ISUB.EQ.106) THEN
9573 C...g + g -> J/Psi + gamma
9574 MINT(21)=KFPR(ISUB,1)
9575 MINT(22)=KFPR(ISUB,2)
9578 ELSEIF(ISUB.EQ.107) THEN
9579 C...g + gamma -> J/Psi + g
9580 MINT(21)=KFPR(ISUB,1)
9581 MINT(22)=KFPR(ISUB,2)
9583 IF(MINT(16).EQ.22) KCC=33
9585 ELSEIF(ISUB.EQ.108) THEN
9586 C...gamma + gamma -> J/Psi + gamma
9587 MINT(21)=KFPR(ISUB,1)
9588 MINT(22)=KFPR(ISUB,2)
9590 ELSEIF(ISUB.EQ.110) THEN
9591 C...f + fbar -> gamma + h0; th arbitrary
9592 IF(PYR(0).GT.0.5D0) JS=2
9597 ELSEIF(ISUB.LE.120) THEN
9598 IF(ISUB.EQ.111) THEN
9599 C...f + fbar -> g + h0; th arbitrary
9600 IF(PYR(0).GT.0.5D0) JS=2
9605 ELSEIF(ISUB.EQ.112) THEN
9606 C...f + g -> f + h0; th = (p(f) - p(f))**2
9607 IF(MINT(15).EQ.21) JS=2
9610 KCS=ISIGN(1,MINT(14+JS))
9612 ELSEIF(ISUB.EQ.113) THEN
9613 C...g + g -> g + h0; th arbitrary
9614 IF(PYR(0).GT.0.5D0) JS=2
9617 KCS=(-1)**INT(1.5D0+PYR(0))
9619 ELSEIF(ISUB.EQ.114) THEN
9620 C...g + g -> gamma + gamma; th arbitrary
9621 IF(PYR(0).GT.0.5D0) JS=2
9626 ELSEIF(ISUB.EQ.115) THEN
9627 C...g + g -> g + gamma; th arbitrary
9628 IF(PYR(0).GT.0.5D0) JS=2
9631 KCS=(-1)**INT(1.5D0+PYR(0))
9633 ELSEIF(ISUB.EQ.116) THEN
9634 C...g + g -> gamma + Z0
9636 ELSEIF(ISUB.EQ.117) THEN
9637 C...g + g -> Z0 + Z0
9639 ELSEIF(ISUB.EQ.118) THEN
9640 C...g + g -> W+ + W-
9643 ELSEIF(ISUB.LE.140) THEN
9644 IF(ISUB.EQ.121) THEN
9645 C...g + g -> Q + Qbar + h0
9646 KCS=(-1)**INT(1.5D0+PYR(0))
9647 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
9649 KCC=11+INT(0.5D0+PYR(0))
9652 ELSEIF(ISUB.EQ.122) THEN
9653 C...q + qbar -> Q + Qbar + h0
9654 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
9659 ELSEIF(ISUB.EQ.123) THEN
9660 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
9665 ELSEIF(ISUB.EQ.124) THEN
9666 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
9672 RVCKM=VINT(180+I)*PYR(0)
9675 IPM=(5-ISIGN(1,I))/2
9677 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
9678 MINT(20+JT)=ISIGN(IB,I)
9679 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9680 IF(RVCKM.LE.0D0) GOTO 430
9683 IB=2*((IA+1)/2)-1+MOD(IA,2)
9684 MINT(20+JT)=ISIGN(IB,I)
9690 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
9691 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
9692 IF(MINT(15).EQ.22) JS=2
9695 KCS=ISIGN(1,MINT(14+JS))
9697 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
9698 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
9699 IF(MINT(15).EQ.22) JS=2
9701 KCS=ISIGN(1,MINT(14+JS))
9703 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
9704 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
9705 KCS=(-1)**INT(1.5D0+PYR(0))
9706 MINT(21)=ISIGN(KFLF,KCS)
9709 IF(MINT(16).EQ.21) KCC=28
9711 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
9712 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
9713 KCS=(-1)**INT(1.5D0+PYR(0))
9714 MINT(21)=ISIGN(KFLF,KCS)
9720 ELSEIF(ISUB.LE.160) THEN
9721 IF(ISUB.EQ.141) THEN
9722 C...f + fbar -> gamma*/Z0/Z'0
9725 ELSEIF(ISUB.EQ.142) THEN
9726 C...f + fbar' -> W'+/-
9727 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9728 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9729 KFRES=ISIGN(34,KCH1+KCH2)
9731 ELSEIF(ISUB.EQ.143) THEN
9732 C...f + fbar' -> H+/-
9733 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9734 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9735 KFRES=ISIGN(37,KCH1+KCH2)
9737 ELSEIF(ISUB.EQ.144) THEN
9739 KFRES=ISIGN(41,MINT(15)+MINT(16))
9741 ELSEIF(ISUB.EQ.145) THEN
9742 C...q + l -> LQ (leptoquark)
9743 IF(IABS(MINT(16)).LE.8) JS=2
9744 KFRES=ISIGN(42,MINT(14+JS))
9746 KCS=ISIGN(1,MINT(14+JS))
9748 ELSEIF(ISUB.EQ.146) THEN
9749 C...e + gamma -> e* (excited lepton)
9750 IF(MINT(15).EQ.22) JS=2
9751 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9754 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
9755 C...q + g -> q* (excited quark)
9756 IF(MINT(15).EQ.21) JS=2
9757 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9759 KCS=ISIGN(1,MINT(14+JS))
9761 ELSEIF(ISUB.EQ.149) THEN
9765 KCS=(-1)**INT(1.5D0+PYR(0))
9768 ELSEIF(ISUB.LE.200) THEN
9769 IF(ISUB.EQ.161) THEN
9770 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
9771 IF(MINT(15).EQ.21) JS=2
9774 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
9775 IB=IA+MOD(IA,2)-MOD(IA+1,2)
9776 MINT(20+JS)=ISIGN(IB,I)
9778 KCS=ISIGN(1,MINT(14+JS))
9780 ELSEIF(ISUB.EQ.162) THEN
9781 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
9782 IF(MINT(15).EQ.21) JS=2
9783 MINT(20+JS)=ISIGN(42,MINT(14+JS))
9784 KFLQL=KFDP(MDCY(42,2),2)
9785 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
9787 KCS=ISIGN(1,MINT(14+JS))
9789 ELSEIF(ISUB.EQ.163) THEN
9790 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
9791 KCS=(-1)**INT(1.5D0+PYR(0))
9792 MINT(21)=ISIGN(42,KCS)
9796 ELSEIF(ISUB.EQ.164) THEN
9797 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
9798 MINT(21)=ISIGN(42,MINT(15))
9802 ELSEIF(ISUB.EQ.165) THEN
9803 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
9804 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9807 ELSEIF(ISUB.EQ.166) THEN
9808 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9809 IF(MOD(MINT(15),2).EQ.0) THEN
9810 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9811 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9813 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9814 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9817 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
9818 C...q + q' -> q" + q* (excited quark)
9820 KFQEXC=MOD(KFQSTR,KEXCIT)
9822 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9823 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
9824 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9828 ELSEIF(ISUB.EQ.169) THEN
9829 C...q + qbar -> e + e* (excited lepton)
9831 KFQEXC=MOD(KFQSTR,KEXCIT)
9833 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9834 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9837 ELSEIF(ISUB.EQ.191) THEN
9838 C...f + fbar -> rho_tc0.
9841 ELSEIF(ISUB.EQ.192) THEN
9842 C...f + fbar' -> rho_tc+/-
9843 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9844 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9845 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
9847 ELSEIF(ISUB.EQ.193) THEN
9848 C...f + fbar -> omega_tc0.
9851 ELSEIF(ISUB.EQ.194) THEN
9852 C...f + fbar -> f' + fbar' via mixture of s-channel
9853 C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
9854 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9857 ELSEIF(ISUB.EQ.195) THEN
9858 C...f + fbar' -> f'' + fbar''' via s-channel
9859 C...rho_tc+ th=(p(f)-p(f'))**2
9860 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9861 IF(MOD(MINT(15),2).EQ.0) THEN
9862 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9863 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9865 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9866 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9871 ELSEIF(ISUB.LE.215) THEN
9872 IF(ISUB.EQ.201) THEN
9873 C...f + fbar -> ~e_L + ~e_Lbar
9874 MINT(21)=ISIGN(KSUSY1+11,KCS)
9877 ELSEIF(ISUB.EQ.202) THEN
9878 C...f + fbar -> ~e_R + ~e_Rbar
9879 MINT(21)=ISIGN(KSUSY2+11,KCS)
9882 ELSEIF(ISUB.EQ.203) THEN
9883 C...f + fbar -> ~e_L + ~e_Rbar
9884 IF(MINT(15).LT.0) JS=2
9885 IF(MINT(2).EQ.1) THEN
9886 MINT(20+JS)=KFPR(ISUB,1)
9887 MINT(23-JS)=-KFPR(ISUB,2)
9889 MINT(20+JS)=-KFPR(ISUB,1)
9890 MINT(23-JS)=KFPR(ISUB,2)
9893 ELSEIF(ISUB.EQ.204) THEN
9894 C...f + fbar -> ~mu_L + ~mu_Lbar
9895 MINT(21)=ISIGN(KSUSY1+13,KCS)
9898 ELSEIF(ISUB.EQ.205) THEN
9899 C...f + fbar -> ~mu_R + ~mu_Rbar
9900 MINT(21)=ISIGN(KSUSY2+13,KCS)
9903 ELSEIF(ISUB.EQ.206) THEN
9904 C...f + fbar -> ~mu_L + ~mu_Rbar
9905 IF(MINT(15).LT.0) JS=2
9906 IF(MINT(2).EQ.1) THEN
9907 MINT(20+JS)=KFPR(ISUB,1)
9908 MINT(23-JS)=-KFPR(ISUB,2)
9910 MINT(20+JS)=-KFPR(ISUB,1)
9911 MINT(23-JS)=KFPR(ISUB,2)
9914 ELSEIF(ISUB.EQ.207) THEN
9915 C...f + fbar -> ~tau_1 + ~tau_1bar
9916 MINT(21)=ISIGN(KSUSY1+15,KCS)
9919 ELSEIF(ISUB.EQ.208) THEN
9920 C...f + fbar -> ~tau_2 + ~tau_2bar
9921 MINT(21)=ISIGN(KSUSY2+15,KCS)
9924 ELSEIF(ISUB.EQ.209) THEN
9925 C...f + fbar -> ~tau_1 + ~tau_2bar
9926 IF(MINT(15).LT.0) JS=2
9927 IF(MINT(2).EQ.1) THEN
9928 MINT(20+JS)=KFPR(ISUB,1)
9929 MINT(23-JS)=-KFPR(ISUB,2)
9931 MINT(20+JS)=-KFPR(ISUB,1)
9932 MINT(23-JS)=KFPR(ISUB,2)
9935 ELSEIF(ISUB.EQ.210) THEN
9936 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
9937 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9938 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9939 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
9940 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
9942 ELSEIF(ISUB.EQ.211) THEN
9943 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
9944 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9945 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9946 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
9947 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9949 ELSEIF(ISUB.EQ.212) THEN
9950 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
9951 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9952 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9953 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
9954 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9956 ELSEIF(ISUB.EQ.213) THEN
9957 C...f + fbar -> ~nul + ~nulbar
9958 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9961 ELSEIF(ISUB.EQ.214) THEN
9962 C...f + fbar -> ~nutau + ~nutaubar
9963 MINT(21)=ISIGN(KSUSY1+16,KCS)
9967 ELSEIF(ISUB.LE.225) THEN
9968 IF(ISUB.EQ.216) THEN
9969 C...f + fbar -> ~chi01 + ~chi01
9973 ELSEIF(ISUB.EQ.217) THEN
9974 C...f + fbar -> ~chi02 + ~chi02
9978 ELSEIF(ISUB.EQ.218 ) THEN
9979 C...f + fbar -> ~chi03 + ~chi03
9983 ELSEIF(ISUB.EQ.219 ) THEN
9984 C...f + fbar -> ~chi04 + ~chi04
9988 ELSEIF(ISUB.EQ.220 ) THEN
9989 C...f + fbar -> ~chi01 + ~chi02
9990 IF(MINT(15).LT.0) JS=2
9991 C IF(PYR(0).GT.0.5D0) JS=2
9992 MINT(20+JS)=KSUSY1+22
9993 MINT(23-JS)=KSUSY1+23
9995 ELSEIF(ISUB.EQ.221 ) THEN
9996 C...f + fbar -> ~chi01 + ~chi03
9997 IF(MINT(15).LT.0) JS=2
9998 C IF(PYR(0).GT.0.5D0) JS=2
9999 MINT(20+JS)=KSUSY1+22
10000 MINT(23-JS)=KSUSY1+25
10002 ELSEIF(ISUB.EQ.222) THEN
10003 C...f + fbar -> ~chi01 + ~chi04
10004 IF(MINT(15).LT.0) JS=2
10005 C IF(PYR(0).GT.0.5D0) JS=2
10006 MINT(20+JS)=KSUSY1+22
10007 MINT(23-JS)=KSUSY1+35
10009 ELSEIF(ISUB.EQ.223) THEN
10010 C...f + fbar -> ~chi02 + ~chi03
10011 IF(MINT(15).LT.0) JS=2
10012 C IF(PYR(0).GT.0.5D0) JS=2
10013 MINT(20+JS)=KSUSY1+23
10014 MINT(23-JS)=KSUSY1+25
10016 ELSEIF(ISUB.EQ.224) THEN
10017 C...f + fbar -> ~chi02 + ~chi04
10018 IF(MINT(15).LT.0) JS=2
10019 C IF(PYR(0).GT.0.5D0) JS=2
10020 MINT(20+JS)=KSUSY1+23
10021 MINT(23-JS)=KSUSY1+35
10023 ELSEIF(ISUB.EQ.225) THEN
10024 C...f + fbar -> ~chi03 + ~chi04
10025 IF(MINT(15).LT.0) JS=2
10026 C IF(PYR(0).GT.0.5D0) JS=2
10027 MINT(20+JS)=KSUSY1+25
10028 MINT(23-JS)=KSUSY1+35
10031 ELSEIF(ISUB.LE.236) THEN
10032 IF(ISUB.EQ.226) THEN
10033 C...f + fbar -> ~chi+-1 + ~chi-+1
10034 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
10035 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10036 MINT(21)=ISIGN(KSUSY1+24,KCH1)
10039 ELSEIF(ISUB.EQ.227) THEN
10040 C...f + fbar -> ~chi+-2 + ~chi-+2
10041 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10042 MINT(21)=ISIGN(KSUSY1+37,KCH1)
10045 ELSEIF(ISUB.EQ.228) THEN
10046 C...f + fbar -> ~chi+-1 + ~chi-+2
10047 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
10048 C...js=1 if pyr<.5, js=2 if pyr>.5
10049 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
10050 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
10051 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
10052 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
10053 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10055 IF(MINT(2).EQ.1) THEN
10056 MINT(21)= ISIGN(KSUSY1+24,KCH1)
10057 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
10058 c IF(KCH2.EQ.0) JS=2
10060 MINT(21)= ISIGN(KSUSY1+37,KCH1)
10061 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
10063 c IF(KCH2.EQ.1) JS=2
10066 ELSEIF(ISUB.EQ.229) THEN
10067 C...q + qbar' -> ~chi01 + ~chi+-1
10068 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
10069 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10070 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10072 IF(MOD(MINT(15),2).EQ.0) JS=2
10073 MINT(20+JS)=KSUSY1+22
10074 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10076 ELSEIF(ISUB.EQ.230) THEN
10077 C...q + qbar' -> ~chi02 + ~chi+-1
10078 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10079 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10080 IF(MOD(MINT(15),2).EQ.0) JS=2
10081 MINT(20+JS)=KSUSY1+23
10082 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10084 ELSEIF(ISUB.EQ.231) THEN
10085 C...q + qbar' -> ~chi03 + ~chi+-1
10086 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10087 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10088 IF(MOD(MINT(15),2).EQ.0) JS=2
10089 MINT(20+JS)=KSUSY1+25
10090 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10092 ELSEIF(ISUB.EQ.232) THEN
10093 C...q + qbar' -> ~chi04 + ~chi+-1
10094 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10095 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10096 IF(MOD(MINT(15),2).EQ.0) JS=2
10097 MINT(20+JS)=KSUSY1+35
10098 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10100 ELSEIF(ISUB.EQ.233) THEN
10101 C...q + qbar' -> ~chi01 + ~chi+-2
10102 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10103 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10104 IF(MOD(MINT(15),2).EQ.0) JS=2
10105 MINT(20+JS)=KSUSY1+22
10106 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10108 ELSEIF(ISUB.EQ.234) THEN
10109 C...q + qbar' -> ~chi02 + ~chi+-2
10110 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10111 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10112 IF(MOD(MINT(15),2).EQ.0) JS=2
10113 MINT(20+JS)=KSUSY1+23
10114 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10116 ELSEIF(ISUB.EQ.235) THEN
10117 C...q + qbar' -> ~chi03 + ~chi+-2
10118 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10119 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10120 IF(MOD(MINT(15),2).EQ.0) JS=2
10121 MINT(20+JS)=KSUSY1+25
10122 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10124 ELSEIF(ISUB.EQ.236) THEN
10125 C...q + qbar' -> ~chi04 + ~chi+-2
10126 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10127 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10128 IF(MOD(MINT(15),2).EQ.0) JS=2
10129 MINT(20+JS)=KSUSY1+35
10130 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10133 ELSEIF(ISUB.LE.245) THEN
10134 IF(ISUB.EQ.237) THEN
10135 C...q + qbar -> ~chi01 + ~g
10137 IF(PYR(0).GT.0.5D0) JS=2
10138 MINT(20+JS)=KSUSY1+21
10139 MINT(23-JS)=KSUSY1+22
10142 ELSEIF(ISUB.EQ.238) THEN
10143 C...q + qbar -> ~chi02 + ~g
10145 IF(PYR(0).GT.0.5D0) JS=2
10146 MINT(20+JS)=KSUSY1+21
10147 MINT(23-JS)=KSUSY1+23
10150 ELSEIF(ISUB.EQ.239) THEN
10151 C...q + qbar -> ~chi03 + ~g
10153 IF(PYR(0).GT.0.5D0) JS=2
10154 MINT(20+JS)=KSUSY1+21
10155 MINT(23-JS)=KSUSY1+25
10158 ELSEIF(ISUB.EQ.240) THEN
10159 C...q + qbar -> ~chi04 + ~g
10161 IF(PYR(0).GT.0.5D0) JS=2
10162 MINT(20+JS)=KSUSY1+21
10163 MINT(23-JS)=KSUSY1+35
10166 ELSEIF(ISUB.EQ.241) THEN
10167 C...q + qbar' -> ~chi+-1 + ~g
10168 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10169 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10170 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10171 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10172 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10173 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10174 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10176 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10177 MINT(20+JS)=KSUSY1+21
10178 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10181 ELSEIF(ISUB.EQ.242) THEN
10182 C...q + qbar' -> ~chi+-2 + ~g
10183 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10184 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10185 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10186 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10187 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10188 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10189 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10191 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10192 MINT(20+JS)=KSUSY1+21
10193 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10196 ELSEIF(ISUB.EQ.243) THEN
10197 C...q + qbar -> ~g + ~g ; th arbitrary
10202 ELSEIF(ISUB.EQ.244) THEN
10203 C...g + g -> ~g + ~g ; th arbitrary
10205 KCS=(-1)**INT(1.5D0+PYR(0))
10210 ELSEIF(ISUB.LE.260) THEN
10211 IF(ISUB.EQ.246) THEN
10212 C...qj + g -> ~qj_L + ~chi01
10213 IF(MINT(15).EQ.21) JS=2
10216 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10217 MINT(23-JS)=KSUSY1+22
10219 KCS=ISIGN(1,MINT(14+JS))
10221 ELSEIF(ISUB.EQ.247) THEN
10222 C...qj + g -> ~qj_R + ~chi01
10223 IF(MINT(15).EQ.21) JS=2
10226 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10227 MINT(23-JS)=KSUSY1+22
10229 KCS=ISIGN(1,MINT(14+JS))
10231 ELSEIF(ISUB.EQ.248) THEN
10232 C...qj + g -> ~qj_L + ~chi02
10233 IF(MINT(15).EQ.21) JS=2
10236 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10237 MINT(23-JS)=KSUSY1+23
10239 KCS=ISIGN(1,MINT(14+JS))
10241 ELSEIF(ISUB.EQ.249) THEN
10242 C...qj + g -> ~qj_R + ~chi02
10243 IF(MINT(15).EQ.21) JS=2
10246 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10247 MINT(23-JS)=KSUSY1+23
10249 KCS=ISIGN(1,MINT(14+JS))
10251 ELSEIF(ISUB.EQ.250) THEN
10252 C...qj + g -> ~qj_L + ~chi03
10253 IF(MINT(15).EQ.21) JS=2
10256 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10257 MINT(23-JS)=KSUSY1+25
10259 KCS=ISIGN(1,MINT(14+JS))
10261 ELSEIF(ISUB.EQ.251) THEN
10262 C...qj + g -> ~qj_R + ~chi03
10263 IF(MINT(15).EQ.21) JS=2
10266 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10267 MINT(23-JS)=KSUSY1+25
10269 KCS=ISIGN(1,MINT(14+JS))
10271 ELSEIF(ISUB.EQ.252) THEN
10272 C...qj + g -> ~qj_L + ~chi04
10273 IF(MINT(15).EQ.21) JS=2
10276 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10277 MINT(23-JS)=KSUSY1+35
10279 KCS=ISIGN(1,MINT(14+JS))
10281 ELSEIF(ISUB.EQ.253) THEN
10282 C...qj + g -> ~qj_R + ~chi04
10283 IF(MINT(15).EQ.21) JS=2
10286 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10287 MINT(23-JS)=KSUSY1+35
10289 KCS=ISIGN(1,MINT(14+JS))
10291 ELSEIF(ISUB.EQ.254) THEN
10292 C...qj + g -> ~qk_L + ~chi+-1
10293 IF(MINT(15).EQ.21) JS=2
10296 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10297 IB=-IA+INT((IA+1)/2)*4-1
10298 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10300 KCS=ISIGN(1,MINT(14+JS))
10302 ELSEIF(ISUB.EQ.255) THEN
10303 C...qj + g -> ~qk_L + ~chi+-1
10304 IF(MINT(15).EQ.21) JS=2
10307 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10308 IB=-IA+INT((IA+1)/2)*4-1
10309 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10311 KCS=ISIGN(1,MINT(14+JS))
10313 ELSEIF(ISUB.EQ.256) THEN
10314 C...qj + g -> ~qk_L + ~chi+-2
10315 IF(MINT(15).EQ.21) JS=2
10318 IB=-IA+INT((IA+1)/2)*4-1
10319 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10320 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10322 KCS=ISIGN(1,MINT(14+JS))
10324 ELSEIF(ISUB.EQ.257) THEN
10325 C...qj + g -> ~qk_R + ~chi+-2
10326 IF(MINT(15).EQ.21) JS=2
10329 IB=-IA+INT((IA+1)/2)*4-1
10330 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10331 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10333 KCS=ISIGN(1,MINT(14+JS))
10335 ELSEIF(ISUB.EQ.258) THEN
10336 C...qj + g -> ~qj_L + ~g
10337 IF(MINT(15).EQ.21) JS=2
10340 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10341 MINT(23-JS)=KSUSY1+21
10343 IF(JS.EQ.2) KCC=KCC+2
10346 ELSEIF(ISUB.EQ.259) THEN
10347 C...qj + g -> ~qj_R + ~g
10348 IF(MINT(15).EQ.21) JS=2
10351 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10352 MINT(23-JS)=KSUSY1+21
10354 IF(JS.EQ.2) KCC=KCC+2
10358 ELSEIF(ISUB.LE.270) THEN
10359 IF(ISUB.EQ.261) THEN
10360 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
10362 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10363 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10365 C...Correct color combination
10366 IF(MINT(43).EQ.4) KCC=4
10368 ELSEIF(ISUB.EQ.262) THEN
10369 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
10371 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10372 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10374 C...Correct color combination
10375 IF(MINT(43).EQ.4) KCC=4
10377 ELSEIF(ISUB.EQ.263) THEN
10378 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
10379 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
10380 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
10381 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10382 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
10385 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
10386 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
10388 C...Correct color combination
10389 IF(MINT(43).EQ.4) KCC=4
10391 ELSEIF(ISUB.EQ.264) THEN
10392 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
10393 KCS=(-1)**INT(1.5D0+PYR(0))
10394 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10398 ELSEIF(ISUB.EQ.265) THEN
10399 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
10400 KCS=(-1)**INT(1.5D0+PYR(0))
10401 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10406 ELSEIF(ISUB.LE.296) THEN
10407 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
10408 C...qi + qj -> ~qi_L + ~qj_L
10410 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10411 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10412 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10414 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
10415 C...qi + qj -> ~qi_R + ~qj_R
10417 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10418 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10419 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10421 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
10422 C...qi + qj -> ~qi_L + ~qj_R
10423 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10424 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10426 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10428 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
10429 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
10430 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10431 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10433 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10435 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
10436 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10437 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10438 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10440 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10442 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
10443 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10444 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10445 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10447 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10449 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
10450 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
10452 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10453 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10455 IF(MINT(43).EQ.4) KCC=4
10457 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
10458 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
10460 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10461 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10463 IF(MINT(43).EQ.4) KCC=4
10465 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
10466 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
10468 KCS=(-1)**INT(1.5D0+PYR(0))
10469 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10473 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
10474 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
10475 KCS=(-1)**INT(1.5D0+PYR(0))
10476 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10480 ELSEIF(ISUB.EQ.294) THEN
10481 C...qj + g -> ~qj_L + ~g
10482 IF(MINT(15).EQ.21) JS=2
10485 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10486 MINT(23-JS)=KSUSY1+21
10488 IF(JS.EQ.2) KCC=KCC+2
10491 ELSEIF(ISUB.EQ.295) THEN
10492 C...qj + g -> ~qj_R + ~g
10493 IF(MINT(15).EQ.21) JS=2
10496 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10497 MINT(23-JS)=KSUSY1+21
10499 IF(JS.EQ.2) KCC=KCC+2
10503 ELSEIF(ISUB.LE.340) THEN
10505 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
10506 C...q + qbar' -> H+ + H0
10507 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10508 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10509 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10510 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
10511 MINT(23-JS)=KFPR(ISUB,2)
10512 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
10513 C...f + fbar -> A0 + H0; th arbitrary
10514 IF(PYR(0).GT.0.5D0) JS=2
10515 MINT(20+JS)=KFPR(ISUB,1)
10516 MINT(23-JS)=KFPR(ISUB,2)
10517 ELSEIF(ISUB.EQ.301) THEN
10518 C...f + fbar -> H+ H-
10519 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10524 ELSEIF(ISUB.LE.360) THEN
10526 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
10527 C...l + l -> H_L++/--, H_R++/--
10528 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10529 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10530 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10532 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
10533 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
10534 IF(MINT(15).EQ.22) JS=2
10535 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
10536 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
10539 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
10540 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
10541 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
10544 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
10545 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
10546 C...as inner process).
10551 RVCKM=VINT(180+I)*PYR(0)
10554 IPM=(5-ISIGN(1,I))/2
10556 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
10557 MINT(20+JT)=ISIGN(IB,I)
10558 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10559 IF(RVCKM.LE.0D0) GOTO 450
10562 IB=2*((IA+1)/2)-1+MOD(IA,2)
10563 MINT(20+JT)=ISIGN(IB,I)
10567 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
10568 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
10570 ELSEIF(ISUB.EQ.353) THEN
10571 C...f + fbar -> Z_R0
10574 ELSEIF(ISUB.EQ.354) THEN
10575 C...f + fbar' -> W+/-
10576 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10577 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10578 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10582 ELSEIF(ISUB.LE.380) THEN
10584 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
10585 C...f + fbar -> charged+ charged- technicolor
10586 KSW=(-1)**INT(1.5D0+PYR(0))
10587 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
10588 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
10590 ELSEIF(ISUB.LE.367) THEN
10591 C...f + fbar -> neutral neutral technicolor
10592 MINT(21)=KFPR(ISUB,1)
10593 MINT(22)=KFPR(ISUB,2)
10595 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375) THEN
10596 C...f + fbar' -> neutral charged technicolor
10599 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10600 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10601 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10602 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10603 MINT(20+JS)=KFPR(ISUB,IN)
10605 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
10606 C...f + fbar' -> charged neutral technicolor
10609 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10610 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10611 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10612 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10613 MINT(23-JS)=KFPR(ISUB,IN)
10616 ELSEIF(ISUB.LE.400) THEN
10617 IF(ISUB.EQ.381) THEN
10618 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
10620 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10622 ELSEIF(ISUB.EQ.382) THEN
10623 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
10624 MINT(21)=ISIGN(KFLF,MINT(15))
10628 ELSEIF(ISUB.EQ.383) THEN
10629 C...f + fbar -> g + g; th arbitrary, TC extensions
10634 ELSEIF(ISUB.EQ.384) THEN
10635 C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
10636 IF(MINT(15).EQ.21) JS=2
10638 IF(MINT(15).EQ.21) KCC=KCC+2
10639 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10640 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10642 ELSEIF(ISUB.EQ.385) THEN
10643 C...g + g -> f + fbar; th arbitrary, TC extensions
10644 KCS=(-1)**INT(1.5D0+PYR(0))
10645 MINT(21)=ISIGN(KFLF,KCS)
10649 ELSEIF(ISUB.EQ.386) THEN
10650 C...g + g -> g + g; th arbitrary, TC extensions
10652 KCS=(-1)**INT(1.5D0+PYR(0))
10654 ELSEIF(ISUB.EQ.387) THEN
10655 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
10656 MINT(21)=ISIGN(MINT(55),MINT(15))
10660 ELSEIF(ISUB.EQ.388) THEN
10661 C...g + g -> Q + Qbar; th arbitrary, TC extensions
10662 KCS=(-1)**INT(1.5D0+PYR(0))
10663 MINT(21)=ISIGN(MINT(55),KCS)
10667 ELSEIF(ISUB.EQ.391) THEN
10668 C...f + fbar -> G*.
10671 ELSEIF(ISUB.EQ.392) THEN
10676 ELSEIF(ISUB.EQ.393) THEN
10677 C...q + qbar -> g + G*; th arbitrary.
10678 IF(PYR(0).GT.0.5D0) JS=2
10679 MINT(20+JS)=KFPR(ISUB,1)
10680 MINT(23-JS)=KFPR(ISUB,2)
10683 ELSEIF(ISUB.EQ.394) THEN
10684 C...q + g -> q + G*; th = (p(f) - p(f))**2
10685 IF(MINT(15).EQ.21) JS=2
10686 MINT(23-JS)=KFPR(ISUB,2)
10688 KCS=ISIGN(1,MINT(14+JS))
10690 ELSEIF(ISUB.EQ.395) THEN
10691 C...g + g -> G* + g; th arbitrary.
10692 IF(PYR(0).GT.0.5D0) JS=2
10693 MINT(23-JS)=KFPR(ISUB,2)
10698 IF(ISET(ISUB).EQ.11) THEN
10699 C...Store documentation for user-defined processes
10700 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
10701 KUPPO(1)=MINT(83)+5
10702 KUPPO(2)=MINT(83)+6
10706 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
10715 IF(IDUP(IUP).EQ.0) K(I,2)=90
10717 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
10725 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
10728 C...Store final state partons for user-defined processes
10733 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
10735 IF(IDUP(IUP).EQ.0) K(N,2)=90
10736 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
10739 K(N,3)=MINT(84)+MOTHUP(1,IUP)
10748 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
10750 C...Arrange colour flow for user-defined processes
10754 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
10755 IF(K(I1,1).EQ.1) K(I1,1)=3
10756 IF(K(I1,1).EQ.11) K(I1,1)=14
10757 C...Find a not yet considered colour/anticolour line.
10759 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
10762 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
10766 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
10767 C...Find all others belonging to same line.
10770 DO 520 IUP2=IUP1+1,NUP
10773 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
10774 IF(ISDE2.EQ.ISDE1) THEN
10775 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
10776 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
10778 ELSEIF(I4.NE.0) THEN
10779 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
10780 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
10782 ELSEIF(IUP2.LE.2) THEN
10783 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
10784 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
10787 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
10788 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
10798 ELSEIF(IDOC.EQ.7) THEN
10799 C...Resonance not decaying; store kinematics
10814 C...Special cases: colour flow in coloured resonances
10815 KCRES=PYCOMP(KFRES)
10816 IF(KCHG(KCRES,2).NE.0) THEN
10820 IF(KCS.EQ.-1) JC=3-J
10821 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
10822 & MINT(84)+ICOL(KCC,1,JC)
10823 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
10824 & MINT(84)+ICOL(KCC,2,JC)
10825 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
10826 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
10835 ELSEIF(IDOC.EQ.8) THEN
10836 C...2 -> 2 processes: store outgoing partons in their CM-frame
10839 KCA=PYCOMP(MINT(20+JT))
10841 IF(KCHG(KCA,2).NE.0) K(I,1)=3
10843 K(I,3)=MINT(83)+IDOC+JT-2
10845 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
10846 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10848 P(I,5)=PYMASS(K(I,2))
10850 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
10851 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
10853 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
10854 KFA1=IABS(MINT(21))
10855 KFA2=IABS(MINT(22))
10856 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
10864 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
10865 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
10866 P(IPU4,4)=SHR-P(IPU3,4)
10867 P(IPU4,3)=-P(IPU3,3)
10872 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
10873 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
10875 ELSEIF(IDOC.EQ.9) THEN
10876 C...2 -> 3 processes: store outgoing partons in their CM frame
10879 KCA=PYCOMP(MINT(20+JT))
10881 IF(KCHG(KCA,2).NE.0) K(I,1)=3
10883 K(I,3)=MINT(83)+IDOC+JT-3
10884 IF(IABS(K(I,2)).LE.22) THEN
10885 P(I,5)=PYMASS(K(I,2))
10887 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10889 PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
10890 P(I,1)=PT*COS(VINT(198+5*JT))
10891 P(I,2)=PT*SIN(VINT(198+5*JT))
10895 K(IPU5,3)=MINT(83)+IDOC
10897 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10898 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10899 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
10900 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
10901 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
10903 P(IPU5,3)=PMT3*SINH(VINT(211))
10904 P(IPU5,4)=PMT3*COSH(VINT(211))
10905 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
10906 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
10907 IF(SQL12.LE.0D0) THEN
10911 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
10912 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
10913 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
10914 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
10915 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
10921 ELSEIF(IDOC.EQ.11) THEN
10922 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
10923 PHI(1)=PARU(2)*PYR(0)
10928 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10930 K(I,3)=MINT(83)+IDOC+JT-2
10931 P(I,5)=PYMASS(K(I,2))
10932 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
10936 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10937 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10938 P(I,1)=PTABS*COS(PHI(JT))
10939 P(I,2)=PTABS*SIN(PHI(JT))
10940 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10941 P(I,4)=0.5D0*SHPR*Z(JT)
10945 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
10949 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
10950 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
10951 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
10958 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10959 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10960 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
10961 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
10970 ELSEIF(IDOC.EQ.12) THEN
10971 C...Z0 and W+/- scattering: store bosons and outgoing partons
10972 PHI(1)=PARU(2)*PYR(0)
10974 JTRAN=INT(1.5D0+PYR(0))
10978 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10980 K(I,3)=MINT(83)+IDOC+JT-2
10981 P(I,5)=PYMASS(K(I,2))
10982 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
10983 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10984 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10985 P(I,1)=PTABS*COS(PHI(JT))
10986 P(I,2)=PTABS*SIN(PHI(JT))
10987 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10988 P(I,4)=0.5D0*SHPR*Z(JT)
10991 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
10994 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
10999 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
11000 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
11001 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
11004 K(IPU,2)=KFPR(ISUB,JT)
11005 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
11006 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
11007 K(IPU,3)=MINT(83)+8+JT
11008 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
11009 P(IPU,5)=PYMASS(K(IPU,2))
11011 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
11013 MINT(22+JT)=K(IPU,2)
11015 C...Find rotation and boost for hard scattering subsystem
11018 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
11019 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
11020 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
11021 GAMCM=(P(I1,4)+P(I2,4))/SHR
11022 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
11023 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
11024 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
11025 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
11026 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
11027 PHICM=PYANGL(PX,PY)
11028 C...Store hard scattering subsystem. Rotate and boost it
11029 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
11031 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
11033 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
11034 PHIWZ=VINT(24)-PHICM
11035 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
11036 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
11037 P(IPU5,3)=PABS*CTHWZ
11038 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
11039 P(IPU6,1)=-P(IPU5,1)
11040 P(IPU6,2)=-P(IPU5,2)
11041 P(IPU6,3)=-P(IPU5,3)
11042 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
11043 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
11055 MINT(8)=MINT(83)+10
11058 IF(ISET(ISUB).EQ.11) THEN
11059 ELSEIF(IDOC.GE.8) THEN
11060 C...Store colour connection indices
11063 IF(KCS.EQ.-1) JC=3-J
11064 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
11065 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
11066 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
11067 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
11068 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
11069 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
11070 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
11071 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
11074 C...Copy outgoing partons to documentation lines
11076 IF(IDOC.EQ.9) IMAX=3
11078 I1=MINT(83)+IDOC-IMAX+I
11082 IF(IDOC.LE.9) K(I1,3)=0
11083 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
11089 ELSEIF(IDOC.EQ.9) THEN
11090 C...Store colour connection indices
11093 IF(KCS.EQ.-1) JC=3-J
11094 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
11095 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
11096 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
11097 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
11098 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
11099 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
11100 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
11101 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
11102 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
11103 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
11106 C...Copy outgoing partons to documentation lines
11108 I1=MINT(83)+IDOC-3+I
11119 C...Low-pT events: remove gluons used for string drawing purposes
11120 IF(ISUB.EQ.95) THEN
11121 K(IPU3,1)=K(IPU3,1)+10
11122 K(IPU4,1)=K(IPU4,1)+10
11127 DO 710 I=MINT(83)+5,MINT(83)+8
11137 C*********************************************************************
11140 C...Generates spacelike parton showers.
11142 SUBROUTINE PYSSPA(IPU1,IPU2)
11144 C...Double precision and integer declarations.
11145 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11146 IMPLICIT INTEGER(I-N)
11147 INTEGER PYK,PYCHGE,PYCOMP
11149 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11150 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11151 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
11152 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
11153 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11154 COMMON/PYINT1/MINT(400),VINT(400)
11155 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
11156 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
11157 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
11159 C...Local arrays and data.
11160 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
11161 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
11162 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
11163 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
11164 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
11167 C...Read out basic information; set global Q^2 scale.
11172 IF(ISET(ISUB).EQ.2) Q2MX=MIN(VINT(2),PARP(67)*VINT(56))
11175 C...Define which processes ME corrections have been implemented for.
11177 IF(MSTP(68).EQ.1) THEN
11178 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
11179 & ISUB.EQ.144) MECOR=1
11180 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
11183 C...Initialize QCD evolution and check phase space.
11187 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
11190 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11191 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11192 Q2INT=SQRT(Q0S*Q2EFF)
11193 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
11194 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
11195 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
11197 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
11200 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11201 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11202 Q2INT=SQRT(Q0S*Q2EFF)
11203 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
11204 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
11205 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
11212 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
11214 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
11215 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
11216 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
11217 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
11221 C...Initialize QED evolution and check phase space.
11225 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
11226 &SPME=PMAS(13,1)**2
11227 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
11228 &SPME=PMAS(15,1)**2
11229 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
11232 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
11234 TEMX=LOG(Q2MX/SPME)
11235 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
11237 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11242 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
11244 C...Loopback point in case of failure to reconstruct kinematics.
11248 IF(LOOP.GT.100) THEN
11254 C...Initial values: flavours, momenta, virtualities.
11257 KFBEAM(JT)=MINT(10+JT)
11258 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
11259 KFLS(JT)=MINT(14+JT)
11260 KFLS(JT+2)=KFLS(JT)
11262 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
11264 Q2S(JT)=FCQ2MX*Q2MX
11271 C...Calculate initial parton distribution weights.
11272 MINT(105)=MINT(102+JT)
11273 MINT(109)=MINT(106+JT)
11274 VINT(120)=VINT(2+JT)
11276 C.... Store side in MINT(124)
11279 IF(XS(JT).LT.1D0-XEE) THEN
11280 IF(MSTP(57).LE.1) THEN
11281 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11283 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11287 XFS(JT,KFL)=XFB(KFL)
11289 C...Special kinematics check for c/b quarks (that g -> c cbar or
11290 C...b bbar kinematically possible).
11291 KFLCB=IABS(KFLS(JT))
11292 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
11293 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
11300 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
11302 C...Find if interference with final state partons.
11304 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
11308 KCA=PYCOMP(IABS(KFLS(I)))
11309 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
11311 IF(KCFI(I).NE.0) THEN
11312 IF(I.EQ.1) IPFS=IPUS1
11313 IF(I.EQ.2) IPFS=IPUS2
11315 ICSI=MOD(K(IPFS,3+J),MSTU(5))
11316 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
11317 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
11319 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
11321 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
11326 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
11329 C...Pick up leg with highest virtuality.
11333 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
11334 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
11335 IF(MORE(JT).EQ.0) JT=3-JT
11340 XFB(KFL)=XFS(JT,KFL)
11345 C...Check if allowed to branch.
11347 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
11349 XEC=MAX(PARP(65)*DSHR/VINT(2),XB*(1D0/(1D0-PARP(66))-1D0))
11350 IF(XB.GE.1D0-2D0*XEC) MCEV=0
11353 IF(MINT(44+JT).EQ.3) THEN
11355 IF(XB.GE.1D0-2D0*XEE) MEEV=0
11356 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
11358 C***Currently kill QED shower for resolved photoproduction.
11359 IF(MINT(18+JT).EQ.1) MEEV=0
11360 C***Currently kill shower for W inside electron.
11361 IF(IABS(KFLB).EQ.24) THEN
11366 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
11368 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11373 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
11377 IF(MSTP(62).LE.1) THEN
11378 IF(ZS(JT).GT.0.99999D0) THEN
11381 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
11382 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
11383 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
11385 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11386 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11389 ALSDUM=PYALPS(FQ2C*Q2B)
11390 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
11392 B0=(33D0-2D0*MSTU(118))/6D0
11394 IF(MEEV.EQ.2) TEVEB=TEVCB
11398 C...Select side for interference with final state partons.
11399 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
11402 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
11404 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
11405 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
11406 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
11408 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
11412 C...Calculate preweighting factor for ME-corrected processes.
11413 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
11415 C...Calculate Altarelli-Parisi weights.
11421 C...q -> q (g or gamma emission), g -> q.
11422 IF(IABS(KFLB).LE.10) THEN
11423 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
11424 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
11426 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
11427 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
11429 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11430 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
11431 WTAPC(21)=WTGF*WTAPC(21)
11432 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11434 C...f -> f, gamma -> f.
11435 ELSEIF(IABS(KFLB).LE.20) THEN
11436 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
11437 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
11438 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
11439 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
11440 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11441 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11442 WTAPE(22)=WTGF*WTAPE(22)
11444 C...f -> g, g -> g.
11445 ELSEIF(KFLB.EQ.21) THEN
11446 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
11447 DO 180 KFL=1,MSTP(58)
11451 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
11452 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11453 DO 190 KFL=1,MSTP(58)
11454 WTAPC(KFL)=WTFG*WTAPC(KFL)
11455 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
11457 WTAPC(21)=WTGG*WTAPC(21)
11459 C...f -> gamma, W+, W-.
11460 ELSEIF(KFLB.EQ.22) THEN
11461 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
11464 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11465 WTAPE(11)=WTFG*WTAPE(11)
11466 WTAPE(-11)=WTFG*WTAPE(-11)
11468 ELSEIF(KFLB.EQ.24) THEN
11469 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11470 & (XEE*(XB+XEE)))/XB
11471 ELSEIF(KFLB.EQ.-24) THEN
11472 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11473 & (XEE*(XB+XEE)))/XB
11476 C...Calculate parton distribution weights and sum.
11479 IF(NTRY.GT.500) THEN
11485 XFBO=MAX(1D-10,XFB(KFLB))
11487 WTSF(KFL)=XFB(KFL)/XFBO
11488 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
11489 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
11491 WTSUMC=MAX(0.0001D0,WTSUMC)
11492 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
11494 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
11497 IF(NTRY2.GT.500) THEN
11502 IF(MSTP(64).LE.0) THEN
11503 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
11504 ELSEIF(MSTP(64).EQ.1) THEN
11505 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
11507 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
11511 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
11512 & (PARU(101)*FWTE*WTSUME*TEMX)))
11513 ELSEIF(MEEV.EQ.2) THEN
11514 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
11517 C...Translate t into Q2 scale; choose between QCD and QED evolution.
11518 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
11519 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
11520 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
11521 C...Ensure that Q2 is above threshold for charm/bottom.
11523 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11525 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
11526 Q2CB=1.1D0*PMAS(KFLCB,1)**2
11527 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11528 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
11531 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11533 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
11536 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11537 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11538 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
11539 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
11540 IF(Q2EB.GT.Q2MNE) MCE=2
11541 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
11542 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
11543 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
11544 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
11545 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
11546 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
11548 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
11549 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
11552 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
11553 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
11556 C...Evolution possibly ended. Update t values.
11560 ELSEIF(MCE.EQ.1) THEN
11563 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11564 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11568 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11571 C...Select flavour for branching parton.
11572 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
11573 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
11576 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
11577 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
11578 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
11579 IF(KFLA.EQ.25) THEN
11584 C...Choose z value and corrective weight.
11586 C...q -> q + g or q -> q + gamma.
11587 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
11588 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
11589 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
11590 WTZ=0.5D0*(1D0+Z**2)
11592 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
11593 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
11594 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
11595 C...f -> f + gamma.
11596 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11597 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
11598 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
11599 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
11601 Z=XB+XB*(XEE/(1D0-XEE))*
11602 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11604 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
11605 C...f -> gamma + f.
11606 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
11607 Z=XB+XB*(XEE/(1D0-XEE))*
11608 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11609 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
11611 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) 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)*
11615 & (Q2B/(Q2B+PMAS(24,1)**2))
11617 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
11618 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
11619 WTZ=1D0-2D0*Z*(1D0-Z)
11621 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11622 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
11623 WTZ=(1D0-Z*(1D0-Z))**2
11624 C...gamma -> f + fbar.
11625 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
11626 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
11627 WTZ=1D0-2D0*Z*(1D0-Z)
11629 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
11631 C...Option with resummation of soft gluon emission as effective z shift.
11633 IF(MSTP(65).GE.1) THEN
11635 IF(KFLB.NE.21) RSOFT=8D0/3D0
11636 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
11637 IF(Z.LE.XB) GOTO 220
11640 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
11641 IF(MSTP(64).GE.2) THEN
11642 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
11643 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
11644 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
11645 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
11649 C...Remove kinematically impossible branchings.
11650 UHAT=Q2B-DSH*(1D0-Z)/Z
11651 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
11653 C...Select phi angle of branching at random.
11654 PHIBR=PARU(2)*PYR(0)
11656 C...Matrix-element corrections for some processes.
11657 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11658 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11659 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
11661 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
11662 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
11664 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
11665 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
11667 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11668 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
11673 C...Impose angular constraint in first branching from interference
11674 C...with final state partons.
11676 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
11677 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
11678 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
11679 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
11680 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
11681 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
11685 C...Option with angular ordering requirement.
11686 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
11687 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT(2))
11688 IF(THE2T.GT.THE2(JT)) GOTO 220
11692 C...Weighting with new parton distributions.
11693 MINT(105)=MINT(102+JT)
11694 MINT(109)=MINT(106+JT)
11695 VINT(120)=VINT(2+JT)
11697 C.... Store side in MINT(124)
11700 IF(MSTP(57).LE.1) THEN
11701 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
11703 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
11706 IF(XFBN.LT.1D-20) THEN
11707 IF(KFLA.EQ.KFLB) THEN
11713 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
11714 TEVCB=0.5D0*(TEVCBS+TEVCB)
11716 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
11717 TEVEB=0.5D0*(TEVEBS+TEVEB)
11729 C.... Store side in MINT(124)
11732 IF(MSTP(57).LE.1) THEN
11733 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
11735 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
11738 IF(XFAN.LT.1D-20) GOTO 200
11740 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
11742 C...Define two hard scatterers in their CM-frame.
11743 260 IF(N.EQ.NS+2) THEN
11745 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
11748 IF(JR.EQ.1) IPO=IPUS1
11749 IF(JR.EQ.2) IPO=IPUS2
11759 P(I,3)=DPLCM*(-1)**(JR+1)
11760 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
11761 P(I,5)=-SQRT(DQ2(JR))
11764 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
11765 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
11768 C...Find maximum allowed mass of timelike parton.
11769 ELSEIF(N.GT.NS+2) THEN
11774 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
11775 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
11776 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
11777 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
11778 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
11780 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
11781 & 1D-10*DPD(1)) IKIN=1
11782 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
11783 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
11784 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
11785 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
11787 C...Generate timelike parton shower (if required).
11794 C...f -> f + g (gamma).
11795 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
11797 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
11798 C...f -> g (gamma, W+-) + f.
11799 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
11801 IF(KFLS(JT+2).EQ.24) THEN
11803 ELSEIF(KFLS(JT+2).EQ.-24) THEN
11806 C...g (gamma) -> f + fbar, g + g.
11808 K(IT,2)=-KFLS(JT+2)
11809 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
11812 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
11813 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
11814 P(IT,5)=PYMASS(K(IT,2))
11815 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
11816 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
11819 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
11820 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
11821 IF(MSTP(63).EQ.1) THEN
11823 ELSEIF(MSTP(63).EQ.2) THEN
11824 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
11828 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11829 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
11830 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
11831 PARJ(85)=SQRT(MAX(0D0,DPT2))*
11832 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
11834 CALL PYSHOW(IT,0,SQRT(Q2TIM))
11837 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
11840 C...Reconstruct kinematics of branching: timelike parton shower.
11842 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11843 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
11844 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
11845 & (4D0*DSH*DPC(3)**2)
11846 IF(DPT2.LT.0D0) GOTO 100
11847 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
11848 & DSHR)/DPC(3)-DPC(3)
11850 P(IT,3)=DPB(1)*(-1)**(JT+1)
11851 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
11853 DPB(1)=SQRT(DPB(1)**2+DPT2)
11854 DPB(2)=SQRT(DPB(1)**2+DMS)
11856 DPB(4)=SQRT(DPB(3)**2+DMS)
11857 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
11859 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
11860 THE=PYANGL(P(IT,3),P(IT,1))
11861 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
11864 C...Reconstruct kinematics of branching: spacelike parton.
11873 P(N+1,3)=P(IT,3)+P(IS(JT),3)
11874 P(N+1,4)=P(IT,4)+P(IS(JT),4)
11875 P(N+1,5)=-SQRT(DQ2(3))
11877 C...Define colour flow of branching.
11882 C...f -> f + gamma (Z, W).
11883 IF(IABS(K(IT,2)).GE.22) THEN
11887 C...f -> gamma (Z, W) + f.
11888 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
11891 C...gamma -> q + qbar, g + g.
11892 ELSEIF(K(N+1,2).EQ.22) THEN
11898 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
11902 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
11905 C...qbar -> qbar + g.
11906 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
11909 C...qbar -> g + qbar.
11910 ELSEIF(K(N+1,2).LT.0) THEN
11913 C...g -> g + g; g -> q + qbar.
11914 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
11921 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
11922 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
11923 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
11924 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
11925 IF(ID1.NE.ID2) THEN
11926 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
11927 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
11930 IF(K(IT,1).EQ.1) THEN
11935 C...Boost to new CM-frame.
11936 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
11937 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
11938 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
11939 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
11940 IR=N+(JT-1)*(IS(1)-N)
11941 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
11945 C...Update kinematics variables.
11948 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THE2(JT)=THE2T
11951 C...Save quantities; loop back.
11955 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
11956 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
11957 KFLS(JT+2)=KFLS(JT)
11962 XFS(JT,KFL)=XFA(KFL)
11971 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
11972 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
11973 IF(MSTU(21).GE.1) N=NS
11974 IF(MSTU(21).GE.1) RETURN
11976 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
11978 C...Boost hard scattering partons to frame of shower initiators.
11980 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
11986 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
11987 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
11988 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
11989 CALL PYROBO(MINT(83)+5,NS,0D0,-ROBO(2),0D0,0D0,0D0)
11990 CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
11993 C...Store user information. Reset Lambda value.
11994 K(IPU1,3)=MINT(83)+3
11995 K(IPU2,3)=MINT(83)+4
11997 MINT(12+JT)=KFLS(JT)
11998 VINT(140+JT)=XS(JT)
11999 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
12006 C*********************************************************************
12009 C...Generates maximum ME weight in some initial-state showers.
12010 C...Inparameter MECOR: kind of hard scattering process
12011 C...Outparameter WTFF: maximum weight for fermion -> fermion
12012 C... WTGF: maximum weight for gluon/photon -> fermion
12013 C... WTFG: maximum weight for fermion -> gluon/photon
12014 C... WTGG: maximum weight for gluon -> gluon
12016 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
12018 C...Double precision and integer declarations.
12019 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12020 IMPLICIT INTEGER(I-N)
12021 INTEGER PYK,PYCHGE,PYCOMP
12023 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12024 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12025 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12026 COMMON/PYINT1/MINT(400),VINT(400)
12027 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12028 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
12030 C...Default maximum weight.
12036 C...Select maximum weight by process.
12037 IF(MECOR.EQ.1) THEN
12040 ELSEIF(MECOR.EQ.2) THEN
12048 C*********************************************************************
12051 C...Calculates actual ME weight in some initial-state showers.
12052 C...Inparameter MECOR: kind of hard scattering process
12053 C... IFLCB: flavour combination of branching,
12054 C... 1 for fermion -> fermion,
12055 C... 2 for gluon/photon -> fermion
12056 C... 3 for fermion -> gluon/photon,
12057 C... 4 for gluon -> gluon
12058 C... Q2: Q2 value of shower branching
12059 C... Z: Z value of branching
12060 C...In+outparameter PHIBR: azimuthal angle of branching
12061 C...Outparameter WTME: actual ME weight
12063 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
12065 C...Double precision and integer declarations.
12066 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12067 IMPLICIT INTEGER(I-N)
12068 INTEGER PYK,PYCHGE,PYCOMP
12070 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12071 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12072 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12073 COMMON/PYINT1/MINT(400),VINT(400)
12074 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12075 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
12077 C...Default output.
12080 C...Define kinematics of shower branching in Mandelstam variables.
12084 UH=Q2-SQM*(1D0-Z)/Z
12086 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
12087 IF(MECOR.EQ.1) THEN
12088 IF(IFLCB.EQ.1) THEN
12089 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
12090 ELSEIF(IFLCB.EQ.2) THEN
12091 WTME=(SH**2+UH**2+2D0*SQM*TH)/((SH-SQM)**2+SQM**2)
12094 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
12095 ELSEIF(MECOR.EQ.2) THEN
12096 IF(IFLCB.EQ.3) THEN
12097 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
12098 ELSEIF(IFLCB.EQ.4) THEN
12099 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
12106 C*********************************************************************
12109 C...Administers the generation of successive final-state showers
12110 C...in external processes.
12112 SUBROUTINE PYADSH(NFIN)
12114 C...Double precision and integer declarations.
12115 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12116 IMPLICIT INTEGER(I-N)
12117 INTEGER PYK,PYCHGE,PYCOMP
12119 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12120 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12121 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12122 COMMON/PYINT1/MINT(400),VINT(400)
12123 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
12125 DIMENSION IBEG(100),KSAV(10,5),IORD(10),PSUM(4),BETA(3)
12127 C...Set primary vertex.
12129 V(MINT(83)+5,J)=0D0
12130 V(MINT(83)+6,J)=0D0
12131 V(MINT(84)+1,J)=0D0
12132 V(MINT(84)+2,J)=0D0
12135 C...Isolate systems of particles with the same mother.
12138 DO 140 I=MINT(84)+3,NFIN
12140 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
12147 C...Set production vertices.
12148 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
12155 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
12158 IF(MSTP(125).GE.1) THEN
12166 C...End loop over systems. Return if no showers to be performed.
12167 IBEG(NSYS+1)=NFIN+1
12168 IF(MSTP(71).LE.0) RETURN
12170 C...Loop through systems of particles; check that sensible size.
12172 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
12173 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
12174 ELSEIF(NSIZ.LE.1) THEN
12175 CALL PYERRM(2,'(PYADSH:) only one particle in system')
12176 ELSEIF(NSIZ.GT.7) THEN
12177 CALL PYERRM(2,'(PYADSH:) more than seven particles in system')
12180 C...Save status codes and daughters of showering pair; reset them.
12187 IF(K(I,1).GT.10) THEN
12189 IF(KSAV(II,1).EQ.14) K(I,1)=3
12191 IF(KSAV(II,1).LE.10) THEN
12192 ELSEIF(K(I,1).EQ.1) THEN
12198 KSAV(II,4)=MOD(K(I,4),MSTU(5))
12199 KSAV(II,5)=MOD(K(I,5),MSTU(5))
12200 K(I,4)=K(I,4)-KSAV(II,4)
12201 K(I,5)=K(I,5)-KSAV(II,5)
12204 PSUM(J)=PSUM(J)+P(I,J)
12208 C...Perform shower.
12209 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
12211 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
12214 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
12216 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
12219 C...Look up showered copies of original showering particles.
12223 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
12224 ELSEIF(K(I,1).EQ.11) THEN
12225 180 IMV=MOD(K(IMV,4),MSTU(5))
12226 IF(K(IMV,1).EQ.11) GOTO 180
12228 KDA1=MOD(K(I,4),MSTU(5))
12229 KDA2=MOD(K(I,5),MSTU(5))
12231 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
12234 KDA1=MOD(K(I3,4),MSTU(5))
12235 KDA2=MOD(K(I3,5),MSTU(5))
12240 C...Restore daughter info of original partons to showered copies.
12241 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
12242 IF(KSAV(II,1).LE.10) THEN
12243 ELSEIF(K(I,1).EQ.1) THEN
12244 K(IMV,4)=KSAV(II,4)
12245 K(IMV,5)=KSAV(II,5)
12247 K(IMV,4)=K(IMV,4)+KSAV(II,4)
12248 K(IMV,5)=K(IMV,5)+KSAV(II,5)
12251 C...Reset mother info of existing daughters to showered copies.
12252 DO 200 I3=IBEG(ISYS+1),NFIN
12253 IF(K(I3,3).EQ.I) K(I3,3)=IMV
12254 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
12255 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
12256 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
12260 C...Boost all original daughters to new frame of showered copy.
12263 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
12265 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
12267 BETA(J)=FAC*BETA(J)
12269 DO 240 I3=IBEG(ISYS+1),NFIN
12272 IF(MSTP(128).LE.0) THEN
12273 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 230
12274 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
12275 & CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
12277 IF(IMO.EQ.IMV) THEN
12278 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
12279 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
12287 C...End of loop over showering systems
12294 C*********************************************************************
12297 C...Allows resonances to decay (including parton showers for hadronic
12300 SUBROUTINE PYRESD(IRES)
12302 C...Double precision and integer declarations.
12303 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12304 IMPLICIT INTEGER(I-N)
12305 INTEGER PYK,PYCHGE,PYCOMP
12306 C...Parameter statement to help give large particle numbers.
12307 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
12308 &KEXCIT=4000000,KDIMEN=5000000)
12310 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12311 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12312 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12313 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
12314 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12315 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12316 COMMON/PYINT1/MINT(400),VINT(400)
12317 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12318 COMMON/PYINT4/MWID(500),WIDS(500,5)
12319 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
12320 &/PYINT1/,/PYINT2/,/PYINT4/
12321 C...Local arrays and complex and character variables.
12322 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
12323 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
12324 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
12325 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
12327 COMPLEX FGK,HA(6,6),HC(6,6)
12329 CHARACTER CODE*9,MASS*9
12331 C...The F, Xi and Xj functions of Gunion and Kunszt
12332 C...(Phys. Rev. D33, 665, plus errata from the authors).
12333 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
12334 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
12335 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
12336 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
12337 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
12338 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
12339 &2D0*(D34/D56+D56/D34))
12341 C...Some general constants.
12344 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
12348 GMMZ=PMAS(23,1)*PMAS(23,2)
12350 GMMW=PMAS(24,1)*PMAS(24,2)
12353 C...Boost and rotate to rest frame of incoming partons,
12354 C...to get proper amount of smearing of decay angles.
12358 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
12359 BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
12360 BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
12361 BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
12362 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
12363 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
12364 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
12365 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
12366 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
12369 C...Reset original resonance configuration.
12374 C...Define initial one, two or three objects for subprocess.
12378 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12379 IREF(1,1)=MINT(84)+2+ISET(ISUB)
12380 IREF(1,4)=MINT(83)+6+ISET(ISUB)
12382 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
12383 IREF(1,1)=MINT(84)+1+ISET(ISUB)
12384 IREF(1,2)=MINT(84)+2+ISET(ISUB)
12385 IREF(1,4)=MINT(83)+5+ISET(ISUB)
12386 IREF(1,5)=MINT(83)+6+ISET(ISUB)
12388 ELSEIF(ISET(ISUB).EQ.5) THEN
12389 IREF(1,1)=MINT(84)+3
12390 IREF(1,2)=MINT(84)+4
12391 IREF(1,3)=MINT(84)+5
12392 IREF(1,4)=MINT(83)+7
12393 IREF(1,5)=MINT(83)+8
12394 IREF(1,6)=MINT(83)+9
12398 C...Define original resonance for odd cases.
12401 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
12403 IF(IHDEC.EQ.1) ISUB=3
12405 IREF(1,4)=K(IRES,3)
12409 C...Check if initial resonance has been moved (in resonance + jet).
12411 IF(IREF(1,JT).GT.0) THEN
12412 IF(K(IREF(1,JT),1).GT.10) THEN
12413 KFA=IABS(K(IREF(1,JT),2))
12414 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
12415 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12416 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12417 DO 110 I=IREF(1,JT)+1,N
12418 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
12421 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12422 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12426 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
12427 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
12433 C.....Set decay vertex for initial resonances
12436 V(IREF(1,JT),I)=0D0
12440 C...Loop over decay history.
12446 IF(IREF(IP,2).EQ.0) JTMAX=1
12447 IF(IREF(IP,3).NE.0) JTMAX=3
12451 C...Check for Higgs which appears as decay product of user-process.
12454 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
12456 IF(IHDEC.EQ.1) ISUB=3
12459 C...Start treatment of one, two or three resonances in parallel.
12471 C...Check whether particle can/is allowed to decay.
12472 IF(ID.EQ.0) GOTO 310
12475 IF(MWID(KCA).EQ.0) GOTO 310
12476 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 310
12477 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
12478 & KFA.EQ.18) IT4=IT4+1
12479 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
12480 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
12482 C...Choose lifetime and determine decay vertex.
12483 IF(K(ID,1).EQ.5) THEN
12485 ELSEIF(K(ID,1).NE.4) THEN
12486 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
12489 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
12492 C...Determine whether decay allowed or not.
12494 IF(MSTJ(22).EQ.2) THEN
12495 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
12496 ELSEIF(MSTJ(22).EQ.3) THEN
12497 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
12498 ELSEIF(MSTJ(22).EQ.4) THEN
12499 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
12500 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
12502 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
12507 C...Info for selection of decay channel: sign, pairings.
12508 IF(KCHG(KCA,3).EQ.0) THEN
12511 IPM=(5-ISIGN(1,K(ID,2)))/2
12514 IF(JTMAX.EQ.2) THEN
12515 KFB=IABS(K(IREF(IP,3-JT),2))
12516 ELSEIF(JTMAX.EQ.3) THEN
12518 KFB=IABS(K(IREF(IP,JT2),2))
12519 IF(KFB.NE.KFA) THEN
12520 JT2=JT+2-3*((JT+1)/3)
12521 KFB=IABS(K(IREF(IP,JT2),2))
12525 C...Select decay channel.
12526 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
12527 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
12528 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
12529 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
12530 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
12531 IF(WDTE0S.LE.0D0) GOTO 310
12535 IDC=IDL+MDCY(KCA,2)-1
12536 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
12537 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
12538 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 180
12540 C...Read out flavours and colour charges of decay channel chosen.
12541 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
12542 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
12543 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
12544 KFC1A=PYCOMP(IABS(KFL1(JT)))
12545 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
12546 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
12547 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
12548 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
12549 KFC2A=PYCOMP(IABS(KFL2(JT)))
12550 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
12551 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
12552 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
12553 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
12555 IF(KFL3(JT).NE.0) THEN
12556 KFC3A=PYCOMP(IABS(KFL3(JT)))
12557 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
12558 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
12559 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
12562 C...Set/save further info on channel.
12564 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
12566 HGZ(JT,1)=VINT(111)
12567 HGZ(JT,2)=VINT(112)
12568 HGZ(JT,3)=VINT(114)
12571 C...Select masses; to begin with assume resonances narrow.
12576 KFLW=IABS(KFL1(JT))
12578 ELSEIF(I.EQ.2) THEN
12579 KFLW=IABS(KFL2(JT))
12581 ELSEIF(I.EQ.3) THEN
12582 IF(KFL3(JT).EQ.0) GOTO 200
12583 KFLW=IABS(KFL3(JT))
12586 P(N+I,5)=PMAS(KCW,1)
12588 C...This prevents SUSY/t particles from becoming too light.
12589 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
12590 PMMN(I)=PMAS(KCW,1)
12591 DO 190 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
12592 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
12593 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
12594 & PMAS(PYCOMP(KFDP(IDC,2)),1)
12595 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
12596 & PMAS(PYCOMP(KFDP(IDC,3)),1)
12597 PMMN(I)=MIN(PMMN(I),PMSUM)
12601 ELSEIF(KFLW.EQ.6) THEN
12602 PMMN(I)=PMAS(24,1)+PMAS(5,1)
12606 C...Check which two out of three are widest.
12609 PWID1=PMAS(KFC1A,2)
12610 PWID2=PMAS(KFC2A,2)
12611 KFLW1=IABS(KFL1(JT))
12612 KFLW2=IABS(KFL2(JT))
12613 IF(KFL3(JT).NE.0) THEN
12614 PWID3=PMAS(KFC3A,2)
12615 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
12618 KFLW1=IABS(KFL3(JT))
12619 ELSEIF(PWID3.GT.PWID2) THEN
12622 KFLW2=IABS(KFL3(JT))
12626 C...If all narrow then only check that masses consistent.
12627 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
12628 & PWID2.LT.PARP(41))) THEN
12630 C....Handle near degeneracy cases.
12631 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
12632 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12633 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
12634 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
12638 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12639 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
12642 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
12643 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
12648 C...For three wide resonances select narrower of three
12649 C...according to BW decoupled from rest.
12652 IF(KFL3(JT).NE.0) THEN
12653 IWID3=6-IWID1-IWID2
12654 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
12658 P(N+IWID3,5)=PYMASS(KFLW3)
12659 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 210
12660 PMTOT=PMTOT-P(N+IWID3,5)
12662 C...Select other two correlated within remaining phase space.
12666 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
12667 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
12668 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12673 CKIN(49)=PMMN(IWID1)
12674 CKIN(50)=PMMN(IWID2)
12675 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12680 IF(MINT(51).EQ.1) GOTO 700
12683 C...Begin fill decay products, with colour flow for coloured objects.
12689 C...1) Three-body decays of SUSY particles (plus special case top).
12690 IF(KFL3(JT).NE.0) THEN
12706 C...Set colour flow for t -> W + b + Z.
12710 IF(KCQM(JT).EQ.-1) ISID=5
12712 K(ID,ISID)=K(ID,ISID)+IDAU
12713 K(IDAU,ISID)=MSTU(5)*ID
12715 C...Set colour flow in three-body decays - programmed as special cases.
12716 ELSEIF(KFC2A.LE.6) THEN
12720 IF(KFL2(JT).LT.0) ISID=5
12721 K(N+2,ISID)=MSTU(5)*(N+3)
12722 K(N+3,9-ISID)=MSTU(5)*(N+2)
12724 IF(KFL1(JT).EQ.KSUSY1+21) THEN
12729 IF(KFL2(JT).LT.0) ISID=5
12730 K(N+1,ISID)=MSTU(5)*(N+2)
12731 K(N+1,9-ISID)=MSTU(5)*(N+3)
12732 K(N+2,ISID)=MSTU(5)*(N+1)
12733 K(N+3,9-ISID)=MSTU(5)*(N+1)
12735 IF(KFA.EQ.KSUSY1+21) THEN
12739 IF(KFL2(JT).LT.0) ISID=5
12740 K(ID,ISID)=K(ID,ISID)+(N+2)
12741 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
12742 K(N+2,ISID)=MSTU(5)*ID
12743 K(N+3,9-ISID)=MSTU(5)*ID
12747 IF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
12748 & IABS(KCQ2(JT)).EQ.1) THEN
12752 IF(KFL2(JT).LT.0) ISID=5
12753 K(N+2,ISID)=MSTU(5)*(N+3)
12754 K(N+3,9-ISID)=MSTU(5)*(N+2)
12757 C...Set colour flow in three-body decays with baryon number violation.
12758 C...Neutralino and chargino decays first.
12759 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
12760 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
12761 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
12762 K(N+4,4)=ITJUNC(JT)*MSTU(5)
12763 C...Insert junction to keep track of colours.
12764 IF(KCQ1(JT).NE.0) K(N+1,1)=3
12765 IF(KCQ2(JT).NE.0) K(N+2,1)=3
12766 IF(KCQ3(JT).NE.0) K(N+3,1)=3
12767 C...Set special junction codes:
12771 C...Order decay products by invariant mass. (will be used in PYSTRF).
12772 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)-
12773 & P(N+1,3)*P(N+2,3)
12774 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)-
12775 & P(N+1,3)*P(N+3,3)
12776 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)-
12777 & P(N+2,3)*P(N+3,3)
12778 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
12779 K(N+4,4)=N+3+K(N+4,4)
12780 K(N+4,5)=N+1+MSTU(5)*(N+2)
12781 ELSEIF(PM13.LT.PM23) THEN
12782 K(N+4,4)=N+2+K(N+4,4)
12783 K(N+4,5)=N+1+MSTU(5)*(N+3)
12785 K(N+4,4)=N+1+K(N+4,4)
12786 K(N+4,5)=N+2+MSTU(5)*(N+3)
12792 C...Connect daughters to junction.
12796 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
12798 C...Particle counter should be stepped up one extra for junction.
12802 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
12803 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
12804 K(N+4,4)=ITJUNC(JT)*MSTU(5)
12805 C...Insert junction to keep track of colours.
12806 IF(KCQ1(JT).NE.0) K(N+1,1)=3
12807 IF(KCQ2(JT).NE.0) K(N+2,1)=3
12808 IF(KCQ3(JT).NE.0) K(N+3,1)=3
12819 C...Start by connecting all daughters to junction.
12820 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
12821 C...Only consider colour topologies with off shell resonances.
12822 RMQ1=PMAS(PYCOMP(K(II,2)),1)
12823 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
12824 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
12825 IF (RMGLU-RMQ1.LT.RMRES) THEN
12826 C...Calculate propagators for each colour topology.
12827 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
12828 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
12829 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
12833 CTMSUM=CTMSUM+CTM2(II-N)
12835 CTMSUM=PYR(0)*CTMSUM
12836 C...Select colour topology J, with most off shell least likely.
12839 CTMSUM=CTMSUM-CTM2(J)
12840 IF (CTMSUM.GT.0D0) GOTO 280
12841 C...The lucky winner gets its colour (anti-colour) directly from gluino.
12842 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
12843 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
12844 C...The other gluino colour is connected to junction
12845 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
12847 K(N+4,4)=K(N+4,4)+ID
12848 C...Lastly, connect junction to remaining daughters.
12849 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
12850 C...Particle counter should be stepped up one extra for junction.
12854 C...Update particle counter.
12857 C...2) Everything else two-body decay.
12859 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
12860 C...First set colour flow as if mother colour singlet.
12861 IF(KCQ1(JT).NE.0) THEN
12863 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
12864 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
12866 IF(KCQ2(JT).NE.0) THEN
12868 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
12869 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
12871 C...Then redirect colour flow if mother (anti)triplet.
12872 IF(KCQM(JT).EQ.0) THEN
12873 ELSEIF(KCQM(JT).NE.2) THEN
12875 IF(KCQM(JT).EQ.-1) ISID=5
12877 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
12878 K(ID,ISID)=K(ID,ISID)+IDAU
12879 K(IDAU,ISID)=MSTU(5)*ID
12880 C...Then redirect colour flow if mother octet.
12881 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
12883 IF(KCQ1(JT).EQ.0) IDAU=N
12884 K(ID,4)=K(ID,4)+IDAU
12885 K(ID,5)=K(ID,5)+IDAU
12886 K(IDAU,4)=MSTU(5)*ID
12887 K(IDAU,5)=MSTU(5)*ID
12890 IF(KCQ1(JT).EQ.-1) ISID=5
12891 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
12892 K(ID,ISID)=K(ID,ISID)+(N-1)
12893 K(ID,9-ISID)=K(ID,9-ISID)+N
12894 K(N-1,ISID)=MSTU(5)*ID
12895 K(N,9-ISID)=MSTU(5)*ID
12898 C...Insert junction
12899 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
12901 C...~q* mother: type 3 junction. ~q mother: type 4.
12902 ITJUNC(JT)=(7+KCQM(JT))/2
12903 C...Specify junction KF and set colour flow from junction
12907 C...Junction type encoded together with mother:
12908 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
12909 K(N,5)=N-1+MSTU(5)*(N-2)
12910 C...Zero P and V for junction (V filled later)
12915 C...Set colour flow from mother to junction
12916 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
12917 C...Set colour flow from daughters to junction
12921 C...(Anti-)colour mother is junction.
12922 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
12927 C...End loop over resonances for daughter flavour and mass selection.
12929 310 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
12931 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
12932 & KFL1(JT).EQ.0) THEN
12933 WRITE(CODE,'(I9)') K(ID,2)
12934 WRITE(MASS,'(F9.3)') P(ID,5)
12935 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
12936 & CODE//' with mass'//MASS)
12942 C...Check for allowed combinations. Skip if no decays.
12943 IF(JTMAX.EQ.1) THEN
12944 IF(KDCY(1).EQ.0) GOTO 690
12945 ELSEIF(JTMAX.EQ.2) THEN
12946 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 690
12947 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12948 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12949 ELSEIF(JTMAX.EQ.3) THEN
12950 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 690
12951 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12952 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12953 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12954 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12955 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12956 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12959 C...Special case: matrix element option for Z0 decay to quarks.
12960 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
12961 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
12963 C...Check consistency of MSTJ options set.
12964 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
12966 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
12969 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
12971 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
12976 C...Select alpha_strong behaviour.
12979 MSTU(111)=MSTJ(108)
12980 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
12982 PARU(112)=PARJ(121)
12983 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
12985 C...Find axial fraction in total cross section for scalar gluon model.
12987 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
12988 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
12989 POLL=1D0-PARJ(131)*PARJ(132)
12990 SFF=1D0/(16D0*XW*XW1)
12991 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
12992 & (PARJ(123)*PARJ(124))**2)
12993 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
12995 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
12996 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
12997 & (PARJ(132)-PARJ(131)))
13000 QF=KCHG(KFLC,1)/3D0
13002 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
13003 & 1D0-(2D0*PMQ/P(ID,5))**2))
13004 VF=SIGN(1D0,QF)-4D0*QF*XW
13005 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
13006 & VF**2*HF1W)+VQ**3*HF1W
13007 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
13010 C...Choice of jet configuration.
13011 CALL PYXJET(P(ID,5),NJET,CUT)
13016 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
13017 ELSEIF(NJET.EQ.3) THEN
13018 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
13023 C...Fill jet configuration; return if incorrect kinematics.
13025 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
13026 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
13027 ELSEIF(NJET.EQ.2) THEN
13028 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
13029 ELSEIF(NJET.EQ.3) THEN
13030 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
13031 ELSEIF(KFLN.EQ.21) THEN
13032 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
13035 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
13038 IF(MSTU(24).NE.0) THEN
13045 C...Angular orientation according to matrix element.
13046 IF(MSTJ(106).EQ.1) THEN
13047 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
13048 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
13050 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
13051 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
13054 C...Boost partons to Z0 rest frame.
13055 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
13056 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
13058 C...Mark decayed resonance and add documentation lines,
13060 IDOC=MINT(83)+MINT(4)
13062 I1=MINT(83)+MINT(4)+1
13064 IF(MSTP(128).GE.1) K(I,3)=ID
13065 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
13076 C...Generate parton shower.
13077 IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
13079 C... End special case for Z0: skip ahead.
13085 C...Order incoming partons and outgoing resonances.
13086 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
13089 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
13090 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
13091 & ILIN(1)=2*MINT(84)+3-ILIN(1)
13092 ILIN(2)=2*MINT(84)+3-ILIN(1)
13094 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
13098 IF(K(IREF(IP,1),2).EQ.23) IORD=2
13099 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
13100 IAKIPD=IABS(K(IREF(IP,IORD),2))
13101 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
13102 IF(KDCY(IORD).EQ.0) IORD=3-IORD
13104 C...Order decay products of resonances.
13105 DO 350 JT=IORD,3-IORD,3-2*IORD
13106 IF(KDCY(JT).EQ.0) THEN
13107 ILIN(IMAX+1)=NSD(JT)
13109 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
13110 ILIN(IMAX+1)=N+2*JT-1
13111 ILIN(IMAX+2)=N+2*JT
13113 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
13114 K(N+2*JT,2)=K(NSD(JT)+2,2)
13116 ILIN(IMAX+1)=N+2*JT
13118 ILIN(IMAX+2)=N+2*JT-1
13120 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
13121 K(N+2*JT,2)=K(NSD(JT)+2,2)
13125 C...Find charge, isospin, left- and righthanded couplings.
13130 KFA=IABS(K(ILIN(I),2))
13131 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 370
13132 COUP(I,1)=KCHG(KFA,1)/3D0
13133 COUP(I,2)=(-1)**MOD(KFA,2)
13134 COUP(I,4)=-2D0*COUP(I,1)*XWV
13135 COUP(I,3)=COUP(I,2)+COUP(I,4)
13138 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
13139 IF(ISUB.EQ.22) THEN
13142 IF(I.EQ.5) I1=3-IORD
13145 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
13146 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
13147 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
13152 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
13153 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
13154 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
13155 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
13157 IF(COWT12.LT.PYR(0)*COMX12) GOTO 160
13161 C...Select angular orientation type - Z'/W' only.
13163 IF(ISUB.EQ.141) THEN
13164 IF(PYR(0).LT.PARU(130)) MZPWP=1
13166 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
13167 IAKIR=IABS(K(IREF(2,2),2))
13168 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
13169 IF(IAKIR.LE.20) MZPWP=2
13171 IF(IP.GE.3) MZPWP=2
13172 ELSEIF(ISUB.EQ.142) THEN
13173 IF(PYR(0).LT.PARU(136)) MZPWP=1
13175 IAKIR=IABS(K(IREF(2,2),2))
13176 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
13177 IF(IAKIR.LE.20) MZPWP=2
13179 IF(IP.GE.3) MZPWP=2
13182 C...Select random angles (begin of weighting procedure).
13183 410 DO 420 JT=1,JTMAX
13184 IF(KDCY(JT).EQ.0) GOTO 420
13185 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
13186 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
13187 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
13190 CTHE(JT)=2D0*PYR(0)-1D0
13191 PHI(JT)=PARU(2)*PYR(0)
13195 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
13196 C...Construct massless four-vectors.
13205 IF(KDCY(JT).EQ.0) GOTO 450
13207 P(N+2*JT-1,3)=0.5D0*P(ID,5)
13208 P(N+2*JT-1,4)=0.5D0*P(ID,5)
13209 P(N+2*JT,3)=-0.5D0*P(ID,5)
13210 P(N+2*JT,4)=0.5D0*P(ID,5)
13211 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
13212 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
13215 C...Store incoming and outgoing momenta, with random rotation to
13216 C...avoid accidental zeroes in HA expressions.
13220 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
13221 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
13222 P(N+4+I,5)=P(ILIN(I),5)
13224 P(N+4+I,J)=P(ILIN(I),J)
13227 480 THERR=ACOS(2D0*PYR(0)-1D0)
13228 PHIRR=PARU(2)*PYR(0)
13229 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
13231 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2)
13239 C...Calculate internal products.
13240 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
13241 & ISUB.EQ.142) THEN
13242 DO 520 I1=IMIN,IMAX-1
13243 DO 510 I2=I1+1,IMAX
13244 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
13245 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
13246 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
13247 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
13248 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
13249 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
13250 HC(I1,I2)=CONJG(HA(I1,I2))
13251 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
13252 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
13253 HA(I2,I1)=-HA(I1,I2)
13254 HC(I2,I1)=-HC(I1,I2)
13259 C...Calculate four-products.
13266 DO 560 I1=IMIN,IMAX-1
13267 DO 550 I2=I1+1,IMAX
13268 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
13269 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
13270 PKK(I2,I1)=PKK(I1,I2)
13276 KFAGM=IABS(IREF(IP,7))
13277 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
13278 C...Isotropic decay selected by user.
13282 ELSEIF(JTMAX.EQ.3) THEN
13283 C...Isotropic decay when three mother particles.
13287 ELSEIF(IT4.GE.1) THEN
13288 C... Isotropic decay t -> b + W etc for 4th generation q and l.
13292 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
13293 & IREF(IP,7).EQ.36) THEN
13294 C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
13295 C...CP-odd case added by Kari Ertresvag Myklevoll.
13296 IF(IP.EQ.1) WTMAX=SH**2
13297 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
13298 KFA=IABS(K(IREF(IP,1),2))
13300 KFLF1A=IABS(KFL1(1))
13301 EF1=KCHG(KFLF1A,1)/3D0
13302 AF1=SIGN(1D0,EF1+0.1D0)
13303 VF1=AF1-4D0*EF1*XWV
13304 KFLF2A=IABS(KFL1(2))
13305 EF2=KCHG(KFLF2A,1)/3D0
13306 AF2=SIGN(1D0,EF2+0.1D0)
13307 VF2=AF2-4D0*EF2*XWV
13308 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)
13309 & *(VF2**2+AF2**2))
13310 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
13313 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
13314 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
13317 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
13318 & -2*PKK(3,4)*PKK(5,6)
13319 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
13320 & (PKK(3,4)*PKK(5,6))
13321 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
13322 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
13324 ELSEIF(KFA.EQ.24) THEN
13325 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
13328 WT=16D0*PKK(3,5)*PKK(4,6)
13331 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
13332 & -2*PKK(3,4)*PKK(5,6)
13333 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
13334 & (PKK(3,4)*PKK(5,6))
13335 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
13336 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
13342 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
13343 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
13345 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
13347 IF(MOD(KFAGM,2).EQ.0) THEN
13355 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
13356 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
13357 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
13358 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
13360 ELSEIF(ISUB.EQ.1) THEN
13361 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
13362 EI=KCHG(IABS(MINT(15)),1)/3D0
13363 AI=SIGN(1D0,EI+0.1D0)
13365 EF=KCHG(IABS(KFL1(1)),1)/3D0
13366 AF=SIGN(1D0,EF+0.1D0)
13369 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
13370 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13371 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
13372 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13373 & (VI**2+AI**2)*VINT(114)*VF**2)
13374 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
13375 & 4D0*VI*AI*VINT(114)*VF*AF)
13376 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13377 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13378 WTMAX=2D0*(WT1+ABS(WT3))
13380 ELSEIF(ISUB.EQ.2) THEN
13381 C...Angular weight for W+/- -> 2 quarks/leptons.
13382 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
13383 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
13384 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13385 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13388 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
13389 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
13390 C...-> gluon/gamma + 2 quarks/leptons.
13391 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13392 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13393 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13394 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13395 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13396 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13397 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13398 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13399 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13400 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13401 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13402 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13403 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
13404 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
13405 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13406 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
13408 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
13409 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
13410 C...-> gluon/gamma + 2 quarks/leptons.
13411 WT=PKK(1,3)**2+PKK(2,4)**2
13412 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
13414 ELSEIF(ISUB.EQ.22) THEN
13415 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
13416 S34=P(IREF(IP,IORD),5)**2
13417 S56=P(IREF(IP,3-IORD),5)**2
13418 TI=PKK(1,3)+PKK(1,4)+S34
13419 UI=PKK(1,5)+PKK(1,6)+S56
13422 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
13423 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
13424 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
13425 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
13426 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
13427 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
13428 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
13429 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
13432 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
13433 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
13434 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
13435 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
13436 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
13437 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
13438 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
13441 ELSEIF(ISUB.EQ.23) THEN
13442 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
13443 D34=P(IREF(IP,IORD),5)**2
13444 D56=P(IREF(IP,3-IORD),5)**2
13445 DT=PKK(1,3)+PKK(1,4)+D34
13446 DU=PKK(1,5)+PKK(1,6)+D56
13447 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
13448 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13449 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13450 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
13452 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
13453 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
13454 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
13455 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13456 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
13457 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
13459 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
13460 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
13461 C...(or H0, or A0).
13462 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
13463 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
13464 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
13465 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
13466 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13468 ELSEIF(ISUB.EQ.25) THEN
13469 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
13470 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
13471 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
13472 D34=P(IREF(IP,IORD),5)**2
13473 D56=P(IREF(IP,3-IORD),5)**2
13474 DT=PKK(1,3)+PKK(1,4)+D34
13475 DU=PKK(1,5)+PKK(1,6)+D56
13476 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
13477 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
13478 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
13479 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
13480 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
13481 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
13482 & REAL(CBWW)*FGK(1,2,5,6,3,4))
13483 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13484 IF(MSTP(50).LE.0) THEN
13485 WT=FGK135**2+(CCWW*FGK253)**2
13486 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
13487 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
13490 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
13491 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
13492 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
13493 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
13496 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
13497 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
13498 C...(or H0, or A0).
13499 WT=PKK(1,3)*PKK(2,4)
13500 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13502 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
13503 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
13504 C...-> f + 2 quarks/leptons.
13505 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13506 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13507 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13508 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13509 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13510 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13511 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13512 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13513 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13514 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13515 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13516 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13517 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
13518 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
13519 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
13520 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
13521 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13522 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
13524 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
13525 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
13526 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
13527 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
13528 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
13530 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
13532 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
13533 WT=16D0*PKK(3,5)*PKK(4,6)
13536 ELSEIF(ISUB.EQ.110) THEN
13537 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
13541 ELSEIF(ISUB.EQ.141) THEN
13542 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13543 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
13544 C...Couplings of incoming flavour.
13545 KFAI=IABS(MINT(15))
13546 EI=KCHG(KFAI,1)/3D0
13547 AI=SIGN(1D0,EI+0.1D0)
13550 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
13551 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
13552 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
13553 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
13554 VPI=PARU(119+2*KFAIC)
13555 API=PARU(120+2*KFAIC)
13556 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
13557 VPI=PARJ(178+2*KFAIC)
13558 API=PARJ(179+2*KFAIC)
13560 VPI=PARJ(186+2*KFAIC)
13561 API=PARJ(187+2*KFAIC)
13563 C...Couplings of final flavour.
13565 EF=KCHG(KFAF,1)/3D0
13566 AF=SIGN(1D0,EF+0.1D0)
13569 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
13570 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
13571 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
13572 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
13573 VPF=PARU(119+2*KFAFC)
13574 APF=PARU(120+2*KFAFC)
13575 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
13576 VPF=PARJ(178+2*KFAFC)
13577 APF=PARJ(179+2*KFAFC)
13579 VPF=PARJ(186+2*KFAFC)
13580 APF=PARJ(187+2*KFAFC)
13582 C...Asymmetry and weight.
13583 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
13584 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
13585 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
13586 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13587 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
13588 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
13589 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
13590 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13591 WTMAX=2D0+ABS(ASYM)
13592 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
13593 C...Angular weight for f + fbar -> Z' -> W+ + W-.
13594 RM1=P(NSD(1)+1,5)**2/SH
13595 RM2=P(NSD(1)+2,5)**2/SH
13596 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13597 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13598 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13600 WT=CFLAT+CCOS2*CTHE(1)**2
13601 WTMAX=CFLAT+MAX(0D0,CCOS2)
13602 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
13603 & IABS(KFL1(1)).EQ.37)) THEN
13604 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
13607 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13608 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
13609 RM1=P(NSD(1)+1,5)**2/SH
13610 RM2=P(NSD(1)+2,5)**2/SH
13611 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13612 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13613 WTMAX=1D0+FLAM2/(8D0*RM1)
13614 ELSEIF(MZPWP.EQ.0) THEN
13615 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13616 C...(W:s like if intermediate Z).
13617 D34=P(IREF(IP,IORD),5)**2
13618 D56=P(IREF(IP,3-IORD),5)**2
13619 DT=PKK(1,3)+PKK(1,4)+D34
13620 DU=PKK(1,5)+PKK(1,6)+D56
13621 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13622 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13623 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
13624 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
13625 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13626 ELSEIF(MZPWP.EQ.1) THEN
13627 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13628 C...(W:s approximately longitudinal, like if intermediate H).
13629 WT=16D0*PKK(3,5)*PKK(4,6)
13632 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
13633 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
13638 ELSEIF(ISUB.EQ.142) THEN
13639 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13640 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
13641 KFAI=IABS(MINT(15))
13643 IF(KFAI.GT.10) KFAIC=2
13644 VI=PARU(129+2*KFAIC)
13645 AI=PARU(130+2*KFAIC)
13648 IF(KFAF.GT.10) KFAFC=2
13649 VF=PARU(129+2*KFAFC)
13650 AF=PARU(130+2*KFAFC)
13651 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
13652 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13653 WTMAX=2D0+ABS(ASYM)
13654 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
13655 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
13656 RM1=P(NSD(1)+1,5)**2/SH
13657 RM2=P(NSD(1)+2,5)**2/SH
13658 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13659 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13660 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13662 WT=CFLAT+CCOS2*CTHE(1)**2
13663 WTMAX=CFLAT+MAX(0D0,CCOS2)
13664 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13665 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
13666 RM1=P(NSD(1)+1,5)**2/SH
13667 RM2=P(NSD(1)+2,5)**2/SH
13668 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13669 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13670 WTMAX=1D0+FLAM2/(8D0*RM1)
13671 ELSEIF(MZPWP.EQ.0) THEN
13672 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13673 C...(W/Z like if intermediate W).
13674 D34=P(IREF(IP,IORD),5)**2
13675 D56=P(IREF(IP,3-IORD),5)**2
13676 DT=PKK(1,3)+PKK(1,4)+D34
13677 DU=PKK(1,5)+PKK(1,6)+D56
13678 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13679 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
13680 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13681 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
13682 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13683 ELSEIF(MZPWP.EQ.1) THEN
13684 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13685 C...(W/Z approximately longitudinal, like if intermediate H).
13686 WT=16D0*PKK(3,5)*PKK(4,6)
13689 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
13690 C...t + bbar -> t + W + bbar.
13695 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
13697 C...Isotropic decay of leptoquarks (assumed spin 0).
13701 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
13702 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
13704 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
13705 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
13706 WT=1D0+SIDE*CTHE(1)
13708 ELSEIF(IP.EQ.1) THEN
13710 RM1=P(NSD(1)+1,5)**2/SH
13711 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13712 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13714 C...W/Z decay assumed isotropic, since not known.
13719 ELSEIF(ISUB.EQ.149) THEN
13720 C...Isotropic decay of techni-eta.
13724 ELSEIF(ISUB.EQ.191) THEN
13725 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13726 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
13727 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
13730 ELSEIF(IP.EQ.1) THEN
13731 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
13732 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13733 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
13734 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13735 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13736 KFAI=IABS(MINT(15))
13737 EI=KCHG(KFAI,1)/3D0
13738 AI=SIGN(1D0,EI+0.1D0)
13742 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
13743 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
13745 EF=KCHG(KFAF,1)/3D0
13746 AF=SIGN(1D0,EF+0.1D0)
13750 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
13751 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
13752 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
13753 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
13754 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
13755 WTMAX=4D0*MAX(ASAME,AFLIP)
13757 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
13762 ELSEIF(ISUB.EQ.192) THEN
13763 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13764 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
13765 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
13768 ELSEIF(IP.EQ.1) THEN
13769 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
13770 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13774 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
13779 ELSEIF(ISUB.EQ.193) THEN
13780 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13781 C...Angular weight for f + fbar -> omega_tc0 ->
13782 C...gamma pi_tc0 or Z0 pi_tc0.
13785 ELSEIF(IP.EQ.1) THEN
13786 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
13787 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13788 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13789 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13790 KFAI=IABS(MINT(15))
13791 EI=KCHG(KFAI,1)/3D0
13792 AI=SIGN(1D0,EI+0.1D0)
13796 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
13797 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
13799 EF=KCHG(KFAF,1)/3D0
13800 AF=SIGN(1D0,EF+0.1D0)
13804 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
13805 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
13806 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
13807 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
13808 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
13809 WTMAX=4D0*MAX(BSAME,BFLIP)
13811 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
13816 ELSEIF(ISUB.EQ.353) THEN
13817 C...Angular weight for Z_R0 -> 2 quarks/leptons.
13818 EI=KCHG(IABS(MINT(15)),1)/3D0
13819 AI=SIGN(1D0,EI+0.1D0)
13821 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
13822 AF=SIGN(1D0,EF+0.1D0)
13824 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
13825 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
13826 WT2=RMF*(VI**2+AI**2)*VF**2
13827 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
13828 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13829 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13830 WTMAX=2D0*(WT1+ABS(WT3))
13832 ELSEIF(ISUB.EQ.354) THEN
13833 C...Angular weight for W_R+/- -> 2 quarks/leptons.
13834 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
13835 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
13836 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13837 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13840 ELSEIF(ISUB.EQ.391) THEN
13841 C...Angular weight for f + fbar -> G* -> f + fbar
13842 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13843 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
13845 C...Other G* decays not yet implemented angular distributions.
13851 ELSEIF(ISUB.EQ.392) THEN
13852 C...Angular weight for g + g -> G* -> f + fbar
13853 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13856 C...Other G* decays not yet implemented angular distributions.
13862 C...Obtain correct angular distribution by rejection techniques.
13867 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
13869 C...Construct massive four-vectors using angles chosen.
13870 570 DO 670 JT=1,JTMAX
13871 IF(KDCY(JT).EQ.0) GOTO 670
13876 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
13878 IF(KFL3(JT).EQ.0) THEN
13879 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
13880 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13883 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
13884 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13889 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
13891 C...Fill in position of decay vertex.
13892 DO 610 I=NSD(JT)+1,N0
13901 C...Mark decayed resonances; trace history.
13905 IF(KCQM(JT).NE.0) THEN
13906 C...Do not kill colour flow through coloured resonance!
13910 C...If 3-body or 2-body with junction:
13911 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
13912 C...If 3-body with junction:
13913 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
13916 C...Add documentation lines.
13917 ISUBRG=MAX(1,MIN(500,MINT(1)))
13918 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
13919 IDOC=MINT(83)+MINT(4)
13922 IF(KFL3(JT).NE.0) IHI=IHI+1
13923 DO 630 I=NSD(JT)+1,IHI
13925 I1=MINT(83)+MINT(4)+1
13927 IF(MSTP(128).GE.1) K(I,3)=ID
13928 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
13932 K(I1,3)=IREF(IP,JT+3)
13941 C...If 3-body or 2-body with junction:
13942 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
13943 C...If 3-body with junction:
13944 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
13947 C...Do showering of two or three objects.
13949 IF(MSTP(71).GE.1) THEN
13950 IF(KFL3(JT).EQ.0) THEN
13951 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
13953 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
13957 IF(JT.EQ.1) NAFT1=N
13959 C...Check if decay products moved by shower.
13963 IF(NSHAFT.GT.NSHBEF) THEN
13964 IF(K(NSD1,1).GT.10) THEN
13965 DO 640 I=NSHBEF+1,NSHAFT
13966 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
13969 IF(K(NSD2,1).GT.10) THEN
13970 DO 650 I=NSHBEF+1,NSHAFT
13971 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
13972 & I.NE.NSD1) NSD2=I
13975 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
13976 DO 660 I=NSHBEF+1,NSHAFT
13977 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
13978 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
13983 C...Store decay products for further treatment.
13988 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
13992 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
13993 IREF(NP,7)=K(IREF(IP,JT),2)
13994 IREF(NP,8)=IREF(IP,JT)
13997 C...Fill information for 2 -> 1 -> 2.
13998 680 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
13999 MINT(7)=MINT(83)+6+2*ISET(ISUB)
14000 MINT(8)=MINT(83)+7+2*ISET(ISUB)
14006 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
14007 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
14008 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
14009 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
14010 VINT(47)=SQRT(VINT(48))
14013 C...Possibility of colour rearrangement in W+W- events.
14014 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
14015 IAKF1=IABS(KFL1(1))
14016 IAKF2=IABS(KFL1(2))
14017 IAKF3=IABS(KFL2(1))
14018 IAKF4=IABS(KFL2(2))
14019 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
14020 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
14021 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
14024 C...Loop back if needed.
14025 690 IF(IP.LT.NP) GOTO 150
14027 C...Boost back to standard frame.
14028 700 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
14034 C*********************************************************************
14037 C...Initializes treatment of multiple interactions, selects kinematics
14038 C...of hardest interaction if low-pT physics included in run, and
14039 C...generates all non-hardest interactions.
14041 SUBROUTINE PYMULT(MMUL)
14043 C...Double precision and integer declarations.
14044 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14045 IMPLICIT INTEGER(I-N)
14046 INTEGER PYK,PYCHGE,PYCOMP
14048 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14049 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14050 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14051 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
14052 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14053 COMMON/PYINT1/MINT(400),VINT(400)
14054 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14055 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
14056 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
14057 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
14058 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
14059 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
14060 C...Local arrays and saved variables.
14061 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
14062 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
14064 C...Initialization of multiple interaction treatment.
14066 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
14074 C...Loop over phase space points: xT2 choice in 20 bins.
14077 NMUL(IXT2)=MSTP(83)
14079 DO 110 ITRY=1,MSTP(83)
14080 RSCA=0.05D0*((21-IXT2)-PYR(0))
14081 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
14082 XT2=MAX(0.01D0*VINT(149),XT2)
14085 C...Choose tau and y*. Calculate cos(theta-hat).
14086 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14087 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14088 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14090 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14096 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14097 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14098 CALL PYKMAP(2,MYST,PYR(0))
14099 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14101 C...Calculate differential cross-section.
14102 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
14103 CALL PYSIGH(NCHN,SIGS)
14104 SIGM(IXT2)=SIGM(IXT2)+SIGS
14106 SIGSUM=SIGSUM+SIGM(IXT2)
14108 SIGSUM=SIGSUM/(20D0*MSTP(83))
14110 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
14111 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
14112 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
14113 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
14114 PARP(82)=0.9D0*PARP(82)
14115 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
14119 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
14120 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
14122 C...Start iteration to find k factor.
14123 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
14131 130 IF(IIT.EQ.0) THEN
14133 ELSEIF(IIT.EQ.1) THEN
14136 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
14139 C...Evaluate overlap integrals.
14140 IF(MSTP(82).EQ.2) THEN
14141 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
14144 IF(MSTP(82).EQ.3) DELTAB=0.02D0
14145 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
14150 IF(MSTP(82).EQ.3) THEN
14151 OV=EXP(-B**2)/PARU(2)
14154 OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
14155 & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
14156 & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
14157 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
14159 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
14160 SP=SP+PARU(2)*B*DELTAB*PACC
14161 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
14162 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
14164 YK=PARU(1)*XK*SO/SP
14166 C...Continue iteration until convergence.
14176 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
14178 C...Store some results for subsequent use.
14183 C...Initialize iteration in xT2 for hardest interaction.
14184 ELSEIF(MMUL.EQ.2) THEN
14185 IF(MSTP(82).LE.0) THEN
14186 ELSEIF(MSTP(82).EQ.1) THEN
14188 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
14189 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
14190 & VINT(317)/(VINT(318)*VINT(320))
14191 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
14192 ELSEIF(MSTP(82).EQ.2) THEN
14194 XT2FAC=VINT(146)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
14195 & VINT(149)*(1D0+VINT(149))
14197 XC2=4D0*CKIN(3)**2/VINT(2)
14198 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
14201 ELSEIF(MMUL.EQ.3) THEN
14202 C...Low-pT or multiple interactions (first semihard interaction):
14203 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
14204 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
14206 IF(MSTP(82).LE.0) THEN
14208 ELSEIF(MSTP(82).EQ.1) THEN
14209 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
14210 ELSEIF(MSTP(82).EQ.2) THEN
14211 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
14212 & VINT(149)))).GT.PYR(0)) XT2=1D0
14213 IF(XT2.GE.1D0) THEN
14214 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
14215 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
14218 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
14219 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
14222 XT2=MAX(0.01D0*VINT(149),XT2)
14224 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
14225 & PYR(0)*(1D0-XC2))-VINT(149)
14226 XT2=MAX(0.01D0*VINT(149),XT2)
14230 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
14231 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
14232 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
14233 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
14236 VINT(21)=0.01D0*VINT(149)
14239 VINT(25)=0.01D0*VINT(149)
14242 C...Multiple interactions (first semihard interaction).
14243 C...Choose tau and y*. Calculate cos(theta-hat).
14244 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14245 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14246 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14248 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14254 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14255 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14256 CALL PYKMAP(2,MYST,PYR(0))
14257 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14259 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
14261 C...Store results of cross-section calculation.
14262 ELSEIF(MMUL.EQ.4) THEN
14265 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
14266 IF(ISET(ISUB).EQ.2)
14267 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
14268 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
14269 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
14270 & (XTS+VINT(149))))
14271 IRBIN=INT(1D0+20D0*RBIN)
14272 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
14273 NMUL(IRBIN)=NMUL(IRBIN)+1
14274 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
14277 C...Choose impact parameter.
14278 ELSEIF(MMUL.EQ.5) THEN
14280 150 IF(MSTP(82).EQ.3) THEN
14281 VINT(148)=PYR(0)/(PARU(2)*VINT(147))
14285 IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
14287 ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
14288 B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
14290 B2=-CQ2*LOG(PYR(0))
14292 VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
14293 & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
14294 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
14297 C...Multiple interactions (variable impact parameter) : reject with
14298 C...probability exp(-overlap*cross-section above pT/normalization).
14299 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
14300 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
14301 DO 160 IBIN=IRBIN+1,20
14302 RNCOR=RNCOR+NMUL(IBIN)
14303 SIGCOR=SIGCOR+SIGM(IBIN)
14305 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
14306 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
14307 VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
14308 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
14309 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
14310 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
14311 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
14312 IF(VINT(150).LT.PYR(0)) GOTO 150
14316 C...Generate additional multiple semihard interactions.
14317 ELSEIF(MMUL.EQ.6) THEN
14327 C...Reconstruct strings in hard scattering.
14329 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
14330 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
14332 DO 190 I=MINT(84)+1,NMAX
14333 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
14334 IF(KCS.EQ.0) GOTO 190
14336 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 180
14337 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 180
14339 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
14341 IST=MOD(K(I,J+1),MSTU(5))
14343 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 180
14344 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 180
14346 IF(J.EQ.1.OR.J.EQ.4) THEN
14356 C...Set up starting values for iteration in xT2.
14357 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
14358 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
14359 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
14360 & ISUBSV.NE.96)) THEN
14361 XT2=(1D0-VINT(141))*(1D0-VINT(142))
14364 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
14365 IF(ISET(ISUBSV).EQ.2)
14366 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
14367 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
14369 IF(MSTP(82).LE.1) THEN
14370 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
14371 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
14372 & VINT(317)/(VINT(318)*VINT(320))
14373 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
14375 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
14376 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
14380 VINT(143)=1D0-VINT(141)
14381 VINT(144)=1D0-VINT(142)
14383 C...Iterate downwards in xT2.
14384 200 IF(MSTP(82).LE.1) THEN
14385 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
14386 IF(XT2.LT.VINT(149)) GOTO 250
14388 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 250
14389 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
14390 & LOG(PYR(0)))-VINT(149)
14391 IF(XT2.LE.0D0) GOTO 250
14392 XT2=MAX(0.01D0*VINT(149),XT2)
14396 C...Choose tau and y*. Calculate cos(theta-hat).
14397 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14398 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14399 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14401 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14407 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14408 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14409 CALL PYKMAP(2,MYST,PYR(0))
14410 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14412 C...Check that x not used up. Accept or reject kinematical variables.
14413 X1M=SQRT(TAU)*EXP(VINT(22))
14414 X2M=SQRT(TAU)*EXP(-VINT(22))
14415 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 200
14416 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
14417 CALL PYSIGH(NCHN,SIGS)
14418 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
14419 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 200
14421 C...Reset K, P and V vectors. Select some variables.
14430 PT=0.5D0*VINT(1)*SQRT(XT2)
14434 C...Add first parton to event record.
14437 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
14438 & 1+INT((2D0+PARJ(2))*PYR(0))
14439 P(N+1,1)=PT*COS(PHI)
14440 P(N+1,2)=PT*SIN(PHI)
14441 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
14442 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
14445 C...Add second parton to event record.
14448 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
14451 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
14452 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
14455 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
14456 C....Choose relevant string pieces to place gluons on.
14462 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
14463 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
14464 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
14465 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
14466 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
14474 C....Colour flow adjustments, new string pieces.
14475 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
14476 & MOD(K(IST1,4),MSTU(5))
14477 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
14478 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
14479 K(I,5)=MSTU(5)*IST1
14480 K(I,4)=MSTU(5)*IST2
14481 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
14482 & MOD(K(IST2,5),MSTU(5))
14483 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
14484 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
14487 KSTR(NSTR+1,2)=IST2
14491 C...String drawing and colour flow for gluon loop.
14492 ELSEIF(K(N+1,2).EQ.21) THEN
14493 K(N+1,4)=MSTU(5)*(N+2)
14494 K(N+1,5)=MSTU(5)*(N+2)
14495 K(N+2,4)=MSTU(5)*(N+1)
14496 K(N+2,5)=MSTU(5)*(N+1)
14503 C...String drawing and colour flow for qqbar pair.
14505 K(N+1,4)=MSTU(5)*(N+2)
14506 K(N+2,5)=MSTU(5)*(N+1)
14512 C...Update remaining energy; iterate.
14514 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14515 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
14516 IF(MSTU(21).GE.1) RETURN
14518 MINT(31)=MINT(31)+1
14519 VINT(151)=VINT(151)+VINT(41)
14520 VINT(152)=VINT(152)+VINT(42)
14521 VINT(143)=VINT(143)-VINT(41)
14522 VINT(144)=VINT(144)-VINT(42)
14523 IF(MINT(31).LT.240) GOTO 200
14531 C...Format statements for printout.
14532 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
14533 &'actions for MSTP(82) =',I2,' ******')
14534 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14535 &D9.2,' mb: rejected')
14536 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14537 &D9.2,' mb: accepted')
14542 C*********************************************************************
14545 C...Adds on target remnants (one or two from each side) and
14546 C...includes primordial kT for hadron beams.
14548 SUBROUTINE PYREMN(IPU1,IPU2)
14550 C...Double precision and integer declarations.
14551 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14552 IMPLICIT INTEGER(I-N)
14553 INTEGER PYK,PYCHGE,PYCOMP
14555 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14556 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14557 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14558 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14559 COMMON/PYINT1/MINT(400),VINT(400)
14560 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
14562 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
14563 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
14565 C...Find event type and remaining energy.
14568 IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
14569 VINT(143)=1D0-VINT(141)
14570 VINT(144)=1D0-VINT(142)
14573 C...Define initial partons.
14578 IF(JT.EQ.1) IPU=IPU1
14579 IF(JT.EQ.2) IPU=IPU2
14586 IF(MINT(47).EQ.1) THEN
14590 ELSEIF(ISUB.EQ.95) THEN
14595 C...No primordial kT, or chosen according to truncated Gaussian or
14596 C...exponential, or (for photon) predetermined or power law.
14597 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
14598 IF(MSTP(91).LE.0) THEN
14600 ELSEIF(MSTP(91).EQ.1) THEN
14601 PT=PARP(91)*SQRT(-LOG(PYR(0)))
14605 PT=-PARP(92)*LOG(RPT1*RPT2)
14607 IF(PT.GT.PARP(93)) GOTO 120
14608 ELSEIF(MINT(106+JT).EQ.3) THEN
14609 PTA=SQRT(VINT(282+JT))
14611 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
14612 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
14613 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
14616 PTB=-PARP(99)*LOG(RPT1*RPT2)
14618 IF(PTB.GT.PARP(100)) GOTO 120
14619 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
14620 PT=PT*0.8D0**MINT(57)
14621 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
14622 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
14623 IF(MSTP(93).LE.0) THEN
14625 ELSEIF(MSTP(93).EQ.1) THEN
14626 PT=PARP(99)*SQRT(-LOG(PYR(0)))
14627 ELSEIF(MSTP(93).EQ.2) THEN
14630 PT=-PARP(99)*LOG(RPT1*RPT2)
14631 ELSEIF(MSTP(93).EQ.3) THEN
14634 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
14638 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
14639 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
14641 IF(PT.GT.PARP(100)) GOTO 120
14649 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14652 IF(MINT(47).EQ.1) RETURN
14654 C...Kinematics construction for initial partons.
14657 IF(ISUB.EQ.95) THEN
14661 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
14662 & (P(I1,2)+P(I2,2))**2
14663 SHR=SQRT(MAX(0D0,SHS))
14664 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
14665 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
14666 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
14667 P(I2,4)=SHR-P(I1,4)
14670 C...Transform partons to overall CM-frame.
14671 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
14672 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
14673 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
14674 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
14675 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
14676 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
14677 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
14678 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
14679 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
14680 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
14681 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
14684 C...Optionally fix up x and Q2 definitions for leptoproduction.
14686 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
14687 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
14688 IF(IDISXQ.EQ.1) THEN
14690 C...Find where incoming and outgoing leptons/partons are sitting.
14692 IF(MINT(42).EQ.1) LESD=2
14693 LPIN=MINT(83)+3-LESD
14695 LQIN=MINT(84)+3-LESD
14696 LEOUT=MINT(84)+2+LESD
14697 LQOUT=MINT(84)+5-LESD
14698 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
14699 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
14701 DO 140 I=MINT(84)+5,N
14702 IF(K(I,2).EQ.94) THEN
14709 IF(LESD.EQ.1) LQBG=IPU2
14711 C...Calculate actual and wanted momentum transfer.
14714 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
14715 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
14716 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
14717 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
14718 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
14719 P(N+1,1)=FAC*P(LEOUT,1)
14720 P(N+1,2)=FAC*P(LEOUT,2)
14721 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
14722 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
14723 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
14726 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
14727 QNEW(J)=P(LEIN,J)-P(N+1,J)
14730 C...Boost outgoing electron and daughters.
14731 IF(LSCMS.EQ.0) THEN
14733 P(LEOUT,J)=P(N+1,J)
14737 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
14739 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
14741 DBE(J)=PINV*P(N+2,J)
14745 190 IORIG=K(IORIG,3)
14746 IF(IORIG.GT.LEOUT) GOTO 190
14747 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
14748 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
14752 C...Copy shower initiator and all outgoing partons.
14756 P(NCOP,J)=P(LQBG,J)
14758 DO 240 I=MINT(84)+1,N
14760 IF(K(I,1).GT.10) GOTO 240
14761 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
14765 220 IORIG=K(IORIG,3)
14766 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
14768 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
14781 C...Calculate relative rescaling factors.
14785 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
14788 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
14791 C...Transfer extra three-momentum of current.
14794 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
14796 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14799 C...Iterate change of initiator momentum to get energy right.
14802 PEEX=-P(N+1,4)-QNEW(4)
14803 PEMV=-P(N+1,3)/P(N+1,4)
14806 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
14808 IF(ABS(PEMV).LT.1D-10) THEN
14810 MINT(57)=MINT(57)+1
14814 P(N+1,3)=P(N+1,3)+PZCH
14815 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)
14817 P(I,3)=P(I,3)+V(I,1)*PZCH
14818 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14820 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
14822 C...Modify momenta in event record.
14823 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
14824 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
14825 IF(ABS(HBE).GE.1D0) THEN
14827 MINT(57)=MINT(57)+1
14831 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
14840 C...Check minimum invariant mass of remnant system(s).
14841 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
14842 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
14843 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
14844 PMIN(0)=SQRT(PMS(0))
14846 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
14847 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
14849 IF(MINT(44+JT).EQ.1) GOTO 340
14850 MINT(105)=MINT(102+JT)
14851 MINT(109)=MINT(106+JT)
14852 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
14853 IF(MINT(51).NE.0) THEN
14854 MINT(57)=MINT(57)+1
14857 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
14858 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
14859 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
14860 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
14861 & P(MINT(83)+JT+2,2)**2)
14863 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
14864 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
14867 MINT(57)=MINT(57)+1
14871 C...Loop over two remnants; skip if none there.
14875 IF(MINT(44+JT).EQ.1) GOTO 410
14876 IF(JT.EQ.1) IPU=IPU1
14877 IF(JT.EQ.2) IPU=IPU2
14879 C...Store first remnant parton.
14891 P(I,5)=PYMASS(K(I,2))
14893 C...First parton colour connections and kinematics.
14894 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
14897 K(I,4)=MSTU(5)*IPU+IPU
14898 K(I,5)=MSTU(5)*IPU+IPU
14899 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14900 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14901 ELSEIF(KCOL.NE.0) THEN
14903 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
14905 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14907 IF(KFLCH(JT).EQ.0) THEN
14908 P(I,1)=-P(MINT(83)+JT+2,1)
14909 P(I,2)=-P(MINT(83)+JT+2,2)
14910 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14911 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
14915 C...When extra remnant parton or hadron: store extra remnant.
14927 P(I,5)=PYMASS(K(I,2))
14929 C...Find parton colour connections of extra remnant.
14930 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
14933 K(I,4)=MSTU(5)*IPU+IPU
14934 K(I,5)=MSTU(5)*IPU+IPU
14935 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14936 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14937 ELSEIF(KCOL.NE.0) THEN
14939 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
14941 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14944 C...Relative transverse momentum when two remnants.
14947 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
14948 IF(IABS(MINT(10+JT)).LT.20) THEN
14952 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
14953 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
14955 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
14956 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
14957 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
14958 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14960 C...Meson or baryon; photon as meson. For splitup below.
14962 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
14964 C***Relative distribution for electron into two electrons. Temporary!
14965 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
14969 C...Relative distribution of electron energy into electron plus parton.
14970 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
14973 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
14975 C...Relative distribution of energy for particle into two jets.
14976 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
14977 CHIK=PARP(92+2*IMB)
14978 IF(MSTP(92).LE.1) THEN
14979 IF(IMB.EQ.1) CHI(JT)=PYR(0)
14980 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
14981 ELSEIF(MSTP(92).EQ.2) THEN
14982 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
14983 ELSEIF(MSTP(92).EQ.3) THEN
14984 CUT=2D0*0.3D0/VINT(1)
14985 380 CHI(JT)=PYR(0)**2
14986 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
14987 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
14988 ELSEIF(MSTP(92).EQ.4) THEN
14989 CUT=2D0*0.3D0/VINT(1)
14990 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
14991 390 CHIR=CUT*CUTR**PYR(0)
14992 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
14993 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
14995 CUT=2D0*0.3D0/VINT(1)
14996 CUTA=CUT**(1D0-PARP(98))
14997 CUTB=(1D0+CUT)**(1D0-PARP(98))
14998 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
14999 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
15000 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
15003 C...Relative distribution of energy for particle into jet plus particle.
15005 IF(MSTP(94).LE.1) THEN
15006 IF(IMB.EQ.1) CHI(JT)=PYR(0)
15007 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
15008 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
15009 ELSEIF(MSTP(94).EQ.2) THEN
15010 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
15011 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
15012 ELSEIF(MSTP(94).EQ.3) THEN
15013 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
15016 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
15021 C...Construct total transverse mass; reject if too large.
15022 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
15023 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
15024 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
15025 IF(LOOP.LT.100) THEN
15029 MINT(57)=MINT(57)+1
15033 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
15034 VINT(158+JT)=CHI(JT)
15036 C...Subdivide longitudinal momentum according to value selected above.
15037 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
15038 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
15039 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
15040 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
15041 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
15046 C...Check if longitudinal boosts needed - if so pick two systems.
15047 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
15048 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
15049 IF(PDEV.LE.1D-6*VINT(1)) RETURN
15050 IF(ISN(1).EQ.0) THEN
15053 ELSEIF(ISN(2).EQ.0) THEN
15056 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
15059 ELSEIF(VINT(143).GT.0.2D0) THEN
15062 ELSEIF(VINT(144).GT.0.2D0) THEN
15065 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
15074 C...E+-pL wanted for system to be modified.
15075 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
15079 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
15080 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
15083 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
15084 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
15085 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
15086 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
15090 DO 450 I=MINT(84)+1,NS
15091 IF(K(I,1).GT.10) GOTO 450
15094 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
15096 IF(IORIG.GT.LPIN) GOTO 430
15097 IF(INCL.EQ.0) GOTO 450
15099 PSYS(0,J)=PSYS(0,J)+P(I,J)
15102 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
15103 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
15104 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
15107 C...Construct longitudinal boosts.
15111 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
15112 IF(DSQLAM.LE.1D-6*DPMTB) THEN
15114 MINT(57)=MINT(57)+1
15117 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
15118 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
15119 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
15120 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
15121 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
15122 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
15123 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
15125 C...Perform longitudinal boosts.
15126 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
15128 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
15129 ELSEIF(IR.EQ.1) THEN
15130 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
15131 ELSEIF(IDISXQ.EQ.1) THEN
15135 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
15137 IF(IORIG.GT.LPIN) GOTO 460
15138 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
15141 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
15143 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
15145 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
15146 ELSEIF(IL.EQ.2) THEN
15147 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
15148 ELSEIF(IDISXQ.EQ.1) THEN
15152 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
15154 IF(IORIG.GT.LPIN) GOTO 480
15155 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
15158 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
15161 C...Final check that energy-momentum conservation worked.
15164 DO 500 I=MINT(84)+1,N
15165 IF(K(I,1).GT.10) GOTO 500
15169 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
15170 IF(PDEV.GT.1D-4*VINT(1)) THEN
15172 MINT(57)=MINT(57)+1
15176 C...Calculate rotation and boost from overall CM frame to
15177 C...hadronic CM frame in leptoproduction.
15179 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
15182 IF(MINT(42).EQ.1) LESD=2
15183 LPIN=MINT(83)+3-LESD
15185 C...Sum upp momenta of everything not lepton or photon to define boost.
15190 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
15191 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
15192 IF(K(I,2).EQ.22) GOTO 530
15194 PSUM(J)=PSUM(J)+P(I,J)
15197 VINT(223)=-PSUM(1)/PSUM(4)
15198 VINT(224)=-PSUM(2)/PSUM(4)
15199 VINT(225)=-PSUM(3)/PSUM(4)
15201 C...Boost incoming hadron to hadronic CM frame to determine rotations.
15207 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
15208 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
15209 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
15211 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
15213 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
15220 C*********************************************************************
15223 C...Handles diffractive and elastic scattering.
15227 C...Double precision and integer declarations.
15228 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15229 IMPLICIT INTEGER(I-N)
15230 INTEGER PYK,PYCHGE,PYCOMP
15232 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15233 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15234 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15235 COMMON/PYINT1/MINT(400),VINT(400)
15236 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
15238 C...Reset K, P and V vectors. Store incoming particles.
15239 DO 110 JT=1,MSTP(126)+10
15259 P(I,J)=VINT(285+5*JT+J)
15264 C...Subprocess; kinematics.
15265 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
15266 PZ=SQRT(SQLAM)/(2D0*VINT(1))
15269 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
15272 C...Elastically scattered particle. (Except elastic GVMD states.)
15273 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
15274 & MINT(106+JT).NE.3)) THEN
15279 P(N,3)=PZ*(-1)**(JT+1)
15281 P(N,5)=SQRT(VINT(62+JT))
15283 C...Decay rho from elastic scattering of gamma with sin**2(theta)
15284 C...distribution of decay products (in rho rest frame).
15285 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
15287 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
15291 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
15292 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
15293 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
15294 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
15295 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
15296 140 CTHE=2D0*PYR(0)-1D0
15297 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
15298 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
15300 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
15303 C...Diffracted particle: low-mass system to two particles.
15304 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
15310 PMMAS=SQRT(VINT(62+JT))
15313 IF(NTRY.LT.20) THEN
15314 MINT(105)=MINT(102+JT)
15315 MINT(109)=MINT(106+JT)
15316 CALL PYSPLI(KFH,21,KFL1,KFL2)
15317 CALL PYKFDI(KFL1,0,KFL3,KF1)
15318 IF(KF1.EQ.0) GOTO 150
15319 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
15320 IF(KF2.EQ.0) GOTO 150
15327 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
15332 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
15333 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
15336 P(N-1,4)=SQRT(PM1**2+PZP**2)
15337 P(N,4)=SQRT(PM2**2+PZP**2)
15338 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
15340 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
15341 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
15343 C...Diffracted particle: valence quark kicked out.
15344 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
15351 MINT(105)=MINT(102+JT)
15352 MINT(109)=MINT(106+JT)
15353 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
15354 P(N-1,5)=PYMASS(K(N-1,2))
15355 P(N,5)=PYMASS(K(N,2))
15356 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
15357 & 4D0*P(N-1,5)**2*P(N,5)**2
15358 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
15359 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
15360 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
15361 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
15362 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
15364 C...Diffracted particle: gluon kicked out.
15373 MINT(105)=MINT(102+JT)
15374 MINT(109)=MINT(106+JT)
15375 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
15377 P(N-2,5)=PYMASS(K(N-2,2))
15379 P(N,5)=PYMASS(K(N,2))
15380 C...Energy distribution for particle into two jets.
15382 IF(MOD(KFH/1000,10).NE.0) IMB=2
15383 CHIK=PARP(92+2*IMB)
15384 IF(MSTP(92).LE.1) THEN
15385 IF(IMB.EQ.1) CHI=PYR(0)
15386 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15387 ELSEIF(MSTP(92).EQ.2) THEN
15388 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
15389 ELSEIF(MSTP(92).EQ.3) THEN
15390 CUT=2D0*0.3D0/VINT(1)
15392 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
15394 ELSEIF(MSTP(92).EQ.4) THEN
15395 CUT=2D0*0.3D0/VINT(1)
15396 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
15397 180 CHIR=CUT*CUTR**PYR(0)
15398 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
15399 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
15401 CUT=2D0*0.3D0/VINT(1)
15402 CUTA=CUT**(1D0-PARP(98))
15403 CUTB=(1D0+CUT)**(1D0-PARP(98))
15404 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
15405 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
15406 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
15408 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
15409 & VINT(62+JT)) GOTO 160
15410 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
15411 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
15412 & (2D0*VINT(62+JT))
15413 PEI=SQRT(PZI**2+SQM)
15414 PQQP=(1D0-CHI)*(PEI+PZI)
15415 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
15416 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
15417 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
15418 P(N-1,3)=P(N-1,4)*(-1)**JT
15419 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
15420 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
15423 C...Documentation lines.
15425 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
15426 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
15427 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
15429 P(I+2,3)=PZ*(-1)**(JT+1)
15431 P(I+2,5)=SQRT(VINT(62+JT))
15434 C...Rotate outgoing partons/particles using cos(theta).
15435 IF(VINT(23).LT.0.9D0) THEN
15436 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
15438 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
15444 C*********************************************************************
15447 C...Set up a DIS process as gamma* + f -> f, with beam remnant
15448 C...and showering added consecutively. Photon flux by the PYGAGA
15449 C...routine (if at all).
15453 C...Double precision and integer declarations.
15454 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15455 IMPLICIT INTEGER(I-N)
15456 INTEGER PYK,PYCHGE,PYCOMP
15457 C...Parameter statement to help give large particle numbers.
15458 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
15459 &KEXCIT=4000000,KDIMEN=5000000)
15461 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15462 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15463 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15464 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15465 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15466 COMMON/PYINT1/MINT(400),VINT(400)
15467 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
15471 C...Choice of subprocess, number of documentation lines
15479 IF(MINT(107).EQ.4) ISIDE=2
15481 C...Reset K, P and V vectors. Store incoming particles
15482 DO 110 JT=1,MSTP(126)+20
15495 P(I,J)=VINT(285+5*JT+J)
15500 C...Store incoming partons in hadronic CM-frame
15505 K(I,3)=MINT(83)+2+JT
15507 IF(MINT(15).EQ.22) THEN
15508 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
15509 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
15510 P(MINT(84)+1,5)=-SQRT(VINT(307))
15511 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
15512 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
15516 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
15517 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
15518 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
15519 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
15520 P(MINT(84)+1,5)=-SQRT(VINT(308))
15524 SIDESG=(-1D0)**(ISIDE-1)
15526 C...Copy incoming partons to documentation lines.
15537 C...Second copy for partons before ISR shower, since no such.
15547 C...Define initial partons.
15550 IF(NTRY.GT.100) THEN
15555 C...Scattered quark in hadronic CM frame.
15560 P(IPU3,5)=PYMASS(KFRES)
15561 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
15562 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
15566 K(I,3)=MINT(83)+4+ISIDE
15574 C...No primordial kT, or chosen according to truncated Gaussian or
15575 C...exponential, or (for photon) predetermined or power law.
15576 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
15577 IF(MSTP(91).LE.0) THEN
15579 ELSEIF(MSTP(91).EQ.1) THEN
15580 PT=PARP(91)*SQRT(-LOG(PYR(0)))
15584 PT=-PARP(92)*LOG(RPT1*RPT2)
15586 IF(PT.GT.PARP(93)) GOTO 190
15587 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
15588 PTA=SQRT(VINT(282+ISIDE))
15590 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
15591 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
15592 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
15595 PTB=-PARP(99)*LOG(RPT1*RPT2)
15597 IF(PTB.GT.PARP(100)) GOTO 190
15598 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
15599 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
15600 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
15601 IF(MSTP(93).LE.0) THEN
15603 ELSEIF(MSTP(93).EQ.1) THEN
15604 PT=PARP(99)*SQRT(-LOG(PYR(0)))
15605 ELSEIF(MSTP(93).EQ.2) THEN
15608 PT=-PARP(99)*LOG(RPT1*RPT2)
15609 ELSEIF(MSTP(93).EQ.3) THEN
15612 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
15616 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
15617 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
15619 IF(PT.GT.PARP(100)) GOTO 190
15625 P(IPU3,1)=PT*COS(PHI)
15626 P(IPU3,2)=PT*SIN(PHI)
15627 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
15628 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
15629 PCP=P(IPU3,4)+ABS(P(IPU3,3))
15631 C...Find one or two beam remnants.
15632 MINT(105)=MINT(102+ISIDE)
15633 MINT(109)=MINT(106+ISIDE)
15634 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
15635 IF(MINT(51).NE.0) THEN
15640 C...Store first remnant parton, with colour info and kinematics.
15644 K(I,3)=MINT(83)+ISIDE
15645 P(I,5)=PYMASS(K(I,2))
15646 KCOL=KCHG(PYCOMP(KFLSP),2)
15649 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
15650 K(I,KFLS+3)=MSTU(5)*IPU3
15651 K(IPU3,6-KFLS)=MSTU(5)*I
15654 IF(KFLCH.EQ.0) THEN
15657 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15659 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
15660 PRP=P(I,4)+ABS(P(I,3))
15662 C...When extra remnant parton or hadron: store extra remnant.
15667 K(I,3)=MINT(83)+ISIDE
15668 P(I,5)=PYMASS(K(I,2))
15669 KCOL=KCHG(PYCOMP(KFLCH),2)
15672 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
15673 K(I,KFLS+3)=MSTU(5)*IPU3
15674 K(IPU3,6-KFLS)=MSTU(5)*I
15678 C...Relative transverse momentum when two remnants.
15681 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
15682 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
15683 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
15684 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
15685 P(I,1)=-P(IPU3,1)-P(I-1,1)
15686 P(I,2)=-P(IPU3,2)-P(I-1,2)
15687 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15689 C...Relative distribution of energy for particle into jet plus particle.
15691 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
15692 IF(MSTP(94).LE.1) THEN
15693 IF(IMB.EQ.1) CHI=PYR(0)
15694 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15695 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15696 ELSEIF(MSTP(94).EQ.2) THEN
15697 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
15698 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15699 ELSEIF(MSTP(94).EQ.3) THEN
15700 CALL PYZDIS(1,0,PMS(4),ZZ)
15703 CALL PYZDIS(1000,0,PMS(4),ZZ)
15707 C...Construct total transverse mass; reject if too large.
15708 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
15709 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
15710 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
15711 IF(LOOP.LT.10) GOTO 200
15714 VINT(158+ISIDE)=CHI
15716 C...Subdivide longitudinal momentum according to value selected above.
15717 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
15719 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
15720 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
15722 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
15723 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
15727 C...Boost current and remnant systems to correct frame.
15728 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
15729 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
15730 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
15732 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
15734 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
15735 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
15736 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
15737 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
15739 C...Let current quark shower; recoil but no showering by colour partner.
15740 QMAX=2D0*SQRT(VINT(309-ISIDE))
15745 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
15752 C*********************************************************************
15755 C...Handles the documentation of the process in MSTI and PARI,
15756 C...and also computes cross-sections based on accumulated statistics.
15760 C...Double precision and integer declarations.
15761 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15762 IMPLICIT INTEGER(I-N)
15763 INTEGER PYK,PYCHGE,PYCOMP
15765 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15766 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15767 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15768 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15769 COMMON/PYINT1/MINT(400),VINT(400)
15770 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15771 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15772 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
15775 C...Calculate Monte Carlo estimates of cross-sections.
15777 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
15778 NGEN(0,3)=NGEN(0,3)+1
15781 IF(I.EQ.96.OR.I.EQ.97) THEN
15783 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
15784 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
15785 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
15786 & DBLE(NGEN(96,2)))
15787 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
15788 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
15789 & DBLE(NGEN(96,2)))
15790 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
15792 ELSEIF(NGEN(I,2).EQ.0) THEN
15793 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
15796 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
15799 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
15802 C...Rescale to known low-pT cross-section for standard QCD processes.
15803 IF(MSUB(95).EQ.1) THEN
15804 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
15805 & XSEC(68,3)+XSEC(95,3)
15806 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
15807 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
15809 XSEC(11,3)=FAC*XSEC(11,3)
15810 XSEC(12,3)=FAC*XSEC(12,3)
15811 XSEC(13,3)=FAC*XSEC(13,3)
15812 XSEC(28,3)=FAC*XSEC(28,3)
15813 XSEC(53,3)=FAC*XSEC(53,3)
15814 XSEC(68,3)=FAC*XSEC(68,3)
15815 XSEC(95,3)=FAC*XSEC(95,3)
15816 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
15820 C...Save information for gamma-p and gamma-gamma.
15821 IF(MINT(121).GT.1) THEN
15827 C...Reset information on hard interaction.
15833 C...Copy integer valued information from MINT into MSTI.
15837 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
15839 C...Store cross-section variables in PARI.
15841 PARI(2)=XSEC(0,3)/MINT(5)
15845 VINT(98)=VINT(98)+VINT(100)
15846 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
15848 C...Store kinematics variables in PARI.
15851 IF(ISUB.NE.95) THEN
15859 PARI(35)=PARI(33)-PARI(34)
15866 PARI(42)=2D0*VINT(47)/VINT(1)
15869 C...Store information on scattered partons in PARI.
15870 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
15873 PARI(36+IS)=P(I,3)/VINT(1)
15874 PARI(38+IS)=P(I,4)/VINT(1)
15875 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
15876 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15877 & SQRT(PR),1D20)),P(I,3))
15878 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
15879 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15880 & SQRT(PR),1D20)),P(I,3))
15881 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
15882 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
15883 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
15887 C...Store sum up transverse and longitudinal momenta.
15888 PARI(65)=2D0*PARI(17)
15889 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
15890 DO 150 I=MSTP(126)+1,N
15891 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
15892 PT=SQRT(P(I,1)**2+P(I,2)**2)
15893 PARI(69)=PARI(69)+PT
15894 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
15895 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
15907 C...Store various other pieces of information into PARI.
15915 C...Store information on lepton -> lepton + gamma in PYGAGA.
15918 PARI(101)=VINT(301)
15919 PARI(102)=VINT(302)
15921 PARI(I)=VINT(I+202)
15924 C...Set information for PYTABU.
15925 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
15928 ELSEIF(ISET(ISUB).EQ.5) THEN
15939 C*********************************************************************
15942 C...Performs transformations between different coordinate frames.
15944 SUBROUTINE PYFRAM(IFRAME)
15946 C...Double precision and integer declarations.
15947 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15948 IMPLICIT INTEGER(I-N)
15949 INTEGER PYK,PYCHGE,PYCOMP
15951 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15952 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15953 COMMON/PYINT1/MINT(400),VINT(400)
15954 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
15956 C...Check that transformation can and should be done.
15957 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
15958 &MINT(91).EQ.1)) THEN
15959 IF(IFRAME.EQ.MINT(6)) RETURN
15961 WRITE(MSTU(11),5000) IFRAME,MINT(6)
15965 IF(MINT(6).EQ.1) THEN
15966 C...Transform from fixed target or user specified frame to
15967 C...overall CM frame.
15968 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
15969 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
15970 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
15971 ELSEIF(MINT(6).EQ.3) THEN
15972 C...Transform from hadronic CM frame in DIS to overall CM frame.
15973 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
15977 IF(IFRAME.EQ.1) THEN
15978 C...Transform from overall CM frame to fixed target or user specified
15980 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
15981 ELSEIF(IFRAME.EQ.3) THEN
15982 C...Transform from overall CM frame to hadronic CM frame in DIS.
15983 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
15984 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
15985 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
15988 C...Set information about new frame.
15992 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
15993 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
15999 C*********************************************************************
16002 C...Calculates full and partial widths of resonances.
16004 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
16006 C...Double precision and integer declarations.
16007 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16008 IMPLICIT INTEGER(I-N)
16009 INTEGER PYK,PYCHGE,PYCOMP
16010 C...Parameter statement to help give large particle numbers.
16011 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16012 &KEXCIT=4000000,KDIMEN=5000000)
16014 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16015 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16016 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16017 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16018 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16019 COMMON/PYINT1/MINT(400),VINT(400)
16020 COMMON/PYINT4/MWID(500),WIDS(500,5)
16021 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
16022 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
16023 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
16024 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
16025 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
16026 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/
16027 C...Local arrays and saved variables.
16028 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
16029 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
16030 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
16031 SAVE MOFSV,WIDWSV,WID2SV
16032 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
16034 C...Compressed code and sign; mass.
16041 C...Reset width information.
16042 DO 110 I=0,MDCY(KC,3)
16049 C...Allow for fudge factor to rescale resonance width.
16051 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
16052 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
16053 IF(MSTP(110).EQ.KFLA) THEN
16055 ELSEIF(MSTP(110).EQ.-1) THEN
16056 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
16057 ELSEIF(MSTP(110).EQ.-2) THEN
16062 C...Not to be treated as a resonance: return.
16063 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
16072 C...Treatment as a resonance based on tabulated branching ratios.
16073 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
16074 C...Loop over possible decay channels; skip irrelevant ones.
16075 DO 120 I=1,MDCY(KC,3)
16077 IF(MDME(IDC,1).LT.0) GOTO 120
16079 C...Read out decay products and nominal masses.
16082 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
16086 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
16092 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
16096 C...Naive partial width and alternative threshold factors.
16097 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
16098 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
16099 & PM1+PM2+PM3.GE.SHR) THEN
16101 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
16102 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
16103 & 4D0*PM1**2*PM2**2))/SH
16104 ELSEIF(MDME(IDC,2).EQ.52) THEN
16105 PMA=MAX(PM1,PM2,PM3)
16106 PMC=MIN(PM1,PM2,PM3)
16107 PMB=PM1+PM2+PM3-PMA-PMC
16108 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
16113 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
16114 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
16115 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
16116 & ((SHR-PMA)**2-(PMB+PMC)**2)*
16117 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
16118 & ((1D0-PMBCN)*PMBCN*SH)
16119 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
16120 WDTP(I)=WDTP(I)*SQRT(
16121 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
16122 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
16123 ELSEIF(MDME(IDC,2).EQ.53) THEN
16124 PMA=MAX(PM1,PM2,PM3)
16125 PMC=MIN(PM1,PM2,PM3)
16126 PMB=PM1+PM2+PM3-PMA-PMC
16127 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
16132 FACACT=SQRT(MAX(0D0,
16133 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
16134 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
16135 & ((SHR-PMA)**2-(PMB+PMC)**2)*
16136 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
16137 & ((1D0-PMBCN)*PMBCN*SH)
16138 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
16142 PMBCN=PMBC**2/PMR**2
16143 FACNOM=SQRT(MAX(0D0,
16144 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
16145 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
16146 & ((PMR-PMA)**2-(PMB+PMC)**2)*
16147 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
16148 & ((1D0-PMBCN)*PMBCN*PMR**2)
16149 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
16151 WDTP(I)=FUDGE*WDTP(I)
16152 WDTP(0)=WDTP(0)+WDTP(I)
16154 C...Calculate secondary width (at most two identical/opposite).
16156 IF(MDME(IDC,1).GT.0) THEN
16157 IF(KFD2.EQ.KFD1) THEN
16158 IF(KCHG(KFC1,3).EQ.0) THEN
16160 ELSEIF(KFD1.GT.0) THEN
16166 WID2=WID2*WIDS(KFC3,2)
16167 ELSEIF(KFD3.LT.0) THEN
16168 WID2=WID2*WIDS(KFC3,3)
16170 ELSEIF(KFD2.EQ.-KFD1) THEN
16173 WID2=WID2*WIDS(KFC3,2)
16174 ELSEIF(KFD3.LT.0) THEN
16175 WID2=WID2*WIDS(KFC3,3)
16177 ELSEIF(KFD3.EQ.KFD1) THEN
16178 IF(KCHG(KFC1,3).EQ.0) THEN
16180 ELSEIF(KFD1.GT.0) THEN
16186 WID2=WID2*WIDS(KFC2,2)
16187 ELSEIF(KFD2.LT.0) THEN
16188 WID2=WID2*WIDS(KFC2,3)
16190 ELSEIF(KFD3.EQ.-KFD1) THEN
16193 WID2=WID2*WIDS(KFC2,2)
16194 ELSEIF(KFD2.LT.0) THEN
16195 WID2=WID2*WIDS(KFC2,3)
16197 ELSEIF(KFD3.EQ.KFD2) THEN
16198 IF(KCHG(KFC2,3).EQ.0) THEN
16200 ELSEIF(KFD2.GT.0) THEN
16206 WID2=WID2*WIDS(KFC1,2)
16207 ELSEIF(KFD1.LT.0) THEN
16208 WID2=WID2*WIDS(KFC1,3)
16210 ELSEIF(KFD3.EQ.-KFD2) THEN
16213 WID2=WID2*WIDS(KFC1,2)
16214 ELSEIF(KFD1.LT.0) THEN
16215 WID2=WID2*WIDS(KFC1,3)
16224 WID2=WID2*WIDS(KFC2,2)
16226 WID2=WID2*WIDS(KFC2,3)
16229 WID2=WID2*WIDS(KFC3,2)
16230 ELSEIF(KFD3.LT.0) THEN
16231 WID2=WID2*WIDS(KFC3,3)
16235 C...Store effective widths according to case.
16236 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16237 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16238 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16239 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16249 C...Here begins detailed dynamical calculation of resonance widths.
16250 C...Shared treatment of Higgs states.
16253 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
16258 C...Common electroweak and strong constants.
16261 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
16264 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
16266 RADC=1D0+AS/PARU(1)
16270 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16271 RADCT=1D0-2.5D0*AS/PARU(1)
16272 DO 140 I=1,MDCY(KC,3)
16274 IF(MDME(IDC,1).LT.0) GOTO 140
16275 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16276 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16277 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
16279 IF(I.GE.4.AND.I.LE.7) THEN
16280 C...t -> W + q; including approximate QCD correction factor.
16281 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
16282 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16283 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16286 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
16289 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
16291 ELSEIF(I.EQ.9) THEN
16293 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16294 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16296 IF(KFLR.LT.0) WID2=WIDS(37,3)
16298 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
16299 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
16302 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
16305 KFC1=PYCOMP(KFDP(IDC,1))
16306 KFC2=PYCOMP(KFDP(IDC,2))
16307 PMNCHI=PMAS(KFC1,1)
16308 PMSTOP=PMAS(KFC2,1)
16309 IF(SHR.GT.PMNCHI+PMSTOP) THEN
16312 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
16314 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
16315 AR=-ET*ZMIXC(IZ,1)*TANW
16316 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
16318 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
16319 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
16320 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
16321 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
16322 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
16323 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
16324 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
16326 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
16328 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
16331 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
16333 KFC1=PYCOMP(KFDP(IDC,1))
16334 KFC2=PYCOMP(KFDP(IDC,2))
16335 PMNCHI=PMAS(KFC1,1)
16336 PMSTOP=PMAS(KFC2,1)
16337 IF(SHR.GT.PMNCHI+PMSTOP) THEN
16340 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
16341 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
16342 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
16343 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
16345 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
16347 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
16350 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
16351 C...t -> ~gravitino + ~t
16353 KFC1=PYCOMP(KFDP(IDC,1))
16354 XMGR2=PMAS(KFC1,1)**2
16355 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
16356 KFC2=PYCOMP(KFDP(IDC,2))
16358 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
16361 WDTP(I)=FUDGE*WDTP(I)
16362 WDTP(0)=WDTP(0)+WDTP(I)
16363 IF(MDME(IDC,1).GT.0) THEN
16364 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16365 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16366 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16367 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16371 ELSEIF(KFLA.EQ.7) THEN
16373 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16374 DO 150 I=1,MDCY(KC,3)
16376 IF(MDME(IDC,1).LT.0) GOTO 150
16377 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16378 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16379 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
16381 IF(I.GE.4.AND.I.LE.7) THEN
16383 WDTP(I)=FAC*VCKM(I-3,4)*
16384 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16385 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16388 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
16389 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
16392 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
16393 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
16396 IF(KFLR.LT.0) WID2=WIDS(24,2)
16397 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16399 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16400 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16403 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
16406 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
16409 WDTP(I)=FUDGE*WDTP(I)
16410 WDTP(0)=WDTP(0)+WDTP(I)
16411 IF(MDME(IDC,1).GT.0) THEN
16412 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16413 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16414 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16415 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16419 ELSEIF(KFLA.EQ.8) THEN
16421 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16422 DO 160 I=1,MDCY(KC,3)
16424 IF(MDME(IDC,1).LT.0) GOTO 160
16425 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16426 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16427 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
16429 IF(I.GE.4.AND.I.LE.7) THEN
16431 WDTP(I)=FAC*VCKM(4,I-3)*
16432 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16433 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16436 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
16439 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
16441 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16443 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16444 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16447 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
16450 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
16453 WDTP(I)=FUDGE*WDTP(I)
16454 WDTP(0)=WDTP(0)+WDTP(I)
16455 IF(MDME(IDC,1).GT.0) THEN
16456 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16457 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16458 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16459 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16463 ELSEIF(KFLA.EQ.17) THEN
16465 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16466 DO 170 I=1,MDCY(KC,3)
16468 IF(MDME(IDC,1).LT.0) GOTO 170
16469 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16470 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16471 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
16474 C...tau' -> W + nu'_tau.
16475 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16476 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16479 WID2=WID2*WIDS(18,2)
16482 WID2=WID2*WIDS(18,3)
16484 ELSEIF(I.EQ.5) THEN
16485 C...tau' -> H + nu'_tau.
16486 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16487 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16490 WID2=WID2*WIDS(18,2)
16493 WID2=WID2*WIDS(18,3)
16496 WDTP(I)=FUDGE*WDTP(I)
16497 WDTP(0)=WDTP(0)+WDTP(I)
16498 IF(MDME(IDC,1).GT.0) THEN
16499 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16500 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16501 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16502 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16506 ELSEIF(KFLA.EQ.18) THEN
16507 C...nu'_tau neutrino.
16508 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16509 DO 180 I=1,MDCY(KC,3)
16511 IF(MDME(IDC,1).LT.0) GOTO 180
16512 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16513 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16514 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
16517 C...nu'_tau -> W + tau'.
16518 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16519 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16522 WID2=WID2*WIDS(17,2)
16525 WID2=WID2*WIDS(17,3)
16527 ELSEIF(I.EQ.3) THEN
16528 C...nu'_tau -> H + tau'.
16529 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16530 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16533 WID2=WID2*WIDS(17,2)
16536 WID2=WID2*WIDS(17,3)
16539 WDTP(I)=FUDGE*WDTP(I)
16540 WDTP(0)=WDTP(0)+WDTP(I)
16541 IF(MDME(IDC,1).GT.0) THEN
16542 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16543 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16544 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16545 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16549 ELSEIF(KFLA.EQ.21) THEN
16551 C***Note that widths are not given in dimensional quantities here.
16552 DO 190 I=1,MDCY(KC,3)
16554 IF(MDME(IDC,1).LT.0) GOTO 190
16555 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16556 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16557 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
16560 C...QCD -> q + qbar
16561 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16562 IF(I.EQ.6) WID2=WIDS(6,1)
16563 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16565 WDTP(I)=FUDGE*WDTP(I)
16566 WDTP(0)=WDTP(0)+WDTP(I)
16567 IF(MDME(IDC,1).GT.0) THEN
16568 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16569 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16570 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16571 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16575 ELSEIF(KFLA.EQ.22) THEN
16577 C***Note that widths are not given in dimensional quantities here.
16578 DO 200 I=1,MDCY(KC,3)
16580 IF(MDME(IDC,1).LT.0) GOTO 200
16581 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16582 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16583 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
16586 C...QED -> q + qbar.
16589 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16590 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16591 IF(I.EQ.6) WID2=WIDS(6,1)
16592 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16593 ELSEIF(I.LE.12) THEN
16594 C...QED -> l+ + l-.
16595 EF=KCHG(9+2*(I-8),1)/3D0
16596 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16597 IF(I.EQ.12) WID2=WIDS(17,1)
16599 WDTP(I)=FUDGE*WDTP(I)
16600 WDTP(0)=WDTP(0)+WDTP(I)
16601 IF(MDME(IDC,1).GT.0) THEN
16602 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16603 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16604 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16605 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16609 ELSEIF(KFLA.EQ.23) THEN
16612 XWC=1D0/(16D0*XW*XW1)
16613 FAC=(AEM*XWC/3D0)*SHR
16615 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
16620 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16622 IF(KFI.GT.20) KFI=IABS(MINT(16))
16628 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
16629 IF(MSTP(43).EQ.3) VINT(112)=
16630 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
16631 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16632 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
16634 DO 220 I=1,MDCY(KC,3)
16636 IF(MDME(IDC,1).LT.0) GOTO 220
16637 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16638 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16639 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
16644 AF=SIGN(1D0,EF+0.1D0)
16647 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16648 IF(I.EQ.6) WID2=WIDS(6,1)
16649 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16650 ELSEIF(I.LE.16) THEN
16651 C...Z0 -> l+ + l-, nu + nubar
16653 AF=SIGN(1D0,EF+0.1D0)
16656 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
16658 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16659 IF(ICASE.EQ.1) THEN
16660 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
16662 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16663 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
16664 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
16665 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
16666 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16667 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
16668 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16669 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
16671 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
16672 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
16673 IF(MDME(IDC,1).GT.0) THEN
16674 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
16675 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
16676 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16677 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
16678 & WDTE(I,MDME(IDC,1))
16679 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16680 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16682 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16683 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
16684 & VINT(111)+FGGF*WID2
16685 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
16686 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16687 & VINT(114)+FZZF*WID2
16691 IF(MINT(61).GE.1) ICASE=3-ICASE
16692 IF(ICASE.EQ.2) GOTO 210
16694 ELSEIF(KFLA.EQ.24) THEN
16696 FAC=(AEM/(24D0*XW))*SHR
16697 DO 230 I=1,MDCY(KC,3)
16699 IF(MDME(IDC,1).LT.0) GOTO 230
16700 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16701 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16702 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
16705 C...W+/- -> q + qbar'
16706 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
16708 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
16709 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
16710 IF(I.GE.13) WID2=WID2*WIDS(7,3)
16712 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
16713 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
16714 IF(I.GE.13) WID2=WID2*WIDS(7,2)
16716 ELSEIF(I.LE.20) THEN
16717 C...W+/- -> l+/- + nu
16720 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
16722 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
16725 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
16726 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16727 WDTP(I)=FUDGE*WDTP(I)
16728 WDTP(0)=WDTP(0)+WDTP(I)
16729 IF(MDME(IDC,1).GT.0) THEN
16730 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16731 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16732 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16733 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16737 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
16738 C...h0 (or H0, or A0):
16740 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
16741 DO 270 I=1,MDCY(KFHIGG,3)
16742 IDC=I+MDCY(KFHIGG,2)-1
16743 IF(MDME(IDC,1).LT.0) GOTO 270
16744 KFC1=PYCOMP(KFDP(IDC,1))
16745 KFC2=PYCOMP(KFDP(IDC,2))
16746 RM1=PMAS(KFC1,1)**2/SH
16747 RM2=PMAS(KFC2,1)**2/SH
16748 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
16754 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
16755 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
16756 C...A0 behaves like beta, ho and H0 like beta**3.
16757 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16758 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16759 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
16760 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
16761 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
16762 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
16763 IF(IHIGG.NE.3) THEN
16764 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
16765 & PARU(151+10*IHIGG))**2
16769 IF(I.EQ.6) WID2=WIDS(6,1)
16770 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16771 ELSEIF(I.LE.12) THEN
16773 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
16774 C...A0 behaves like beta, ho and H0 like beta**3.
16775 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16776 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
16777 & PARU(153+10*IHIGG)**2
16778 IF(I.EQ.12) WID2=WIDS(17,1)
16780 ELSEIF(I.EQ.13) THEN
16781 C...h0 -> g + g; quark loop contribution only
16784 DO 240 J=1,2*MSTP(1)
16785 EPS=(2D0*PMAS(J,1))**2/SH
16786 C...Loop integral; function of eps=4m^2/shat; different for A0.
16787 IF(EPS.LE.1D0) THEN
16788 IF(EPS.GT.1D-4) THEN
16790 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16792 RLN=LOG(4D0/EPS-2D0)
16794 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16795 PHIIM=0.5D0*PARU(1)*RLN
16797 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16800 IF(IHIGG.LE.2) THEN
16801 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16802 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
16804 ETAREJ=-0.5D0*EPS*PHIRE
16805 ETAIMJ=-0.5D0*EPS*PHIIM
16807 C...Couplings (=1 for standard model Higgs).
16808 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16809 IF(MOD(J,2).EQ.1) THEN
16810 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
16811 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
16813 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
16814 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
16820 ETA2=ETARE**2+ETAIM**2
16821 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
16823 ELSEIF(I.EQ.14) THEN
16824 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
16828 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16830 IF(J.LE.2*MSTP(1)) THEN
16832 EPS=(2D0*PMAS(J,1))**2/SH
16833 ELSEIF(J.LE.3*MSTP(1)) THEN
16834 JL=2*(J-2*MSTP(1))-1
16835 EJ=KCHG(10+JL,1)/3D0
16836 EPS=(2D0*PMAS(10+JL,1))**2/SH
16837 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16838 EPS=(2D0*PMAS(24,1))**2/SH
16840 EPS=(2D0*PMAS(37,1))**2/SH
16842 C...Loop integral; function of eps=4m^2/shat.
16843 IF(EPS.LE.1D0) THEN
16844 IF(EPS.GT.1D-4) THEN
16846 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16848 RLN=LOG(4D0/EPS-2D0)
16850 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16851 PHIIM=0.5D0*PARU(1)*RLN
16853 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16856 IF(J.LE.3*MSTP(1)) THEN
16857 C...Fermion loops: loop integral different for A0; charges.
16858 IF(IHIGG.LE.2) THEN
16859 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16860 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
16862 PHIPRE=-0.5D0*EPS*PHIRE
16863 PHIPIM=-0.5D0*EPS*PHIIM
16865 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16867 EJH=PARU(151+10*IHIGG)
16868 ELSEIF(J.LE.2*MSTP(1)) THEN
16870 EJH=PARU(152+10*IHIGG)
16873 EJH=PARU(153+10*IHIGG)
16875 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16876 ETAREJ=EJC*EJH*PHIPRE
16877 ETAIMJ=EJC*EJH*PHIPIM
16878 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16879 C...W loops: loop integral and charges.
16880 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
16881 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
16882 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16883 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16884 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16887 C...Charged H loops: loop integral and charges.
16888 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
16889 & PARU(158+10*IHIGG+2*(IHIGG/3))
16890 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
16891 ETAIMJ=-EPS**2*PHIIM*FACHHH
16896 ETA2=ETARE**2+ETAIM**2
16897 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
16899 ELSEIF(I.EQ.15) THEN
16900 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
16904 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16906 IF(J.LE.2*MSTP(1)) THEN
16908 AJ=SIGN(1D0,EJ+0.1D0)
16910 EPS=(2D0*PMAS(J,1))**2/SH
16911 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
16912 ELSEIF(J.LE.3*MSTP(1)) THEN
16913 JL=2*(J-2*MSTP(1))-1
16914 EJ=KCHG(10+JL,1)/3D0
16915 AJ=SIGN(1D0,EJ+0.1D0)
16917 EPS=(2D0*PMAS(10+JL,1))**2/SH
16918 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
16920 EPS=(2D0*PMAS(24,1))**2/SH
16921 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
16923 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
16924 IF(EPS.LE.1D0) THEN
16926 IF(EPS.GT.1D-4) THEN
16927 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16929 RLN=LOG(4D0/EPS-2D0)
16931 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16932 PHIIM=0.5D0*PARU(1)*RLN
16933 PSIRE=0.5D0*ROOT*RLN
16934 PSIIM=-0.5D0*ROOT*PARU(1)
16936 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16938 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
16941 IF(EPSP.LE.1D0) THEN
16942 ROOT=SQRT(1D0-EPSP)
16943 IF(EPSP.GT.1D-4) THEN
16944 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16946 RLN=LOG(4D0/EPSP-2D0)
16948 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
16949 PHIIMP=0.5D0*PARU(1)*RLN
16950 PSIREP=0.5D0*ROOT*RLN
16951 PSIIMP=-0.5D0*ROOT*PARU(1)
16953 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
16955 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
16958 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
16959 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
16960 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
16961 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
16962 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
16963 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
16964 IF(J.LE.3*MSTP(1)) THEN
16965 C...Fermion loops: loop integral different for A0; charges.
16966 IF(IHIGG.EQ.3) FXYRE=0D0
16967 IF(IHIGG.EQ.3) FXYIM=0D0
16968 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16970 EJH=PARU(151+10*IHIGG)
16971 ELSEIF(J.LE.2*MSTP(1)) THEN
16973 EJH=PARU(152+10*IHIGG)
16976 EJH=PARU(153+10*IHIGG)
16978 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16979 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
16980 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
16981 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16982 C...W loops: loop integral and charges.
16983 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
16984 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
16985 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
16986 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16987 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16988 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16991 C...Charged H loops: loop integral and charges.
16992 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
16993 & PARU(158+10*IHIGG+2*(IHIGG/3))
16994 ETAREJ=FACHHH*FXYRE
16995 ETAIMJ=FACHHH*FXYIM
17000 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
17001 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
17004 ELSEIF(I.LE.17) THEN
17005 C...h0 -> Z0 + Z0, W+ + W-
17006 PM1=PMAS(IABS(KFDP(IDC,1)),1)
17007 PG1=PMAS(IABS(KFDP(IDC,1)),2)
17008 IF(MINT(62).GE.1) THEN
17009 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
17010 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
17011 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
17012 MOFSV(IHIGG,I-15)=0
17013 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
17017 MOFSV(IHIGG,I-15)=1
17018 RMAS=SQRT(MAX(0D0,SH))
17019 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
17021 WIDWSV(IHIGG,I-15)=WIDW
17022 WID2SV(IHIGG,I-15)=WID2
17025 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
17026 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
17030 WIDW=WIDWSV(IHIGG,I-15)
17031 WID2=WID2SV(IHIGG,I-15)
17034 WDTP(I)=FAC*WIDW/(2D0*(18-I))
17035 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
17036 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
17037 & PARU(138+I+10*IHIGG)**2
17038 WID2=WID2*WIDS(7+I,1)
17040 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
17041 C...H0 -> Z0 + h0, A0-> Z0 + h0
17042 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
17043 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17044 IF(IHIGG.EQ.2) THEN
17045 WDTP(I)=WDTP(I)*PARU(179)**2
17046 ELSEIF(IHIGG.EQ.3) THEN
17047 WDTP(I)=WDTP(I)*PARU(186)**2
17049 WID2=WIDS(23,2)*WIDS(25,2)
17051 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
17052 C...H0 -> h0 + h0, A0-> h0 + h0
17053 WDTP(I)=FAC*0.25D0*
17054 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
17055 IF(IHIGG.EQ.2) THEN
17056 WDTP(I)=WDTP(I)*PARU(176)**2
17057 ELSEIF(IHIGG.EQ.3) THEN
17058 WDTP(I)=WDTP(I)*PARU(169)**2
17061 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
17062 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
17063 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
17064 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17065 & *PARU(195+IHIGG)**2
17067 WID2=WIDS(24,2)*WIDS(37,3)
17068 ELSEIF(I.EQ.21) THEN
17069 WID2=WIDS(24,3)*WIDS(37,2)
17072 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
17074 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
17075 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*0.0D0
17076 WID2=WIDS(36,2)*WIDS(23,2)
17078 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
17080 WDTP(I)=FAC*0.5D0*PARU(180)**2*
17081 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
17082 WID2=WIDS(25,2)*WIDS(36,2)
17084 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
17086 WDTP(I)=FAC*0.25D0*PARU(177)**2*
17087 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
17092 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
17095 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
17096 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
17097 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
17102 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
17104 IF(KFC2.EQ.KFC1) THEN
17108 IF(KFDP(IDC,1).LT.0) KSGN1=3
17110 IF(KFDP(IDC,2).LT.0) KSGN2=3
17111 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
17114 WDTP(I)=FUDGE*WDTP(I)
17115 WDTP(0)=WDTP(0)+WDTP(I)
17116 IF(MDME(IDC,1).GT.0) THEN
17117 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17118 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17119 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17120 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17124 ELSEIF(KFLA.EQ.32) THEN
17127 XWC=1D0/(16D0*XW*XW1)
17128 FAC=(AEM*XWC/3D0)*SHR
17131 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
17139 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17140 KFAI=IABS(MINT(15))
17141 EI=KCHG(KFAI,1)/3D0
17142 AI=SIGN(1D0,EI+0.1D0)
17145 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
17146 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
17147 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
17148 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
17149 VPI=PARU(119+2*KFAIC)
17150 API=PARU(120+2*KFAIC)
17151 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
17152 VPI=PARJ(178+2*KFAIC)
17153 API=PARJ(179+2*KFAIC)
17155 VPI=PARJ(186+2*KFAIC)
17156 API=PARJ(187+2*KFAIC)
17160 SQMZP=PMAS(32,1)**2
17162 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
17163 & MSTP(44).EQ.7) VINT(111)=1D0
17164 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
17165 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
17166 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
17167 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
17168 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
17169 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
17170 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
17171 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
17172 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
17173 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
17174 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
17176 DO 290 I=1,MDCY(KC,3)
17178 IF(MDME(IDC,1).LT.0) GOTO 290
17179 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17180 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17181 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
17185 C...Z'0 -> q + qbar
17187 AF=SIGN(1D0,EF+0.1D0)
17190 VPF=PARU(123-2*MOD(I,2))
17191 APF=PARU(124-2*MOD(I,2))
17192 ELSEIF(I.LE.4) THEN
17193 VPF=PARJ(182-2*MOD(I,2))
17194 APF=PARJ(183-2*MOD(I,2))
17196 VPF=PARJ(190-2*MOD(I,2))
17197 APF=PARJ(191-2*MOD(I,2))
17200 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
17201 & PYHFTH(SH,SH*RM1,1D0)
17202 IF(I.EQ.6) WID2=WIDS(6,1)
17203 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
17204 ELSEIF(I.LE.16) THEN
17205 C...Z'0 -> l+ + l-, nu + nubar
17207 AF=SIGN(1D0,EF+0.1D0)
17210 VPF=PARU(127-2*MOD(I,2))
17211 APF=PARU(128-2*MOD(I,2))
17212 ELSEIF(I.LE.12) THEN
17213 VPF=PARJ(186-2*MOD(I,2))
17214 APF=PARJ(187-2*MOD(I,2))
17216 VPF=PARJ(194-2*MOD(I,2))
17217 APF=PARJ(195-2*MOD(I,2))
17220 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
17222 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17223 IF(ICASE.EQ.1) THEN
17224 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
17225 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
17226 & APF**2*(1D0-4D0*RM1))*BE34
17227 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17228 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
17229 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
17230 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
17231 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
17232 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
17233 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
17234 ELSEIF(MINT(61).EQ.2) THEN
17235 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
17236 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17237 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
17238 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
17239 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
17241 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
17244 ELSEIF(I.EQ.17) THEN
17246 WDTPZP=PARU(129)**2*XW1**2*
17247 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17248 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17249 IF(ICASE.EQ.1) THEN
17252 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17253 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
17254 ELSEIF(MINT(61).EQ.2) THEN
17263 ELSEIF(I.EQ.18) THEN
17265 CZC=2D0*(1D0-2D0*XW)
17266 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
17267 IF(ICASE.EQ.1) THEN
17268 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
17269 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
17270 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17271 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
17272 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
17273 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
17274 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
17275 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
17276 ELSEIF(MINT(61).EQ.2) THEN
17278 FGZF=0.25D0*PARU(142)*CZC*BE34C
17279 FGZPF=0.25D0*PARU(143)*CZC*BE34C
17280 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
17281 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
17282 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
17285 ELSEIF(I.EQ.19) THEN
17286 C...Z'0 -> Z0 + gamma.
17287 ELSEIF(I.EQ.20) THEN
17289 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17290 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
17291 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
17292 IF(ICASE.EQ.1) THEN
17295 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17296 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
17297 ELSEIF(MINT(61).EQ.2) THEN
17305 WID2=WIDS(23,2)*WIDS(25,2)
17306 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
17307 C...Z' -> h0 + A0 or H0 + A0.
17308 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17316 IF(ICASE.EQ.1) THEN
17317 WDTPZ=CZAH**2*BE34C
17318 WDTP(I)=FAC*CZPAH**2*BE34C
17319 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17320 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
17321 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
17323 ELSEIF(MINT(61).EQ.2) THEN
17328 FZZPF=CZAH*CZPAH*BE34C
17329 FZPZPF=CZPAH**2*BE34C
17331 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
17332 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
17334 IF(ICASE.EQ.1) THEN
17335 VINT(117)=VINT(117)+FAC*WDTPZ
17336 WDTP(I)=FUDGE*WDTP(I)
17337 WDTP(0)=WDTP(0)+WDTP(I)
17339 IF(MDME(IDC,1).GT.0) THEN
17340 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
17341 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
17342 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17343 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
17344 & WDTE(I,MDME(IDC,1))
17345 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17346 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17348 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
17349 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
17350 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
17351 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
17353 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
17355 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
17356 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
17357 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
17359 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
17360 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
17364 IF(MINT(61).GE.1) ICASE=3-ICASE
17365 IF(ICASE.EQ.2) GOTO 280
17367 ELSEIF(KFLA.EQ.34) THEN
17369 FAC=(AEM/(24D0*XW))*SHR
17370 DO 300 I=1,MDCY(KC,3)
17372 IF(MDME(IDC,1).LT.0) GOTO 300
17373 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17374 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17375 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
17379 C...W'+/- -> q + qbar'
17380 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
17381 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
17383 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
17384 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
17385 IF(I.GE.13) WID2=WID2*WIDS(7,3)
17387 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
17388 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
17389 IF(I.GE.13) WID2=WID2*WIDS(7,2)
17391 ELSEIF(I.LE.20) THEN
17392 C...W'+/- -> l+/- + nu
17393 FCOF=PARU(133)**2+PARU(134)**2
17395 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17397 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17400 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
17401 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17402 ELSEIF(I.EQ.21) THEN
17403 C...W'+/- -> W+/- + Z0
17404 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
17405 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17406 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17407 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
17408 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
17409 ELSEIF(I.EQ.23) THEN
17410 C...W'+/- -> W+/- + h0
17411 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17412 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
17413 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17414 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17416 WDTP(I)=FUDGE*WDTP(I)
17417 WDTP(0)=WDTP(0)+WDTP(I)
17418 IF(MDME(IDC,1).GT.0) THEN
17419 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17420 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17421 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17422 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17426 ELSEIF(KFLA.EQ.37) THEN
17428 C IF(MSTP(49).EQ.0) THEN
17431 C SHFS=PMAS(37,1)**2
17433 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
17434 DO 310 I=1,MDCY(KC,3)
17436 IF(MDME(IDC,1).LT.0) GOTO 310
17437 KFC1=PYCOMP(KFDP(IDC,1))
17438 KFC2=PYCOMP(KFDP(IDC,2))
17439 RM1=PMAS(KFC1,1)**2/SH
17440 RM2=PMAS(KFC2,1)**2/SH
17441 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
17444 C...H+/- -> q + qbar'
17445 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
17446 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
17447 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
17448 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
17449 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17451 IF(I.EQ.3) WID2=WIDS(6,2)
17452 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
17454 IF(I.EQ.3) WID2=WIDS(6,3)
17455 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
17457 ELSEIF(I.LE.8) THEN
17458 C...H+/- -> l+/- + nu
17459 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
17460 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
17461 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17463 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
17465 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
17467 ELSEIF(I.EQ.9) THEN
17468 C...H+/- -> W+/- + h0.
17469 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
17470 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17471 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17472 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17476 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
17479 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
17480 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
17481 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
17486 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
17489 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
17491 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
17492 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
17494 WDTP(I)=FUDGE*WDTP(I)
17495 WDTP(0)=WDTP(0)+WDTP(I)
17496 IF(MDME(IDC,1).GT.0) THEN
17497 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17498 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17499 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17500 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17504 ELSEIF(KFLA.EQ.41) THEN
17506 FAC=(AEM/(12D0*XW))*SHR
17507 DO 320 I=1,MDCY(KC,3)
17509 IF(MDME(IDC,1).LT.0) GOTO 320
17510 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17511 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17512 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
17517 ELSEIF(I.LE.9) THEN
17521 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17522 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17524 IF(I.EQ.4) WID2=WIDS(6,3)
17525 IF(I.EQ.5) WID2=WIDS(7,3)
17526 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
17527 IF(I.EQ.9) WID2=WIDS(17,3)
17529 IF(I.EQ.4) WID2=WIDS(6,2)
17530 IF(I.EQ.5) WID2=WIDS(7,2)
17531 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
17532 IF(I.EQ.9) WID2=WIDS(17,2)
17534 WDTP(I)=FUDGE*WDTP(I)
17535 WDTP(0)=WDTP(0)+WDTP(I)
17536 IF(MDME(IDC,1).GT.0) THEN
17537 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17538 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17539 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17540 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17544 ELSEIF(KFLA.EQ.42) THEN
17545 C...LQ (leptoquark).
17546 FAC=(AEM/4D0)*PARU(151)*SHR
17547 DO 330 I=1,MDCY(KC,3)
17549 IF(MDME(IDC,1).LT.0) GOTO 330
17550 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17551 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17552 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
17553 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17555 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
17556 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
17557 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
17558 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
17559 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
17560 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
17561 WDTP(I)=FUDGE*WDTP(I)
17562 WDTP(0)=WDTP(0)+WDTP(I)
17563 IF(MDME(IDC,1).GT.0) THEN
17564 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17565 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17566 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17567 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17571 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
17572 C...Techni-pi0 and techni-pi0':
17573 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
17574 DO 340 I=1,MDCY(KC,3)
17576 IF(MDME(IDC,1).LT.0) GOTO 340
17577 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17578 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17581 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
17585 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
17586 & /(8D0*PARU(1))*SH*SHR
17587 IF(KFLA.EQ.KTECHN+111) THEN
17594 C...pi_tc -> f + fbar.
17596 IKA=IABS(KFDP(IDC,1))
17597 IF(IKA.LT.10) FCOF=3D0*RADC
17600 IF(IKA.GE.4.AND.IKA.LE.6) THEN
17601 FCOF=FCOF*RTCM(1+IKA)**2
17602 HM1=PYMRUN(KFDP(IDC,1),SH)
17603 HM2=PYMRUN(KFDP(IDC,2),SH)
17604 ELSEIF(IKA.EQ.15) THEN
17605 FCOF=FCOF*RTCM(8)**2
17607 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17608 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17610 WDTP(I)=FUDGE*WDTP(I)
17611 WDTP(0)=WDTP(0)+WDTP(I)
17612 IF(MDME(IDC,1).GT.0) THEN
17613 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17614 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17615 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17616 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17620 ELSEIF(KFLA.EQ.KTECHN+211) THEN
17622 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
17623 DO 350 I=1,MDCY(KC,3)
17625 IF(MDME(IDC,1).LT.0) GOTO 350
17626 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17627 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17629 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
17633 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
17635 C...pi_tc -> f + f'.
17637 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
17638 C...pi_tc+ -> W b b~
17639 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
17641 XMT2=PMAS(6,1)**2/SH
17642 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
17643 KFC3=PYCOMP(KFDP(IDC,3))
17644 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
17646 T0 = (1D0-CHECK**2)*
17647 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
17648 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
17649 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
17650 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
17651 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
17652 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
17661 IKA=IABS(KFDP(IDC,1))
17662 IF(IKA.LT.10) FCOF=3D0*RADC
17665 IF(I.GE.1.AND.I.LE.5) THEN
17667 FCOF=FCOF*RTCM(5)**2
17668 ELSEIF(I.LE.4) THEN
17669 FCOF=FCOF*RTCM(6)**2
17670 ELSEIF(I.EQ.5) THEN
17671 FCOF=FCOF*RTCM(7)**2
17673 HM1=PYMRUN(KFDP(IDC,1),SH)
17674 HM2=PYMRUN(KFDP(IDC,2),SH)
17675 ELSEIF(I.EQ.8) THEN
17676 FCOF=FCOF*RTCM(8)**2
17678 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17679 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17681 WDTP(I)=FUDGE*WDTP(I)
17682 WDTP(0)=WDTP(0)+WDTP(I)
17683 IF(MDME(IDC,1).GT.0) THEN
17684 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17685 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17686 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17687 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17691 ELSEIF(KFLA.EQ.KTECHN+331) THEN
17693 FAC=(SH/PARP(46)**2)*SHR
17694 DO 360 I=1,MDCY(KC,3)
17696 IF(MDME(IDC,1).LT.0) GOTO 360
17697 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17698 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17699 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
17702 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
17703 IF(I.EQ.2) WID2=WIDS(6,1)
17705 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
17707 WDTP(I)=FUDGE*WDTP(I)
17708 WDTP(0)=WDTP(0)+WDTP(I)
17709 IF(MDME(IDC,1).GT.0) THEN
17710 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17711 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17712 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17713 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17717 ELSEIF(KFLA.EQ.KTECHN+113) THEN
17719 ALPRHT=2.91D0*(3D0/ITCM(1))
17720 FAC=(ALPRHT/12D0)*SHR
17721 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
17725 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17727 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
17728 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17729 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17730 DO 370 I=1,MDCY(KC,3)
17732 IF(MDME(IDC,1).LT.0) GOTO 370
17733 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17734 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17735 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
17738 C...rho_tc0 -> W+ + W-.
17739 WDTP(I)=FAC*RTCM(3)**4*
17740 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17742 ELSEIF(I.EQ.2) THEN
17743 C...rho_tc0 -> W+ + pi_tc-.
17744 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17745 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17746 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17747 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17748 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
17749 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17750 ELSEIF(I.EQ.3) THEN
17751 C...rho_tc0 -> pi_tc+ + W-.
17752 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17753 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17754 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17755 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17756 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
17757 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
17758 ELSEIF(I.EQ.4) THEN
17759 C...rho_tc0 -> pi_tc+ + pi_tc-.
17760 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
17761 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17762 WID2=WIDS(PYCOMP(KTECHN+211),1)
17763 ELSEIF(I.EQ.5) THEN
17764 C...rho_tc0 -> gamma + pi_tc0
17765 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17766 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17768 WID2=WIDS(PYCOMP(KTECHN+111),2)
17769 ELSEIF(I.EQ.6) THEN
17770 C...rho_tc0 -> gamma + pi_tc0'
17771 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17772 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
17773 WID2=WIDS(PYCOMP(KTECHN+221),2)
17774 ELSEIF(I.EQ.7) THEN
17775 C...rho_tc0 -> Z0 + pi_tc0
17776 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17777 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17779 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17780 ELSEIF(I.EQ.8) THEN
17781 C...rho_tc0 -> Z0 + pi_tc0'
17782 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17783 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
17785 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17787 C...rho_tc0 -> f + fbar.
17792 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
17796 IF(IA.GE.17) WID2=WIDS(IA,1)
17799 AI=SIGN(1D0,EI+0.1D0)
17803 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
17804 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
17805 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
17806 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
17808 WDTP(I)=FUDGE*WDTP(I)
17809 WDTP(0)=WDTP(0)+WDTP(I)
17810 IF(MDME(IDC,1).GT.0) THEN
17811 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17812 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17813 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17814 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17818 ELSEIF(KFLA.EQ.KTECHN+213) THEN
17820 ALPRHT=2.91D0*(3D0/ITCM(1))
17821 FAC=(ALPRHT/12D0)*SHR
17825 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
17827 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
17828 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
17829 DO 380 I=1,MDCY(KC,3)
17831 IF(MDME(IDC,1).LT.0) GOTO 380
17832 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17833 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17834 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
17837 C...rho_tc+ -> W+ + Z0.
17838 WDTP(I)=FAC*RTCM(3)**4*
17839 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17841 WID2=WIDS(24,2)*WIDS(23,2)
17843 WID2=WIDS(24,3)*WIDS(23,2)
17845 ELSEIF(I.EQ.2) THEN
17846 C...rho_tc+ -> W+ + pi_tc0.
17847 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17848 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17849 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17850 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17851 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
17853 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
17855 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
17857 ELSEIF(I.EQ.3) THEN
17858 C...rho_tc+ -> pi_tc+ + Z0.
17859 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17860 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17861 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17862 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
17863 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
17864 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17865 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17868 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
17870 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
17872 ELSEIF(I.EQ.4) THEN
17873 C...rho_tc+ -> pi_tc+ + pi_tc0.
17874 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
17875 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17877 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
17879 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
17881 ELSEIF(I.EQ.5) THEN
17882 C...rho_tc+ -> pi_tc+ + gamma
17883 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17884 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17887 WID2=WIDS(PYCOMP(KTECHN+211),2)
17889 WID2=WIDS(PYCOMP(KTECHN+211),3)
17891 ELSEIF(I.EQ.6) THEN
17892 C...rho_tc+ -> W+ + pi_tc0'
17893 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17894 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
17896 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
17898 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
17901 C...rho_tc+ -> f + fbar'.
17905 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
17907 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
17908 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
17909 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
17911 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
17912 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
17913 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
17918 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17920 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17923 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17924 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17926 WDTP(I)=FUDGE*WDTP(I)
17927 WDTP(0)=WDTP(0)+WDTP(I)
17928 IF(MDME(IDC,1).GT.0) THEN
17929 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17930 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17931 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17932 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17936 ELSEIF(KFLA.EQ.KTECHN+223) THEN
17938 ALPRHT=2.91D0*(3D0/ITCM(1))
17939 FAC=(ALPRHT/12D0)*SHR
17940 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
17943 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17945 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17946 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17947 DO 390 I=1,MDCY(KC,3)
17949 IF(MDME(IDC,1).LT.0) GOTO 390
17950 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17951 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17952 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
17955 C...omega_tc0 -> gamma + pi_tc0.
17956 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
17957 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
17958 WID2=WIDS(PYCOMP(KTECHN+111),2)
17959 ELSEIF(I.EQ.2) THEN
17960 C...omega_tc0 -> Z0 + pi_tc0
17961 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17962 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
17964 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17965 ELSEIF(I.EQ.3) THEN
17966 C...omega_tc0 -> gamma + pi_tc0'
17967 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17968 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
17970 WID2=WIDS(PYCOMP(KTECHN+221),2)
17971 ELSEIF(I.EQ.4) THEN
17972 C...omega_tc0 -> Z0 + pi_tc0'
17973 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17974 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
17976 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17977 ELSEIF(I.EQ.5) THEN
17978 C...omega_tc0 -> W+ + pi_tc-
17979 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17980 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
17981 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
17982 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17983 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17984 ELSEIF(I.EQ.6) THEN
17985 C...omega_tc0 -> pi_tc+ + W-
17986 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17987 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
17988 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
17989 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17990 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
17991 ELSEIF(I.EQ.7) THEN
17992 C...omega_tc0 -> W+ + W-.
17993 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
17994 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17996 ELSEIF(I.EQ.8) THEN
17997 C...omega_tc0 -> pi_tc+ + pi_tc-.
17998 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
17999 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
18000 WID2=WIDS(PYCOMP(KTECHN+211),1)
18002 C...omega_tc0 -> f + fbar.
18007 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
18011 IF(IA.GE.17) WID2=WIDS(IA,1)
18014 AI=SIGN(1D0,EI+0.1D0)
18016 VALI=-0.5D0*(VI+AI)
18017 VARI=-0.5D0*(VI-AI)
18018 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
18019 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
18020 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
18021 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
18023 WDTP(I)=FUDGE*WDTP(I)
18024 WDTP(0)=WDTP(0)+WDTP(I)
18025 IF(MDME(IDC,1).GT.0) THEN
18026 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18027 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18028 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18029 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18033 C.....V8 -> quark anti-quark
18034 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
18037 IF(ITCM(2).EQ.0) THEN
18039 ELSEIF(ITCM(2).EQ.1) THEN
18042 DO 400 I=1,MDCY(KC,3)
18044 IF(MDME(IDC,1).LT.0) GOTO 400
18045 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
18047 IF(RM1.GT.0.25D0) GOTO 400
18049 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
18054 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
18055 IF(I.EQ.6) WID2=WIDS(6,1)
18056 WDTP(I)=FUDGE*WDTP(I)
18057 WDTP(0)=WDTP(0)+WDTP(I)
18058 IF(MDME(IDC,1).GT.0) THEN
18059 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18060 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18061 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18062 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18066 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
18067 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
18069 DO 410 I=1,MDCY(KC,3)
18071 IF(MDME(IDC,1).LT.0) GOTO 410
18072 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18073 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18074 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
18078 IF(KFLA.EQ.KTECHN+100111) THEN
18083 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
18084 & /(2D0*PARU(1))*SH*SHR*CLEBG
18087 C...pi_tc -> f + fbar.
18088 IF(I.EQ.6) WID2=WIDS(6,1)
18090 IKA=IABS(KFDP(IDC,1))
18091 IF(IKA.LT.10) FCOF=3D0*RADC
18092 HM1=PYMRUN(KFDP(IDC,1),SH)
18093 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
18094 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18096 WDTP(I)=FUDGE*WDTP(I)
18097 WDTP(0)=WDTP(0)+WDTP(I)
18098 IF(MDME(IDC,1).GT.0) THEN
18099 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18100 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18101 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18102 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18106 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
18108 ALPRHT=2.91D0*(3D0/ITCM(1))
18110 SIN2T=2D0*TANT3/(TANT3**2+1D0)
18111 SINT3=TANT3/SQRT(TANT3**2+1D0)
18114 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
18115 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
18116 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
18117 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
18118 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
18120 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
18122 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
18124 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
18126 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
18127 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
18128 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
18129 IF(ITCM(2).EQ.0) THEN
18134 DO 420 I=1,MDCY(KC,3)
18135 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
18136 & KFLA.EQ.KTECHN+300113)) GOTO 420
18138 IF(MDME(IDC,1).LT.0) GOTO 420
18139 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18140 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18141 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
18144 IF(I.EQ.6) WID2=WIDS(6,1)
18146 IF(KFLA.EQ.KTECHN+200113) THEN
18149 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
18152 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
18157 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
18158 FMIX=1D0/TANT3/SIN2T
18162 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
18163 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
18164 ELSEIF(I.EQ.7) THEN
18165 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
18166 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
18167 PSH=SHR*(1D0-RM1)/2D0
18168 WDTP(I)=AS/9D0*PSH**3/RM82
18170 WDTP(I)=2D0*WDTP(I)*CSXPP**2
18171 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
18173 WDTP(I)=5D0*WDTP(I)
18174 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
18177 WDTP(I)=FUDGE*WDTP(I)
18178 WDTP(0)=WDTP(0)+WDTP(I)
18179 IF(MDME(IDC,1).GT.0) THEN
18180 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18181 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18182 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18183 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18187 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
18188 C...d* excited quark.
18189 FAC=(SH/RTCM(41)**2)*SHR
18190 DO 430 I=1,MDCY(KC,3)
18192 IF(MDME(IDC,1).LT.0) GOTO 430
18193 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18194 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18195 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
18199 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
18201 ELSEIF(I.EQ.2) THEN
18202 C...d* -> gamma + d.
18203 QF=-RTCM(43)/2D0+RTCM(44)/6D0
18204 WDTP(I)=FAC*AEM*QF**2/4D0
18206 ELSEIF(I.EQ.3) THEN
18208 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
18209 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18210 & (1D0-RM1)**2*(2D0+RM1)
18212 ELSEIF(I.EQ.4) THEN
18214 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18215 & (1D0-RM1)**2*(2D0+RM1)
18216 IF(KFLR.GT.0) WID2=WIDS(24,3)
18217 IF(KFLR.LT.0) WID2=WIDS(24,2)
18219 WDTP(I)=FUDGE*WDTP(I)
18220 WDTP(0)=WDTP(0)+WDTP(I)
18221 IF(MDME(IDC,1).GT.0) THEN
18222 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18223 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18224 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18225 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18229 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
18230 C...u* excited quark.
18231 FAC=(SH/RTCM(41)**2)*SHR
18232 DO 440 I=1,MDCY(KC,3)
18234 IF(MDME(IDC,1).LT.0) GOTO 440
18235 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18236 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18237 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
18241 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
18243 ELSEIF(I.EQ.2) THEN
18244 C...u* -> gamma + u.
18245 QF=RTCM(43)/2D0+RTCM(44)/6D0
18246 WDTP(I)=FAC*AEM*QF**2/4D0
18248 ELSEIF(I.EQ.3) THEN
18250 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
18251 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18252 & (1D0-RM1)**2*(2D0+RM1)
18254 ELSEIF(I.EQ.4) THEN
18256 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18257 & (1D0-RM1)**2*(2D0+RM1)
18258 IF(KFLR.GT.0) WID2=WIDS(24,2)
18259 IF(KFLR.LT.0) WID2=WIDS(24,3)
18261 WDTP(I)=FUDGE*WDTP(I)
18262 WDTP(0)=WDTP(0)+WDTP(I)
18263 IF(MDME(IDC,1).GT.0) THEN
18264 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18265 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18266 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18267 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18271 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
18272 C...e* excited lepton.
18273 FAC=(SH/RTCM(41)**2)*SHR
18274 DO 450 I=1,MDCY(KC,3)
18276 IF(MDME(IDC,1).LT.0) GOTO 450
18277 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18278 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18279 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
18282 C...e* -> gamma + e.
18283 QF=-RTCM(43)/2D0-RTCM(44)/2D0
18284 WDTP(I)=FAC*AEM*QF**2/4D0
18286 ELSEIF(I.EQ.2) THEN
18288 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
18289 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18290 & (1D0-RM1)**2*(2D0+RM1)
18292 ELSEIF(I.EQ.3) THEN
18294 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18295 & (1D0-RM1)**2*(2D0+RM1)
18296 IF(KFLR.GT.0) WID2=WIDS(24,3)
18297 IF(KFLR.LT.0) WID2=WIDS(24,2)
18299 WDTP(I)=FUDGE*WDTP(I)
18300 WDTP(0)=WDTP(0)+WDTP(I)
18301 IF(MDME(IDC,1).GT.0) THEN
18302 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18303 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18304 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18305 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18309 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
18310 C...nu*_e excited neutrino.
18311 FAC=(SH/RTCM(41)**2)*SHR
18312 DO 460 I=1,MDCY(KC,3)
18314 IF(MDME(IDC,1).LT.0) GOTO 460
18315 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18316 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18317 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
18320 C...nu*_e -> Z0 + nu*_e.
18321 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
18322 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18323 & (1D0-RM1)**2*(2D0+RM1)
18325 ELSEIF(I.EQ.2) THEN
18326 C...nu*_e -> W+ + e.
18327 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18328 & (1D0-RM1)**2*(2D0+RM1)
18329 IF(KFLR.GT.0) WID2=WIDS(24,2)
18330 IF(KFLR.LT.0) WID2=WIDS(24,3)
18332 WDTP(I)=FUDGE*WDTP(I)
18333 WDTP(0)=WDTP(0)+WDTP(I)
18334 IF(MDME(IDC,1).GT.0) THEN
18335 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18336 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18337 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18338 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18342 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
18343 C...G* (graviton resonance):
18344 FAC=(PARP(50)**2/PARU(1))*SHR
18345 DO 470 I=1,MDCY(KC,3)
18347 IF(MDME(IDC,1).LT.0) GOTO 470
18348 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18349 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18350 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
18355 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
18356 & PYHFTH(SH,SH*RM1,1D0)
18357 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
18358 & (1D0+8D0*RM1/3D0)/320D0
18359 IF(I.EQ.6) WID2=WIDS(6,1)
18360 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
18361 ELSEIF(I.LE.16) THEN
18362 C...G* -> l+ + l-, nu + nubar
18364 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
18365 & (1D0+8D0*RM1/3D0)/320D0
18366 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
18367 ELSEIF(I.EQ.17) THEN
18370 ELSEIF(I.EQ.18) THEN
18371 C...G* -> gamma + gamma.
18373 ELSEIF(I.EQ.19) THEN
18375 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
18376 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
18378 ELSEIF(I.EQ.20) THEN
18380 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
18381 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
18384 WDTP(I)=FUDGE*WDTP(I)
18385 WDTP(0)=WDTP(0)+WDTP(I)
18386 IF(MDME(IDC,1).GT.0) THEN
18387 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18388 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18389 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18390 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18394 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
18395 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
18396 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
18397 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
18398 DO 480 I=1,MDCY(KC,3)
18400 IF(MDME(IDC,1).LT.0) GOTO 480
18401 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
18402 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
18403 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
18404 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
18407 C...nu_lR -> l- qbar q'
18408 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18409 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18410 ELSEIF(I.LE.18) THEN
18411 C...nu_lR -> l+ q qbar'
18412 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
18413 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
18415 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
18417 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
18419 X=(PM1+PM2+PM3)/SHR
18420 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
18422 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
18423 WDTP(I)=FAC*FCOF*FX*FY
18424 WDTP(I)=FUDGE*WDTP(I)
18425 WDTP(0)=WDTP(0)+WDTP(I)
18426 IF(MDME(IDC,1).GT.0) THEN
18427 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18428 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18429 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18430 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18434 ELSEIF(KFLA.EQ.9900023) THEN
18436 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
18437 DO 490 I=1,MDCY(KC,3)
18439 IF(MDME(IDC,1).LT.0) GOTO 490
18440 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18441 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18442 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
18446 C...Z_R0 -> q + qbar
18448 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
18449 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
18451 IF(I.EQ.6) WID2=WIDS(6,1)
18452 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
18453 C...Z_R0 -> l+ + l-
18457 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
18458 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
18463 ELSEIF(I.LE.15) THEN
18464 C...Z0 -> nu_R + nu_R, assumed Majorana.
18468 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
18471 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
18472 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
18473 WDTP(I)=FUDGE*WDTP(I)
18474 WDTP(0)=WDTP(0)+WDTP(I)
18475 IF(MDME(IDC,1).GT.0) THEN
18476 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18477 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18478 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18479 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18483 ELSEIF(KFLA.EQ.9900024) THEN
18485 FAC=(AEM/(24D0*XW))*SHR
18486 DO 500 I=1,MDCY(KC,3)
18488 IF(MDME(IDC,1).LT.0) GOTO 500
18489 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18490 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18491 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
18494 C...W_R+/- -> q + qbar'
18495 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18497 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18499 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
18501 ELSEIF(I.LE.12) THEN
18502 C...W_R+/- -> l+/- + nu_R
18505 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
18506 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18507 WDTP(I)=FUDGE*WDTP(I)
18508 WDTP(0)=WDTP(0)+WDTP(I)
18509 IF(MDME(IDC,1).GT.0) THEN
18510 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18511 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18512 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18513 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18517 ELSEIF(KFLA.EQ.9900041) THEN
18519 FAC=(1D0/(8D0*PARU(1)))*SHR
18520 DO 510 I=1,MDCY(KC,3)
18522 IF(MDME(IDC,1).LT.0) GOTO 510
18523 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18524 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18525 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
18528 C...H_L++/-- -> l+/- + l'+/-
18529 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18530 & (IABS(KFDP(IDC,2))-9)/2)**2
18531 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18532 ELSEIF(I.EQ.7) THEN
18533 C...H_L++/-- -> W_L+/- + W_L+/-
18534 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
18535 & (3D0*RM1+0.25D0/RM1-1D0)
18536 WID2=WIDS(24,4+(1-KFLS)/2)
18539 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18540 WDTP(I)=FUDGE*WDTP(I)
18541 WDTP(0)=WDTP(0)+WDTP(I)
18542 IF(MDME(IDC,1).GT.0) THEN
18543 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18544 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18545 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18546 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18550 ELSEIF(KFLA.EQ.9900042) THEN
18552 FAC=(1D0/(8D0*PARU(1)))*SHR
18553 DO 520 I=1,MDCY(KC,3)
18555 IF(MDME(IDC,1).LT.0) GOTO 520
18556 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18557 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18558 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
18561 C...H_R++/-- -> l+/- + l'+/-
18562 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18563 & (IABS(KFDP(IDC,2))-9)/2)**2
18564 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18565 ELSEIF(I.EQ.7) THEN
18566 C...H_R++/-- -> W_R+/- + W_R+/-
18567 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
18568 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
18571 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18572 WDTP(I)=FUDGE*WDTP(I)
18573 WDTP(0)=WDTP(0)+WDTP(I)
18574 IF(MDME(IDC,1).GT.0) THEN
18575 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18576 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18577 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18578 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18589 C***********************************************************************
18592 C...Calculates partial width and differential cross-section maxima
18593 C...of channels/processes not allowed on mass-shell, and selects
18594 C...masses in such channels/processes.
18596 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
18598 C...Double precision and integer declarations.
18599 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18600 IMPLICIT INTEGER(I-N)
18601 INTEGER PYK,PYCHGE,PYCOMP
18603 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18604 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18605 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
18606 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
18607 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18608 COMMON/PYINT1/MINT(400),VINT(400)
18609 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
18610 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
18611 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
18614 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
18615 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
18616 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
18619 C...Find if particles equal, maximum mass, matrix elements, etc.
18625 IF(KFD(1).EQ.KFD(2)) MEQL=1
18627 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
18628 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
18634 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
18637 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
18638 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
18639 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
18640 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
18641 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
18642 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
18645 C...Find where Breit-Wigners are required, else select discrete masses.
18647 KFCA=PYCOMP(KFD(I))
18649 PMD(I)=PMAS(KFCA,1)
18650 PGD(I)=PMAS(KFCA,2)
18655 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
18658 RMG(I)=(PMG(I)/PMMX)**2
18664 C...Find allowed mass range and Breit-Wigner parameters.
18666 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
18668 PMU(I)=PMMX-PARP(42)
18669 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18670 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18671 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
18673 IF(MLM.EQ.2) ILM=3-I
18674 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
18675 IF(MBW(3-I).EQ.0) THEN
18676 PMU(I)=PMMX-PMD(3-I)
18678 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
18680 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
18681 & MIN(PMU(I),CKIN(NOFF+2*ILM))
18682 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18683 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18684 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18685 IF(MBW(I).EQ.1) THEN
18686 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18687 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18688 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18691 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
18693 IF(MLM.EQ.2) ILM=3-I
18694 PML(I)=MAX(CKIN(48+I),PARP(42))
18695 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
18696 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18697 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18698 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18699 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18700 IF(MBW(I).EQ.1) THEN
18701 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18702 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18703 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18708 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
18710 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
18715 C...Calculation of partial width of resonance.
18716 IF(MOFSH.EQ.1) THEN
18718 C..If only one integration, pick that to be the inner.
18719 IF(MBW(1).EQ.0) THEN
18725 ELSEIF(MBW(2).EQ.0) THEN
18729 C...Start outer loop of integration.
18730 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18731 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18732 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18738 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18739 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
18740 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
18744 C...Start inner loop of integration.
18746 PMU1=MIN(PMU(1),PMMX-PM2)
18747 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
18748 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18749 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18750 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
18758 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
18759 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
18762 C...Evaluate function value - inner loop.
18763 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18764 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
18765 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
18766 & RM2**2+10D0*RM1*RM2)
18767 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
18770 C...Go to next position in inner loop.
18776 ELSEIF(NPT1.LE.8) THEN
18778 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
18780 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18781 INX1(NPT1)=INX1(ISH1)
18784 ELSEIF(NPT1.LT.100) THEN
18787 IF(ISH1.GT.NPT1) ISH1=2
18788 IF(ISH1.EQ.ISN1) GOTO 160
18789 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
18790 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
18792 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18793 INX1(NPT1)=INX1(ISH1)
18798 C...Calculate integral over inner loop.
18801 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
18802 & (XPT1(INX1(IPT1))-XPT1(IPT1))
18804 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
18805 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18806 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
18809 C...Go to next position in outer loop.
18815 ELSEIF(NPT2.LE.8) THEN
18817 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
18819 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18820 INX2(NPT2)=INX2(ISH2)
18823 ELSEIF(NPT2.LT.100) THEN
18826 IF(ISH2.GT.NPT2) ISH2=2
18827 IF(ISH2.EQ.ISN2) GOTO 200
18828 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
18829 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
18831 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18832 INX2(NPT2)=INX2(ISH2)
18837 C...Calculate integral over outer loop.
18840 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
18841 & (XPT2(INX2(IPT2))-XPT2(IPT2))
18843 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
18844 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
18849 C...Save result; second integration for user-selected mass range.
18850 IF(LOOP.EQ.1) WIDW=FSUM2
18852 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
18853 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
18860 C...Select two decay product masses of a resonance.
18861 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
18863 IF(MBW(I).EQ.0) GOTO 230
18864 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
18866 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
18867 RMG(I)=(PMG(I)/PMMX)**2
18869 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18870 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
18872 C...Weight with matrix element (if none known, use beta factor).
18873 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
18875 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
18876 ELSEIF(MMED.EQ.2) THEN
18877 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
18878 & RMG(2)**2+10D0*RMG(1)*RMG(2))
18879 ELSEIF(MMED.EQ.3) THEN
18880 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
18884 IF(WTBE.LT.PYR(0)) GOTO 220
18888 C...Find suitable set of masses for initialization of 2 -> 2 processes.
18889 ELSEIF(MOFSH.EQ.3) THEN
18890 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
18891 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
18893 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
18895 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
18899 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
18900 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
18901 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
18906 C...Evaluate importance of excluded tails of Breit-Wigners.
18907 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18908 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18912 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
18916 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
18917 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
18919 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
18920 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
18921 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
18922 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
18924 C...Pick one particle to be the lighter (if improves efficiency).
18925 ELSEIF(MOFSH.EQ.4) THEN
18926 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18927 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18928 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
18930 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
18932 IF(MBW(I).EQ.0) GOTO 270
18934 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18936 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18938 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18939 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
18940 IF(RBR.LT.0.8D0) THEN
18941 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
18942 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
18943 ELSEIF(RBR.LT.0.9D0) THEN
18944 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
18945 ELSEIF(RBR.LT.1.5D0) THEN
18946 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
18948 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
18949 & (PMV**2-PML(I)**2))))
18952 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18953 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
18954 IF(MINT(48).EQ.1) THEN
18955 NGEN(0,1)=NGEN(0,1)+1
18956 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
18966 C...Give weight for selected mass distribution.
18969 IF(MBW(I).EQ.0) GOTO 280
18971 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18973 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18974 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
18975 & (PMD(I)*PGD(I))**2)/PARU(1)
18979 FI0=(ATV-ATL(I))/PARU(1)
18980 FI1=PMV**2-PML(I)**2
18981 FI2=2D0*LOG(PMV/PML(I))
18982 FI3=1D0/PML(I)**2-1D0/PMV**2
18983 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18984 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
18985 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
18988 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
18990 VINT(80)=VINT(80)*FI0
18992 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
18998 C***********************************************************************
19001 C...Handles the possibility of colour reconnection in W+W- events,
19002 C...Based on the main scenarios of the Sjostrand and Khoze study:
19003 C...I, II, II', intermediate and instantaneous; plus one model
19004 C...along the lines of the Gustafson and Hakkinen: GH.
19005 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
19006 C...is as if first resonance is W+ and second W-.
19008 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
19010 C...Double precision and integer declarations.
19011 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19012 IMPLICIT INTEGER(I-N)
19013 INTEGER PYK,PYCHGE,PYCOMP
19014 C...Parameter value; number of points in MC integration.
19015 PARAMETER (NPT=100)
19017 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19018 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19019 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19020 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19021 COMMON/PYINT1/MINT(400),VINT(400)
19022 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19024 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
19025 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
19026 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
19027 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
19028 &TMC(20),IJOIN(100)
19030 C...Functions to give four-product and to do determinants.
19031 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)
19032 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
19033 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
19034 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
19036 C...Only allow fraction of recoupling for GH, intermediate and
19038 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
19039 IF(PYR(0).GT.PARP(120)) RETURN
19043 C...Common part for scenarios I, II, II', and GH.
19044 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
19045 &MSTP(115).EQ.5) THEN
19047 C...Read out frequently-used parameters.
19051 IF(ISUB.EQ.22) PMW=PMAS(23,1)
19053 IF(ISUB.EQ.22) PGW=PMAS(23,2)
19060 C...Find range of decay products of the W's.
19061 C...Background: the W's are stored in IW1 and IW2.
19062 C...Their direct decay products in NSD1+1 through NSD1+4.
19063 C...Products after shower (if any) in NSD1+5 through NAFT1
19064 C...for first W and in NAFT1+1 through N for the second.
19065 IF(NAFT1.GT.NSD1+4) THEN
19072 IF(N.GT.NAFT1) THEN
19080 C...Rearrange parton shower products along strings.
19082 CALL PYPREP(NSD1+1)
19084 C...Find partons pointing back to W+ and W-; store them with quark
19085 C...end of string first.
19091 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
19092 IF(IABS(K(I,2)).GE.22) GOTO 120
19093 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
19094 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
19104 IF(K(I,1).EQ.1) ISGP=0
19105 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
19106 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
19116 IF(K(I,1).EQ.1) ISGM=0
19120 C...Boost to W+W- rest frame (not strictly needed).
19122 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
19124 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
19125 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
19126 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
19128 C...Select decay vertices of W+ and W-.
19129 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
19130 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
19131 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
19132 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
19135 XP(J)=TP*P(IW1,J)/P(IW1,4)
19136 XM(J)=TM*P(IW2,J)/P(IW2,4)
19139 C...Begin scenario I specifics.
19140 IF(MSTP(115).EQ.1) THEN
19142 C...Reconstruct velocity and direction of W+ string pieces.
19144 IF(K(INP(IIP),2).LT.0) GOTO 170
19147 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
19148 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
19152 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
19153 DIRP(IIP,J)=V1(J)-V2(J)
19155 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
19157 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
19159 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
19163 C...Reconstruct velocity and direction of W- string pieces.
19165 IF(K(INM(IIM),2).LT.0) GOTO 200
19168 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
19169 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
19173 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
19174 DIRM(IIM,J)=V1(J)-V2(J)
19176 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
19178 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
19180 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
19184 C...Loop over number of space-time points.
19189 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
19190 R=SQRT(-LOG(PYR(0)))
19192 X=BLOWR*RHAD*R*COS(PHI)
19193 Y=BLOWR*RHAD*R*SIN(PHI)
19194 R=SQRT(-LOG(PYR(0)))
19196 Z=BLOWR*RHAD*R*COS(PHI)
19197 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
19199 C...Reject impossible points. Weight for sample distribution.
19200 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
19201 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
19202 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
19204 C...Loop over W+ string pieces and find one with largest weight.
19212 IF(K(INP(IIP),2).LT.0) GOTO 220
19213 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
19214 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
19216 XB(J)=XD(J)+BEDG*BETP(IIP,J)
19218 XB(4)=BETP(IIP,4)*(XD(4)-BED)
19219 SR2=XB(1)**2+XB(2)**2+XB(3)**2
19220 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
19221 & DIRP(IIP,3)*XB(3))**2
19222 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
19224 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
19225 IF(WTP.GT.WTMAXP) THEN
19231 C...Loop over W- string pieces and find one with largest weight.
19239 IF(K(INM(IIM),2).LT.0) GOTO 240
19240 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
19241 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
19243 XB(J)=XD(J)+BEDG*BETM(IIM,J)
19245 XB(4)=BETM(IIM,4)*(XD(4)-BED)
19246 SR2=XB(1)**2+XB(2)**2+XB(3)**2
19247 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
19248 & DIRM(IIM,3)*XB(3))**2
19249 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
19251 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
19252 IF(WTM.GT.WTMAXM) THEN
19258 C...Result of integration.
19260 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
19261 WT=WTMAXP*WTMAXM/WTSMP
19269 RES=BLOWR**3*BLOWT*SUM/NPT
19271 C...Decide whether to reconnect and, if so, where.
19273 PREC=1D0-EXP(-FACT*RES)
19274 IF(PREC.GT.PYR(0)) THEN
19279 IF(RSUM.LE.0D0) GOTO 270
19285 C...Begin scenario II and II' specifics.
19286 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
19288 C...Loop through all string pieces, one from W+ and one from W-.
19292 IF(K(INP(IIP),2).LT.0) GOTO 340
19296 IF(K(INM(IIM),2).LT.0) GOTO 330
19300 C...Find endpoint velocity vectors.
19302 V1P(J)=P(I1P,J)/P(I1P,4)
19303 V2P(J)=P(I2P,J)/P(I2P,4)
19304 V1M(J)=P(I1M,J)/P(I1M,4)
19305 V2M(J)=P(I2M,J)/P(I2M,4)
19308 C...Define q matrix and find t.
19310 Q(1,J)=V2P(J)-V1P(J)
19311 Q(2,J)=-(V2M(J)-V1M(J))
19312 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
19313 Q(4,J)=V1P(J)-V1M(J)
19315 T=-DETER(1,2,3)/DETER(1,2,4)
19317 C...Find alpha and beta; i.e. coordinates of crossing point.
19320 S13=Q(3,1)+Q(4,1)*T
19323 S23=Q(3,2)+Q(4,2)*T
19324 DEN=S11*S22-S12*S21
19325 ALP=(S12*S23-S22*S13)/DEN
19326 BET=(S21*S13-S11*S23)/DEN
19328 C...Check if solution acceptable.
19330 IF(T.LT.GTMAX) IANSW=0
19331 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
19332 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
19334 C...Find point of crossing and check that not inconsistent.
19336 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
19337 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
19339 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
19340 & (XPP(3)-XMM(3))**2
19341 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
19342 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
19343 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
19345 C...Find string eigentimes at crossing.
19346 IF(IANSW.EQ.1) THEN
19347 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
19348 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
19349 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
19350 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
19356 C...Order crossings by time. End loop over crossings.
19357 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
19359 DO 310 I1=NCROSS,1,-1
19360 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
19380 C...Loop over crossings; find first (if any) acceptable one.
19382 IF(NCROSS.GE.1) THEN
19384 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
19385 IF(PNFRAG.GT.PYR(0)) THEN
19386 C...Scenario II: only compare with fragmentation time.
19387 IF(MSTP(115).EQ.2) THEN
19392 C...Scenario II': also require that string length decreases.
19400 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19401 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19402 IF(ELNEW.LT.ELOLD) THEN
19414 C...Begin scenario GH specifics.
19415 ELSEIF(MSTP(115).EQ.5) THEN
19417 C...Loop through all string pieces, one from W+ and one from W-.
19421 IF(K(INP(IIP),2).LT.0) GOTO 380
19425 IF(K(INM(IIM),2).LT.0) GOTO 370
19429 C...Look for largest decrease of (exponent of) Lambda measure.
19430 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19431 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19432 ELDIF=ELNEW/MAX(1D-10,ELOLD)
19433 IF(ELDIF.LT.ELMIN) THEN
19445 C...Common for scenarios I, II, II' and GH: reconnect strings.
19449 DO 390 IS=1,NNP+NNM
19453 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
19455 ELSEIF(IS.LE.IIP+NNM) THEN
19456 I=INM(IS-IIP-NNM+IIM)
19461 IF(K(I,2).LT.0) THEN
19462 CALL PYJOIN(NJOIN,IJOIN)
19467 C...Restore original event record if no reconnection.
19469 DO 400 I=NSD1+1,NOLD
19470 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
19471 K(I,4)=MOD(K(I,4),MSTU(5)**2)
19472 K(I,5)=MOD(K(I,5),MSTU(5)**2)
19481 C...Boost back system.
19482 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19483 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19484 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
19485 & BEWW(1),BEWW(2),BEWW(3))
19487 C...Common part for intermediate and instantaneous scenarios.
19488 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
19491 C...Remove old shower products and reset showering ones.
19493 DO 420 I=NSD1+1,NSD1+4
19495 K(I,4)=MOD(K(I,4),MSTU(5)**2)
19496 K(I,5)=MOD(K(I,5),MSTU(5)**2)
19499 C...Identify quark-antiquark pairs.
19503 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
19506 C...Reconnect strings.
19509 CALL PYJOIN(2,IJOIN)
19512 CALL PYJOIN(2,IJOIN)
19514 C...Do new parton showers in intermediate scenario.
19515 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
19518 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
19519 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
19522 C...Do new parton showers in instantaneous scenario.
19523 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
19524 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
19525 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
19526 PPM=SQRT(MAX(0D0,PPM2))
19527 CALL PYSHOW(IQ1,IQ4,PPM)
19528 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
19529 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
19530 PPM=SQRT(MAX(0D0,PPM2))
19531 CALL PYSHOW(IQ3,IQ2,PPM)
19538 C***********************************************************************
19541 C...Checks generated variables against pre-set kinematical limits;
19542 C...also calculates limits on variables used in generation.
19544 SUBROUTINE PYKLIM(ILIM)
19546 C...Double precision and integer declarations.
19547 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19548 IMPLICIT INTEGER(I-N)
19549 INTEGER PYK,PYCHGE,PYCOMP
19551 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19552 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19553 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19554 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19555 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19556 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19557 COMMON/PYINT1/MINT(400),VINT(400)
19558 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19559 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19562 C...Common kinematical expressions.
19566 IF(ISUB.EQ.96) GOTO 100
19570 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
19571 CKIN09=MAX(CKIN(9),CKIN(13))
19572 CKIN10=MIN(CKIN(10),CKIN(14))
19573 CKIN11=MAX(CKIN(11),CKIN(15))
19574 CKIN12=MIN(CKIN(12),CKIN(16))
19576 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
19577 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
19578 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
19579 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
19584 RM3=SQM3/(TAU*VINT(2))
19585 RM4=SQM4/(TAU*VINT(2))
19586 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19589 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
19590 &PTHMIN=MAX(CKIN(3),CKIN(5))
19593 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
19594 C...pre-set kinematical limits.
19599 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
19600 X1=SQRT(TAUE)*EXP(YST)
19601 X2=SQRT(TAUE)*EXP(-YST)
19603 IF(MINT(47).NE.1) THEN
19604 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
19605 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
19606 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
19607 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
19609 IF(MINT(45).NE.1) THEN
19610 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
19612 IF(MINT(46).NE.1) THEN
19613 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
19615 IF(MINT(45).EQ.2) THEN
19616 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19618 IF(MINT(46).EQ.2) THEN
19619 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19621 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
19622 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
19623 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
19624 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
19625 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
19626 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
19627 Y3=YST+0.5D0*LOG(EXPY3)
19628 Y4=YST+0.5D0*LOG(EXPY4)
19633 STH=SQRT(MAX(0D0,1D0-CTH**2))
19634 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
19635 & CTH)**2-4D0*RM3))
19636 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
19637 & CTH)**2-4D0*RM4))
19638 IF(STH.GE.1D-10) THEN
19639 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
19641 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
19643 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
19644 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
19645 ETALAR=MAX(ETA3,ETA4)
19646 ETASMA=MIN(ETA3,ETA4)
19648 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
19649 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
19650 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
19651 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
19653 RPTS=4D0*VINT(71)**2/SH
19654 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
19655 RM34=MAX(1D-20,2D0*RM3*RM4)
19656 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
19657 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
19658 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
19659 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
19660 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
19661 IF(PTH.LT.PTHMIN) MINT(51)=1
19662 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
19663 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
19664 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
19665 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
19666 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
19667 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
19668 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
19669 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
19670 IF(THA.LT.CKIN(35)) MINT(51)=1
19671 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
19672 IF(UHA.LT.CKIN(37)) MINT(51)=1
19673 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
19675 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
19676 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
19677 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
19680 C...Additional cuts on W2 (approximately) in DIS.
19681 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
19683 IF(IABS(MINT(12)).LT.20) XBJ=X1
19685 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
19686 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
19687 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
19690 ELSEIF(ILIM.EQ.1) THEN
19691 C...Calculate limits on tau
19692 C...0) due to definition
19695 C...1) due to limits on subsystem mass
19696 TAUMN1=CKIN(1)**2/VINT(2)
19698 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
19699 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
19700 TM3=SQRT(SQM3+PTHMIN**2)
19701 TM4=SQRT(SQM4+PTHMIN**2)
19703 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
19704 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
19706 C...3) due to limits on pT-hat and cos(theta-hat)
19707 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
19708 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
19710 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
19711 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
19712 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
19714 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
19715 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
19716 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
19717 C...4) due to limits on x1 and x2
19718 TAUMN4=CKIN(21)*CKIN(23)
19719 TAUMX4=CKIN(22)*CKIN(24)
19720 C...5) due to limits on xF
19722 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
19723 C...6) due to limits on that and uhat
19724 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
19726 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
19727 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
19729 C...Net effect of all separate limits.
19730 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
19731 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
19732 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19735 ELSEIF(MINT(47).EQ.5) THEN
19736 VINT(31)=MIN(VINT(31),1D0-2D-10)
19737 ELSEIF(MINT(47).GE.6) THEN
19738 VINT(31)=MIN(VINT(31),1D0-1D-10)
19740 IF(VINT(31).LE.VINT(11)) MINT(51)=1
19742 ELSEIF(ILIM.EQ.2) THEN
19743 C...Calculate limits on y*
19745 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
19747 C...0) due to kinematics
19750 C...1) due to explicit limits
19753 C...2) due to limits on x1
19754 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
19755 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
19756 C...3) due to limits on x2
19757 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
19758 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
19759 C...4) due to limits on xF
19760 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
19761 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
19762 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
19763 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
19764 C...5) due to simultaneous limits on y-large and y-small
19765 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
19766 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
19767 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
19768 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
19769 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
19770 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
19771 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
19773 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
19774 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
19775 RZMX=BE34*MIN(CKIN(28),CTHLIM)
19776 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
19777 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
19778 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
19779 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
19780 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
19781 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
19783 C...Net effect of all separate limits.
19784 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
19785 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
19786 IF(MINT(47).EQ.1) THEN
19789 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
19790 VINT(12)=(1D0-1D-9)*YSTMX0
19791 VINT(32)=(1D0+1D-9)*YSTMX0
19792 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
19793 VINT(12)=-(1D0+1D-9)*YSTMX0
19794 VINT(32)=-(1D0-1D-9)*YSTMX0
19795 ELSEIF(MINT(47).EQ.5) THEN
19796 YSTEE=LOG((1D0-1D-10)/TAURT)
19797 VINT(12)=MAX(VINT(12),-YSTEE)
19798 VINT(32)=MIN(VINT(32),YSTEE)
19800 IF(VINT(32).LE.VINT(12)) MINT(51)=1
19802 ELSEIF(ILIM.EQ.3) THEN
19803 C...Calculate limits on cos(theta-hat)
19805 C...0) due to definition
19810 C...1) due to explicit limits
19811 CTNMN1=MIN(0D0,CKIN(27))
19812 CTNMX1=MIN(0D0,CKIN(28))
19813 CTPMN1=MAX(0D0,CKIN(27))
19814 CTPMX1=MAX(0D0,CKIN(28))
19815 C...2) due to limits on pT-hat
19816 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
19820 IF(CKIN(4).GE.0D0) THEN
19821 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
19822 & (BE34**2*TAU*VINT(2))))
19825 C...3) due to limits on y-large and y-small
19826 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
19827 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
19828 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
19829 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
19830 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
19831 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
19832 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
19833 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
19834 C...4) due to limits on that
19840 IF(CKIN(35).GT.0D0) THEN
19841 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
19842 IF(CTLIM.GT.0D0) THEN
19849 IF(CKIN(36).GT.0D0) THEN
19850 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
19851 IF(CTLIM.LT.0D0) THEN
19858 C...5) due to limits on uhat
19863 IF(CKIN(37).GT.0D0) THEN
19864 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
19865 IF(CTLIM.LT.0D0) THEN
19872 IF(CKIN(38).GT.0D0) THEN
19873 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
19874 IF(CTLIM.GT.0D0) THEN
19882 C...Net effect of all separate limits.
19883 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
19884 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
19885 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
19886 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
19887 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
19889 ELSEIF(ILIM.EQ.4) THEN
19890 C...Calculate limits on tau'
19891 C...0) due to kinematics
19893 IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
19894 PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
19895 TAPMN0=(SQRT(TAU)+PQRAT)**2
19898 C...1) due to explicit limits
19899 TAPMN1=CKIN(31)**2/VINT(2)
19901 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
19903 C...Net effect of all separate limits.
19904 VINT(16)=MAX(TAPMN0,TAPMN1)
19905 VINT(36)=MIN(TAPMX0,TAPMX1)
19906 IF(MINT(47).EQ.1) THEN
19909 ELSEIF(MINT(47).EQ.5) THEN
19910 VINT(36)=MIN(VINT(36),1D0-2D-10)
19911 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
19912 VINT(36)=MIN(VINT(36),1D0-1D-10)
19914 IF(VINT(36).LE.VINT(16)) MINT(51)=1
19919 C...Special case for low-pT and multiple interactions:
19920 C...effective kinematical limits for tau, y*, cos(theta-hat).
19921 100 IF(ILIM.EQ.0) THEN
19922 ELSEIF(ILIM.EQ.1) THEN
19923 IF(MSTP(82).LE.1) THEN
19924 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19927 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
19930 ELSEIF(ILIM.EQ.2) THEN
19931 VINT(12)=0.5D0*LOG(VINT(21))
19933 ELSEIF(ILIM.EQ.3) THEN
19934 IF(MSTP(82).LE.1) THEN
19935 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19936 & (VINT(21)*VINT(2))
19938 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19939 & (VINT(21)*VINT(2))
19941 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
19950 C*********************************************************************
19953 C...Maps a uniform distribution into a distribution of a kinematical
19954 C...variable according to one of the possibilities allowed. It is
19955 C...assumed that kinematical limits have been set by a PYKLIM call.
19957 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
19959 C...Double precision and integer declarations.
19960 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19961 IMPLICIT INTEGER(I-N)
19962 INTEGER PYK,PYCHGE,PYCOMP
19964 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19965 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19966 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19967 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19968 COMMON/PYINT1/MINT(400),VINT(400)
19969 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19970 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
19972 C...Convert VVAR to tau variable.
19978 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
19981 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
19985 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19987 ELSEIF(MVAR.EQ.1) THEN
19988 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
19989 ELSEIF(MVAR.EQ.2) THEN
19990 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
19991 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
19992 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
19993 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
19994 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
19995 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
19996 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
19997 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
19998 ELSEIF(MINT(47).EQ.5) THEN
19999 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
20000 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
20001 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20003 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
20004 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
20005 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20007 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
20009 C...Convert VVAR to y* variable.
20010 ELSEIF(IVAR.EQ.2) THEN
20014 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
20015 IF(MINT(47).EQ.1) THEN
20017 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
20018 YST=-0.5D0*LOG(TAUE)
20019 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
20020 YST=0.5D0*LOG(TAUE)
20021 ELSEIF(MVAR.EQ.1) THEN
20022 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
20023 ELSEIF(MVAR.EQ.2) THEN
20024 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
20025 ELSEIF(MVAR.EQ.3) THEN
20026 AUPP=ATAN(EXP(YSTMAX))
20027 ALOW=ATAN(EXP(YSTMIN))
20028 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
20029 ELSEIF(MVAR.EQ.4) THEN
20030 YST0=-0.5D0*LOG(TAUE)
20031 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
20032 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
20033 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
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=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
20040 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
20042 C...Convert VVAR to cos(theta-hat) variable.
20043 ELSEIF(IVAR.EQ.3) THEN
20044 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
20046 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
20047 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
20055 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20056 VCTN=VVAR*(ANEG+APOS)/ANEG
20057 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
20059 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20060 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
20062 ELSEIF(MVAR.EQ.2) THEN
20063 RMNMIN=MAX(RM34,RSQM-CTNMIN)
20064 RMNMAX=MAX(RM34,RSQM-CTNMAX)
20065 RMPMIN=MAX(RM34,RSQM-CTPMIN)
20066 RMPMAX=MAX(RM34,RSQM-CTPMAX)
20067 ANEG=LOG(RMNMIN/RMNMAX)
20068 APOS=LOG(RMPMIN/RMPMAX)
20069 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20070 VCTN=VVAR*(ANEG+APOS)/ANEG
20071 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
20073 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20074 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
20076 ELSEIF(MVAR.EQ.3) THEN
20077 RMNMIN=MAX(RM34,RSQM+CTNMIN)
20078 RMNMAX=MAX(RM34,RSQM+CTNMAX)
20079 RMPMIN=MAX(RM34,RSQM+CTPMIN)
20080 RMPMAX=MAX(RM34,RSQM+CTPMAX)
20081 ANEG=LOG(RMNMAX/RMNMIN)
20082 APOS=LOG(RMPMAX/RMPMIN)
20083 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20084 VCTN=VVAR*(ANEG+APOS)/ANEG
20085 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
20087 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20088 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
20090 ELSEIF(MVAR.EQ.4) THEN
20091 RMNMIN=MAX(RM34,RSQM-CTNMIN)
20092 RMNMAX=MAX(RM34,RSQM-CTNMAX)
20093 RMPMIN=MAX(RM34,RSQM-CTPMIN)
20094 RMPMAX=MAX(RM34,RSQM-CTPMAX)
20095 ANEG=1D0/RMNMAX-1D0/RMNMIN
20096 APOS=1D0/RMPMAX-1D0/RMPMIN
20097 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20098 VCTN=VVAR*(ANEG+APOS)/ANEG
20099 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
20101 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20102 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
20104 ELSEIF(MVAR.EQ.5) THEN
20105 RMNMIN=MAX(RM34,RSQM+CTNMIN)
20106 RMNMAX=MAX(RM34,RSQM+CTNMAX)
20107 RMPMIN=MAX(RM34,RSQM+CTPMIN)
20108 RMPMAX=MAX(RM34,RSQM+CTPMAX)
20109 ANEG=1D0/RMNMIN-1D0/RMNMAX
20110 APOS=1D0/RMPMIN-1D0/RMPMAX
20111 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20112 VCTN=VVAR*(ANEG+APOS)/ANEG
20113 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
20115 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20116 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
20119 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
20120 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
20123 C...Convert VVAR to tau' variable.
20124 ELSEIF(IVAR.EQ.4) THEN
20128 IF(MINT(47).EQ.1) THEN
20130 ELSEIF(MVAR.EQ.1) THEN
20131 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
20132 ELSEIF(MVAR.EQ.2) THEN
20133 AUPP=(1D0-TAU/TAUPMX)**4
20134 ALOW=(1D0-TAU/TAUPMN)**4
20135 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
20136 ELSEIF(MINT(47).EQ.5) THEN
20137 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
20138 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
20139 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20141 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
20142 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
20143 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20145 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
20147 C...Selection of extra variables needed in 2 -> 3 process:
20148 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
20149 C...Since no options are available, the functions of PYKLIM
20150 C...and PYKMAP are joint for these choices.
20151 ELSEIF(IVAR.EQ.5) THEN
20153 C...Read out total energy and particle masses.
20156 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
20157 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
20159 SHP=VINT(26)*VINT(2)
20163 PM3=SQRT(VINT(21))*VINT(1)
20164 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
20171 C...Specify coefficients of pT choice; upper and lower limits.
20172 IF(MPTPK.EQ.1) THEN
20180 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
20182 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
20184 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
20186 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
20189 C...Select transverse momenta according to
20190 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
20193 IF(HMX.LT.1.0001D0*HMN) THEN
20199 IF(RPT.LT.HWT1) THEN
20200 PTS1=PTSMN1+PYR(0)*HDE
20201 ELSEIF(RPT.LT.HWT1+HWT2) THEN
20202 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
20204 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
20206 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
20207 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
20210 IF(HMX.LT.1.0001D0*HMN) THEN
20216 IF(RPT.LT.HWT1) THEN
20217 PTS2=PTSMN2+PYR(0)*HDE
20218 ELSEIF(RPT.LT.HWT1+HWT2) THEN
20219 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
20221 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
20223 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
20224 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
20226 C...Select azimuthal angles and check pT choice.
20227 PHI1=PARU(2)*PYR(0)
20228 PHI2=PARU(2)*PYR(0)
20230 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
20231 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
20232 & CKIN(56)**2)) THEN
20237 C...Calculate transverse masses and check phase space not closed.
20244 PM12=(PMT1+PMT2)**2
20245 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
20250 C...Select rapidity for particle 3 and check phase space not closed.
20251 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
20252 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
20253 IF(Y3MAX.LT.1D-6) THEN
20257 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
20261 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
20264 PMS12=PE12**2-PZ12**2
20265 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
20266 IF(SQL12.LT.1D-6*SHP) THEN
20270 PMM1=PMS12+PMS1-PMS2
20271 PMM2=PMS12+PMS2-PMS1
20272 TFAC=-SHPR/(2D0*PMS12)
20273 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
20274 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
20275 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
20276 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
20278 C...Construct relative mirror weights and make choice.
20279 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
20283 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
20284 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
20286 WTP=WTPU/(WTPU+WTNU)
20287 WTN=WTNU/(WTPU+WTNU)
20289 IF(WTN.GT.PYR(0)) EPS=-1D0
20291 C...Store result of variable choice and associated weights.
20301 IF(EPS.GT.0D0) THEN
20310 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
20311 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
20312 VINT(219)=0.5D0*(PMS12-PTS3)
20319 C***********************************************************************
20322 C...Differential matrix elements for all included subprocesses
20323 C...Note that what is coded is (disregarding the COMFAC factor)
20324 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
20325 C...when d(sigma-hat) is given in the zero-width limit, the delta
20326 C...function in tau is replaced by a (modified) Breit-Wigner:
20327 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
20328 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
20329 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
20330 C...i.e., dimensionless quantities
20331 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
20332 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
20333 C...(2pi)^4 delta^4(P - sum p_i)
20334 C...COMFAC contains the factor pi/s (or equivalent) and
20335 C...the conversion factor from GeV^-2 to mb
20337 SUBROUTINE PYSIGH(NCHN,SIGS)
20339 C...Double precision and integer declarations
20340 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20341 IMPLICIT INTEGER(I-N)
20342 INTEGER PYK,PYCHGE,PYCOMP
20343 C...Parameter statement to help give large particle numbers.
20344 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
20345 &KEXCIT=4000000,KDIMEN=5000000)
20347 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20348 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20349 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20350 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20351 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20352 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20353 COMMON/PYINT1/MINT(400),VINT(400)
20354 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20355 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20356 COMMON/PYINT4/MWID(500),WIDS(500,5)
20357 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20358 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20359 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
20360 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
20361 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
20362 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
20363 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
20364 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
20365 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
20366 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
20367 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20368 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
20369 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYSGCM/
20370 C...Local arrays and complex variables
20371 DIMENSION X(2),XPQ(-25:25)
20373 C...Map of processes onto which routine to call
20374 C...in order to evaluate cross section:
20375 C...0 = not implemented;
20376 C...1 = standard QCD (including photons);
20377 C...2 = heavy flavours;
20379 C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
20381 C...6 = Technicolor;
20382 C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
20383 DIMENSION MAPPR(500)
20384 DATA (MAPPR(I),I=1,180)/
20385 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
20386 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
20387 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
20388 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
20389 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
20390 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
20391 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
20392 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
20393 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
20394 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
20395 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
20396 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
20397 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
20398 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
20399 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
20400 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
20401 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
20402 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
20403 DATA (MAPPR(I),I=181,500)/
20404 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
20405 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
20407 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
20409 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
20410 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
20411 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
20412 7 6, 6, 6, 6, 6, 6, 6, 0, 0, 0,
20413 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
20414 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
20417 C...Reset number of channels and cross-section
20421 C...Read process to consider.
20426 C...Read kinematical variables and limits
20444 C...Derive kinematical quantities
20446 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
20447 X(1)=SQRT(TAUE)*EXP(YST)
20448 X(2)=SQRT(TAUE)*EXP(-YST)
20449 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
20450 IF(X(1).GT.1D0-1D-7) RETURN
20451 ELSEIF(MINT(45).EQ.3) THEN
20452 X(1)=MIN(1D0-1.1D-10,X(1))
20454 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
20455 IF(X(2).GT.1D0-1D-7) RETURN
20456 ELSEIF(MINT(46).EQ.3) THEN
20457 X(2)=MIN(1D0-1.1D-10,X(2))
20459 SH=MAX(1D0,TAU*VINT(2))
20464 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
20465 RPTS=4D0*VINT(71)**2/SH
20466 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
20467 RM34=MAX(1D-20,2D0*RM3*RM4)
20469 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
20470 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
20471 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
20472 IF(ISTSB.EQ.0) THEN
20474 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
20475 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
20477 C...Kinematics with incoming masses tricky: now depends on how
20478 C...subprocess has been set up w.r.t. order of incoming partons.
20480 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
20482 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
20483 IF(ISUB.EQ.35) THEN
20487 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
20488 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
20489 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
20491 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
20493 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
20500 C...Choice of Q2 scale: hard, parton distributions, parton showers
20501 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
20503 ELSEIF(ISTSB.EQ.8) THEN
20504 IF(MINT(107).EQ.4) Q2=VINT(307)
20505 IF(MINT(108).EQ.4) Q2=VINT(308)
20506 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
20508 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
20510 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
20511 IF(MSTP(32).EQ.1) THEN
20512 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
20513 ELSEIF(MSTP(32).EQ.2) THEN
20514 Q2=SQPTH+0.5D0*(SQM3+SQM4)
20515 ELSEIF(MSTP(32).EQ.3) THEN
20517 ELSEIF(MSTP(32).EQ.4) THEN
20519 ELSEIF(MSTP(32).EQ.5) THEN
20521 ELSEIF(MSTP(32).EQ.6) THEN
20523 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
20525 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
20526 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
20527 & (SQPTH+0.5D0*(SQM3+SQM4))
20528 ELSEIF(MSTP(32).EQ.7) THEN
20529 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
20530 ELSEIF(MSTP(32).EQ.8) THEN
20531 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
20532 ELSEIF(MSTP(32).EQ.9) THEN
20533 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
20534 ELSEIF(MSTP(32).EQ.10) THEN
20537 IF(ISTSB.EQ.9) Q2=SQPTH
20538 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
20539 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
20542 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20544 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
20545 & ISUB.EQ.351) Q2SF=PMAS(24,1)**2
20546 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
20547 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
20548 & ISUB.EQ.186.OR.ISUB.EQ.187) THEN
20549 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
20550 IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
20551 IF(MSTP(39).EQ.3) Q2SF=SH
20552 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
20553 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
20558 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
20559 IF(MSTP(69).GE.2) Q2SF=VINT(2)
20560 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
20561 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20563 IF(MINT(43).EQ.3) XBJ=X(1)
20564 IF(MSTP(22).EQ.1) THEN
20566 ELSEIF(MSTP(22).EQ.2) THEN
20567 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
20568 ELSEIF(MSTP(22).EQ.3) THEN
20569 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
20571 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
20574 IF(MSTP(68).EQ.1.AND.(ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.
20575 &ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
20576 &ISUBSV.EQ.144.OR.ISUBSV.EQ.152.OR.ISUBSV.EQ.157)) THEN
20578 ELSEIF(MSTP(68).GE.2.AND.(ISUBSV.NE.11.AND.ISUBSV.NE.12.AND.
20579 &ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.ISUBSV.NE.53.AND.
20580 &ISUBSV.NE.68)) THEN
20584 C...Store derived kinematical quantities
20591 IF(ISTSB.NE.8) VINT(48)=SQPTH
20592 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
20593 VINT(50)=TAUP*VINT(2)
20594 VINT(49)=SQRT(MAX(0D0,VINT(50)))
20598 VINT(53)=SQRT(Q2SF)
20600 VINT(55)=SQRT(Q2PS)
20602 C...Calculate parton distributions
20603 IF(ISTSB.LE.0) GOTO 160
20604 IF(MINT(47).GE.2) THEN
20605 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
20607 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
20608 IF(ISUB.EQ.99) THEN
20609 IF(MINT(140+I).EQ.0) THEN
20610 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
20612 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
20617 MINT(105)=MINT(102+I)
20618 MINT(109)=MINT(106+I)
20619 VINT(120)=VINT(2+I)
20621 C.... Store side in MINT(124)
20624 IF(MSTP(57).LE.1) THEN
20625 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
20627 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
20630 XSFX(I,KFL)=XPQ(KFL)
20635 C...Calculate alpha_em, alpha_strong and K-factor
20638 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
20639 &1D0-(PMAS(24,1)/PMAS(23,1))**2
20641 XWC=1D0/(16D0*XW*XW1)
20643 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
20644 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
20647 IF(MSTP(33).EQ.1) THEN
20649 ELSEIF(MSTP(33).EQ.2) THEN
20651 FACA=PARP(32)/PARP(31)
20652 ELSEIF(MSTP(33).EQ.3) THEN
20654 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
20655 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
20662 C...Set flags for allowed reacting partons/leptons
20667 IF(MINT(44+I).EQ.1) THEN
20668 KFAC(I,MINT(10+I))=1
20669 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
20670 KFAC(I,MINT(10+I))=1
20676 KFAC(I,J)=KFIN(I,J)
20677 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
20678 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
20683 C...Lower and upper limit for fermion flavour loops
20689 IF(KFAC(1,-J).EQ.1) MMIN1=-J
20690 IF(KFAC(1,J).EQ.1) MMAX1=J
20691 IF(KFAC(2,-J).EQ.1) MMIN2=-J
20692 IF(KFAC(2,J).EQ.1) MMAX2=J
20694 MMINA=MIN(MMIN1,MMIN2)
20695 MMAXA=MAX(MMAX1,MMAX2)
20697 C...Common resonance mass and width combinations
20700 GMMZ=PMAS(23,1)*PMAS(23,2)
20701 GMMW=PMAS(24,1)*PMAS(24,2)
20703 C...Polarization factors...implemented so far for W+W-(25)
20704 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
20705 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
20706 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
20707 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
20709 C...Phase space integral in tau
20710 COMFAC=PARU(1)*PARU(5)/VINT(2)
20711 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
20712 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
20713 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
20714 ATAU1=LOG(TAUMAX/TAUMIN)
20715 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
20716 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
20717 IF(MINT(72).GE.1) THEN
20720 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
20722 IF(ATAUD.GT.1D-10) H1=H1+
20723 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
20724 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
20726 IF(ATAUD.GT.1D-10) H1=H1+
20727 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
20729 IF(MINT(72).EQ.2) THEN
20732 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
20734 IF(ATAUD.GT.1D-10) H1=H1+
20735 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
20736 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
20738 IF(ATAUD.GT.1D-10) H1=H1+
20739 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
20741 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20742 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
20743 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20744 & MAX(2D-10,1D0-TAU)
20745 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20746 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
20747 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20748 & MAX(1D-10,1D0-TAU)
20750 COMFAC=COMFAC*ATAU1/(TAU*H1)
20753 C...Phase space integral in y*
20754 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
20756 AYST0=YSTMAX-YSTMIN
20757 IF(AYST0.LT.1D-10) THEN
20760 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20762 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20763 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20764 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20765 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20766 IF(MINT(45).EQ.3) THEN
20767 YST0=-0.5D0*LOG(TAUE)
20768 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
20769 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
20770 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
20771 & MAX(1D-10,1D0-EXP(YST-YST0))
20773 IF(MINT(46).EQ.3) THEN
20774 YST0=-0.5D0*LOG(TAUE)
20775 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
20776 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
20777 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
20778 & MAX(1D-10,1D0-EXP(-YST-YST0))
20780 COMFAC=COMFAC*AYST0/H2
20784 C...2 -> 1 processes: reduction in angular part of phase space integral
20785 C...for case of decaying resonance
20786 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
20787 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
20788 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
20789 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
20790 & KFPR(ISUB,1).EQ.39) THEN
20791 COMFAC=COMFAC*0.5D0*ACTH0
20793 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
20794 & CTPMAX**3-CTPMIN**3)
20798 C...2 -> 2 processes: angular part of phase space integral
20799 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
20800 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
20801 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
20802 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
20803 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
20804 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
20805 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
20806 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
20807 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
20808 H3=COEF(ISUBSV,13)+
20809 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
20810 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
20811 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
20812 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
20813 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
20815 C...2 -> 2 processes: take into account final state Breit-Wigners
20816 COMFAC=COMFAC*VINT(80)
20819 C...2 -> 3, 4 processes: phace space integral in tau'
20820 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20821 ATAUP1=LOG(TAUPMX/TAUPMN)
20822 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
20823 H4=COEF(ISUBSV,18)+
20824 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
20825 IF(MINT(47).EQ.5) THEN
20826 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
20827 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
20828 ELSEIF(MINT(47).GE.6) THEN
20829 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
20830 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
20832 COMFAC=COMFAC*ATAUP1/H4
20835 C...2 -> 3, 4 processes: effective W/Z parton distributions
20836 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
20837 IF(1D0-TAU/TAUP.GT.1D-4) THEN
20838 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
20840 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
20845 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
20846 IF(ISTSB.EQ.5) THEN
20847 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
20848 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
20851 C...Phase space integral for low-pT and multiple interactions
20852 IF(ISTSB.EQ.9) THEN
20853 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
20854 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
20855 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
20856 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
20857 COMFAC=COMFAC*ATAU1/H1
20858 AYST0=YSTMAX-YSTMIN
20859 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20860 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20861 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20862 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20863 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20864 COMFAC=COMFAC*AYST0/H2
20865 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
20866 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
20867 C...introduced to make cross-section finite for xT2 -> 0
20868 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
20872 C...Real gamma + gamma: include factor 2 when different nature
20873 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
20874 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
20876 C...Extra factors to include the effects of
20877 C...longitudinal resolved photons (but not direct or DIS ones).
20879 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
20880 & MINT(106+ISDE).LE.3) THEN
20883 IF(MSTP(16).EQ.0) THEN
20884 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
20885 & XY=VINT(304+ISDE)
20887 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
20888 & XY=VINT(308+ISDE)
20890 Q2GA=VINT(306+ISDE)
20891 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
20892 & Q2GA.GT.0D0) THEN
20894 IF(MSTP(17).EQ.1) THEN
20895 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
20896 ELSEIF(MSTP(17).EQ.2) THEN
20897 REDUCE=4D0*Q2GA/(Q2+Q2GA)
20898 ELSEIF(MSTP(17).EQ.3) THEN
20899 PMVIRT=PMAS(PYCOMP(113),1)
20900 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20901 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
20902 PMVIRT=PMAS(PYCOMP(113),1)
20903 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20904 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
20905 PMVIRT=PMAS(PYCOMP(113),1)
20906 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20907 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
20908 PMVSMN=4D0*PARP(15)**2
20909 PMVSMX=4D0*VINT(154)**2
20910 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20911 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
20912 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
20913 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
20914 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
20915 PMVIRT=PMAS(PYCOMP(113),1)
20916 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20917 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
20918 PMVIRT=PMAS(PYCOMP(113),1)
20919 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20920 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
20921 PMVSMN=4D0*PARP(15)**2
20922 PMVSMX=4D0*VINT(154)**2
20923 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20924 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
20925 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
20928 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
20929 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
20930 & (1D0-2D0*BEAMAS**2/Q2GA))
20931 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
20936 COMFAC=COMFAC*VINT(314+ISDE)
20939 C...Evaluate cross sections - done in separate routines by kind
20940 C...of physics, to keep PYSIGH of sensible size.
20942 C...Standard QCD (including photons).
20943 CALL PYSGQC(NCHN,SIGS)
20944 ELSEIF(MAP.EQ.2) THEN
20945 C...Heavy flavours.
20946 CALL PYSGHF(NCHN,SIGS)
20947 ELSEIF(MAP.EQ.3) THEN
20949 CALL PYSGWZ(NCHN,SIGS)
20950 ELSEIF(MAP.EQ.4) THEN
20951 C...Higgs (2 doublets; including longitudinal W/Z scattering).
20952 CALL PYSGHG(NCHN,SIGS)
20953 ELSEIF(MAP.EQ.5) THEN
20955 CALL PYSGSU(NCHN,SIGS)
20956 ELSEIF(MAP.EQ.6) THEN
20958 CALL PYSGTC(NCHN,SIGS)
20959 ELSEIF(MAP.EQ.7) THEN
20960 C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
20961 CALL PYSGEX(NCHN,SIGS)
20964 C...Multiply with parton distributions
20965 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
20967 IF(MINT(45).GE.2) THEN
20969 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
20971 IF(MINT(46).GE.2) THEN
20973 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
20975 SIGS=SIGS+SIGH(ICHN)
20982 C*********************************************************************
20985 C...Subprocess cross sections for QCD processes,
20986 C...including photons.
20987 C...Auxiliary to PYSIGH.
20989 SUBROUTINE PYSGQC(NCHN,SIGS)
20991 C...Double precision and integer declarations
20992 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20993 IMPLICIT INTEGER(I-N)
20994 INTEGER PYK,PYCHGE,PYCOMP
20995 C...Parameter statement to help give large particle numbers.
20996 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
20997 &KEXCIT=4000000,KDIMEN=5000000)
20999 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21000 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21001 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
21002 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21003 COMMON/PYINT1/MINT(400),VINT(400)
21004 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
21005 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
21006 COMMON/PYINT4/MWID(500),WIDS(500,5)
21007 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
21008 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
21009 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
21010 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
21011 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
21012 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
21013 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
21015 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
21017 C...Differential cross section expressions.
21019 IF(ISUB.LE.20) THEN
21020 IF(ISUB.EQ.10) THEN
21021 C...f + f' -> f + f' (gamma/Z/W exchange)
21022 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
21023 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
21024 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
21025 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
21026 DO 110 I=MMIN1,MMAX1
21027 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
21029 DO 100 J=MMIN2,MMAX2
21030 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
21032 C...Electroweak couplings
21033 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
21034 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
21036 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
21037 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
21040 C...gamma/Z exchange, only gamma exchange, or only Z exchange
21041 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
21042 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
21043 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
21044 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
21045 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
21046 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21047 ELSEIF(MSTP(21).EQ.2) THEN
21048 FACNCF=FACGGF*EI**2*EJ**2
21050 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
21051 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21053 C...Extrafactor 2 for only one incoming neutrino spin state.
21054 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
21055 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
21063 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
21064 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
21065 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
21066 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
21067 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
21077 ELSEIF(ISUB.EQ.11) THEN
21078 C...f + f' -> f + f' (g exchange)
21079 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
21080 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
21081 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
21082 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
21083 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
21084 DO 130 I=MMIN1,MMAX1
21086 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
21087 DO 120 J=MMIN2,MMAX2
21089 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
21095 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
21097 SIGH(NCHN)=0.5D0*SIGH(NCHN)
21102 SIGH(NCHN)=0.5D0*FACQQ2
21107 ELSEIF(ISUB.EQ.12) THEN
21108 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
21109 CALL PYWIDT(21,SH,WDTP,WDTE)
21110 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
21111 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21112 DO 140 I=MMINA,MMAXA
21113 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21114 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
21122 ELSEIF(ISUB.EQ.13) THEN
21123 C...f + fbar -> g + g (q + qbar -> g + g only)
21124 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21126 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21128 DO 150 I=MMINA,MMAXA
21129 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21130 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
21135 SIGH(NCHN)=0.5D0*FACGG1
21140 SIGH(NCHN)=0.5D0*FACGG2
21143 ELSEIF(ISUB.EQ.14) THEN
21144 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
21145 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
21146 DO 160 I=MMINA,MMAXA
21147 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21148 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
21149 EI=KCHG(IABS(I),1)/3D0
21154 SIGH(NCHN)=FACGG*EI**2
21157 ELSEIF(ISUB.EQ.18) THEN
21158 C...f + fbar -> gamma + gamma
21159 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
21160 DO 170 I=MMINA,MMAXA
21161 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
21162 EI=KCHG(IABS(I),1)/3D0
21164 IF(IABS(I).LE.10) FCOI=FACA/3D0
21169 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
21173 ELSEIF(ISUB.LE.40) THEN
21174 IF(ISUB.EQ.28) THEN
21175 C...f + g -> f + g (q + g -> q + g only)
21176 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
21178 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
21180 DO 190 I=MMINA,MMAXA
21181 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
21183 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
21184 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
21187 ISIG(NCHN,3-ISDE)=21
21192 ISIG(NCHN,3-ISDE)=21
21198 ELSEIF(ISUB.EQ.29) THEN
21199 C...f + g -> f + gamma (q + g -> q + gamma only)
21200 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
21201 DO 210 I=MMINA,MMAXA
21202 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
21203 EI=KCHG(IABS(I),1)/3D0
21206 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
21207 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
21210 ISIG(NCHN,3-ISDE)=21
21216 ELSEIF(ISUB.EQ.33) THEN
21217 C...f + gamma -> f + g (q + gamma -> q + g only)
21218 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
21219 DO 230 I=MMINA,MMAXA
21220 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
21221 EI=KCHG(IABS(I),1)/3D0
21224 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
21225 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
21228 ISIG(NCHN,3-ISDE)=22
21234 ELSEIF(ISUB.EQ.34) THEN
21235 C...f + gamma -> f + gamma
21236 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
21237 DO 250 I=MMINA,MMAXA
21238 IF(I.EQ.0) GOTO 250
21239 EI=KCHG(IABS(I),1)/3D0
21242 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
21243 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
21246 ISIG(NCHN,3-ISDE)=22
21253 ELSEIF(ISUB.LE.80) THEN
21254 IF(ISUB.EQ.53) THEN
21255 C...g + g -> f + fbar (g + g -> q + qbar only)
21256 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
21258 C...Begin by d, u, s flavours.
21260 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
21261 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
21262 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
21263 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
21264 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
21265 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
21266 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21267 & UH2/SH2)*FLAVWT*FACA
21268 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21269 & TH2/SH2)*FLAVWT*FACA
21280 C...Next c and b flavours: modified that and uhat for fixed
21281 C...cos(theta-hat).
21283 SQMAVG=PMAS(IFL,1)**2
21284 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
21285 BE34=SQRT(1D0-4D0*SQMAVG/SH)
21286 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21287 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21288 THUHQ=THQ*UHQ-SQMAVG*SH
21289 IF(MSTP(34).EQ.0) THEN
21290 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
21291 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
21293 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21294 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
21295 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21296 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
21298 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
21299 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
21303 ISIG(NCHN,3)=1+2*(IFL-3)
21308 ISIG(NCHN,3)=2+2*(IFL-3)
21314 ELSEIF(ISUB.EQ.54) THEN
21315 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
21316 CALL PYWIDT(21,SH,WDTP,WDTE)
21318 DO 280 I=1,MIN(8,MDCY(21,3))
21320 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21323 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
21324 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
21331 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
21339 ELSEIF(ISUB.EQ.58) THEN
21340 C...gamma + gamma -> f + fbar
21341 CALL PYWIDT(22,SH,WDTP,WDTE)
21343 DO 290 I=1,MIN(12,MDCY(22,3))
21344 IF(I.LE.8) EF= KCHG(I,1)/3D0
21345 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
21346 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21349 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
21350 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
21358 ELSEIF(ISUB.EQ.68) THEN
21360 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
21361 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
21363 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
21365 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
21371 SIGH(NCHN)=0.5D0*FACGG1
21376 SIGH(NCHN)=0.5D0*FACGG2
21381 SIGH(NCHN)=0.5D0*FACGG3
21384 ELSEIF(ISUB.EQ.80) THEN
21385 C...q + gamma -> q' + pi+/-
21386 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
21387 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
21388 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
21389 DELSH=UH*SQRT(ASSH*Q2FPSH)
21390 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
21391 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
21392 DELUH=SH*SQRT(ASUH*Q2FPUH)
21393 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
21394 IF(I.EQ.0) GOTO 320
21395 EI=KCHG(IABS(I),1)/3D0
21396 EJ=SIGN(1D0-ABS(EI),EI)
21398 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
21399 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
21402 ISIG(NCHN,3-ISDE)=22
21404 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
21409 ELSEIF(ISUB.LE.100) THEN
21410 IF(ISUB.EQ.91) THEN
21411 C...Elastic scattering
21412 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
21414 ELSEIF(ISUB.EQ.92) THEN
21415 C...Single diffractive scattering (first side, i.e. XB)
21416 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
21418 ELSEIF(ISUB.EQ.93) THEN
21419 C...Single diffractive scattering (second side, i.e. AX)
21420 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
21422 ELSEIF(ISUB.EQ.94) THEN
21423 C...Double diffractive scattering
21424 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
21426 ELSEIF(ISUB.EQ.95) THEN
21427 C...Low-pT scattering
21428 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
21430 ELSEIF(ISUB.EQ.96) THEN
21431 C...Multiple interactions: sum of QCD processes
21432 CALL PYWIDT(21,SH,WDTP,WDTE)
21434 C...q + q' -> q + q'
21435 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
21436 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
21437 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
21438 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
21439 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
21440 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
21442 IF(I.EQ.0) GOTO 340
21444 IF(J.EQ.0) GOTO 330
21450 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
21452 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
21457 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
21462 C...q + qbar -> q' + qbar' or g + g
21463 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
21464 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
21465 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21467 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21470 IF(I.EQ.0) GOTO 350
21480 SIGH(NCHN)=0.5D0*FACGG1
21485 SIGH(NCHN)=0.5D0*FACGG2
21489 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
21491 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
21494 IF(I.EQ.0) GOTO 370
21498 ISIG(NCHN,3-ISDE)=21
21503 ISIG(NCHN,3-ISDE)=21
21509 C...g + g -> q + qbar (only d, u, s)
21512 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
21513 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
21514 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
21515 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
21516 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
21517 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
21518 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21519 & UH2/SH2)*FLAVWT*FACA
21520 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21521 & TH2/SH2)*FLAVWT*FACA
21533 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
21536 SQMAVG=PMAS(IFL,1)**2
21537 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
21538 BE34=SQRT(1D0-4D0*SQMAVG/SH)
21539 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21540 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21541 THUHQ=THQ*UHQ-SQMAVG*SH
21542 IF(MSTP(34).EQ.0) THEN
21543 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
21544 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
21546 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21547 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
21548 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21549 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
21551 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
21552 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
21556 ISIG(NCHN,3)=531+2*(IFL-3)
21561 ISIG(NCHN,3)=532+2*(IFL-3)
21567 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
21568 & 2D0*TH/SH+TH2/SH2)*FACA
21569 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
21570 & 2D0*SH/UH+SH2/UH2)*FACA
21571 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
21572 & 2D0*UH/TH+UH2/TH2)
21577 SIGH(NCHN)=0.5D0*FACGG1
21582 SIGH(NCHN)=0.5D0*FACGG2
21587 SIGH(NCHN)=0.5D0*FACGG3
21589 ELSEIF(ISUB.EQ.99) THEN
21590 C...f + gamma* -> f.
21591 IF(MINT(107).EQ.4) THEN
21600 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
21601 PM2RHO=PMAS(PYCOMP(113),1)**2
21602 IF(MSTP(19).EQ.0) THEN
21604 ELSEIF(MSTP(19).EQ.1) THEN
21605 COMFAC=COMFAC/(Q2GA+PM2RHO)
21606 ELSEIF(MSTP(19).EQ.2) THEN
21607 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
21609 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
21611 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
21612 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
21613 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
21614 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
21616 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
21618 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
21620 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
21621 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
21623 DO 390 I=MMINA,MMAXA
21624 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
21625 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
21626 EI=KCHG(IABS(I),1)/3D0
21629 ISIG(NCHN,3-ISDE)=22
21631 SIGH(NCHN)=COMFAC*EI**2
21636 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
21637 C...g + g -> gamma + gamma or g + g -> g + gamma
21652 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
21654 EI=KCHG(IABS(I),1)/3D0
21656 IF(ISUB.EQ.115) EIWT=EI
21661 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
21662 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
21665 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
21666 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
21667 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
21668 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
21674 CALL PYWAUX(1,EPSS,W1SR,W1SI)
21675 CALL PYWAUX(1,EPST,W1TR,W1TI)
21676 CALL PYWAUX(1,EPSU,W1UR,W1UI)
21677 CALL PYWAUX(2,EPSS,W2SR,W2SI)
21678 CALL PYWAUX(2,EPST,W2TR,W2TI)
21679 CALL PYWAUX(2,EPSU,W2UR,W2UI)
21680 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
21681 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
21682 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
21683 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
21684 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
21685 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
21686 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
21687 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
21688 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
21689 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
21690 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
21691 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
21692 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
21693 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
21694 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
21695 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
21696 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
21697 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
21698 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
21699 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
21700 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
21701 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
21702 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
21703 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
21704 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
21705 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
21706 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
21707 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
21708 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
21709 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
21710 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
21711 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
21712 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
21713 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
21714 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
21715 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
21716 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
21717 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
21718 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
21719 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
21720 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
21721 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
21722 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
21723 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
21724 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
21725 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
21726 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
21727 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
21728 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
21729 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
21730 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
21731 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
21732 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
21733 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
21734 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
21735 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
21737 A0STUR=A0STUR+EIWT*B0STUR
21738 A0STUI=A0STUI+EIWT*B0STUI
21739 A0TSUR=A0TSUR+EIWT*B0TSUR
21740 A0TSUI=A0TSUI+EIWT*B0TSUI
21741 A0UTSR=A0UTSR+EIWT*B0UTSR
21742 A0UTSI=A0UTSI+EIWT*B0UTSI
21743 A1STUR=A1STUR+EIWT*B1STUR
21744 A1STUI=A1STUI+EIWT*B1STUI
21745 A2STUR=A2STUR+EIWT*B2STUR
21746 A2STUI=A2STUI+EIWT*B2STUI
21748 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
21749 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
21750 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
21751 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
21752 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
21757 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
21758 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
21761 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
21762 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
21764 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
21766 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
21768 IF(ISUB.EQ.131) THEN
21769 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
21770 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
21772 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
21774 DO 430 I=MMINA,MMAXA
21775 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
21776 EI=KCHG(IABS(I),1)/3D0
21779 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
21780 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
21783 ISIG(NCHN,3-ISDE)=22
21789 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
21790 C...f + gamma*_(T,L) -> f + gamma
21792 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
21794 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
21796 IF(ISUB.EQ.133) THEN
21797 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
21798 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
21800 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
21802 DO 450 I=MMINA,MMAXA
21803 IF(I.EQ.0) GOTO 450
21804 EI=KCHG(IABS(I),1)/3D0
21807 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
21808 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
21811 ISIG(NCHN,3-ISDE)=22
21817 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
21818 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
21820 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
21822 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
21824 CALL PYWIDT(21,SH,WDTP,WDTE)
21826 DO 460 I=1,MIN(8,MDCY(21,3))
21828 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21831 IF(ISUB.EQ.135) THEN
21832 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
21833 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
21835 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
21837 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
21844 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
21852 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
21853 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
21855 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
21857 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
21858 CALL PYWIDT(22,SH,WDTP,WDTE)
21860 DO 470 I=1,MIN(12,MDCY(22,3))
21861 IF(I.LE.8) EF= KCHG(I,1)/3D0
21862 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
21863 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21866 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
21867 IF(ISUB.EQ.137) THEN
21868 FPARAM=-SH*(TH+UH)/DLAMB2
21869 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
21870 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
21871 & 2D0*PH1*PH2*FPARAM**2)
21872 ELSEIF(ISUB.EQ.138) THEN
21873 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
21874 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
21875 & 2D0*PH1**2*(TH-UH)**2)
21876 ELSEIF(ISUB.EQ.139) THEN
21877 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
21878 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
21879 & 2D0*PH2**2*(TH-UH)**2)
21881 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
21882 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
21884 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
21898 C*********************************************************************
21901 C...Subprocess cross sections for heavy flavour production,
21902 C...open and closed.
21903 C...Auxiliary to PYSIGH.
21905 SUBROUTINE PYSGHF(NCHN,SIGS)
21907 C...Double precision and integer declarations
21908 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21909 IMPLICIT INTEGER(I-N)
21910 INTEGER PYK,PYCHGE,PYCOMP
21911 C...Parameter statement to help give large particle numbers.
21912 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
21913 &KEXCIT=4000000,KDIMEN=5000000)
21915 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21916 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21917 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21918 COMMON/PYINT1/MINT(400),VINT(400)
21919 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
21920 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
21921 COMMON/PYINT4/MWID(500),WIDS(500,5)
21922 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
21923 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
21924 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
21925 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
21926 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
21929 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
21931 C...Differential cross section expressions.
21933 IF(ISUB.LE.100) THEN
21934 IF(ISUB.EQ.81) THEN
21935 C...q + qbar -> Q + Qbar
21936 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21937 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21938 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21939 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
21941 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
21943 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21944 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21946 DO 100 I=MMINA,MMAXA
21947 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21948 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
21956 ELSEIF(ISUB.EQ.82) THEN
21957 C...g + g -> Q + Qbar
21958 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21959 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21960 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21961 THUHQ=THQ*UHQ-SQMAVG*SH
21962 IF(MSTP(34).EQ.0) THEN
21963 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
21964 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
21966 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21967 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
21968 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21969 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
21971 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
21972 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
21973 IF(MSTP(35).GE.1) THEN
21974 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
21975 FACQQ1=FACQQ1*FATRE
21976 FACQQ2=FACQQ2*FATRE
21979 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21980 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21983 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
21996 ELSEIF(ISUB.EQ.83) THEN
21997 C...f + q -> f' + Q
21998 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
21999 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
22000 DO 130 I=MMIN1,MMAX1
22001 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
22002 DO 120 J=MMIN2,MMAX2
22003 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
22004 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
22005 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
22006 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
22012 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
22013 & (IABS(I)+1)/2)*VINT(180+J)
22014 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
22015 & (MINT(55)+1)/2)*VINT(180+J)
22018 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
22019 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22022 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
22023 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22026 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
22027 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
22029 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
22035 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
22036 & (IABS(J)+1)/2)*VINT(180+I)
22037 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
22038 & (MINT(55)+1)/2)*VINT(180+I)
22040 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
22041 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22044 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
22045 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22048 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
22049 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
22054 ELSEIF(ISUB.EQ.84) THEN
22055 C...g + gamma -> Q + Qbar
22056 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22057 THQ=-0.5D0*SH*(1D0-BE34*CTH)
22058 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
22059 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
22060 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
22062 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
22064 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
22065 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
22067 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
22074 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
22082 ELSEIF(ISUB.EQ.85) THEN
22083 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
22084 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22085 THQ=-0.5D0*SH*(1D0-BE34*CTH)
22086 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
22087 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
22088 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
22089 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
22090 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
22091 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
22092 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
22093 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
22095 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
22096 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
22097 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
22099 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
22107 ELSEIF(ISUB.EQ.86) THEN
22108 C...g + g -> J/Psi + g
22109 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
22110 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22111 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22112 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22120 ELSEIF(ISUB.EQ.87) THEN
22121 C...g + g -> chi_0c + g
22122 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
22123 QGTW=(SH*TH*UH)/SH**3
22125 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
22126 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
22127 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
22128 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
22129 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
22130 & (QGTW*(QGTW-RGTW*PGTW)**4)
22131 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22139 ELSEIF(ISUB.EQ.88) THEN
22140 C...g + g -> chi_1c + g
22141 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
22142 QGTW=(SH*TH*UH)/SH**3
22144 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
22145 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
22146 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
22147 & (QGTW-RGTW*PGTW)**4
22148 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22156 ELSEIF(ISUB.EQ.89) THEN
22157 C...g + g -> chi_2c + g
22158 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
22159 QGTW=(SH*TH*UH)/SH**3
22161 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
22162 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
22163 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
22164 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
22165 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
22166 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
22167 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22176 ELSEIF(ISUB.LE.200) THEN
22177 IF(ISUB.EQ.104) THEN
22178 C...g + g -> chi_c0.
22180 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
22181 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
22182 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
22183 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22191 ELSEIF(ISUB.EQ.105) THEN
22192 C...g + g -> chi_c2.
22194 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
22195 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
22196 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
22197 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22205 ELSEIF(ISUB.EQ.106) THEN
22206 C...g + g -> J/Psi + gamma.
22208 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
22209 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22210 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22211 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22219 ELSEIF(ISUB.EQ.107) THEN
22220 C...g + gamma -> J/Psi + g.
22222 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
22223 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22224 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22225 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
22232 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
22240 ELSEIF(ISUB.EQ.108) THEN
22241 C...gamma + gamma -> J/Psi + gamma.
22243 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
22244 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22245 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22246 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
22259 C*********************************************************************
22262 C...Subprocess cross sections for W/Z processes,
22263 C...except that longitudinal WW scattering is in Higgs sector.
22264 C...Auxiliary to PYSIGH.
22266 SUBROUTINE PYSGWZ(NCHN,SIGS)
22268 C...Double precision and integer declarations
22269 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22270 IMPLICIT INTEGER(I-N)
22271 INTEGER PYK,PYCHGE,PYCOMP
22272 C...Parameter statement to help give large particle numbers.
22273 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
22274 &KEXCIT=4000000,KDIMEN=5000000)
22276 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22277 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22278 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
22279 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
22280 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22281 COMMON/PYINT1/MINT(400),VINT(400)
22282 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
22283 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
22284 COMMON/PYINT4/MWID(500),WIDS(500,5)
22285 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
22286 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
22287 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
22288 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
22289 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
22290 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
22291 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
22292 C...Local arrays and complex numbers
22293 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
22295 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
22297 C...Differential cross section expressions.
22299 IF(ISUB.LE.20) THEN
22301 C...f + fbar -> gamma*/Z0
22303 CALL PYWIDT(23,SH,WDTP,WDTE)
22305 FACZ=4D0*COMFAC*3D0
22308 DO 100 I=MMINA,MMAXA
22309 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
22310 EI=KCHG(IABS(I),1)/3D0
22314 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
22316 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
22321 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
22322 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
22323 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
22324 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
22327 ELSEIF(ISUB.EQ.2) THEN
22328 C...f + fbar' -> W+/-
22329 CALL PYWIDT(24,SH,WDTP,WDTE)
22331 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
22332 HP=AEM/(24D0*XW)*SH
22333 DO 120 I=MMIN1,MMAX1
22334 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
22336 DO 110 J=MMIN2,MMAX2
22337 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
22339 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
22340 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22342 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22344 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
22349 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
22350 SIGH(NCHN)=HI*FACBW*HF
22354 ELSEIF(ISUB.EQ.15) THEN
22355 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
22356 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22357 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22361 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22362 DO 130 I=1,MIN(16,MDCY(23,3))
22364 IF(MDME(IDC,1).LT.0) GOTO 130
22366 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22370 AF=SIGN(1D0,EF+0.1D0)
22372 ELSEIF(I.LE.16) THEN
22374 AF=SIGN(1D0,EF+0.1D0)
22377 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22378 IF(4D0*RM1.LT.1D0) THEN
22380 IF(I.LE.8) FCOF=3D0*RADC4
22381 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22383 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22384 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22385 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22386 & AF**2*(1D0-4D0*RM1))*BE34
22390 C...Propagators: as simulated in PYOFSH and as desired
22391 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22395 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22397 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22398 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22399 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22400 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22401 C...Loop over flavours; consider full gamma/Z structure
22402 DO 140 I=MMINA,MMAXA
22403 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
22404 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
22405 EI=KCHG(IABS(I),1)/3D0
22412 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
22413 & (VI**2+AI**2)*HFZZ)/HBW4
22416 ELSEIF(ISUB.EQ.16) THEN
22417 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
22418 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22419 C...Propagators: as simulated in PYOFSH and as desired
22420 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22421 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22422 GMMWC=SQRT(SQM4)*WDTP(0)
22423 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22424 FACWG=FACWG*HBW4C/HBW4
22425 DO 160 I=MMIN1,MMAX1
22427 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
22428 DO 150 J=MMIN2,MMAX2
22430 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
22431 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
22432 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22433 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22434 FCKM=VCKM((IA+1)/2,(JA+1)/2)
22439 SIGH(NCHN)=FACWG*FCKM*WIDSC
22443 ELSEIF(ISUB.EQ.19) THEN
22444 C...f + fbar -> gamma + (gamma*/Z0)
22445 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22446 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22450 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22451 DO 170 I=1,MIN(16,MDCY(23,3))
22453 IF(MDME(IDC,1).LT.0) GOTO 170
22455 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22459 AF=SIGN(1D0,EF+0.1D0)
22461 ELSEIF(I.LE.16) THEN
22463 AF=SIGN(1D0,EF+0.1D0)
22466 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22467 IF(4D0*RM1.LT.1D0) THEN
22469 IF(I.LE.8) FCOF=3D0*RADC4
22470 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22472 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22473 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22474 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22475 & AF**2*(1D0-4D0*RM1))*BE34
22479 C...Propagators: as simulated in PYOFSH and as desired
22480 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22484 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22486 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22487 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22488 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22489 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22490 C...Loop over flavours; consider full gamma/Z structure
22491 DO 180 I=MMINA,MMAXA
22492 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
22493 EI=KCHG(IABS(I),1)/3D0
22497 IF(IABS(I).LE.10) FCOI=FACA/3D0
22502 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
22503 & (VI**2+AI**2)*HFZZ)/HBW4
22506 ELSEIF(ISUB.EQ.20) THEN
22507 C...f + fbar' -> gamma + W+/-
22508 FACGW=COMFAC*0.5D0*AEM**2/XW
22509 C...Propagators: as simulated in PYOFSH and as desired
22510 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22511 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22512 GMMWC=SQRT(SQM4)*WDTP(0)
22513 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22514 FACGW=FACGW*HBW4C/HBW4
22515 C...Anomalous couplings
22516 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22519 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
22520 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
22521 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
22522 & (4D0*SQMW))/(TH+UH)**2
22524 DO 200 I=MMIN1,MMAX1
22526 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
22527 DO 190 J=MMIN2,MMAX2
22529 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
22530 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
22531 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22533 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22534 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22536 FACWR=UH/(TH+UH)-1D0/3D0
22537 FCKM=VCKM((IA+1)/2,(JA+1)/2)
22544 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
22549 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
22554 ELSEIF(ISUB.LE.40) THEN
22555 IF(ISUB.EQ.22) THEN
22556 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
22557 C...Kinematics dependence
22558 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
22559 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
22560 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22566 RADC3=1D0+PYALPS(SQM3)/PARU(1)
22567 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22568 DO 230 I=1,MIN(16,MDCY(23,3))
22570 IF(MDME(IDC,1).LT.0) GOTO 230
22572 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
22573 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
22576 AF=SIGN(1D0,EF+0.1D0)
22578 ELSEIF(I.LE.16) THEN
22580 AF=SIGN(1D0,EF+0.1D0)
22583 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
22584 IF(4D0*RM1.LT.1D0) THEN
22586 IF(I.LE.8) FCOF=3D0*RADC3
22587 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22589 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22590 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22591 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
22592 & AF**2*(1D0-4D0*RM1))*BE34
22595 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22596 IF(4D0*RM1.LT.1D0) THEN
22598 IF(I.LE.8) FCOF=3D0*RADC4
22599 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22601 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22602 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22603 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
22604 & AF**2*(1D0-4D0*RM1))*BE34
22608 C...Propagators: as simulated in PYOFSH and as desired
22609 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
22610 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22614 CALL PYWIDT(23,SQM3,WDTP,WDTE)
22616 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22618 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
22619 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
22620 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
22625 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22627 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22629 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
22630 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
22631 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
22633 C...Loop over flavours; separate left- and right-handed couplings
22634 DO 270 I=MMINA,MMAXA
22635 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
22636 EI=KCHG(IABS(I),1)/3D0
22642 IF(IABS(I).LE.10) FCOI=FACA/3D0
22644 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
22645 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
22646 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
22647 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
22649 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
22650 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
22651 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
22652 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
22657 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
22660 ELSEIF(ISUB.EQ.23) THEN
22661 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
22662 FACZW=COMFAC*0.5D0*(AEM/XW)**2
22663 FACZW=FACZW*WIDS(23,2)
22664 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
22665 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
22666 DO 290 I=MMIN1,MMAX1
22668 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
22669 DO 280 J=MMIN2,MMAX2
22671 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
22672 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
22673 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22675 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22677 AI=SIGN(1D0,EI+0.1D0)
22680 AJ=SIGN(1D0,EJ+0.1D0)
22682 IF(VI+AI.GT.0) THEN
22691 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
22693 IF(IA.LE.10) FCOI=FACA/3D0
22698 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
22699 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
22700 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
22701 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
22702 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
22703 & WIDS(24,(5-KCHW)/2)
22704 C***Protect against slightly negative cross sections. (Reason yet to be
22705 C***sorted out. One possibility: addition of width to the W propagator.)
22706 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
22710 ELSEIF(ISUB.EQ.25) THEN
22711 C...f + fbar -> W+ + W-
22712 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
22714 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
22715 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
22716 CALL PYWIDT(24,SQM3,WDTP,WDTE)
22717 GMMW3=SQRT(SQM3)*WDTP(0)
22718 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
22719 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22720 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22721 GMMW4=SQRT(SQM4)*WDTP(0)
22722 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
22723 C...Kinematical functions
22724 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
22725 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
22726 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
22727 GT=THUH34+4D0*THUH/TH2
22728 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
22729 GU=THUH34+4D0*THUH/UH2
22730 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
22731 C...Common factors and couplings
22732 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
22733 FACWW=FACWW*WIDS(24,1)
22735 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
22736 CZZ=AEM**2/(32D0*XW**2)*HBWZC
22737 CNG=AEM**2/(4D0*XW)
22738 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
22739 CNN=AEM**2/(16D0*XW**2)
22740 C...Coulomb factor for W+W- pair
22741 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
22742 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
22743 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
22744 IF(COULE.LT.100D0*PMAS(24,2)) THEN
22745 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
22746 & PMAS(24,2)**2)-COULE))
22748 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
22750 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
22751 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
22752 & PMAS(24,2)**2)+COULE))
22754 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
22757 IF(MSTP(40).EQ.1) THEN
22758 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
22759 & MAX(1D-10,2D0*COULP*COULP1))
22760 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
22761 ELSEIF(MSTP(40).EQ.2) THEN
22762 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
22763 COULCP=DCMPLX(0D0,DBLE(COULP))
22764 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
22765 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
22766 & (4D0*COULCP)*LOG(COULCD)
22767 COULCS=DCMPLX(0D0,0D0)
22770 COULXX=(ISTP-0.5)/NSTP
22771 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
22772 & (1D0+COULXX/COULCD))
22774 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
22776 FACCOU=ABS(COULCR)**2
22777 ELSEIF(MSTP(40).EQ.3) THEN
22778 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
22779 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
22780 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
22782 ELSEIF(MSTP(40).EQ.4) THEN
22783 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
22789 C...Loop over allowed flavours
22790 DO 310 I=MMINA,MMAXA
22791 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
22792 EI=KCHG(IABS(I),1)/3D0
22793 AI=SIGN(1D0,EI+0.1D0)
22796 IF(IABS(I).LE.10) FCOI=FACA/3D0
22797 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
22799 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
22800 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
22802 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
22803 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
22806 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22807 BET=SQRT(1D0-4D0*XMW02/SH)
22808 GAT=1D0/SQRT(1D0-BET**2)
22810 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
22811 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
22812 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
22813 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
22814 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
22815 & (1D0-2D0*BET*CTH+BET**2))
22816 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
22817 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
22818 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
22819 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
22820 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
22821 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
22822 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
22829 SIGH(NCHN)=FACWW*FCOI*DSIGWW
22832 ELSEIF(ISUB.EQ.30) THEN
22833 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
22834 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
22836 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22840 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22841 DO 320 I=1,MIN(16,MDCY(23,3))
22843 IF(MDME(IDC,1).LT.0) GOTO 320
22845 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22849 AF=SIGN(1D0,EF+0.1D0)
22851 ELSEIF(I.LE.16) THEN
22853 AF=SIGN(1D0,EF+0.1D0)
22856 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22857 IF(4D0*RM1.LT.1D0) THEN
22859 IF(I.LE.8) FCOF=3D0*RADC4
22860 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22862 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22863 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22864 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22865 & AF**2*(1D0-4D0*RM1))*BE34
22869 C...Propagators: as simulated in PYOFSH and as desired
22870 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22874 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22876 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22877 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22878 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22879 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22880 C...Loop over flavours; consider full gamma/Z structure
22881 DO 340 I=MMINA,MMAXA
22882 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
22883 EI=KCHG(IABS(I),1)/3D0
22886 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
22887 & (VI**2+AI**2)*HFZZ)/HBW4
22889 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
22890 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
22893 ISIG(NCHN,3-ISDE)=21
22899 ELSEIF(ISUB.EQ.31) THEN
22900 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
22901 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
22902 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
22903 C...Propagators: as simulated in PYOFSH and as desired
22904 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22905 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22906 GMMWC=SQRT(SQM4)*WDTP(0)
22907 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22908 FACWQ=FACWQ*HBW4C/HBW4
22909 DO 360 I=MMINA,MMAXA
22910 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
22912 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22913 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22915 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
22916 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
22919 ISIG(NCHN,3-ISDE)=21
22921 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
22925 ELSEIF(ISUB.EQ.35) THEN
22926 C...f + gamma -> f + (gamma*/Z0)
22927 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
22928 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
22929 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
22930 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
22931 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
22932 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
22934 FZQN=SH2+UH2+2D0*SQM4*TH
22937 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
22938 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22942 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22943 DO 370 I=1,MIN(16,MDCY(23,3))
22945 IF(MDME(IDC,1).LT.0) GOTO 370
22947 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22951 AF=SIGN(1D0,EF+0.1D0)
22953 ELSEIF(I.LE.16) THEN
22955 AF=SIGN(1D0,EF+0.1D0)
22958 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22959 IF(4D0*RM1.LT.1D0) THEN
22961 IF(I.LE.8) FCOF=3D0*RADC4
22962 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22964 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22965 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22966 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22967 & AF**2*(1D0-4D0*RM1))*BE34
22971 C...Propagators: as simulated in PYOFSH and as desired
22972 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22976 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22978 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22979 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22980 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22981 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22982 C...Loop over flavours; consider full gamma/Z structure
22983 DO 390 I=MMINA,MMAXA
22984 IF(I.EQ.0) GOTO 390
22985 EI=KCHG(IABS(I),1)/3D0
22988 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
22989 & (VI**2+AI**2)*HFZZ)/HBW4
22990 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
22992 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
22993 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
22996 ISIG(NCHN,3-ISDE)=22
22998 SIGH(NCHN)=FACZQ*FZQN/FZQD
23002 ELSEIF(ISUB.EQ.36) THEN
23003 C...f + gamma -> f' + W+/-
23004 FWQ=COMFAC*AEM**2/(2D0*XW)*
23005 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
23006 C...Propagators: as simulated in PYOFSH and as desired
23007 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
23008 CALL PYWIDT(24,SQM4,WDTP,WDTE)
23009 GMMWC=SQRT(SQM4)*WDTP(0)
23010 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
23012 DO 410 I=MMINA,MMAXA
23013 IF(I.EQ.0) GOTO 410
23015 EIA=ABS(KCHG(IABS(I),1)/3D0)
23016 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
23017 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
23018 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
23020 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
23021 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
23024 ISIG(NCHN,3-ISDE)=22
23026 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
23031 ELSEIF(ISUB.LE.100) THEN
23032 IF(ISUB.EQ.69) THEN
23033 C...gamma + gamma -> W+ + W-
23034 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
23035 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
23036 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
23037 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
23038 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
23046 ELSEIF(ISUB.EQ.70) THEN
23047 C...gamma + W+/- -> Z0 + W+/-
23048 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
23049 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
23050 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
23051 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
23052 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
23053 DO 440 KCHW=1,-1,-2
23055 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
23058 ISIG(NCHN,3-ISDE)=24*KCHW
23060 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
23069 C*********************************************************************
23072 C...Subprocess cross sections for Higgs processes,
23073 C...except Higgs pairs in PYSGSU, but including WW scattering.
23074 C...Auxiliary to PYSIGH.
23076 SUBROUTINE PYSGHG(NCHN,SIGS)
23078 C...Double precision and integer declarations
23079 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23080 IMPLICIT INTEGER(I-N)
23081 INTEGER PYK,PYCHGE,PYCOMP
23082 C...Parameter statement to help give large particle numbers.
23083 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23084 &KEXCIT=4000000,KDIMEN=5000000)
23086 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23087 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23088 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23089 COMMON/PYINT1/MINT(400),VINT(400)
23090 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
23091 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
23092 COMMON/PYINT4/MWID(500),WIDS(500,5)
23093 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23094 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
23095 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
23096 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
23097 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
23098 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
23099 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
23100 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
23101 C...Local arrays and complex variables
23102 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
23103 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
23104 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
23106 C...Convert H or A process into equivalent h one
23109 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
23110 &ISUB.LE.190)) THEN
23112 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
23114 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
23115 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
23116 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
23117 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
23118 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
23119 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
23120 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
23121 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
23122 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
23123 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
23124 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
23125 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
23127 SQMH=PMAS(KFHIGG,1)**2
23128 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
23130 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23131 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
23132 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
23133 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
23134 IF(MSTP(46).LE.4) THEN
23135 HDTLH=LOG(PMAS(25,1)/PARP(44))
23136 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
23137 HDTNR=-1D0/18D0+HDTLH/6D0
23139 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
23140 HDTLQ=LOG(PARP(45)/PARP(44))
23141 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
23142 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
23145 C...Calculate lowest and next-to-lowest order partial wave amplitudes
23146 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
23150 HDTLS=LOG(SH/PARP(44)**2)
23151 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
23152 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
23153 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
23154 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
23155 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
23156 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
23157 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
23158 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
23160 C...Unitarize partial wave amplitudes with Pade or K-matrix method
23161 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
23162 A00U=A00L/(1D0-A004/A00L)
23163 A20U=A20L/(1D0-A204/A20L)
23164 A11U=A11L/(1D0-A114/A11L)
23166 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
23167 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
23168 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
23172 C...Differential cross section expressions.
23174 IF(ISUB.LE.60) THEN
23176 C...f + fbar -> h0 (or H0, or A0)
23177 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23179 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23180 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23182 HP=AEM/(8D0*XW)*SH/SQMW*SH
23183 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23184 DO 100 I=MMINA,MMAXA
23185 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
23187 RMQ=PYMRUN(IA,SH)**2/SH
23189 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
23190 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
23192 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
23193 IF(IA.GT.10) IKFI=3
23194 HI=HI*PARU(150+10*IHIGG+IKFI)**2
23195 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
23196 HI=HI/(1D0+RMSS(41))**2
23197 IF(IHIGG.NE.3) THEN
23198 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
23199 & PARU(151+10*IHIGG))**2
23207 SIGH(NCHN)=HI*FACBW*HF
23210 ELSEIF(ISUB.EQ.5) THEN
23212 CALL PYWIDT(25,SH,WDTP,WDTE)
23214 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23215 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
23216 HP=AEM/(8D0*XW)*SH/SQMW*SH
23217 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23219 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
23220 DO 120 I=MMIN1,MMAX1
23221 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
23222 DO 110 J=MMIN2,MMAX2
23223 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
23224 EI=KCHG(IABS(I),1)/3D0
23227 EJ=KCHG(IABS(J),1)/3D0
23234 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
23238 ELSEIF(ISUB.EQ.8) THEN
23240 CALL PYWIDT(25,SH,WDTP,WDTE)
23242 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23243 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
23244 HP=AEM/(8D0*XW)*SH/SQMW*SH
23245 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23247 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
23248 DO 140 I=MMIN1,MMAX1
23249 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
23250 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23251 DO 130 J=MMIN2,MMAX2
23252 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
23253 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23254 IF(EI*EJ.GT.0D0) GOTO 130
23259 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
23263 ELSEIF(ISUB.EQ.24) THEN
23264 C...f + fbar -> Z0 + h0 (or H0, or A0)
23265 C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
23266 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
23267 CALL PYWIDT(23,SQM3,WDTP,WDTE)
23268 GMMZ3=SQRT(SQM3)*WDTP(0)
23269 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
23270 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23271 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23272 GMMH4=SQRT(SQM4)*WDTP(0)
23273 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
23274 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
23275 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
23276 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
23277 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
23278 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
23279 & PARU(154+10*IHIGG)**2
23280 DO 150 I=MMINA,MMAXA
23281 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
23282 EI=KCHG(IABS(I),1)/3D0
23286 IF(IABS(I).LE.10) FCOI=FACA/3D0
23291 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
23294 ELSEIF(ISUB.EQ.26) THEN
23295 C...f + fbar' -> W+/- + h0 (or H0, or A0)
23296 C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
23297 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
23298 CALL PYWIDT(24,SQM3,WDTP,WDTE)
23299 GMMW3=SQRT(SQM3)*WDTP(0)
23300 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
23301 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23302 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23303 GMMH4=SQRT(SQM4)*WDTP(0)
23304 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
23305 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
23306 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
23307 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
23308 FACHW=FACHW*WIDS(KFHIGG,2)
23309 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
23310 & PARU(155+10*IHIGG)**2
23311 DO 170 I=MMIN1,MMAX1
23313 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
23314 DO 160 J=MMIN2,MMAX2
23316 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
23317 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
23318 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
23320 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
23322 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
23324 IF(IA.LE.10) FCOI=FACA/3D0
23329 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
23333 ELSEIF(ISUB.EQ.32) THEN
23334 C...f + g -> f + h0 (q + g -> q + h0 only)
23335 SQMHC=PMAS(25,1)**2
23336 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
23337 DO 190 I=MMINA,MMAXA
23339 IF(IA.NE.5) GOTO 190
23341 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
23342 & (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
23343 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
23346 FACHCQ=FHCQ*SQML/SQMW*
23347 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
23348 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
23349 & (SQMHC-SQMQ-SH)/SH)
23350 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
23352 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
23353 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 180
23356 ISIG(NCHN,3-ISDE)=21
23358 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
23363 ELSEIF(ISUB.LE.80) THEN
23364 IF(ISUB.EQ.71) THEN
23365 C...Z0 + Z0 -> Z0 + Z0
23366 IF(SH.LE.4.01D0*SQMZ) GOTO 220
23368 IF(MSTP(46).LE.2) THEN
23369 C...Exact scattering ME:s for on-mass-shell gauge bosons
23370 BE2=1D0-4D0*SQMZ/SH
23371 TH=-0.5D0*SH*BE2*(1D0-CTH)
23372 UH=-0.5D0*SH*BE2*(1D0+CTH)
23373 IF(MAX(TH,UH).GT.-1D0) GOTO 220
23374 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
23375 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23376 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23377 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
23378 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
23379 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
23380 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
23381 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
23382 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
23383 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
23384 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
23385 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
23386 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
23387 & (ASHIM+ATHIM+AUHIM)**2)
23388 IF(MSTP(46).EQ.2) FACZZ=0D0
23391 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23392 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
23393 & ABS(A00U+2D0*A20U)**2
23395 FACZZ=FACZZ*WIDS(23,1)
23397 DO 210 I=MMIN1,MMAX1
23398 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
23399 EI=KCHG(IABS(I),1)/3D0
23403 DO 200 J=MMIN2,MMAX2
23404 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
23405 EJ=KCHG(IABS(J),1)/3D0
23413 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
23418 ELSEIF(ISUB.EQ.72) THEN
23419 C...Z0 + Z0 -> W+ + W-
23420 IF(SH.LE.4.01D0*SQMZ) GOTO 250
23422 IF(MSTP(46).LE.2) THEN
23423 C...Exact scattering ME:s for on-mass-shell gauge bosons
23424 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
23426 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
23427 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
23428 IF(MAX(TH,UH).GT.-1D0) GOTO 250
23429 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
23430 & (1D0-2D0*SQMZ/SH)
23431 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23432 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23433 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
23434 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23435 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23436 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
23437 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23439 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
23440 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23441 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23442 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
23443 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23445 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
23447 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
23448 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
23449 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
23450 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
23451 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
23452 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
23453 & (ATWIM+AUWIM+A4IM)**2)
23456 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23457 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
23458 & ABS(A00U-A20U)**2
23460 FACWW=FACWW*WIDS(24,1)
23462 DO 240 I=MMIN1,MMAX1
23463 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
23464 EI=KCHG(IABS(I),1)/3D0
23468 DO 230 J=MMIN2,MMAX2
23469 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
23470 EJ=KCHG(IABS(J),1)/3D0
23478 SIGH(NCHN)=FACWW*AVI*AVJ
23483 ELSEIF(ISUB.EQ.73) THEN
23484 C...Z0 + W+/- -> Z0 + W+/-
23485 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
23487 IF(MSTP(46).LE.2) THEN
23488 C...Exact scattering ME:s for on-mass-shell gauge bosons
23489 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
23490 EP1=1D0-(SQMZ-SQMW)/SH
23491 EP2=1D0+(SQMZ-SQMW)/SH
23492 TH=-0.5D0*SH*BE2*(1D0-CTH)
23493 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
23494 IF(MAX(TH,UH).GT.-1D0) GOTO 280
23495 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
23496 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
23497 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
23498 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
23499 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
23500 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
23501 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
23503 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
23504 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
23505 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
23506 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
23507 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
23508 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
23509 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
23510 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
23511 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
23512 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
23513 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
23514 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
23516 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
23517 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
23519 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
23520 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
23521 IF(MSTP(46).LE.0) FACZW=0D0
23522 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
23523 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
23524 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
23525 & (ASWIM+AUWIM+A4IM)**2)
23528 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23529 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
23530 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
23532 FACZW=FACZW*WIDS(23,2)
23534 DO 270 I=MMIN1,MMAX1
23535 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
23536 EI=KCHG(IABS(I),1)/3D0
23540 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
23541 DO 260 J=MMIN2,MMAX2
23542 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
23543 EJ=KCHG(IABS(J),1)/3D0
23547 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
23552 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
23557 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
23562 ELSEIF(ISUB.EQ.75) THEN
23563 C...W+ + W- -> gamma + gamma
23565 ELSEIF(ISUB.EQ.76) THEN
23566 C...W+ + W- -> Z0 + Z0
23567 IF(SH.LE.4.01D0*SQMZ) GOTO 310
23569 IF(MSTP(46).LE.2) THEN
23570 C...Exact scattering ME:s for on-mass-shell gauge bosons
23571 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
23573 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
23574 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
23575 IF(MAX(TH,UH).GT.-1D0) GOTO 310
23576 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
23577 & (1D0-2D0*SQMZ/SH)
23578 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23579 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23580 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
23581 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23582 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23583 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
23584 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23586 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
23587 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23588 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23589 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
23590 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23592 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
23594 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
23596 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
23597 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
23598 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
23599 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
23600 & (ATWIM+AUWIM+A4IM)**2)
23603 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23604 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
23605 & ABS(A00U-A20U)**2
23607 FACZZ=FACZZ*WIDS(23,1)
23609 DO 300 I=MMIN1,MMAX1
23610 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
23611 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23612 DO 290 J=MMIN2,MMAX2
23613 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
23614 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23615 IF(EI*EJ.GT.0D0) GOTO 290
23620 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
23625 ELSEIF(ISUB.EQ.77) THEN
23626 C...W+/- + W+/- -> W+/- + W+/-
23627 IF(SH.LE.4.01D0*SQMW) GOTO 340
23629 IF(MSTP(46).LE.2) THEN
23630 C...Exact scattering ME:s for on-mass-shell gauge bosons
23631 BE2=1D0-4D0*SQMW/SH
23635 TH=-0.5D0*SH*BE2*(1D0-CTH)
23636 UH=-0.5D0*SH*BE2*(1D0+CTH)
23637 IF(MAX(TH,UH).GT.-1D0) GOTO 340
23639 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23640 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23642 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
23643 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
23645 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
23646 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
23647 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
23650 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
23652 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
23653 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
23654 ATGRE=0.5D0*XW*SH/TH*TGZANG
23656 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
23658 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
23659 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
23660 AUGRE=0.5D0*XW*SH/UH*UGZANG
23662 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
23664 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
23666 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
23668 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
23670 IF(MSTP(46).LE.0) THEN
23675 ELSEIF(MSTP(46).EQ.1) THEN
23676 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23677 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23678 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23679 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23681 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23682 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23683 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23684 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23686 AWWA2=AWWARE**2+AWWAIM**2
23687 AWWS2=AWWSRE**2+AWWSIM**2
23690 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23691 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
23692 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
23693 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
23696 DO 330 I=MMIN1,MMAX1
23697 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
23698 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23699 DO 320 J=MMIN2,MMAX2
23700 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
23701 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23702 IF(EI*EJ.LT.0D0) THEN
23704 IF(MSTP(45).EQ.1) GOTO 320
23705 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
23706 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
23709 IF(MSTP(45).EQ.2) GOTO 320
23710 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
23711 IF(MSTP(46).GE.3) FACWW=FWWS
23712 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
23713 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
23719 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
23720 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
23726 ELSEIF(ISUB.LE.120) THEN
23727 IF(ISUB.EQ.102) THEN
23728 C...g + g -> h0 (or H0, or A0)
23729 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23731 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23732 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23733 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23735 HI=SHR*WDTP(13)/32D0
23736 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
23741 SIGH(NCHN)=HI*FACBW*HF
23744 ELSEIF(ISUB.EQ.103) THEN
23745 C...gamma + gamma -> h0 (or H0, or A0)
23746 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23748 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23749 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23750 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23752 HI=SHR*WDTP(14)*2D0
23753 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
23758 SIGH(NCHN)=HI*FACBW*HF
23761 ELSEIF(ISUB.EQ.110) THEN
23762 C...f + fbar -> gamma + h0
23763 THUH=MAX(TH*UH,SH*CKIN(3)**2)
23764 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
23765 FACHG=FACHG*WIDS(KFHIGG,2)
23766 C...Calculate loop contributions for intermediate gamma* and Z0
23767 CIGTOT=DCMPLX(0D0,0D0)
23768 CIZTOT=DCMPLX(0D0,0D0)
23771 IF(J.LE.2*MSTP(1)) THEN
23774 AJ=SIGN(1D0,EJ+0.1D0)
23776 BALP=SQM4/(2D0*PMAS(J,1))**2
23777 BBET=SH/(2D0*PMAS(J,1))**2
23778 ELSEIF(J.LE.3*MSTP(1)) THEN
23780 JL=2*(J-2*MSTP(1))-1
23781 EJ=KCHG(10+JL,1)/3D0
23782 AJ=SIGN(1D0,EJ+0.1D0)
23784 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
23785 BBET=SH/(2D0*PMAS(10+JL,1))**2
23787 BALP=SQM4/(2D0*PMAS(24,1))**2
23788 BBET=SH/(2D0*PMAS(24,1))**2
23790 BABI=1D0/(BALP-BBET)
23791 IF(BALP.LT.1D0) THEN
23792 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
23795 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
23796 & -DBLE(0.5D0*PARU(1)))
23799 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
23800 IF(BBET.LT.1D0) THEN
23801 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
23804 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
23805 & -DBLE(0.5D0*PARU(1)))
23808 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
23809 IF(J.LE.3*MSTP(1)) THEN
23810 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
23811 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
23812 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
23813 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
23816 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
23817 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
23818 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
23819 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
23820 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
23821 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
23825 CIGTOT=CIGTOT/DBLE(SH)
23826 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
23827 C...Loop over initial flavours
23828 DO 380 I=MMINA,MMAXA
23829 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
23830 EI=KCHG(IABS(I),1)/3D0
23834 IF(IABS(I).LE.10) FCOI=FACA/3D0
23839 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
23840 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
23843 ELSEIF(ISUB.EQ.111) THEN
23844 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
23845 IF(MSTP(38).NE.0) THEN
23846 C...Simple case: only do gg <-> h exactly.
23847 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23848 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
23849 & (TH**2+UH**2)/(SH*SQM4)
23850 C...Propagators: as simulated in PYOFSH and as desired
23851 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23852 GMMHC=SQRT(SQM4)*WDTP(0)
23853 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23854 & ((SQM4-SQMH)**2+GMMHC**2)
23855 FACGH=FACGH*HBW4C/HBW4
23857 C...Messy case: do full loop integrals
23860 DO 390 I=1,2*MSTP(1)
23864 CALL PYWAUX(1,EPSS,W1SR,W1SI)
23865 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23866 CALL PYWAUX(2,EPSS,W2SR,W2SI)
23867 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23868 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
23869 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
23870 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
23871 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
23873 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23874 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
23875 FACGH=FACGH*WIDS(25,2)
23877 DO 400 I=MMINA,MMAXA
23878 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
23879 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
23887 ELSEIF(ISUB.EQ.112) THEN
23888 C...f + g -> f + h0 (q + g -> q + h0 only)
23889 IF(MSTP(38).NE.0) THEN
23890 C...Simple case: only do gg <-> h exactly.
23891 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23892 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
23893 & (SH**2+UH**2)/(-TH*SQM4)
23894 C...Propagators: as simulated in PYOFSH and as desired
23895 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23896 GMMHC=SQRT(SQM4)*WDTP(0)
23897 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23898 & ((SQM4-SQMH)**2+GMMHC**2)
23899 FACQH=FACQH*HBW4C/HBW4
23901 C...Messy case: do full loop integrals
23904 DO 410 I=1,2*MSTP(1)
23908 CALL PYWAUX(1,EPST,W1TR,W1TI)
23909 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23910 CALL PYWAUX(2,EPST,W2TR,W2TI)
23911 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23912 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
23913 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
23914 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
23915 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
23917 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23918 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
23919 FACQH=FACQH*WIDS(25,2)
23921 DO 430 I=MMINA,MMAXA
23922 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
23924 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
23925 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
23928 ISIG(NCHN,3-ISDE)=21
23934 ELSEIF(ISUB.EQ.113) THEN
23935 C...g + g -> g + h0
23936 IF(MSTP(38).NE.0) THEN
23937 C...Simple case: only do gg <-> h exactly.
23938 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23939 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
23940 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
23941 C...Propagators: as simulated in PYOFSH and as desired
23942 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23943 GMMHC=SQRT(SQM4)*WDTP(0)
23944 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23945 & ((SQM4-SQMH)**2+GMMHC**2)
23946 FACGH=FACGH*HBW4C/HBW4
23948 C...Messy case: do full loop integrals
23957 DO 440 I=1,2*MSTP(1)
23963 IF(EPSH.LT.1D-6) GOTO 440
23964 CALL PYWAUX(1,EPSS,W1SR,W1SI)
23965 CALL PYWAUX(1,EPST,W1TR,W1TI)
23966 CALL PYWAUX(1,EPSU,W1UR,W1UI)
23967 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23968 CALL PYWAUX(2,EPSS,W2SR,W2SI)
23969 CALL PYWAUX(2,EPST,W2TR,W2TI)
23970 CALL PYWAUX(2,EPSU,W2UR,W2UI)
23971 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23972 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
23973 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
23974 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
23975 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
23976 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
23977 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
23978 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
23979 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
23980 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
23981 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
23982 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
23983 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
23984 W3STUR=YHSTUR-Y3STUR-Y3UTSR
23985 W3STUI=YHSTUI-Y3STUI-Y3UTSI
23986 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
23987 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
23988 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
23989 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
23990 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
23991 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
23992 W3USTR=YHUSTR-Y3USTR-Y3TSUR
23993 W3USTI=YHUSTI-Y3USTI-Y3TSUI
23994 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
23995 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
23996 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
23997 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
23998 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
23999 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
24000 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
24001 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
24002 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
24003 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
24004 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
24005 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
24006 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
24007 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
24008 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
24009 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
24010 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
24011 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
24012 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
24013 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
24014 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
24015 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
24016 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
24017 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
24018 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
24019 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
24020 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
24021 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
24022 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
24023 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
24024 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
24025 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
24026 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
24027 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
24028 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
24029 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
24030 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
24031 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
24032 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
24033 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
24034 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
24035 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
24036 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
24037 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
24038 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
24039 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
24040 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
24041 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
24042 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
24043 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
24044 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
24045 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
24046 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
24047 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
24048 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
24049 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
24050 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
24051 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
24052 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
24053 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
24054 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
24055 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
24056 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24057 & (W2SR-W2HR+W3STUR))
24058 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
24059 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24060 & (W2TR-W2HR+W3TUSR))
24061 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
24062 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24063 & (W2UR-W2HR+W3USTR))
24064 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
24065 A2STUR=A2STUR+B2STUR+B2SUTR
24066 A2STUI=A2STUI+B2STUI+B2SUTI
24067 A2USTR=A2USTR+B2USTR+B2UTSR
24068 A2USTI=A2USTI+B2USTI+B2UTSI
24069 A2TUSR=A2TUSR+B2TUSR+B2TSUR
24070 A2TUSI=A2TUSI+B2TUSI+B2TSUI
24071 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
24072 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
24074 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
24075 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
24076 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
24077 FACGH=FACGH*WIDS(25,2)
24079 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
24088 ELSEIF(ISUB.LE.170) THEN
24089 IF(ISUB.EQ.121) THEN
24090 C...g + g -> Q + Qbar + h0
24091 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
24094 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24095 & (0.5D0*PMF/PMAS(24,1))**2
24097 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24099 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24101 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24102 IF(IA.GT.10) IKFI=3
24103 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24104 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24105 FACQQH=FACQQH/(1D0+RMSS(41))**2
24106 IF(IHIGG.NE.3) THEN
24107 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24108 & PARU(151+10*IHIGG))**2
24112 CALL PYQQBH(WTQQBH)
24113 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24115 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24116 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24117 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24123 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24126 ELSEIF(ISUB.EQ.122) THEN
24127 C...q + qbar -> Q + Qbar + h0
24130 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24131 & (0.5D0*PMF/PMAS(24,1))**2
24133 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24135 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24137 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24138 IF(IA.GT.10) IKFI=3
24139 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24140 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24141 FACQQH=FACQQH/(1D0+RMSS(41))**2
24142 IF(IHIGG.NE.3) THEN
24143 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24144 & PARU(151+10*IHIGG))**2
24148 CALL PYQQBH(WTQQBH)
24149 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24151 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24152 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24153 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24155 DO 470 I=MMINA,MMAXA
24156 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
24157 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
24162 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24165 ELSEIF(ISUB.EQ.123) THEN
24166 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
24168 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
24169 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24170 & PARU(154+10*IHIGG)**2
24171 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24172 & (VINT(216)-VINT(209)**2))**2
24173 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24174 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
24175 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24177 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24178 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24179 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24181 DO 490 I=MMIN1,MMAX1
24182 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
24184 DO 480 J=MMIN2,MMAX2
24185 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
24187 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
24188 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
24190 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
24191 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
24193 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
24194 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
24199 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
24203 ELSEIF(ISUB.EQ.124) THEN
24204 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
24206 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
24207 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24208 & PARU(155+10*IHIGG)**2
24209 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24210 & (VINT(216)-VINT(209)**2))**2
24211 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24212 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24214 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24215 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24216 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24218 DO 510 I=MMIN1,MMAX1
24219 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
24220 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
24221 DO 500 J=MMIN2,MMAX2
24222 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
24223 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
24224 IF(EI*EJ.GT.0D0) GOTO 500
24225 FACLR=VINT(180+I)*VINT(180+J)
24230 SIGH(NCHN)=FACLR*FACWW*FACBW
24234 ELSEIF(ISUB.EQ.143) THEN
24235 C...f + fbar' -> H+/-
24236 SQMHC=PMAS(37,1)**2
24237 CALL PYWIDT(37,SH,WDTP,WDTE)
24239 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
24240 HP=AEM/(8D0*XW)*SH/SQMW*SH
24241 DO 530 I=MMIN1,MMAX1
24242 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
24244 IM=(MOD(IA,10)+1)/2
24245 DO 520 J=MMIN2,MMAX2
24246 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
24248 JM=(MOD(JA,10)+1)/2
24249 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
24250 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24252 IF(MOD(IA,2).EQ.0) THEN
24259 RML=PYMRUN(IL,SH)**2/SH
24260 RMU=PYMRUN(IU,SH)**2/SH
24261 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
24262 IF(IA.LE.10) HI=HI*FACA/3D0
24263 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24264 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
24269 SIGH(NCHN)=HI*FACBW*HF
24273 ELSEIF(ISUB.EQ.161) THEN
24274 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
24275 C...(choice of only b and t to avoid kinematics problems)
24276 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
24277 C...H propagator: as simulated in PYOFSH and as desired
24278 SQMHC=PMAS(37,1)**2
24279 GMMHC=PMAS(37,1)*PMAS(37,2)
24280 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
24281 CALL PYWIDT(37,SQM4,WDTP,WDTE)
24282 GMMHCC=SQRT(SQM4)*WDTP(0)
24283 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
24284 FHCQ=FHCQ*HBW4C/HBW4
24285 DO 550 I=MMINA,MMAXA
24287 IF(IA.NE.5) GOTO 550
24288 SQML=PYMRUN(IA,SH)**2
24290 SQMQ=PYMRUN(IUA,SH)**2
24291 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
24292 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
24293 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
24294 & (SQMHC-SQMQ-SH)/SH)
24295 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
24297 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
24298 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 540
24301 ISIG(NCHN,3-ISDE)=21
24303 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
24312 C*********************************************************************
24315 C...Subprocess cross sections for SUSY processes,
24316 C...including Higgs pair production.
24317 C...Auxiliary to PYSIGH.
24319 SUBROUTINE PYSGSU(NCHN,SIGS)
24321 C...Double precision and integer declarations
24322 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24323 IMPLICIT INTEGER(I-N)
24324 INTEGER PYK,PYCHGE,PYCOMP
24325 C...Parameter statement to help give large particle numbers.
24326 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24327 &KEXCIT=4000000,KDIMEN=5000000)
24329 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24330 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24331 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24332 COMMON/PYINT1/MINT(400),VINT(400)
24333 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24334 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
24335 COMMON/PYINT4/MWID(500),WIDS(500,5)
24336 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24337 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24338 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
24339 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
24340 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
24341 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
24342 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
24343 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
24344 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
24345 C...Local arrays and complex variables
24346 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
24347 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
24348 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
24349 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
24352 C...Z and W width, combinations of weak mixing angle
24356 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
24358 C...Convert almost equivalent SUSY processes into each other
24359 C...Extract differences in flavours and couplings
24361 C...Sleptons and sneutrinos
24362 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
24363 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24366 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
24367 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24370 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
24371 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24373 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
24374 IF(ISUB.EQ.210) THEN
24376 ELSEIF(ISUB.EQ.211) THEN
24378 ELSEIF(ISUB.EQ.212) THEN
24382 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
24383 IF(ISUB.EQ.213) THEN
24384 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24386 ELSEIF(ISUB.EQ.214) THEN
24393 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
24394 IF(ISUB.EQ.216) THEN
24397 ELSEIF(ISUB.EQ.217) THEN
24400 ELSEIF(ISUB.EQ.218) THEN
24403 ELSEIF(ISUB.EQ.219) THEN
24406 ELSEIF(ISUB.EQ.220) THEN
24409 ELSEIF(ISUB.EQ.221) THEN
24412 ELSEIF(ISUB.EQ.222) THEN
24415 ELSEIF(ISUB.EQ.223) THEN
24418 ELSEIF(ISUB.EQ.224) THEN
24421 ELSEIF(ISUB.EQ.225) THEN
24428 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
24429 IF(ISUB.EQ.226) THEN
24432 ELSEIF(ISUB.EQ.227) THEN
24435 ELSEIF(ISUB.EQ.228) THEN
24441 C...Neutralino + chargino
24442 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
24443 IF(ISUB.EQ.229) THEN
24446 ELSEIF(ISUB.EQ.230) THEN
24449 ELSEIF(ISUB.EQ.231) THEN
24452 ELSEIF(ISUB.EQ.232) THEN
24455 ELSEIF(ISUB.EQ.233) THEN
24458 ELSEIF(ISUB.EQ.234) THEN
24461 ELSEIF(ISUB.EQ.235) THEN
24464 ELSEIF(ISUB.EQ.236) THEN
24470 C...Gluino + neutralino
24471 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
24472 IF(ISUB.EQ.237) THEN
24474 ELSEIF(ISUB.EQ.238) THEN
24476 ELSEIF(ISUB.EQ.239) THEN
24478 ELSEIF(ISUB.EQ.240) THEN
24483 C...Gluino + chargino
24484 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
24485 IF(ISUB.EQ.241) THEN
24487 ELSEIF(ISUB.EQ.242) THEN
24492 C...Squark + neutralino
24493 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
24495 IF(MOD(ISUB,2).NE.0) ILR=1
24496 IF(ISUB.LE.247) THEN
24498 ELSEIF(ISUB.LE.249) THEN
24500 ELSEIF(ISUB.LE.251) THEN
24502 ELSEIF(ISUB.LE.253) THEN
24508 C...Squark + chargino
24509 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
24510 IF(ISUB.LE.255) THEN
24512 ELSEIF(ISUB.LE.257) THEN
24515 IF(MOD(ISUB,2).EQ.0) THEN
24523 C...Squark + gluino
24524 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
24529 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
24531 IF(ISUB.EQ.262) ILR=1
24533 ELSEIF(ISUB.EQ.265) THEN
24537 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
24539 IF(ISUB.LE.273) THEN
24540 IF(ISUB.EQ.273) ILR=1
24543 ELSEIF(ISUB.LE.276) THEN
24544 IF(ISUB.EQ.276) ILR=1
24547 ELSEIF(ISUB.LE.278) THEN
24548 IF(ISUB.EQ.278) ILR=1
24552 IF(ISUB.EQ.280) ILR=1
24557 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
24559 IF(ISUB.LE.283) THEN
24560 IF(ISUB.EQ.283) ILR=1
24563 ELSEIF(ISUB.LE.286) THEN
24564 IF(ISUB.EQ.286) ILR=1
24567 ELSEIF(ISUB.LE.288) THEN
24568 IF(ISUB.EQ.288) ILR=1
24571 ELSEIF(ISUB.LE.290) THEN
24572 IF(ISUB.EQ.290) ILR=1
24575 ELSEIF(ISUB.LE.293) THEN
24576 IF(ISUB.EQ.293) ILR=1
24579 ELSEIF(ISUB.EQ.296) THEN
24583 C...Squark + gluino
24584 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
24589 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
24590 IF(ISUB.EQ.297) THEN
24591 RKF=.5D0*PARU(195)**2
24592 ELSEIF(ISUB.EQ.298) THEN
24593 RKF=.5D0*(1D0-PARU(195)**2)
24597 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
24598 IF(ISUB.EQ.299) THEN
24601 ELSEIF(ISUB.EQ.300) THEN
24607 ELSEIF(ISUB.EQ.301) THEN
24613 C...Supersymmetric processes - all of type 2 -> 2 :
24614 C...correct final-state Breit-Wigners from fixed to running width.
24615 IF(MSTP(42).GT.0) THEN
24617 KFLW=KFPR(ISUBSV,I)
24619 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
24620 IF(I.EQ.1) SQMI=SQM3
24621 IF(I.EQ.2) SQMI=SQM4
24622 SQMS=PMAS(KCW,1)**2
24623 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
24624 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
24625 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
24626 GMMI=SQRT(SQMI)*WDTP(0)
24627 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
24628 COMFAC=COMFAC*(HBWI/HBWS)
24632 C...Differential cross section expressions.
24634 IF(ISUB.LE.210) THEN
24635 IF(ISUB.EQ.201) THEN
24636 C...f + fbar -> e_L + e_Lbar
24637 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24638 DO 130 I=MMIN1,MMAX1
24640 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
24642 TT3I=SIGN(1D0,EI+1D-6)/2D0
24646 C...Color factor for e+ e-
24647 IF(IA.GE.11) FCOL=3D0
24648 IF(ISUBSV.EQ.301) THEN
24651 ELSEIF(ILR.EQ.1) THEN
24652 A1=SFMIX(KFID,3)**2
24653 A2=SFMIX(KFID,4)**2
24654 ELSEIF(ILR.EQ.0) THEN
24655 A1=SFMIX(KFID,1)**2
24656 A2=SFMIX(KFID,2)**2
24658 XLQ=(TT3J-EJ*XW)*A1
24662 TAA=(EI*EJ)**2*(POLL+POLR)
24663 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
24664 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
24665 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
24666 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
24670 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
24676 DK=1D0/(TH-SMZ(II)**2)
24677 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
24679 FREK=FAC2*TANW*EI*ZMIX(II,1)
24680 TNN1=TNN1+FLEK**2*DK
24681 TNN2=TNN2+FREK**2*DK
24683 DL=1D0/(TH-SMZ(JJ)**2)
24684 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
24686 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
24687 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
24690 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
24691 & A2**2*TNN2**2*POLR)
24692 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
24693 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
24694 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
24695 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
24696 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
24699 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
24702 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
24703 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
24704 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
24709 SIGH(NCHN)=FACQQ1+FACQQ2
24712 ELSEIF(ISUB.EQ.203) THEN
24713 C...f + fbar -> e_L + e_Rbar
24714 DO 160 I=MMIN1,MMAX1
24716 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
24717 EI=KCHG(IABS(I),1)/3D0
24718 TT3I=SIGN(1D0,EI)/2D0
24722 C...Color factor for e+ e-
24723 IF(IA.GE.11) FCOL=3D0
24724 A1=SFMIX(KFID,1)**2
24725 A2=SFMIX(KFID,2)**2
24730 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
24731 & /XW**2/XW1**2*A1*A2
24732 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
24737 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
24743 DK=1D0/(TH-SMZ(II)**2)
24744 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
24746 FREK=FAC2*TANW*EI*ZMIX(II,1)
24747 TNN1=TNN1+FLEK**2*DK
24748 TNN2=TNN2+FREK**2*DK
24750 DL=1D0/(TH-SMZ(JJ)**2)
24751 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
24753 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
24754 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
24757 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
24758 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
24759 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
24760 TZN=(UH*TH-SQM3*SQM4)*A1*A2
24761 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
24762 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
24765 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
24766 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
24767 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
24773 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24774 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
24779 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
24780 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24783 ELSEIF(ISUB.EQ.210) THEN
24784 C...q + qbar' -> W*- > ~l_L + ~nu_L
24785 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
24786 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
24787 DO 180 I=MMIN1,MMAX1
24789 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
24790 DO 170 J=MMIN2,MMAX2
24792 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
24793 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
24795 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
24796 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
24798 IF(KCHSUM.LT.0) KCHW=3
24803 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
24804 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
24805 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24807 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
24808 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
24810 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
24815 ELSEIF(ISUB.LE.220) THEN
24816 IF(ISUB.EQ.213) THEN
24817 C...f + fbar -> ~nu_L + ~nu_Lbar
24818 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
24819 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24820 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24822 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24825 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
24828 DO 190 I=MMIN1,MMAX1
24830 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
24833 C...Color factor for e+ e-
24834 IF(IA.GE.11) FCOL=3D0
24835 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
24839 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
24840 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
24843 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
24845 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
24851 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
24852 & *AEM**2*FCOL/3D0/XW**2
24855 ELSEIF(ISUB.EQ.216) THEN
24856 C...q + qbar -> ~chi0_1 + ~chi0_1
24857 IF(IZID1.EQ.IZID2) THEN
24858 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24860 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24861 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24863 FACXX=COMFAC*AEM**2/3D0/XW**2
24864 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
24867 WU2 = (UH-ZM12)*(UH-ZM22)
24868 WT2 = (TH-ZM12)*(TH-ZM22)
24869 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
24870 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
24871 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
24873 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
24874 IF(IZID2.NE.IZID1) THEN
24875 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
24878 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
24879 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
24881 DO 210 I=MMINA,MMAXA
24882 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
24883 EI=KCHG(IABS(I),1)/3D0
24884 T3I=SIGN(1D0,EI+1D-6)/2D0
24885 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
24886 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
24887 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
24888 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
24889 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
24890 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
24891 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
24893 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
24894 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
24895 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
24897 IF(IABS(I).GE.11) FCOL=3D0
24898 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
24899 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
24900 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
24901 & QRL*DCONJG(QRR)*POLR)*WS2
24906 SIGH(NCHN)=FACXX*FACGG1*FCOL
24910 ELSEIF(ISUB.LE.230) THEN
24911 IF(ISUB.EQ.226) THEN
24912 C...f + fbar -> ~chi+_1 + ~chi-_1
24913 FACXX=COMFAC*AEM**2/3D0
24916 WU2 = (UH-ZM12)*(UH-ZM22)
24917 WT2 = (TH-ZM12)*(TH-ZM22)
24918 WS2 = SMW(IZID1)*SMW(IZID2)*SH
24919 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
24920 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
24922 IF(IZID1.EQ.IZID2) DIFF=1D0
24924 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
24925 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
24926 IF(IZID2.NE.IZID1) THEN
24927 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
24928 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
24931 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
24932 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
24933 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
24934 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
24935 DO 230 I=MMINA,MMAXA
24936 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
24937 EI=KCHG(IABS(I),1)/3D0
24938 T3I=SIGN(1D0,EI+1D-6)/2D0
24939 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
24940 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
24941 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
24942 IF(MOD(I,2).EQ.0) THEN
24943 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
24944 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
24945 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
24946 & DCMPLX(T3I/XW/(TH-XML2))
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-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
24951 & DCMPLX(T3I/XW/(TH-XML2))
24954 IF(IABS(I).GE.11) FCOL=3D0
24955 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
24956 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
24957 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
24958 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
24963 IF(IZID1.EQ.IZID2) THEN
24964 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24966 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
24967 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24972 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24973 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
24977 ELSEIF(ISUB.EQ.229) THEN
24978 C...q + qbar' -> ~chi0_1 + ~chi+-_1
24979 FACXX=COMFAC*AEM**2/6D0/XW**2
24982 WU2 = (UH-ZM12)*(UH-ZM22)
24983 WT2 = (TH-ZM12)*(TH-ZM22)
24984 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
24985 RT2I = 1D0/SQRT(2D0)
24986 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
24987 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
24989 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
24990 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
24993 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
24995 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
24996 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
24997 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
24998 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
25000 DO 270 I=MMIN1,MMAX1
25002 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
25004 T3I=SIGN(1D0,EI+1D-6)/2D0
25005 DO 260 J=MMIN2,MMAX2
25007 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
25008 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
25010 T3J=SIGN(1D0,EJ+1D-6)/2D0
25012 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25013 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25015 IF(KCHSUM.LT.0) KCHW=3
25016 IF(MOD(IA,2).EQ.0) THEN
25017 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
25018 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
25019 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
25020 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
25021 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25022 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
25025 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
25026 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
25027 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
25028 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
25029 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25030 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
25033 ZINTR=DBLE(QLR*DCONJG(QLL))
25034 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
25040 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25041 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25046 ELSEIF(ISUB.LE.240) THEN
25047 IF(ISUB.EQ.237) THEN
25048 C...q + qbar -> gluino + ~chi0_1
25049 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25050 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25051 FAC0=COMFAC*AS*AEM*4D0/9D0/XW
25054 DO 280 I=MMINA,MMAXA
25055 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
25056 EI=KCHG(IABS(I),1)/3D0
25058 XLQC = -TANW*EI*ZMIX(IZID,1)
25059 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25060 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25063 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
25064 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
25065 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
25066 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
25067 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
25068 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25069 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
25070 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
25071 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
25072 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25077 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
25081 ELSEIF(ISUB.LE.250) THEN
25082 IF(ISUB.EQ.241) THEN
25083 C...q + qbar' -> ~chi+-_1 + gluino
25084 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
25087 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
25088 FAC0=UMIX(IZID,1)**2
25089 FAC1=VMIX(IZID,1)**2
25090 DO 300 I=MMIN1,MMAX1
25092 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
25093 DO 290 J=MMIN2,MMAX2
25095 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
25096 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
25098 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25099 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25101 IF(KCHSUM.LT.0) KCHW=3
25102 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
25103 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
25104 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
25105 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
25106 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
25107 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
25108 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
25109 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
25110 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
25111 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
25112 & SH/(TH-XMU2)/(UH-XMD2))/2D0
25117 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
25118 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25119 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25123 ELSEIF(ISUB.EQ.243) THEN
25124 C...q + qbar -> gluino + gluino
25125 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25128 DO 310 I=MMINA,MMAXA
25129 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
25130 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
25132 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
25133 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
25134 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25135 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25136 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25137 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25138 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
25139 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
25140 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25141 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25142 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25143 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25147 C...1/2 for identical particles
25148 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
25151 ELSEIF(ISUB.EQ.244) THEN
25152 C...g + g -> gluino + gluino
25153 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25156 FACQQ1=COMFAC*AS**2*9D0/4D0*(
25157 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
25158 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
25159 FACQQ2=COMFAC*AS**2*9D0/4D0*(
25160 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
25161 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
25162 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
25163 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
25164 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
25169 SIGH(NCHN)=FACQQ1/2D0
25174 SIGH(NCHN)=FACQQ2/2D0
25179 SIGH(NCHN)=FACQQ3/2D0
25182 ELSEIF(ISUB.EQ.246) THEN
25183 C...g + q_j -> ~chi0_1 + ~q_j
25184 FAC0=COMFAC*AS*AEM/6D0/XW
25187 FACZQ0=FAC0*( (ZM2-TH)/SH +
25188 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25189 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25190 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25191 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
25192 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
25193 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
25194 EI=KCHG(IABS(I),1)/3D0
25196 XRQZ = -TANW*EI*ZMIX(IZID,1)
25197 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25198 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25200 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
25202 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
25208 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
25209 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
25212 ISIG(NCHN,3-ISDE)=21
25214 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25215 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25220 ELSEIF(ISUB.LE.260) THEN
25221 IF(ISUB.EQ.254) THEN
25222 C...g + q_j -> ~chi1_1 + ~q_i
25223 FAC0=COMFAC*AS*AEM/12D0/XW
25228 FACZQ0=FAC0*( (ZM2-TH)/SH +
25229 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25230 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25231 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
25232 IF(MOD(KFNSQ1,2).EQ.0) THEN
25239 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
25240 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
25241 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
25243 IF(MOD(IA,2).EQ.0) THEN
25248 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
25252 IF(I.LT.0) KCHWQ=5-KCHW
25254 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
25255 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
25258 ISIG(NCHN,3-ISDE)=21
25260 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25261 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
25265 ELSEIF(ISUB.EQ.258) THEN
25266 C...g + q_j -> gluino + ~q_i
25273 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
25274 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
25275 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
25276 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
25277 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
25279 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
25280 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
25281 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
25282 FACQG1=COMFAC*AS**2*FACQG1/2D0
25283 FACQG2=COMFAC*AS**2*FACQG2/2D0
25284 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25285 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
25286 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
25287 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
25290 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25291 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25293 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
25294 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
25297 ISIG(NCHN,3-ISDE)=21
25299 SIGH(NCHN)=FACQG1*FACSEL
25302 ISIG(NCHN,3-ISDE)=21
25304 SIGH(NCHN)=FACQG2*FACSEL
25309 ELSEIF(ISUB.LE.270) THEN
25310 IF(ISUB.EQ.261) THEN
25311 C...q_i + q_ibar -> ~t_1 + ~t_1bar
25312 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
25313 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25314 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25316 DO 390 I=MMIN1,MMAX1
25318 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
25319 IF(IA.GE.11.AND.IA.LE.18) THEN
25321 EJ=KCHG(KFNSQ,1)/3D0
25322 T3I=SIGN(1D0,EI)/2D0
25323 T3J=SIGN(1D0,EJ)/2D0
25324 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
25325 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
25326 XLF=2D0*(T3I-EI*XW)
25328 TAA=0.5D0*(EI*EJ)**2
25329 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
25330 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25331 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
25332 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25333 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
25339 SIGH(NCHN)=FACQQ1*FAC0
25342 ELSEIF(ISUB.EQ.263) THEN
25343 C...f + fbar -> ~t1 + ~t2bar
25344 DO 400 I=MMIN1,MMAX1
25346 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
25347 EI=KCHG(IABS(I),1)/3D0
25348 TT3I=SIGN(1D0,EI)/2D0
25352 C...Color factor for e+ e-
25353 IF(IA.GE.11) FCOL=3D0
25354 XLQ=2D0*(TT3J-EJ*XW)
25356 XLF=2D0*(TT3I-EI*XW)
25358 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
25359 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
25360 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25361 C...Factor of 2 for t1 t2bar + t2 t1bar
25362 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
25363 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
25368 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25369 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
25374 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
25375 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25378 ELSEIF(ISUB.EQ.264) THEN
25379 C...g + g -> ~t_1 + ~t_1bar
25382 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
25383 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25384 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
25385 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
25386 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
25400 ELSEIF(ISUB.LE.280) THEN
25401 IF(ISUB.EQ.271) THEN
25402 C...q + q' -> ~q + ~q' (~g exchange)
25403 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
25411 FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
25412 FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
25415 FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
25416 FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
25417 FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
25420 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
25421 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
25422 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
25423 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
25425 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
25428 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
25429 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
25431 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
25432 IF(I*J.LT.0) GOTO 420
25437 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25438 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
25441 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
25442 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
25444 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
25445 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25446 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
25453 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
25454 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
25456 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
25457 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25458 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
25464 ELSEIF(ISUB.EQ.274) THEN
25465 C...q + qbar' -> ~q + ~qbar'
25466 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
25470 C...Mrenna...Normalization.and.1/XMT
25471 FACQQ1=COMFAC*AS**2*2D0/9D0*(
25472 & (UH*TH-SQM3*SQM4)/XMT**2 )
25473 FACQQB=COMFAC*AS**2*2D0/9D0*(
25474 & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT))
25475 FACQQB=FACQQB+FACQQ1
25477 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
25480 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
25481 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
25482 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
25483 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
25485 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
25488 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
25489 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
25491 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
25492 IF(I*J.GT.0) GOTO 440
25497 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25498 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
25499 IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
25500 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25504 ELSEIF(ISUB.EQ.277) THEN
25505 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
25506 C...if i .eq. j covered in 274
25507 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
25508 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25510 DO 460 I=MMIN1,MMAX1
25512 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
25513 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
25514 IF(IA.EQ.KFNSQ) GOTO 460
25515 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
25517 EJ=KCHG(KFNSQ,1)/3D0
25519 T3I=SIGN(1D0,EI)/2D0
25521 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
25522 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
25524 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
25525 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
25527 XLF=2D0*(T3I-EI*XW)
25534 TAA=0.5D0*(EI*EJ)**2
25535 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
25536 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25537 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
25538 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25539 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
25540 ELSEIF(IA.LE.6) THEN
25541 FAC0=AS**2*8D0/9D0/2D0
25547 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25550 ELSEIF(ISUB.EQ.279) THEN
25551 C...g + g -> ~q_j + ~q_jbar
25554 C...5=RKF because ~t ~tbar treated separately
25555 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
25556 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
25557 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
25558 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
25563 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25568 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25578 C*********************************************************************
25581 C...Subprocess cross sections for Technicolor processes.
25582 C...Auxiliary to PYSIGH.
25584 SUBROUTINE PYSGTC(NCHN,SIGS)
25586 C...Double precision and integer declarations
25587 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25588 IMPLICIT INTEGER(I-N)
25589 INTEGER PYK,PYCHGE,PYCOMP
25590 C...Parameter statement to help give large particle numbers.
25591 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
25592 &KEXCIT=4000000,KDIMEN=5000000)
25594 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25595 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25596 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
25597 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25598 COMMON/PYINT1/MINT(400),VINT(400)
25599 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
25600 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
25601 COMMON/PYINT4/MWID(500),WIDS(500,5)
25602 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
25603 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
25604 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
25605 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
25606 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
25607 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
25608 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
25609 C...Local arrays and complex variables
25610 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
25611 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
25612 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
25613 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
25614 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
25615 COMPLEX*16 DVVS,DVVT,DVVU
25618 C...Combinations of weak mixing angle.
25620 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
25622 C...Convert almost equivalent technicolor processes into
25623 C...a few basic processes, and set distinguishing parameters.
25624 IF(ISUB.GE.361.AND.ISUB.LE.379) THEN
25627 SN2W=2D0*SQRT(PARU(102)*(1D0-PARU(102)))
25628 CS2W=1D0-2D0*PARU(102)
25629 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
25631 CSXI=COS(ASIN(RTCM(3)))
25632 CSXIP=COS(ASIN(RTCM(4)))
25633 QUPD=2D0*RTCM(2)-1D0
25634 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
25635 C... rho_tc0 -> W_L W_L
25636 IF(ISUB.EQ.361) THEN
25640 C... rho_tc0 -> W_L pi_tc-
25641 ELSEIF(ISUB.EQ.362) THEN
25645 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
25647 ELSEIF(ISUB.EQ.363) THEN
25651 CAB2=(1D0-RTCM(3)**2)**2
25652 C... rho_tc0/omega_tc -> gamma pi_tc
25653 ELSEIF(ISUB.EQ.364) THEN
25662 VZGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
25664 ELSEIF(ISUB.EQ.365) THEN
25668 VRGP=CSXIP/RTCM(12)
25673 VAGP=2D0*Q2UD*CSXIP
25674 VZGP=CSXIP/SN2W*(1D0-4D0*PARU(102)*Q2UD)
25676 ELSEIF(ISUB.EQ.366) THEN
25680 VOGP=CSXI*CT2W/RTCM(12)
25681 VRGP=-QUPD*CSXI*TANW/RTCM(12)
25684 VAGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
25685 VZGP=-QUPD*CSXI*CS2W/(1D0-PARU(102))
25687 ELSEIF(ISUB.EQ.367) THEN
25691 VRGP=CSXIP*CT2W/RTCM(12)
25692 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
25695 VAGP=CSXIP*(1D0-4D0*Q2UD*PARU(102))/SN2W
25696 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*PARU(102)**2)/SN2W**2
25698 ELSEIF(ISUB.EQ.368) THEN
25702 VOGP=CSXI/(2D0*SQRT(PARU(102)))/RTCM(12)
25706 ARGP=-CSXI/(2D0*SQRT(PARU(102)))/RTCM(13)
25707 VAGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
25708 VZGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
25709 C... rho_tc+ -> W_L Z_L
25710 ELSEIF(ISUB.EQ.370) THEN
25715 ELSEIF(ISUB.EQ.371) THEN
25719 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
25721 ELSEIF(ISUB.EQ.372) THEN
25725 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
25727 ELSEIF(ISUB.EQ.373) THEN
25731 CAB2=(1D0-RTCM(3)**2)**2
25733 ELSEIF(ISUB.EQ.374) THEN
25738 VWGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
25740 ELSEIF(ISUB.EQ.375) THEN
25744 VRGP=-QUPD*CSXI*TANW
25745 ARGP=CSXI/(2D0*SQRT(PARU(102)*(1D0-PARU(102))))
25746 VWGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
25748 ELSEIF(ISUB.EQ.376) THEN
25753 ARGP=-CSXI/(2D0*SQRT(PARU(102)))
25756 ELSEIF(ISUB.EQ.377) THEN
25761 VRGP=CSXIP/(2D0*SQRT(PARU(102)))
25762 VWGP=CSXIP/(2D0*PARU(102))
25766 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
25767 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
25768 IF(ITCM(5).LE.4) THEN
25786 ELSEIF(ITCM(5).EQ.5) THEN
25788 IF(ITCM(2).EQ.0) THEN
25793 ALPRHT=2.91D0*(3D0/ITCM(1))
25794 SIN2T=2D0*TANT3/(TANT3**2+1D0)
25795 SINT3=TANT3/SQRT(TANT3**2+1D0)
25796 XIG=SQRT(PYALPS(SH)/ALPRHT)
25797 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
25798 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
25799 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
25800 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
25801 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
25802 & SINT3**2)*2D0/SIN2T
25803 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
25804 & SINT3**2)*2D0/SIN2T
25806 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
25807 SM1112=X12*RTCM(28)**2*SIN2T
25808 SM1121=-X21*RTCM(28)**2*SIN2T
25811 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
25812 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
25815 ZTC(1,1)=DCMPLX(SH,0D0)
25816 CALL PYWIDT(3100021,SH,WDTP,WDTE)
25817 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
25818 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
25819 CALL PYWIDT(3100113,SH,WDTP,WDTE)
25820 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
25821 CALL PYWIDT(3400113,SH,WDTP,WDTE)
25822 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
25823 CALL PYWIDT(3200113,SH,WDTP,WDTE)
25824 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
25825 CALL PYWIDT(3300113,SH,WDTP,WDTE)
25826 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
25828 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
25832 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
25833 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
25834 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
25835 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
25848 CALL PYLDCM(ZTC,6,6,INDX,D)
25852 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
25857 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
25863 XIG=SQRT(PYALPS(-TH)/ALPRHT)
25865 ZTC(1,1)=DCMPLX(TH)
25866 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
25867 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
25868 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
25869 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
25870 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
25872 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
25876 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
25877 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
25878 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
25879 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
25891 CALL PYLDCM(ZTC,6,6,INDX,D)
25895 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
25899 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
25905 XIG=SQRT(PYALPS(-UH)/ALPRHT)
25907 ZTC(1,1)=DCMPLX(UH,0D0)
25908 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
25909 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
25910 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
25911 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
25912 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
25914 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
25918 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
25919 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
25920 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
25921 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
25933 CALL PYLDCM(ZTC,6,6,INDX,D)
25937 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
25941 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
25948 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
25949 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
25950 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
25951 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
25952 DQGS=DGGS-DGVS*DCMPLX(TANT3)
25953 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
25955 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
25956 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
25957 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
25958 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
25959 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
25960 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
25963 SQDQTS=ABS(DQTS)**2
25964 SQDQQS=ABS(DQQS)**2
25965 SQDQQT=ABS(DQQT)**2
25966 SQDQQU=ABS(DQQU)**2
25967 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
25969 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
25971 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
25973 SQDGGS=ABS(DGGS)**2
25974 SQDGGT=ABS(DGGT)**2
25975 SQDGGU=ABS(DGGU)**2
25979 REDGTU=DBLE(DGGU*DCONJG(DGGT))
25980 REDGSU=DBLE(DGGU*DCONJG(DGGS))
25981 REDGST=DBLE(DGGS*DCONJG(DGGT))
25982 REDQST=DBLE(DQQS*DCONJG(DQQT))
25983 REDQTU=DBLE(DQQT*DCONJG(DQQU))
25988 C...Differential cross section expressions.
25990 IF(ISUB.LE.190) THEN
25991 IF(ISUB.EQ.149) THEN
25992 C...g + g -> eta_tc
25993 KCTC=PYCOMP(KTECHN+331)
25994 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
25996 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
25997 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
25999 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
26001 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26006 SIGH(NCHN)=HI*FACBW*HF
26009 ELSEIF(ISUB.EQ.165) THEN
26010 C...q + qbar -> l+ + l- (including contact term for compositeness)
26011 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26012 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26013 KFF=IABS(KFPR(ISUB,1))
26015 AF=SIGN(1D0,EF+0.1D0)
26020 IF(KFF.LE.10) FCOF=3D0
26022 IF(KFF.EQ.6) WID2=WIDS(6,1)
26023 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
26024 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
26025 DO 260 I=MMINA,MMAXA
26026 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
26027 EI=KCHG(IABS(I),1)/3D0
26028 AI=SIGN(1D0,EI+0.1D0)
26033 IF(IABS(I).LE.10) FCOI=FACA/3D0
26034 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
26035 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
26036 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
26037 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
26039 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
26040 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
26042 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
26043 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
26044 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
26045 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
26046 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
26051 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
26054 ELSEIF(ISUB.EQ.166) THEN
26055 C...q + q'bar -> l + nu_l (including contact term for compositeness)
26056 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
26057 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
26058 KFF=IABS(KFPR(ISUB,1))
26060 IF(KFF.LE.10) FCOF=3D0
26061 DO 280 I=MMIN1,MMAX1
26062 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
26064 DO 270 J=MMIN2,MMAX2
26065 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
26067 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
26068 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26071 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
26073 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
26074 & MOD(J,2).EQ.0)) THEN
26075 IF(KFF.EQ.5) WID2=WIDS(6,2)
26076 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
26077 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
26079 IF(KFF.EQ.5) WID2=WIDS(6,3)
26080 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
26081 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
26087 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
26088 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
26089 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
26094 ELSEIF(ISUB.LE.200) THEN
26095 IF(ISUB.EQ.191) THEN
26096 C...q + qbar -> rho_tc0.
26097 KCTC=PYCOMP(KTECHN+113)
26098 SQMRHT=PMAS(KCTC,1)**2
26099 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26101 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
26102 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26103 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26104 ALPRHT=2.91D0*(3D0/ITCM(1))
26105 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
26106 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26107 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26108 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26109 DO 290 I=MMINA,MMAXA
26110 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
26112 EI=KCHG(IABS(I),1)/3D0
26113 AI=SIGN(1D0,EI+0.1D0)
26117 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26118 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
26119 IF(IA.LE.10) HI=HI*FACA/3D0
26124 SIGH(NCHN)=HI*FACBW*HF
26127 ELSEIF(ISUB.EQ.192) THEN
26128 C...q + qbar' -> rho_tc+/-.
26129 KCTC=PYCOMP(KTECHN+213)
26130 SQMRHT=PMAS(KCTC,1)**2
26131 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26133 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
26134 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26135 ALPRHT=2.91D0*(3D0/ITCM(1))
26136 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
26137 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26138 DO 310 I=MMIN1,MMAX1
26139 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
26141 DO 300 J=MMIN2,MMAX2
26142 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
26144 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
26145 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26147 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26148 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
26150 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
26155 SIGH(NCHN)=HI*FACBW*HF
26159 ELSEIF(ISUB.EQ.193) THEN
26160 C...q + qbar -> omega_tc0.
26161 KCTC=PYCOMP(KTECHN+223)
26162 SQMOMT=PMAS(KCTC,1)**2
26163 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26165 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
26166 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26167 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26168 ALPRHT=2.91D0*(3D0/ITCM(1))
26169 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
26170 & (2D0*RTCM(2)-1D0)**2
26171 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26172 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26173 DO 320 I=MMINA,MMAXA
26174 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
26176 EI=KCHG(IABS(I),1)/3D0
26177 AI=SIGN(1D0,EI+0.1D0)
26181 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
26182 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
26183 IF(IA.LE.10) HI=HI*FACA/3D0
26188 SIGH(NCHN)=HI*FACBW*HF
26191 ELSEIF(ISUB.EQ.194) THEN
26192 C...f + fbar -> f' + fbar' via s-channel rho_tc and omega_tc.
26194 ALPRHT=2.91D0*(3D0/ITCM(1))
26196 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
26197 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
26199 QUPD=2D0*RTCM(2)-1D0
26200 FAR=SQRT(AEM/ALPRHT)
26208 CALL PYWIDT(23,SH,WDTP,WDTE)
26209 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26210 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26211 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26212 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26213 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26214 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26215 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26216 DAA=(-Sfzr*SSMO - Sfzo*SSMR + SSMO*SSMR*SSMZ)/DETD/SH
26217 DZZ=(-Sfar*SSMO - Sfao*SSMR + SSMO*SSMR)/DETD/SH
26218 DAZ=(far*fzr*SSMO + fao*fzo*SSMR)/DETD/SH
26220 XWRHT=1D0/(4D0*XW*(1D0-XW))
26221 KFF=IABS(KFPR(ISUB,1))
26223 AF=SIGN(1D0,EF+0.1D0)
26228 IF(KFF.LE.10) FCOF=3D0
26231 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
26232 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
26233 DZZ=DZZ*DCMPLX(XWRHT,0D0)
26234 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
26236 DO 330 I=MMINA,MMAXA
26237 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
26238 EI=KCHG(IABS(I),1)/3D0
26239 AI=SIGN(1D0,EI+0.1D0)
26244 IF(IABS(I).LE.10) FCOI=FCOI/3D0
26245 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
26246 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
26247 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
26248 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
26249 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
26250 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
26255 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
26258 ELSEIF(ISUB.EQ.195) THEN
26259 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+
26262 ALPRHT=2.91D0*(3D0/ITCM(1))
26263 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
26265 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26266 CALL PYWIDT(24,SH,WDTP,WDTE)
26267 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26268 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26269 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26272 IF(KFA.LE.8) FCOF=3D0
26273 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26274 HP=FACTC*ABS(SSMR/DETD)**2/SH**2*FCOF
26276 DO 350 I=MMIN1,MMAX1
26277 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
26279 DO 340 J=MMIN2,MMAX2
26280 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
26282 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
26283 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26285 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26287 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26292 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
26297 ELSEIF(ISUB.LE.380) THEN
26298 IF(ISUB.EQ.361) THEN
26299 C...f + fbar -> W_L W_L, W_L pi_tc, pi_tc pi_tc
26300 FACA=(SH**2*BE34**2-(TH-UH)**2)
26301 ALPRHT=2.91D0*(3D0/ITCM(1))
26302 HP=(1D0/12D0)*AEM**2*CAB2*COMFAC*FACA*3D0
26303 FAR=SQRT(AEM/ALPRHT)
26311 CALL PYWIDT(23,SH,WDTP,WDTE)
26312 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26313 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26314 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26315 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26316 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26317 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26318 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26319 DARHO=-(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26320 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26321 DAA=-(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
26322 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
26323 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH
26325 DO 360 I=MMINA,MMAXA
26326 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 360
26328 EI=KCHG(IABS(I),1)/3D0
26329 AI=SIGN(1D0,EI+0.1D0)
26331 VALI=0.25D0*(VI+AI)
26332 VARI=0.25D0*(VI-AI)
26333 F2L=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
26334 $ VALI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
26335 F2R=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
26336 $ VARI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
26337 HI=ABS(F2L)**2+ABS(F2R)**2
26338 IF(IA.LE.10) HI=HI/3D0
26343 IF(KFA.EQ.KFB) THEN
26344 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
26346 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26351 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26355 ELSEIF(ISUB.EQ.364) THEN
26356 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
26358 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
26359 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
26360 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
26362 ALPRHT=2.91D0*(3D0/ITCM(1))
26363 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
26364 FAR=SQRT(AEM/ALPRHT)
26372 CALL PYWIDT(23,SH,WDTP,WDTE)
26373 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26374 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26375 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26376 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26377 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26378 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26379 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26380 DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26381 DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26382 DAOME=(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)/DETD/SH
26383 DZOME=(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH
26384 DAA=(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
26385 DZZ=(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
26386 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH
26388 DO 370 I=MMINA,MMAXA
26389 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
26391 EI=KCHG(IABS(I),1)/3D0
26392 AI=SIGN(1D0,EI+0.1D0)
26394 VALI=0.25D0*(VI+AI)
26395 VARI=0.25D0*(VI-AI)
26396 C...........Add in anomaly contribution
26397 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
26398 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
26399 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
26400 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
26401 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
26402 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
26403 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
26404 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
26405 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
26406 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
26407 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
26408 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
26409 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
26410 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
26412 IF(IA.LE.10) HI=HI/3D0
26417 IF(ISUBSV.NE.368) THEN
26418 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
26420 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26425 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26429 ELSEIF(ISUB.EQ.370) THEN
26430 C...f + fbar' -> W_L Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
26432 FACA=(SH**2*BE34**2-(TH-UH)**2)
26433 ALPRHT=2.91D0*(3D0/ITCM(1))
26434 HP=(1D0/96D0)*AEM**2*CAB2*COMFAC*FACA*3D0/XW**2
26435 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26436 CALL PYWIDT(24,SH,WDTP,WDTE)
26437 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26438 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26439 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26440 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26443 HP=HP*ABS(DWW+DWRHO)**2
26444 DO 390 I=MMIN1,MMAX1
26445 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 390
26447 DO 380 J=MMIN2,MMAX2
26448 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 380
26450 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 380
26451 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26453 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26455 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26460 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26461 & WIDS(PYCOMP(KFB),2)
26465 ELSEIF(ISUB.EQ.374) THEN
26466 C...f + fbar' -> gamma pi_tc
26467 FANOM=SQRT(AEM)*ITCM(1)/2D0/PARU(2)/RTCM(1)
26468 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
26469 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*ARGP**2
26470 ALPRHT=2.91D0*(3D0/ITCM(1))
26471 HP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
26472 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26473 CALL PYWIDT(24,SH,WDTP,WDTE)
26474 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26475 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26476 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26477 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26479 DWRHO=-DCMPLX(FWR,0D0)/DETD/SH
26480 HP=HP*(AFAC*ABS(DWRHO)**2+
26481 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP/SQRT(SQTV))**2)
26482 DO 410 I=MMIN1,MMAX1
26483 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
26485 DO 400 J=MMIN2,MMAX2
26486 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
26488 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
26489 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26491 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26493 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26498 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26499 & WIDS(PYCOMP(KFB),2)
26504 ELSEIF(ISUB.LE.390) THEN
26505 IF(ISUB.EQ.381) THEN
26506 C...f + f' -> f + f' (g exchange)
26507 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
26508 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
26509 & MSTP(34)*2D0/3D0*UH2*REDQST)
26510 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
26511 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
26512 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
26513 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
26514 C...Modifications from contact interactions (compositeness)
26515 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
26516 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
26517 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
26518 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
26519 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
26520 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
26521 RATCII=(FACCI1*FACCI2+FACQQI)/(FACCI1+FACCI2)
26522 ELSEIF(ITCM(5).EQ.5) THEN
26527 CSM.......Check this change from
26531 DO 430 I=MMIN1,MMAX1
26533 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
26534 DO 420 J=MMIN2,MMAX2
26536 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
26541 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
26544 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
26547 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
26548 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
26555 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
26556 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
26557 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
26559 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
26560 SIGH(NCHN)=0.5D0*FACCI2*RATCII
26566 ELSEIF(ISUB.EQ.382) THEN
26567 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
26568 CALL PYWIDT(21,SH,WDTP,WDTE)
26569 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
26570 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26571 IF(ITCM(5).EQ.1) THEN
26572 C...Modifications from contact interactions (compositeness)
26575 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
26576 & WDTE(I,2)+WDTE(I,4))
26578 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
26579 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
26580 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26581 ELSEIF(ITCM(5).EQ.5) THEN
26582 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
26583 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
26584 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
26586 DO 450 I=MMINA,MMAXA
26587 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26588 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
26593 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
26595 ELSEIF(ITCM(5).EQ.5) THEN
26607 ELSEIF(ISUB.EQ.383) THEN
26608 C...f + fbar -> g + g (q + qbar -> g + g only)
26609 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
26610 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
26611 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
26612 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
26613 IF(ITCM(5).EQ.5) THEN
26614 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
26615 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
26616 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
26617 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
26619 DO 460 I=MMINA,MMAXA
26620 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26621 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
26626 SIGH(NCHN)=0.5D0*FACGG1
26627 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
26632 SIGH(NCHN)=0.5D0*FACGG2
26633 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
26636 ELSEIF(ISUB.EQ.384) THEN
26637 C...f + g -> f + g (q + g -> q + g only)
26638 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
26639 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
26640 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
26641 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
26642 DO 480 I=MMINA,MMAXA
26643 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
26645 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
26646 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
26649 ISIG(NCHN,3-ISDE)=21
26654 ISIG(NCHN,3-ISDE)=21
26660 ELSEIF(ISUB.EQ.385) THEN
26661 C...g + g -> f + fbar (g + g -> q + qbar only)
26662 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
26664 C...Begin by d, u, s flavours.
26666 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
26667 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
26668 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
26669 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
26670 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
26671 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
26672 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
26673 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
26674 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
26675 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
26686 C...Next c and b flavours: modified that and uhat for fixed
26687 C...cos(theta-hat).
26689 SQMAVG=PMAS(IFL,1)**2
26690 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
26691 BE34=SQRT(1D0-4D0*SQMAVG/SH)
26692 THQ=-0.5D0*SH*(1D0-BE34*CTH)
26693 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
26694 THUHQ=THQ*UHQ-SQMAVG*SH
26695 IF(MSTP(34).EQ.0) THEN
26696 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
26697 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
26699 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26700 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
26701 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26702 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
26704 IF(ITCM(5).GE.5) THEN
26706 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
26707 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26708 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
26709 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26711 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
26712 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26713 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
26714 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26717 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
26718 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
26722 ISIG(NCHN,3)=1+2*(IFL-3)
26727 ISIG(NCHN,3)=2+2*(IFL-3)
26733 ELSEIF(ISUB.EQ.386) THEN
26735 IF(ITCM(5).LE.4) THEN
26736 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
26737 & 2D0*TH/SH+TH2/SH2)*FACA
26738 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
26739 & 2D0*SH/UH+SH2/UH2)*FACA
26740 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
26741 & 2D0*UH/TH+UH2/TH2)
26743 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
26744 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
26745 & 4D0*REDGST*(SH + 2D0*TH)*
26746 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
26747 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
26748 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
26749 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
26750 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
26751 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
26752 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
26753 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
26754 & 4D0*REDGSU*(SH + 2D0*UH)*
26755 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
26756 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
26757 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
26758 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
26759 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
26760 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
26761 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
26762 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
26763 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
26764 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
26765 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
26766 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
26767 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
26768 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
26769 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
26770 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
26771 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
26772 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
26773 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
26774 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
26775 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
26776 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
26778 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
26783 SIGH(NCHN)=0.5D0*FACGG1
26788 SIGH(NCHN)=0.5D0*FACGG2
26793 SIGH(NCHN)=0.5D0*FACGG3
26796 ELSEIF(ISUB.EQ.387) THEN
26797 C...q + qbar -> Q + Qbar
26798 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
26799 THQ=-0.5D0*SH*(1D0-BE34*CTH)
26800 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
26801 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
26803 IF(ITCM(5).GE.5) THEN
26804 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
26805 FACQQB=FACQQB*SH2*SQDQTS
26807 FACQQB=FACQQB*SH2*SQDQQS
26810 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
26812 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
26813 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
26815 DO 520 I=MMINA,MMAXA
26816 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26817 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
26825 ELSEIF(ISUB.EQ.388) THEN
26826 C...g + g -> Q + Qbar
26827 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
26828 THQ=-0.5D0*SH*(1D0-BE34*CTH)
26829 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
26830 THUHQ=THQ*UHQ-SQMAVG*SH
26831 IF(MSTP(34).EQ.0) THEN
26832 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
26833 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
26835 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26836 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
26837 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26838 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
26840 IF(ITCM(5).GE.5) THEN
26841 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
26842 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
26843 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26844 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
26845 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26847 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
26848 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26849 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
26850 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26853 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
26854 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
26855 IF(MSTP(35).GE.1) THEN
26856 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
26857 FACQQ1=FACQQ1*FATRE
26858 FACQQ2=FACQQ2*FATRE
26861 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
26862 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
26865 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
26885 C*********************************************************************
26888 C...Subprocess cross sections for assorted exotic processes,
26889 C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
26890 C...Auxiliary to PYSIGH.
26892 SUBROUTINE PYSGEX(NCHN,SIGS)
26894 C...Double precision and integer declarations
26895 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26896 IMPLICIT INTEGER(I-N)
26897 INTEGER PYK,PYCHGE,PYCOMP
26898 C...Parameter statement to help give large particle numbers.
26899 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
26900 &KEXCIT=4000000,KDIMEN=5000000)
26902 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26903 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26904 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
26905 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26906 COMMON/PYINT1/MINT(400),VINT(400)
26907 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
26908 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
26909 COMMON/PYINT4/MWID(500),WIDS(500,5)
26910 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
26911 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
26912 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
26913 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
26914 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
26915 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
26916 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
26918 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
26920 C...Differential cross section expressions.
26922 IF(ISUB.LE.160) THEN
26923 IF(ISUB.EQ.141) THEN
26924 C...f + fbar -> gamma*/Z0/Z'0
26925 SQMZP=PMAS(32,1)**2
26927 CALL PYWIDT(32,SH,WDTP,WDTE)
26933 FACZP=4D0*COMFAC*3D0
26934 DO 100 I=MMINA,MMAXA
26935 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
26936 EI=KCHG(IABS(I),1)/3D0
26942 VPI=PARU(123-2*MOD(IABS(I),2))
26943 API=PARU(124-2*MOD(IABS(I),2))
26944 ELSEIF(IA.LE.4) THEN
26945 VPI=PARJ(182-2*MOD(IABS(I),2))
26946 API=PARJ(183-2*MOD(IABS(I),2))
26948 VPI=PARJ(190-2*MOD(IABS(I),2))
26949 API=PARJ(191-2*MOD(IABS(I),2))
26953 VPI=PARU(127-2*MOD(IABS(I),2))
26954 API=PARU(128-2*MOD(IABS(I),2))
26955 ELSEIF(IA.LE.14) THEN
26956 VPI=PARJ(186-2*MOD(IABS(I),2))
26957 API=PARJ(187-2*MOD(IABS(I),2))
26959 VPI=PARJ(194-2*MOD(IABS(I),2))
26960 API=PARJ(195-2*MOD(IABS(I),2))
26964 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
26966 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
26968 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
26973 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
26974 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
26975 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
26976 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
26977 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
26978 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
26979 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
26980 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
26983 ELSEIF(ISUB.EQ.142) THEN
26984 C...f + fbar' -> W'+/-
26985 SQMWP=PMAS(34,1)**2
26986 CALL PYWIDT(34,SH,WDTP,WDTE)
26988 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
26989 HP=AEM/(24D0*XW)*SH
26990 DO 120 I=MMIN1,MMAX1
26991 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
26993 DO 110 J=MMIN2,MMAX2
26994 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
26996 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
26997 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26999 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
27000 HI=HP*(PARU(133)**2+PARU(134)**2)
27001 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
27002 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
27007 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
27008 SIGH(NCHN)=HI*FACBW*HF
27012 ELSEIF(ISUB.EQ.144) THEN
27015 CALL PYWIDT(41,SH,WDTP,WDTE)
27017 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
27018 HP=AEM/(12D0*XW)*SH
27019 DO 140 I=MMIN1,MMAX1
27020 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
27022 DO 130 J=MMIN2,MMAX2
27023 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
27025 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
27027 IF(IA.LE.10) HI=HI*FACA/3D0
27028 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
27033 SIGH(NCHN)=HI*FACBW*HF
27037 ELSEIF(ISUB.EQ.145) THEN
27038 C...q + l -> LQ (leptoquark)
27039 SQMLQ=PMAS(42,1)**2
27040 CALL PYWIDT(42,SH,WDTP,WDTE)
27042 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
27043 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
27045 KFLQQ=KFDP(MDCY(42,2),1)
27046 KFLQL=KFDP(MDCY(42,2),2)
27047 DO 160 I=MMIN1,MMAX1
27048 IF(KFAC(1,I).EQ.0) GOTO 160
27050 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
27051 DO 150 J=MMIN2,MMAX2
27052 IF(KFAC(2,J).EQ.0) GOTO 150
27054 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
27055 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
27056 IF(JA.EQ.IA) GOTO 150
27057 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
27058 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
27060 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
27065 SIGH(NCHN)=HI*FACBW*HF
27069 ELSEIF(ISUB.EQ.146) THEN
27070 C...e + gamma* -> e* (excited lepton)
27071 KFQSTR=KFPR(ISUB,1)
27072 KCQSTR=PYCOMP(KFQSTR)
27073 KFQEXC=MOD(KFQSTR,KEXCIT)
27074 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
27076 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
27077 QF=-RTCM(43)/2D0-RTCM(44)/2D0
27078 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
27079 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
27082 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
27084 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
27085 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
27087 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27088 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
27091 ISIG(NCHN,3-ISDE)=22
27093 SIGH(NCHN)=HI*FACBW*HF
27097 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
27098 C...d + g -> d* and u + g -> u* (excited quarks)
27099 KFQSTR=KFPR(ISUB,1)
27100 KCQSTR=PYCOMP(KFQSTR)
27101 KFQEXC=MOD(KFQSTR,KEXCIT)
27102 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
27104 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
27105 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
27106 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
27109 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
27111 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
27112 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
27114 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27115 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
27118 ISIG(NCHN,3-ISDE)=21
27120 SIGH(NCHN)=HI*FACBW*HF
27125 ELSEIF(ISUB.LE.190) THEN
27126 IF(ISUB.EQ.162) THEN
27127 C...q + g -> LQ + lbar; LQ=leptoquark
27128 SQMLQ=PMAS(42,1)**2
27129 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
27130 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
27131 KFLQQ=KFDP(MDCY(42,2),1)
27132 DO 220 I=MMINA,MMAXA
27133 IF(IABS(I).NE.KFLQQ) GOTO 220
27136 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
27137 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
27140 ISIG(NCHN,3-ISDE)=21
27142 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
27146 ELSEIF(ISUB.EQ.163) THEN
27147 C...g + g -> LQ + LQbar; LQ=leptoquark
27148 SQMLQ=PMAS(42,1)**2
27149 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
27150 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
27151 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
27152 & ((TH-SQMLQ)*(UH-SQMLQ)))
27153 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
27157 C...Since don't know proper colour flow, randomize between alternatives
27158 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
27162 ELSEIF(ISUB.EQ.164) THEN
27163 C...q + qbar -> LQ + LQbar; LQ=leptoquark
27164 DELTA=0.25D0*(SQM3-SQM4)**2/SH
27165 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
27168 C SQMLQ=PMAS(42,1)**2
27169 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
27170 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
27171 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
27172 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
27173 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
27174 KFLQQ=KFDP(MDCY(42,2),1)
27175 DO 240 I=MMINA,MMAXA
27176 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
27177 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
27183 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
27186 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
27187 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
27188 KFQSTR=KFPR(ISUB,2)
27189 KCQSTR=PYCOMP(KFQSTR)
27190 KFQEXC=MOD(KFQSTR,KEXCIT)
27191 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
27192 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
27193 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
27194 C...Propagators: as simulated in PYOFSH and as desired
27195 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
27196 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
27197 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
27198 GMMQC=SQRT(SQM4)*WDTP(0)
27199 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
27200 FACQSA=FACQSA*HBW4C/HBW4
27201 FACQSB=FACQSB*HBW4C/HBW4
27202 C...Branching ratios.
27203 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
27204 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
27205 DO 260 I=MMIN1,MMAX1
27207 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
27208 DO 250 J=MMIN2,MMAX2
27210 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
27211 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
27216 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
27217 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
27222 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
27223 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
27224 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
27229 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
27230 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
27231 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
27232 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
27237 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
27238 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
27243 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
27244 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
27245 ELSEIF(I.EQ.-J) THEN
27250 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27251 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27256 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27257 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27258 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
27263 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
27264 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
27265 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
27270 ELSEIF(ISUB.EQ.169) THEN
27271 C...q + qbar -> e + e* (excited lepton)
27272 KFQSTR=KFPR(ISUB,2)
27273 KCQSTR=PYCOMP(KFQSTR)
27274 KFQEXC=MOD(KFQSTR,KEXCIT)
27275 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
27276 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
27277 C...Propagators: as simulated in PYOFSH and as desired
27278 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
27279 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
27280 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
27281 GMMQC=SQRT(SQM4)*WDTP(0)
27282 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
27283 FACQSB=FACQSB*HBW4C/HBW4
27284 C...Branching ratios.
27285 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
27286 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
27287 DO 270 I=MMIN1,MMAX1
27289 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
27292 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
27297 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27298 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27303 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27304 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27308 ELSEIF(ISUB.LE.360) THEN
27309 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
27310 C...l + l -> H_L++/-- or H_R++/--.
27312 KFREC=PYCOMP(KFRES)
27313 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
27315 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
27316 DO 290 I=MMIN1,MMAX1
27318 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
27320 DO 280 J=MMIN2,MMAX2
27322 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
27324 IF(I*J.LT.0) GOTO 280
27325 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
27330 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
27331 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
27332 SIGH(NCHN)=HI*FACBW*HF
27336 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
27337 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
27339 KFREC=PYCOMP(KFRES)
27340 C...Propagators: as simulated in PYOFSH and as desired
27341 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
27342 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
27343 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
27344 GMMC=SQRT(SQM3)*WDTP(0)
27345 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
27346 FHCC=COMFAC*AEM*HBW3C/HBW3
27347 DO 310 I=MMINA,MMAXA
27349 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
27351 J=ISIGN(KFPR(ISUB,2),-I)
27352 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
27353 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
27354 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
27356 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
27357 & (TH-SQM4)*SH)/(TH-SQM4)**2
27358 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
27360 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
27361 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
27362 & ((UH-SQM3)*(TH-SQM4))
27363 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
27364 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
27365 & ((UH-SQM3)*(SH-SQML))
27366 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
27367 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
27368 & ((SH-SQML)*(TH-SQM4))
27369 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
27370 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
27372 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
27373 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
27376 ISIG(NCHN,3-ISDE)=22
27378 SIGH(NCHN)=FHCC*SMM*WIDSC
27382 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
27383 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
27385 KFREC=PYCOMP(KFRES)
27386 SQMH=PMAS(KFREC,1)**2
27387 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
27388 C...Propagators: H++/-- as simulated in PYOFSH and as desired
27389 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
27390 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
27391 GMMH3=SQRT(SQM3)*WDTP(0)
27392 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
27393 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
27394 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
27395 GMMH4=SQRT(SQM4)*WDTP(0)
27396 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
27397 C...Kinematical and coupling functions
27398 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
27399 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
27400 C...Loop over allowed flavours
27401 DO 320 I=MMINA,MMAXA
27402 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
27403 EI=KCHG(IABS(I),1)/3D0
27404 AI=SIGN(1D0,EI+0.1D0)
27407 IF(IABS(I).LE.10) FCOI=FACA/3D0
27408 IF(ISUB.EQ.349) THEN
27409 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
27410 IF(IABS(I).LT.10) THEN
27411 DSIGHH=8D0*AEM**2*(EI**2/SH2+
27412 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
27413 & (VI**2+AI**2)*XWHH**2*HBWZ)
27415 IAOFF=181+3*((IABS(I)-11)/2)
27416 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
27418 DSIGHH=8D0*AEM**2*(EI**2/SH2+
27419 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
27420 & (VI**2+AI**2)*XWHH**2*HBWZ)+
27421 & 8D0*AEM*(EI*HSUM/(SH*TH)+
27422 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
27426 IF(IABS(I).LT.10) THEN
27427 DSIGHH=8D0*AEM**2*EI**2/SH2
27429 IAOFF=181+3*((IABS(I)-11)/2)
27430 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
27432 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
27440 SIGH(NCHN)=FACHH*FCOI*DSIGHH
27443 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
27444 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
27446 KFREC=PYCOMP(KFRES)
27447 SQMH=PMAS(KFREC,1)**2
27448 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
27449 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
27450 & PMAS(PYCOMP(9900024),1)**2
27451 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
27452 FACPRT=1D0/((VINT(204)**2-VINT(215))*
27453 & (VINT(209)**2-VINT(216)))
27454 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
27455 & (VINT(209)**2+2D0*VINT(218)))
27456 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
27458 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
27459 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
27461 DO 340 I=MMIN1,MMAX1
27462 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
27463 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
27464 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
27465 DO 330 J=MMIN2,MMAX2
27466 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
27467 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
27468 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
27470 IF(IABS(KCHH).NE.2) GOTO 330
27471 FACLR=VINT(180+I)*VINT(180+J)
27472 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
27473 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
27474 FACPRP=0.5D0*(FACPRT+FACPRU)**2
27482 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
27486 ELSEIF(ISUB.EQ.353) THEN
27487 C...f + fbar -> Z_R0
27488 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
27489 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
27491 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
27492 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27493 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
27494 DO 350 I=MMINA,MMAXA
27495 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
27496 IF(IABS(I).LE.8) THEN
27497 EI=KCHG(IABS(I),1)/3D0
27498 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
27499 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
27504 HI=HP*(VI**2+AI**2)
27505 IF(IABS(I).LE.10) HI=HI*FACA/3D0
27510 SIGH(NCHN)=HI*FACBW*HF
27513 ELSEIF(ISUB.EQ.354) THEN
27514 C...f + fbar' -> W_R+/-
27515 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
27516 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
27518 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
27519 HP=AEM/(24D0*XW)*SH
27520 DO 370 I=MMIN1,MMAX1
27521 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
27523 DO 360 J=MMIN2,MMAX2
27524 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
27526 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
27527 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
27529 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
27531 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
27536 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
27537 SIGH(NCHN)=HI*FACBW*HF
27542 ELSEIF(ISUB.LE.400) THEN
27543 IF(ISUB.EQ.391) THEN
27544 C...f + fbar -> G*.
27545 KFGSTR=KFPR(ISUB,1)
27546 KCGSTR=PYCOMP(KFGSTR)
27547 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
27549 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27550 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
27551 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
27552 DO 380 I=MMINA,MMAXA
27553 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
27555 IF(IABS(I).LE.10) HI=HI*FACA/3D0
27563 ELSEIF(ISUB.EQ.392) THEN
27565 KFGSTR=KFPR(ISUB,1)
27566 KCGSTR=PYCOMP(KFGSTR)
27567 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
27569 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27570 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
27571 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
27572 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
27580 ELSEIF(ISUB.EQ.393) THEN
27581 C...q + qbar -> g + G*.
27582 KFGSTR=KFPR(ISUB,2)
27583 KCGSTR=PYCOMP(KFGSTR)
27584 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
27585 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
27586 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
27588 C...Propagators: as simulated in PYOFSH and as desired
27589 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
27590 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
27591 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
27592 HS=SQRT(SQM4)*WDTP(0)
27593 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27594 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
27595 FACG=FACG*HBW4C/HBW4
27596 DO 400 I=MMINA,MMAXA
27597 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
27598 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
27606 ELSEIF(ISUB.EQ.394) THEN
27607 C...q + g -> q + G*.
27608 KFGSTR=KFPR(ISUB,2)
27609 KCGSTR=PYCOMP(KFGSTR)
27610 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
27611 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
27612 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
27613 & 2D0*TH2*TH/(UH*SH2))
27614 C...Propagators: as simulated in PYOFSH and as desired
27615 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
27616 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
27617 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
27618 HS=SQRT(SQM4)*WDTP(0)
27619 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27620 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
27621 FACG=FACG*HBW4C/HBW4
27622 DO 420 I=MMINA,MMAXA
27623 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
27625 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
27626 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
27629 ISIG(NCHN,3-ISDE)=21
27635 ELSEIF(ISUB.EQ.395) THEN
27636 C...g + g -> g + G*.
27637 KFGSTR=KFPR(ISUB,2)
27638 KCGSTR=PYCOMP(KFGSTR)
27639 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
27640 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
27641 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
27642 C...Propagators: as simulated in PYOFSH and as desired
27643 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
27644 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
27645 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
27646 HS=SQRT(SQM4)*WDTP(0)
27647 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27648 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
27649 FACG=FACG*HBW4C/HBW4
27650 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
27663 C*********************************************************************
27666 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
27667 C...parton distributions according to a few different parametrizations.
27668 C...Note that what is coded is x times the probability distribution,
27669 C...i.e. xq(x,Q2) etc.
27671 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
27673 C...Double precision and integer declarations.
27674 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27675 IMPLICIT INTEGER(I-N)
27676 INTEGER PYK,PYCHGE,PYCOMP
27678 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27679 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27680 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27681 COMMON/PYINT1/MINT(400),VINT(400)
27682 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
27684 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
27686 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
27687 &XPPI(-6:6),XPPR(-6:6)
27689 C...Interface to PDFLIB.
27690 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
27692 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
27693 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
27694 CHARACTER*20 PARM(20)
27695 DATA VALUE/20*0D0/,PARM/20*' '/
27697 C...Data related to Schuler-Sjostrand photon distributions.
27698 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
27700 C...Reset parton distributions.
27706 C...Check x and particle species.
27707 IF(X.LE.0D0.OR.X.GE.1D0) THEN
27708 WRITE(MSTU(11),5000) X
27712 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
27713 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
27714 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
27715 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
27716 &KFA.NE.310.AND.KFA.NE.130) THEN
27717 WRITE(MSTU(11),5100) KF
27721 C...Electron (or muon or tau) parton distribution call.
27722 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
27723 CALL PYPDEL(KFA,X,Q2,XPEL)
27728 C...Photon parton distribution call (VDM+anomalous).
27729 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
27730 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
27731 CALL PYPDGA(X,Q2,XPGA)
27735 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
27738 IF(MSTP(55).GE.7) P2MX=4.0D0
27739 IF(MSTP(57).EQ.0) Q2MX=P2MX
27741 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27742 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
27747 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
27750 IF(MSTP(55).GE.11) P2MX=4.0D0
27751 IF(MSTP(57).EQ.0) Q2MX=P2MX
27753 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27754 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
27756 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
27759 ELSEIF(MSTP(56).EQ.2) THEN
27760 C...Call PDFLIB parton distributions.
27764 VALUE(2)=MSTP(55)/1000
27766 VALUE(3)=MOD(MSTP(55),1000)
27767 IF(MINT(93).NE.3000000+MSTP(55)) THEN
27768 CALL PDFSET(PARM,VALUE)
27769 MINT(93)=3000000+MSTP(55)
27772 QQ2=MAX(0D0,Q2MIN,Q2)
27773 IF(MSTP(57).EQ.0) QQ2=Q2MIN
27775 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27777 IF(MSTP(55).EQ.5004) THEN
27778 IF(5D0*P2.LT.QQ2.AND.
27779 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
27780 & P2.GE.0D0.AND.P2.LT.10D0.AND.
27781 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
27782 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
27797 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
27826 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
27829 C...Pion/gammaVDM parton distribution call.
27830 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
27831 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
27832 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
27833 & MSTP(55).LE.12) THEN
27834 ISET=1+MOD(MSTP(55)-1,4)
27837 IF(ISET.GE.3) P2MX=4.0D0
27838 IF(MSTP(57).EQ.0) Q2MX=P2MX
27840 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27841 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
27843 XPQ(KFL)=XPVMD(KFL)
27846 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
27847 CALL PYPDPI(X,Q2,XPPI)
27851 ELSEIF(MSTP(54).EQ.2) THEN
27852 C...Call PDFLIB parton distributions.
27856 VALUE(2)=MSTP(53)/1000
27858 VALUE(3)=MOD(MSTP(53),1000)
27859 IF(MINT(93).NE.2000000+MSTP(53)) THEN
27860 CALL PDFSET(PARM,VALUE)
27861 MINT(93)=2000000+MSTP(53)
27864 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27865 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27866 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27882 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
27885 C...Anomalous photon parton distribution call.
27886 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
27889 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
27890 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
27891 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
27892 IF(MSTP(57).EQ.0) Q2MX=P2MX
27894 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27895 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
27897 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
27900 ELSEIF(MSTP(56).EQ.1) THEN
27901 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
27902 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
27903 IF(MSTP(57).EQ.0) Q2MX=P2MX
27905 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27906 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
27908 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
27911 ELSEIF(MSTP(56).EQ.2) THEN
27912 IF(MSTP(57).EQ.0) Q2MX=P2MX
27913 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
27918 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
27919 IF(MSTP(57).EQ.0) Q2MX=P2MX
27920 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
27926 210 RKF=11D0*PYR(0)
27928 IF(RKF.GT.1D0) KFR=2
27929 IF(RKF.GT.5D0) KFR=3
27930 IF(RKF.GT.6D0) KFR=4
27931 IF(RKF.GT.10D0) KFR=5
27932 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
27933 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
27934 IF(MSTP(57).EQ.0) Q2MX=P2MX
27935 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
27942 C...Proton parton distribution call.
27944 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
27945 CALL PYPDPR(X,Q2,XPPR)
27949 ELSEIF(MSTP(52).EQ.2) THEN
27950 C...Call PDFLIB parton distributions.
27954 VALUE(2)=MSTP(51)/1000
27956 VALUE(3)=MOD(MSTP(51),1000)
27957 IF(MINT(93).NE.1000000+MSTP(51)) THEN
27958 CALL PDFSET_ALICE(PARM,VALUE)
27959 MINT(93)=1000000+MSTP(51)
27962 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27963 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27965 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27981 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
27985 C...Isospin average for pi0/gammaVDM.
27986 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
27987 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
27992 XPS=0.5D0*(XPQ(1)+XPQ(-2))
27993 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
27997 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
27998 XPQ(1)=XPQ(1)+0.2D0*XPV
27999 XPQ(-1)=XPQ(-1)+0.2D0*XPV
28000 XPQ(2)=XPQ(2)+0.8D0*XPV
28001 XPQ(-2)=XPQ(-2)+0.8D0*XPV
28002 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
28004 XPQ(-3)=XPQ(-3)+XPV
28005 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
28007 XPQ(-4)=XPQ(-4)+XPV
28008 IF(MSTP(55).GE.9) THEN
28014 XPQ(1)=XPQ(1)+0.5D0*XPV
28015 XPQ(-1)=XPQ(-1)+0.5D0*XPV
28016 XPQ(2)=XPQ(2)+0.5D0*XPV
28017 XPQ(-2)=XPQ(-2)+0.5D0*XPV
28020 C...Rescale for gammaVDM by effective gamma -> rho coupling.
28021 C+++Do not rescale?
28022 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
28023 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
28025 XPQ(KFL)=VINT(281)*XPQ(KFL)
28027 VINT(232)=VINT(281)*XPV
28030 C...Simple recipes for kaons.
28031 ELSEIF(KFA.EQ.321) THEN
28032 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
28034 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
28035 XPS=0.5D0*(XPQ(1)+XPQ(-2))
28036 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
28039 XPQ(1)=XPQ(1)+0.5D0*XPV
28040 XPQ(-1)=XPQ(-1)+0.5D0*XPV
28041 XPQ(3)=XPQ(3)+0.5D0*XPV
28042 XPQ(-3)=XPQ(-3)+0.5D0*XPV
28044 C...Isospin conjugation for neutron.
28045 ELSEIF(KFA.EQ.2112) THEN
28053 C...Simple recipes for hyperon (average valence parton distribution).
28054 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
28055 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
28056 XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
28057 XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
28062 XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
28063 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
28064 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
28067 C...Charge conjugation for antiparticle.
28070 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
28077 C...Allow gluon also in position 21.
28080 C...Check positivity and reset above maximum allowed flavour.
28082 XPQ(KFL)=MAX(0D0,XPQ(KFL))
28083 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
28086 C...Formats for error printouts.
28087 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
28088 5100 FORMAT(' Error: illegal particle code for parton distribution;',
28090 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
28096 C*********************************************************************
28099 C...Gives proton parton distribution at small x and/or Q^2 according to
28100 C...correct limiting behaviour.
28102 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
28104 C...Double precision and integer declarations.
28105 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28106 IMPLICIT INTEGER(I-N)
28107 INTEGER PYK,PYCHGE,PYCOMP
28109 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28110 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28111 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28112 COMMON/PYINT1/MINT(400),VINT(400)
28113 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28115 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
28116 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
28118 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
28122 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
28123 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
28124 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
28126 CALL PYPDFU(KF,X,Q2,XPQ)
28130 C...Reset. Check x.
28134 IF(X.LE.0D0.OR.X.GE.1D0) THEN
28135 WRITE(MSTU(11),5000) X
28139 C...Define valence content.
28143 IF(KF.EQ.2212) THEN
28146 ELSEIF(KF.EQ.-2212) THEN
28149 ELSEIF(KF.EQ.2112) THEN
28152 ELSEIF(KF.EQ.-2112) THEN
28155 ELSEIF(KF.EQ.211) THEN
28159 ELSEIF(KF.EQ.-211) THEN
28163 ELSEIF(MINT(105).LE.223) THEN
28168 ELSEIF(MINT(105).EQ.333) THEN
28173 ELSEIF(MINT(105).EQ.443) THEN
28180 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
28181 CALL PYPDFU(KFC,X,Q2,XPA)
28182 Q2MN=MAX(3D0,VINT(231))
28183 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
28184 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
28186 C...Large Q2 and large x: naive call is enough.
28187 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
28193 C...Small Q2 and large x: dampen boundary value.
28194 ELSEIF(X.GT.XMN) THEN
28196 C...Evaluate at boundary and define dampening factors.
28197 CALL PYPDFU(KFC,X,Q2MN,XPA)
28198 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
28199 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
28201 C...Separate valence and sea parts of parton distribution.
28203 XFV1=XPA(KFV1)-XPA(-KFV1)
28204 XPA(KFV1)=XPA(-KFV1)
28205 XFV2=XPA(KFV2)-XPA(-KFV2)
28206 XPA(KFV2)=XPA(-KFV2)
28208 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
28209 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
28210 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
28211 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
28214 C...Dampen valence and sea separately. Put back together.
28216 XPQ(KFL)=FS*XPA(KFL)
28219 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
28220 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
28222 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
28223 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
28224 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
28225 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
28229 C...Large Q2 and small x: interpolate behaviour.
28230 ELSEIF(Q2.GT.Q2MN) THEN
28232 C...Evaluate at extremes and define coefficients for interpolation.
28233 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
28235 CALL PYPDFU(KFC,X,Q2B,XPB)
28237 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
28238 FVA=(X/XMN)**0.45D0*FLA
28239 FSA=(X/XMN)**(-0.08D0)*FLA
28242 C...Separate valence and sea parts of parton distribution.
28244 XFVA1=XPA(KFV1)-XPA(-KFV1)
28245 XPA(KFV1)=XPA(-KFV1)
28246 XFVA2=XPA(KFV2)-XPA(-KFV2)
28247 XPA(KFV2)=XPA(-KFV2)
28248 XFVB1=XPB(KFV1)-XPB(-KFV1)
28249 XPB(KFV1)=XPB(-KFV1)
28250 XFVB2=XPB(KFV2)-XPB(-KFV2)
28251 XPB(KFV2)=XPB(-KFV2)
28253 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
28254 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
28255 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
28256 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
28257 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
28258 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
28259 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
28260 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
28263 C...Interpolate for valence and sea. Put back together.
28265 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
28268 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
28269 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
28271 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
28272 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
28273 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
28274 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
28278 C...Small Q2 and small x: dampen boundary value and add term.
28281 C...Evaluate at boundary and define dampening factors.
28282 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
28283 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
28285 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
28286 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
28287 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
28288 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
28289 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
28290 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
28292 C...Separate valence and sea parts of parton distribution.
28294 XFV1=XPA(KFV1)-XPA(-KFV1)
28295 XPA(KFV1)=XPA(-KFV1)
28296 XFV2=XPA(KFV2)-XPA(-KFV2)
28297 XPA(KFV2)=XPA(-KFV2)
28299 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
28300 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
28301 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
28302 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
28305 C...Dampen valence and sea separately. Add constant terms.
28306 C...Put back together.
28308 XPQ(KFL)=FSA*XPA(KFL)
28312 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
28314 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
28315 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
28318 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
28320 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
28321 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
28322 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
28323 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
28329 C...Format for error printout.
28330 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
28335 C*********************************************************************
28338 C...Gives electron (or muon, or tau) parton distribution.
28340 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
28342 C...Double precision and integer declarations.
28343 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28344 IMPLICIT INTEGER(I-N)
28345 INTEGER PYK,PYCHGE,PYCOMP
28347 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28348 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28349 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28350 COMMON/PYINT1/MINT(400),VINT(400)
28351 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28353 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
28355 C...Interface to PDFLIB.
28356 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
28358 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
28359 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
28360 CHARACTER*20 PARM(20)
28361 DATA VALUE/20*0D0/,PARM/20*' '/
28363 C...Some common constants.
28369 IF(KFA.EQ.13) PME=PMAS(13,1)
28370 IF(KFA.EQ.15) PME=PMAS(15,1)
28371 XL=LOG(MAX(1D-10,X))
28372 X1L=LOG(MAX(1D-10,1D0-X))
28373 HLE=LOG(MAX(3D0,Q2/PME**2))
28374 HBE2=(AEM/PARU(1))*(HLE-1D0)
28376 C...Electron inside electron, see R. Kleiss et al., in Z physics at
28377 C...LEP 1, CERN 89-08, p. 34
28378 IF(MSTP(59).LE.1) THEN
28379 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
28380 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
28381 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
28382 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
28383 & 4D0*XL/(1D0-X)-5D0-X)
28385 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
28386 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
28387 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
28389 C...Zero distribution for very large x and rescale it for intermediate.
28390 IF(X.GT.1D0-1D-10) THEN
28392 ELSEIF(X.GT.1D0-1D-7) THEN
28393 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
28397 C...Photon and (transverse) W- inside electron.
28398 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
28399 IF(MSTP(13).LE.1) THEN
28402 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
28404 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
28405 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
28406 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
28408 C...Electron or positron inside photon inside electron.
28409 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
28410 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
28411 & 2D0*X*(1D0+X)*XL)
28412 XPEL(11)=XPEL(11)+XFSEA
28415 C...Initialize PDFLIB photon parton distributions.
28416 IF(MSTP(56).EQ.2) THEN
28420 VALUE(2)=MSTP(55)/1000
28422 VALUE(3)=MOD(MSTP(55),1000)
28423 IF(MINT(93).NE.3000000+MSTP(55)) THEN
28424 CALL PDFSET(PARM,VALUE)
28425 MINT(93)=3000000+MSTP(55)
28429 C...Quarks and gluons inside photon inside electron:
28430 C...numerical convolution required.
28439 IF(ITER.EQ.0) NSTP=2
28441 SXP(KFL)=0.5D0*SXP(KFL)
28444 IF(ITER.EQ.0) WTSTP=0.5D0
28445 C...Pick grid of x_{gamma} values logarithmically even.
28450 XLE=XL*(ISTP-0.5D0)/NSTP
28452 XE=MIN(1D0-1D-10,EXP(XLE))
28453 XG=MIN(1D0-1D-10,X/XE)
28454 C...Evaluate photon inside electron parton distribution for convolution.
28455 XPGP=1D0+(1D0-XE)**2
28456 IF(MSTP(13).LE.1) THEN
28459 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
28461 C...Evaluate photon parton distributions for convolution.
28462 IF(MSTP(56).EQ.1) THEN
28463 IF(MSTP(55).EQ.1) THEN
28464 CALL PYPDGA(XG,Q2,XPGA)
28465 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
28468 IF(MSTP(55).GE.7) P2MX=4.0D0
28469 IF(MSTP(57).EQ.0) Q2MX=P2MX
28471 IF(VINT(120).LT.0D0) P2=VINT(120)**2
28472 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
28474 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
28477 IF(MSTP(55).GE.11) P2MX=4.0D0
28478 IF(MSTP(57).EQ.0) Q2MX=P2MX
28480 IF(VINT(120).LT.0D0) P2=VINT(120)**2
28481 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
28485 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
28487 ELSEIF(MSTP(56).EQ.2) THEN
28488 C...Call PDFLIB parton distributions.
28490 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
28491 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
28492 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
28493 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
28494 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
28495 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
28496 SXP(3)=SXP(3)+WTSTP*XPGP*STR
28497 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
28498 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
28499 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
28502 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
28503 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
28504 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
28506 C...Put convolution into output arrays.
28508 XPEL(0)=FCONV*SXP(0)
28510 XPEL(KFL)=FCONV*SXP(KFL)
28511 XPEL(-KFL)=XPEL(KFL)
28518 C*********************************************************************
28521 C...Gives photon parton distribution.
28523 SUBROUTINE PYPDGA(X,Q2,XPGA)
28525 C...Double precision and integer declarations.
28526 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28527 IMPLICIT INTEGER(I-N)
28528 INTEGER PYK,PYCHGE,PYCOMP
28530 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28531 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28532 COMMON/PYINT1/MINT(400),VINT(400)
28533 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
28535 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
28536 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
28537 &DGCS(4,3),DGDS(4,3),DGES(4,3)
28539 C...The following data lines are coefficients needed in the
28540 C...Drees and Grassie photon parton distribution parametrization.
28541 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
28542 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
28543 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
28544 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
28545 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
28546 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
28547 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
28548 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
28549 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
28550 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
28551 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
28552 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
28553 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
28554 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
28555 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
28556 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
28557 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
28558 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
28559 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
28560 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
28561 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
28562 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
28563 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
28564 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
28565 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
28566 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
28568 C...Photon parton distribution from Drees and Grassie.
28569 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
28574 IF(MSTP(57).LE.0) THEN
28577 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
28581 IF(Q2.GT.25D0) NF=4
28582 IF(Q2.GT.300D0) NF=5
28586 C...Evaluate gluon content.
28587 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
28588 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
28589 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
28590 XPGL=DGA*X**DGB*X1**DGC
28592 C...Evaluate up- and down-type quark content.
28593 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
28594 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
28595 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
28596 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
28597 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
28598 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
28599 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
28600 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
28601 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
28602 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
28603 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
28605 IF(NF.EQ.4) DGF=10D0
28606 IF(NF.EQ.5) DGF=55D0/6D0
28607 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
28609 XPQU=(XPQS+9D0*XPQN)/6D0
28610 XPQD=(XPQS-4.5D0*XPQN)/6D0
28611 ELSEIF(NF.EQ.4) THEN
28612 XPQU=(XPQS+6D0*XPQN)/8D0
28613 XPQD=(XPQS-6D0*XPQN)/8D0
28615 XPQU=(XPQS+7.5D0*XPQN)/10D0
28616 XPQD=(XPQS-5D0*XPQN)/10D0
28619 C...Put into output arrays.
28624 IF(NF.GE.4) XPGA(4)=AEM*XPQU
28625 IF(NF.GE.5) XPGA(5)=AEM*XPQD
28627 XPGA(-KFL)=XPGA(KFL)
28633 C*********************************************************************
28636 C...Constructs the F2 and parton distributions of the photon
28637 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
28638 C...For F2, c and b are included by the Bethe-Heitler formula;
28639 C...in the 'MSbar' scheme additionally a Cgamma term is added.
28640 C...Contains the SaS sets 1D, 1M, 2D and 2M.
28641 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28643 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
28645 C...Double precision and integer declarations.
28646 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28647 IMPLICIT INTEGER(I-N)
28648 INTEGER PYK,PYCHGE,PYCOMP
28650 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
28652 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
28653 SAVE /PYINT8/,/PYINT9/
28655 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
28656 C...Charm and bottom masses (low to compensate for J/psi etc.).
28657 DATA PMC/1.3D0/, PMB/4.6D0/
28658 C...alpha_em and alpha_em/(2*pi).
28659 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
28660 C...Lambda value for 4 flavours.
28662 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
28664 C...VMD couplings f_V**2/(4*pi).
28665 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
28666 C...Masses for rho (=omega) and phi.
28667 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
28668 C...Number of points in integration for IP2=1.
28686 C...Set Q0 cut-off parameter as function of set used.
28694 C...Scale choice for off-shell photon; common factors.
28699 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
28700 FACNOR=LOG(Q2/Q02)/NSTEP
28701 ELSEIF(IP2.EQ.2) THEN
28703 ELSEIF(IP2.EQ.3) THEN
28705 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
28706 ELSEIF(IP2.EQ.4) THEN
28707 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28708 & ((Q2+P2)*(Q02+P2)))
28709 ELSEIF(IP2.EQ.5) THEN
28710 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28711 & ((Q2+P2)*(Q02+P2)))
28712 P2MX=Q0*SQRT(P2MXA)
28713 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
28714 ELSEIF(IP2.EQ.6) THEN
28715 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28716 & ((Q2+P2)*(Q02+P2)))
28717 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
28719 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28720 & ((Q2+P2)*(Q02+P2)))
28721 P2MX=Q0*SQRT(P2MXA)
28723 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
28724 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
28725 IF(ABS(Q2-Q02).GT.1D-6) THEN
28726 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
28727 ELSEIF(P2.LT.Q02) THEN
28728 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
28734 C...Call VMD parametrization for d quark and use to give rho, omega,
28735 C...phi. Note dipole dampening for off-shell photon.
28736 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28740 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
28741 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
28743 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
28745 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
28746 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
28747 XPVMD(3)=XPVMD(3)+FACS*XFVAL
28748 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
28749 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
28750 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
28751 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
28752 VXPVMD(2)=FRACU*FACUD*XFVAL
28753 VXPVMD(3)=FACS*XFVAL
28754 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
28755 VXPVMD(-2)=FRACU*FACUD*XFVAL
28756 VXPVMD(-3)=FACS*XFVAL
28759 C...Anomalous parametrizations for different strategies
28760 C...for off-shell photons; except full integration.
28762 C...Call anomalous parametrization for d + u + s.
28763 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28765 XPANL(KFL)=FACNOR*XPGA(KFL)
28766 VXPANL(KFL)=FACNOR*VXPGA(KFL)
28769 C...Call anomalous parametrization for c and b.
28770 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28772 XPANH(KFL)=FACNOR*XPGA(KFL)
28773 VXPANH(KFL)=FACNOR*VXPGA(KFL)
28775 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28777 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
28778 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
28782 C...Special option: loop over flavours and integrate over k2.
28784 DO 160 ISTEP=1,NSTEP
28785 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
28786 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
28787 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
28788 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
28789 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
28790 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
28791 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
28793 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
28794 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
28795 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
28796 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
28802 C...Call Bethe-Heitler term expression for charm and bottom.
28803 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
28806 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
28810 C...For MSbar subtraction call C^gamma term expression for d, u, s.
28811 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
28812 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
28814 XPDIR(KFL)=XPGA(KFL)
28818 C...Store result in output array.
28821 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
28822 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
28823 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
28824 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
28825 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
28831 C*********************************************************************
28834 C...Evaluates the VMD parton distributions of a photon,
28835 C...evolved homogeneously from an initial scale P2 to Q2.
28836 C...Does not include dipole suppression factor.
28837 C...ISET is parton distribution set, see above;
28838 C...additionally ISET=0 is used for the evolution of an anomalous photon
28839 C...which branched at a scale P2 and then evolved homogeneously to Q2.
28840 C...ALAM is the 4-flavour Lambda, which is automatically converted
28841 C...to 3- and 5-flavour equivalents as needed.
28842 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28844 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
28846 C...Double precision and integer declarations.
28847 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28848 IMPLICIT INTEGER(I-N)
28849 INTEGER PYK,PYCHGE,PYCOMP
28850 C...Local arrays and data.
28851 DIMENSION XPGA(-6:6), VXPGA(-6:6)
28852 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
28861 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
28862 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
28863 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
28864 P2EFF=MAX(P2,1.2D0*ALAM3**2)
28865 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
28866 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
28867 Q2EFF=MAX(Q2,P2EFF)
28869 C...Find number of flavours at lower and upper scale.
28871 IF(P2EFF.LT.PMC**2) NFP=3
28872 IF(P2EFF.GT.PMB**2) NFP=5
28874 IF(Q2EFF.LT.PMC**2) NFQ=3
28875 IF(Q2EFF.GT.PMB**2) NFQ=5
28877 C...Find s as sum of 3-, 4- and 5-flavour parts.
28881 IF(NFQ.EQ.3) Q2DIV=Q2EFF
28882 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
28884 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
28886 IF(NFP.EQ.3) P2DIV=PMC**2
28888 IF(NFQ.EQ.5) Q2DIV=PMB**2
28889 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
28893 IF(NFP.EQ.5) P2DIV=P2EFF
28894 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
28897 C...Calculate frequent combinations of x and s.
28904 C...Evaluate homogeneous anomalous parton distributions below or
28905 C...above threshold.
28907 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28908 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28909 XVAL = X * 1.5D0 * (X**2+X1**2)
28913 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
28914 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
28915 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
28916 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
28917 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
28918 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
28919 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
28920 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
28921 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
28922 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
28923 & (2D0*X-1D0)*X*XL**2)
28926 C...Evaluate set 1D parton distributions below or above threshold.
28927 ELSEIF(ISET.EQ.1) THEN
28928 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28929 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28930 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
28931 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
28932 XSEA = 0.100D0 * X1**3.76D0
28934 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
28935 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
28936 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
28937 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
28938 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
28939 & X**0.40D0 * X1**(1.76D0+3D0*S)
28940 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
28941 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
28942 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
28943 XSEA0 = 0.100D0 * X1**3.76D0
28946 C...Evaluate set 1M parton distributions below or above threshold.
28947 ELSEIF(ISET.EQ.2) THEN
28948 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28949 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28950 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
28951 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
28954 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
28955 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
28956 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
28957 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
28958 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
28959 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
28960 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
28961 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
28966 C...Evaluate set 2D parton distributions below or above threshold.
28967 ELSEIF(ISET.EQ.3) THEN
28968 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28969 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28970 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
28971 XGLU = 1.925D0 * X1**2
28972 XSEA = 0.242D0 * X1**4
28974 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
28975 & X**(0.46D0+0.25D0*S) *
28976 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
28977 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
28978 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
28979 & EXP(-18.67D0*S) *
28980 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
28981 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
28982 & XL**(9.3D0*S/(1D0+1.7D0*S))
28983 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
28984 & (1D0-0.607D0*S+21.95D0*S2) *
28985 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
28986 XSEA0 = 0.242D0 * X1**4
28989 C...Evaluate set 2M parton distributions below or above threshold.
28990 ELSEIF(ISET.EQ.4) THEN
28991 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28992 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28993 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
28994 XGLU = 1.808D0 * X1**2
28995 XSEA = 0.209D0 * X1**4
28997 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
28998 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
28999 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
29000 & XL**(5.15D0*S/(1D0+2D0*S)) +
29001 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
29002 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
29003 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
29004 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
29005 & XL**(10.9D0*S/(1D0+2.5D0*S))
29006 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
29007 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
29008 & X1**(4D0+S) * XL**(0.45D0*S)
29009 XSEA0 = 0.209D0 * X1**4
29013 C...Threshold factors for c and b sea.
29014 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
29016 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29017 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29019 XCHM=XSEA*(1D0-(SCH/SLL)**2)
29021 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
29025 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29026 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29028 XBOT=XSEA*(1D0-(SBT/SLL)**2)
29030 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
29034 C...Fill parton distributions.
29041 XPGA(KFA)=XPGA(KFA)+XVAL
29043 XPGA(-KFL)=XPGA(KFL)
29051 C*********************************************************************
29054 C...Evaluates the parton distributions of the anomalous photon,
29055 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
29056 C...KF=0 gives the sum over (up to) 5 flavours,
29057 C...KF<0 limits to flavours up to abs(KF),
29058 C...KF>0 is for flavour KF only.
29059 C...ALAM is the 4-flavour Lambda, which is automatically converted
29060 C...to 3- and 5-flavour equivalents as needed.
29061 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
29063 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
29065 C...Double precision and integer declarations.
29066 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29067 IMPLICIT INTEGER(I-N)
29068 INTEGER PYK,PYCHGE,PYCOMP
29069 C...Local arrays and data.
29070 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
29071 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
29078 IF(Q2.LE.P2) RETURN
29081 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
29082 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
29084 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
29085 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
29086 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
29087 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
29088 Q2EFF=MAX(Q2,P2EFF)
29091 C...Find number of flavours at lower and upper scale.
29093 IF(P2EFF.LT.PMC**2) NFP=3
29094 IF(P2EFF.GT.PMB**2) NFP=5
29096 IF(Q2EFF.LT.PMC**2) NFQ=3
29097 IF(Q2EFF.GT.PMB**2) NFQ=5
29099 C...Define range of flavour loop.
29103 ELSEIF(KF.LT.0) THEN
29111 C...Loop over flavours the photon can branch into.
29112 DO 110 KFL=KFLMN,KFLMX
29114 C...Light flavours: calculate t range and (approximate) s range.
29115 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
29116 TDIFF=LOG(Q2EFF/P2EFF)
29117 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
29118 & LOG(P2EFF/ALAMSQ(NFQ)))
29119 IF(NFQ.GT.NFP) THEN
29121 IF(NFQ.EQ.4) Q2DIV=PMC**2
29122 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
29123 & LOG(P2EFF/ALAMSQ(NFQ)))
29124 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
29125 & LOG(P2EFF/ALAMSQ(NFQ-1)))
29126 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
29128 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
29130 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
29131 & LOG(P2EFF/ALAMSQ(4)))
29132 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
29133 & LOG(P2EFF/ALAMSQ(3)))
29134 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
29137 C...u and s quark do not need a separate treatment when d has been done.
29138 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
29140 C...Charm: as above, but only include range above c threshold.
29141 ELSEIF(KFL.EQ.4) THEN
29142 IF(Q2.LE.PMC**2) GOTO 110
29143 P2EFF=MAX(P2EFF,PMC**2)
29144 Q2EFF=MAX(Q2EFF,P2EFF)
29145 TDIFF=LOG(Q2EFF/P2EFF)
29146 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
29147 & LOG(P2EFF/ALAMSQ(NFQ)))
29148 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
29150 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
29151 & LOG(P2EFF/ALAMSQ(NFQ)))
29152 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
29153 & LOG(P2EFF/ALAMSQ(NFQ-1)))
29154 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
29157 C...Bottom: as above, but only include range above b threshold.
29158 ELSEIF(KFL.EQ.5) THEN
29159 IF(Q2.LE.PMB**2) GOTO 110
29160 P2EFF=MAX(P2EFF,PMB**2)
29161 Q2EFF=MAX(Q2,P2EFF)
29162 TDIFF=LOG(Q2EFF/P2EFF)
29163 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
29164 & LOG(P2EFF/ALAMSQ(NFQ)))
29167 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
29169 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
29170 FAC=AEM2PI*2D0*CHSQ*TDIFF
29172 C...Evaluate parton distributions (normalized to unit momentum sum).
29173 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
29174 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
29175 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
29176 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
29177 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
29178 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
29179 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
29180 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
29181 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
29182 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
29183 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
29184 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
29186 C...Threshold factors for c and b sea.
29187 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
29189 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29190 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29191 XCHM=XSEA*(1D0-(SCH/SLL)**3)
29194 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29195 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29196 XBOT=XSEA*(1D0-(SBT/SLL)**3)
29200 C...Add contribution of each valence flavour.
29201 XPGA(0)=XPGA(0)+FAC*XGLU
29202 XPGA(1)=XPGA(1)+FAC*XSEA
29203 XPGA(2)=XPGA(2)+FAC*XSEA
29204 XPGA(3)=XPGA(3)+FAC*XSEA
29205 XPGA(4)=XPGA(4)+FAC*XCHM
29206 XPGA(5)=XPGA(5)+FAC*XBOT
29207 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
29208 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
29211 XPGA(-KFL)=XPGA(KFL)
29212 VXPGA(-KFL)=VXPGA(KFL)
29218 C*********************************************************************
29221 C...Evaluates the Bethe-Heitler cross section for heavy flavour
29223 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
29225 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
29227 C...Double precision and integer declarations.
29228 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29229 IMPLICIT INTEGER(I-N)
29230 INTEGER PYK,PYCHGE,PYCOMP
29233 DATA AEM2PI/0.0011614D0/
29239 C...Check kinematics limits.
29240 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
29242 BETA2=1D0-4D0*PM2/W2
29243 IF(BETA2.LT.1D-10) RETURN
29247 C...Simple case: P2 = 0.
29248 IF(P2.LT.1D-4) THEN
29249 IF(BETA.LT.0.99D0) THEN
29250 XBL=LOG((1D0+BETA)/(1D0-BETA))
29252 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
29254 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
29255 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
29257 C...Complicated case: P2 > 0, based on approximation of
29258 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
29260 RPQ=1D0-4D0*X**2*P2/Q2
29261 IF(RPQ.GT.1D-10) THEN
29262 RPBE=SQRT(RPQ*BETA2)
29263 IF(RPBE.LT.0.99D0) THEN
29264 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
29265 XBI=2D0*RPBE/(1D0-RPBE**2)
29267 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
29268 XBL=LOG((1D0+RPBE)**2/RPBESN)
29269 XBI=2D0*RPBE/RPBESN
29271 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
29272 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
29273 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
29277 C...Multiply by charge-squared etc. to get parton distribution.
29279 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
29280 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
29285 C*********************************************************************
29288 C...Evaluates the direct contribution, i.e. the C^gamma term,
29289 C...as needed in MSbar parametrizations.
29290 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
29292 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
29294 C...Double precision and integer declarations.
29295 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29296 IMPLICIT INTEGER(I-N)
29297 INTEGER PYK,PYCHGE,PYCOMP
29298 C...Local array and data.
29299 DIMENSION XPGA(-6:6)
29300 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
29307 C...Evaluate common x-dependent expression.
29308 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
29309 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
29311 C...d, u, s part by simple charge factor.
29312 XPGA(1)=(1D0/9D0)*CGAM
29313 XPGA(2)=(4D0/9D0)*CGAM
29314 XPGA(3)=(1D0/9D0)*CGAM
29316 C...Also fill for antiquarks.
29324 C*********************************************************************
29327 C...Gives pi+ parton distribution according to two different
29328 C...parametrizations.
29330 SUBROUTINE PYPDPI(X,Q2,XPPI)
29332 C...Double precision and integer declarations.
29333 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29334 IMPLICIT INTEGER(I-N)
29335 INTEGER PYK,PYCHGE,PYCOMP
29337 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29338 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29339 COMMON/PYINT1/MINT(400),VINT(400)
29340 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
29342 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
29344 C...The following data lines are coefficients needed in the
29345 C...Owens pion parton distribution parametrizations, see below.
29346 C...Expansion coefficients for up and down valence quark distributions.
29347 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
29348 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29349 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29350 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
29351 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
29352 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29353 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29354 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
29355 C...Expansion coefficients for gluon distribution.
29356 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
29357 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
29358 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
29359 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
29360 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
29361 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
29362 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
29363 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
29364 C...Expansion coefficients for (up+down+strange) quark sea distribution.
29365 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
29366 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
29367 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
29368 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
29369 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
29370 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
29371 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
29372 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
29373 C...Expansion coefficients for charm quark sea distribution.
29374 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
29375 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
29376 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
29377 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
29378 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
29379 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
29380 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
29381 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
29383 C...Euler's beta function, requires ordinary Gamma function
29384 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
29386 C...Reset output array.
29391 IF(MSTP(53).LE.2) THEN
29392 C...Pion parton distributions from Owens.
29393 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
29395 C...Determine set, Lambda and s expansion variable.
29397 IF(NSET.EQ.1) ALAM=0.2D0
29398 IF(NSET.EQ.2) ALAM=0.4D0
29400 IF(MSTP(57).LE.0) THEN
29403 Q2IN=MIN(2D3,MAX(4D0,Q2))
29404 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
29407 C...Calculate parton distributions.
29410 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
29411 & COW(3,IS,KFL,NSET)*SD**2
29414 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
29416 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
29421 C...Put into output array.
29424 XPPI(2)=XQ(1)+XQ(3)/6D0
29427 XPPI(-1)=XQ(1)+XQ(3)/6D0
29432 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
29433 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
29437 C...Determine s expansion variable and some x expressions.
29439 IF(MSTP(57).LE.0) THEN
29442 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
29443 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
29449 C...Evaluate valence, gluon and sea distributions.
29450 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
29451 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
29452 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
29454 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
29455 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
29457 & (1D0-X)**(0.390D0+1.053D0*SD)
29458 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
29460 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
29462 & XL**(2.538D0-0.763D0*SD)
29463 IF(SD.LE.0.888D0) THEN
29466 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
29468 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
29471 IF(SD.LE.1.351D0) THEN
29474 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
29475 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
29479 C...Put into output array.
29487 XPPI(-KFL)=XPPI(KFL)
29489 XPPI(2)=XPPI(2)+XFVAL
29490 XPPI(-1)=XPPI(-1)+XFVAL
29496 C*********************************************************************
29499 C...Gives proton parton distributions according to a few different
29500 C...parametrizations.
29502 SUBROUTINE PYPDPR(X,Q2,XPPR)
29504 C...Double precision and integer declarations.
29505 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29506 IMPLICIT INTEGER(I-N)
29507 INTEGER PYK,PYCHGE,PYCOMP
29509 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29510 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29511 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29512 COMMON/PYINT1/MINT(400),VINT(400)
29513 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
29514 C...Arrays and data.
29515 DIMENSION XPPR(-6:6),Q2MIN(16)
29516 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
29517 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
29519 C...Reset output array.
29524 C...Common preliminaries.
29525 NSET=MAX(1,MIN(16,MSTP(51)))
29526 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
29527 VINT(231)=Q2MIN(NSET)
29528 IF(MSTP(57).EQ.0) THEN
29531 Q2L=MAX(Q2MIN(NSET),Q2)
29534 IF(NSET.GE.1.AND.NSET.LE.3) THEN
29535 C...Interface to the CTEQ 3 parton distributions.
29536 QRT=SQRT(MAX(1D0,Q2L))
29538 C...Loop over flavours.
29541 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
29542 ELSEIF(I.LE.2) THEN
29543 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
29549 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
29550 C...Interface to the GRV 94 distributions.
29552 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29553 ELSEIF(NSET.EQ.5) THEN
29554 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29556 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29559 C...Put into output array.
29561 XPPR(-1)=0.5D0*(UDB+DEL)
29562 XPPR(-2)=0.5D0*(UDB-DEL)
29566 XPPR(1)=DV+XPPR(-1)
29567 XPPR(2)=UV+XPPR(-2)
29572 ELSEIF(NSET.EQ.7) THEN
29573 C...Interface to the CTEQ 5L parton distributions.
29574 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
29575 C...freezing x*f(x,Q2) at borders.
29576 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
29577 XIN=MAX(1D-6,MIN(1D0,X))
29579 C...Loop over flavours (with u <-> d notation mismatch).
29580 SUMUDB=PYCT5L(-1,XIN,QRT)
29581 RATUDB=PYCT5L(-2,XIN,QRT)
29584 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
29585 ELSEIF(I.EQ.2) THEN
29586 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
29587 ELSEIF(I.EQ.-1) THEN
29588 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
29589 ELSEIF(I.EQ.-2) THEN
29590 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
29592 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
29593 IF(I.LT.0) XPPR(-I)=XPPR(I)
29597 ELSEIF(NSET.EQ.8) THEN
29598 C...Interface to the CTEQ 5M1 parton distributions.
29599 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
29600 XIN=MAX(1D-6,MIN(1D0,X))
29602 C...Loop over flavours (with u <-> d notation mismatch).
29603 SUMUDB=PYCT5M(-1,XIN,QRT)
29604 RATUDB=PYCT5M(-2,XIN,QRT)
29607 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
29608 ELSEIF(I.EQ.2) THEN
29609 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
29610 ELSEIF(I.EQ.-1) THEN
29611 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
29612 ELSEIF(I.EQ.-2) THEN
29613 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
29615 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
29616 IF(I.LT.0) XPPR(-I)=XPPR(I)
29620 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
29621 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
29622 C...obsolete but offers backwards compatibility.
29623 CALL PYPDPO(X,Q2L,XPPR)
29625 C...Symmetric choice for debugging only
29626 ELSEIF(NSET.EQ.16) THEN
29644 C*********************************************************************
29647 C...Gives the CTEQ 3 parton distribution function sets in
29648 C...parametrized form, of October 24, 1994.
29649 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
29650 C...J. Qiu, W.K. Tung and H. Weerts.
29652 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
29654 C...Double precision declaration.
29655 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29656 IMPLICIT INTEGER(I-N)
29658 C...Data on Lambda values of fits, minimum Q and quark masses.
29659 DIMENSION ALM(3), QMS(4:6)
29660 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
29661 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
29663 C....Check flavour thresholds. Set up QI for SB.
29666 IF(Q .LE. QMS(IP)) THEN
29675 C...Use "standard lambda" of parametrization program for expansion.
29677 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
29682 C...Expansion for CTEQ3L.
29683 IF(ISET .EQ. 1) THEN
29684 IF(IPRT .EQ. 2) THEN
29685 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
29687 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
29688 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
29689 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
29690 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
29691 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
29692 ELSEIF(IPRT .EQ. 1) THEN
29693 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
29695 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
29696 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
29697 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
29698 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
29699 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
29700 ELSEIF(IPRT .EQ. 0) THEN
29701 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
29703 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
29704 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
29705 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
29706 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
29707 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
29708 ELSEIF(IPRT .EQ. -1) THEN
29709 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
29711 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
29712 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
29713 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
29714 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
29715 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
29716 ELSEIF(IPRT .EQ. -2) THEN
29717 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
29719 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
29720 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
29721 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
29722 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
29723 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
29724 ELSEIF(IPRT .EQ. -3) THEN
29725 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
29727 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
29728 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
29729 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
29730 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
29731 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
29732 ELSEIF(IPRT .EQ. -4) THEN
29733 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
29735 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
29736 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
29737 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
29738 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
29739 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
29740 ELSEIF(IPRT .EQ. -5) THEN
29741 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
29743 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
29744 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
29745 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
29746 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
29747 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
29748 ELSEIF(IPRT .EQ. -6) THEN
29749 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
29751 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
29752 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
29753 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
29754 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
29755 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
29758 C...Expansion for CTEQ3M.
29759 ELSEIF(ISET .EQ. 2) THEN
29760 IF(IPRT .EQ. 2) THEN
29761 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
29763 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
29764 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
29765 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
29766 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
29767 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
29768 ELSEIF(IPRT .EQ. 1) THEN
29769 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
29771 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
29772 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
29773 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
29774 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
29775 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
29776 ELSEIF(IPRT .EQ. 0) THEN
29777 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
29779 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
29780 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
29781 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
29782 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
29783 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
29784 ELSEIF(IPRT .EQ. -1) THEN
29785 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
29787 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
29788 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
29789 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
29790 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
29791 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
29792 ELSEIF(IPRT .EQ. -2) THEN
29793 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
29795 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
29796 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
29797 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
29798 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
29799 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
29800 ELSEIF(IPRT .EQ. -3) THEN
29801 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
29803 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
29804 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
29805 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
29806 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
29807 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
29808 ELSEIF(IPRT .EQ. -4) THEN
29809 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
29811 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
29812 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
29813 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
29814 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
29815 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
29816 ELSEIF(IPRT .EQ. -5) THEN
29817 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
29819 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
29820 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
29821 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
29822 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
29823 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
29824 ELSEIF(IPRT .EQ. -6) THEN
29825 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
29827 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
29828 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
29829 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
29830 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
29831 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
29834 C...Expansion for CTEQ3D.
29835 ELSEIF(ISET .EQ. 3) THEN
29836 IF(IPRT .EQ. 2) THEN
29837 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
29839 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
29840 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
29841 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
29842 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
29843 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
29844 ELSEIF(IPRT .EQ. 1) THEN
29845 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
29847 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
29848 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
29849 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
29850 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
29851 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
29852 ELSEIF(IPRT .EQ. 0) THEN
29853 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
29855 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
29856 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
29857 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
29858 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
29859 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
29860 ELSEIF(IPRT .EQ. -1) THEN
29861 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
29863 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
29864 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
29865 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
29866 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
29867 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
29868 ELSEIF(IPRT .EQ. -2) THEN
29869 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
29871 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
29872 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
29873 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
29874 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
29875 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
29876 ELSEIF(IPRT .EQ. -3) THEN
29877 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
29879 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
29880 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
29881 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
29882 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
29883 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
29884 ELSEIF(IPRT .EQ. -4) THEN
29885 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
29887 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
29888 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
29889 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
29890 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
29891 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
29892 ELSEIF(IPRT .EQ. -5) THEN
29893 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
29895 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
29896 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
29897 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
29898 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
29899 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
29900 ELSEIF(IPRT .EQ. -6) THEN
29901 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
29903 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
29904 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
29905 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
29906 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
29907 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
29911 C...Calculation of x * f(x, Q).
29912 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
29913 & *(LOG(1D0+1D0/X))**A5 )
29918 C*********************************************************************
29921 C...Gives the GRV 94 L (leading order) parton distribution function set
29922 C...in parametrized form.
29923 C...Authors: M. Glueck, E. Reya and A. Vogt.
29925 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29927 C...Double precision declaration.
29928 IMPLICIT DOUBLE PRECISION (A - Z)
29930 C...Common expressions.
29932 LAM2 = 0.2322D0 * 0.2322D0
29933 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
29939 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
29940 AKU = 0.590D0 - 0.024D0 * S
29941 BKU = 0.131D0 + 0.063D0 * S
29942 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
29943 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
29944 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
29945 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
29946 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
29949 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
29951 BKD = 0.486D0 + 0.062D0 * S
29952 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
29953 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
29954 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
29955 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
29956 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
29959 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
29960 AKE = 0.409D0 - 0.005D0 * S
29961 BKE = 0.799D0 + 0.071D0 * S
29962 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
29963 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
29965 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
29966 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
29971 AKX = 0.410D0 - 0.232D0 * S
29972 BKX = 0.534D0 - 0.457D0 * S
29973 AGX = 0.890D0 - 0.140D0 * S
29975 CX = 0.320D0 + 0.683D0 * S
29976 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
29977 EX = 4.119D0 + 1.713D0 * S
29978 ESX = 0.682D0 + 2.978D0 * S
29979 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
29986 AKS = 1.798D0 - 0.596D0 * S
29987 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
29988 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
29989 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
29990 EST = 3.981D0 + 1.638D0 * S
29992 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
30000 BC = 4.24D0 - 0.804D0 * S
30001 DCT = 3.46D0 - 1.076D0 * S
30002 ECT = 4.61D0 + 1.49D0 * S
30003 ESC = 2.555D0 + 1.961D0 * S
30004 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
30013 DBT = 2.929D0 + 1.396D0 * S
30014 EBT = 4.71D0 + 1.514D0 * S
30015 ESB = 4.02D0 + 1.239D0 * S
30016 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
30021 AKG = 1.742D0 - 0.930D0 * S
30022 BKG = - 0.399D0 * S2
30023 AG = 7.486D0 - 2.185D0 * S
30024 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
30025 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
30026 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
30027 EG = 0.807D0 + 2.005D0 * S
30028 ESG = 3.841D0 + 0.316D0 * S
30029 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
30035 C*********************************************************************
30038 C...Gives the GRV 94 M (MSbar) parton distribution function set
30039 C...in parametrized form.
30040 C...Authors: M. Glueck, E. Reya and A. Vogt.
30042 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
30044 C...Double precision declaration.
30045 IMPLICIT DOUBLE PRECISION (A - Z)
30047 C...Common expressions.
30049 LAM2 = 0.248D0 * 0.248D0
30050 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
30056 NU = 1.304D0 + 0.863D0 * S
30057 AKU = 0.558D0 - 0.020D0 * S
30059 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
30060 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
30061 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
30062 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
30063 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
30066 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
30067 AKD = 0.270D0 - 0.019D0 * S
30069 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
30070 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
30071 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
30072 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
30073 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
30076 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
30077 AKE = 0.409D0 - 0.007D0 * S
30078 BKE = 0.782D0 + 0.082D0 * S
30079 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
30080 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
30082 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
30083 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
30091 BGX = 3.210D0 - 1.866D0 * S
30093 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
30094 EX = 3.077D0 + 1.446D0 * S
30095 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
30096 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
30103 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
30104 AS = -4.329D0 + 1.131D0 * S
30105 BS = 9.568D0 - 1.744D0 * S
30106 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
30107 EST = 3.031D0 + 1.639D0 * S
30108 ESS = 5.837D0 + 0.815D0 * S
30109 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
30115 AKC = -0.625D0 - 0.523D0 * S
30117 BC = 1.896D0 + 1.616D0 * S
30118 DCT = 4.12D0 + 0.683D0 * S
30119 ECT = 4.36D0 + 1.328D0 * S
30120 ESC = 0.677D0 + 0.679D0 * S
30121 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
30127 AKB = - 0.193D0 * S
30130 DBT = 3.447D0 + 0.927D0 * S
30131 EBT = 4.68D0 + 1.259D0 * S
30132 ESB = 1.892D0 + 2.199D0 * S
30133 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
30138 AKG = 1.724D0 + 0.157D0 * S
30139 BKG = 0.800D0 + 1.016D0 * S
30140 AG = 7.517D0 - 2.547D0 * S
30141 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
30142 CG = 4.039D0 + 1.491D0 * S
30143 DG = 3.404D0 + 0.830D0 * S
30144 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
30145 ESG = 3.256D0 - 0.436D0 * S
30146 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
30151 C*********************************************************************
30154 C...Gives the GRV 94 D (DIS) parton distribution function set
30155 C...in parametrized form.
30156 C...Authors: M. Glueck, E. Reya and A. Vogt.
30158 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
30160 C...Double precision declaration.
30161 IMPLICIT DOUBLE PRECISION (A - Z)
30163 C...Common expressions.
30165 LAM2 = 0.248D0 * 0.248D0
30166 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
30172 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
30173 AKU = 0.563D0 - 0.025D0 * S
30174 BKU = 0.054D0 + 0.154D0 * S
30175 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
30176 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
30177 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
30178 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
30179 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
30182 ND = 0.156D0 - 0.017D0 * S
30183 AKD = 0.299D0 - 0.022D0 * S
30184 BKD = 0.259D0 - 0.015D0 * S
30185 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
30186 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
30187 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
30188 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
30189 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
30192 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
30193 AKE = 0.419D0 - 0.013D0 * S
30194 BKE = 1.064D0 - 0.038D0 * S
30195 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
30196 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
30197 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
30198 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
30199 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
30204 AKX = 0.326D0 + 0.150D0 * S
30205 BKX = 0.956D0 + 0.405D0 * S
30207 BGX = 3.794D0 - 2.359D0 * DS
30209 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
30210 EX = 3.049D0 + 1.597D0 * S
30211 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
30212 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
30219 AKS = 1.415D0 - 0.641D0 * DS
30220 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
30221 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
30222 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
30223 EST = 4.546D0 + 0.372D0 * S2
30224 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
30225 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
30231 AKC = -0.625D0 - 0.523D0 * S
30233 BC = 1.896D0 + 1.616D0 * S
30234 DCT = 4.12D0 + 0.683D0 * S
30235 ECT = 4.36D0 + 1.328D0 * S
30236 ESC = 0.677D0 + 0.679D0 * S
30237 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
30243 AKB = - 0.193D0 * S
30246 DBT = 3.447D0 + 0.927D0 * S
30247 EBT = 4.68D0 + 1.259D0 * S
30248 ESB = 1.892D0 + 2.199D0 * S
30249 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
30255 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
30256 AG = 25.09D0 - 7.935D0 * S
30257 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
30258 CG = 590.3D0 - 173.8D0 * S
30259 DG = 5.196D0 + 1.857D0 * S
30260 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
30261 ESG = 3.232D0 - 0.542D0 * S
30262 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
30267 C*********************************************************************
30270 C...Auxiliary for the GRV 94 parton distribution functions
30271 C...for u and d valence and d-u sea.
30272 C...Authors: M. Glueck, E. Reya and A. Vogt.
30274 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
30276 C...Double precision declaration.
30277 IMPLICIT DOUBLE PRECISION (A - Z)
30281 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
30287 C*********************************************************************
30290 C...Auxiliary for the GRV 94 parton distribution functions
30291 C...for d+u sea and gluon.
30292 C...Authors: M. Glueck, E. Reya and A. Vogt.
30294 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
30296 C...Double precision declaration.
30297 IMPLICIT DOUBLE PRECISION (A - Z)
30301 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
30302 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
30307 C*********************************************************************
30310 C...Auxiliary for the GRV 94 parton distribution functions
30311 C...for s, c and b sea.
30312 C...Authors: M. Glueck, E. Reya and A. Vogt.
30314 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
30316 C...Double precision declaration.
30317 IMPLICIT DOUBLE PRECISION (A - Z)
30325 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
30326 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
30332 C*********************************************************************
30335 C...Auxiliary function for parametrization of CTEQ5L.
30336 C...Author: J. Pumplin 9/99.
30338 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
30339 C...in Parametrized Form
30340 C... September 15, 1999
30342 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
30343 C... CTEQ5 PPARTON DISTRIBUTIONS"
30346 C...The CTEQ5M1 set given here is an updated version of the original
30347 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
30348 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
30349 C...almost all applications.
30350 C...The improvement is in the QCD evolution which is now more
30351 C...accurate, and which agrees completely with the benchmark work
30352 C...of the HERA 96/97 Workshop.
30353 C...The differences between the parametrized and the corresponding
30354 C...table versions (on which it is based) are of similar order as
30355 C...between the two version.
30357 C...!! Because accurate parametrizations over a wide range of (x,Q)
30358 C...is hard to obtain, only the most widely used sets CTEQ5M and
30359 C...CTEQ5L are available in parametrized form for now.
30361 C...These parametrizations were obtained by Jon Pumplin.
30363 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
30364 C -------------------------------------------------------------------
30365 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
30366 C 3 CTEQ5L Leading Order 0.127 192 146
30367 C -------------------------------------------------------------------
30368 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
30369 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
30372 C...The two Iset value are adopted to agree with the standard table
30375 C...Range of validity:
30376 C...The range of (x, Q) covered by this parametrization of the QCD
30377 C...evolved parton distributions is 1E-6 < x < 1 ;
30378 C...1.1 GeV < Q < 10 TeV. Of course, the PDF's are constrained by
30379 C...data only in a subset of that region; and the assumed DGLAP
30380 C...evolution is unlikely to be valid for all of it either.
30382 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
30383 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
30384 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
30385 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
30387 FUNCTION PYCT5L(IFL,X,Q)
30389 C...Double precision declaration.
30390 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30391 IMPLICIT INTEGER(I-N)
30393 PARAMETER (NEX=8, NLF=2)
30394 DIMENSION AM(0:NEX,0:NLF,-5:2)
30395 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
30396 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
30397 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
30398 DIMENSION AF(0:NEX)
30400 DATA MEXVEC( 2) / 8 /
30401 DATA MLFVEC( 2) / 2 /
30402 DATA UT1VEC( 2) / 0.4971265E+01 /
30403 DATA UT2VEC( 2) / -0.1105128E+01 /
30404 DATA ALFVEC( 2) / 0.2987216E+00 /
30405 DATA QMAVEC( 2) / 0.0000000E+00 /
30406 DATA (AM( 0,K, 2),K=0, 2)
30407 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
30408 DATA (AM( 1,K, 2),K=0, 2)
30409 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
30410 DATA (AM( 2,K, 2),K=0, 2)
30411 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
30412 DATA (AM( 3,K, 2),K=0, 2)
30413 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
30414 DATA (AM( 4,K, 2),K=0, 2)
30415 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
30416 DATA (AM( 5,K, 2),K=0, 2)
30417 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
30418 DATA (AM( 6,K, 2),K=0, 2)
30419 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
30420 DATA (AM( 7,K, 2),K=0, 2)
30421 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
30422 DATA (AM( 8,K, 2),K=0, 2)
30423 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
30425 DATA MEXVEC( 1) / 8 /
30426 DATA MLFVEC( 1) / 2 /
30427 DATA UT1VEC( 1) / 0.2612618E+01 /
30428 DATA UT2VEC( 1) / -0.1258304E+06 /
30429 DATA ALFVEC( 1) / 0.3407552E+00 /
30430 DATA QMAVEC( 1) / 0.0000000E+00 /
30431 DATA (AM( 0,K, 1),K=0, 2)
30432 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
30433 DATA (AM( 1,K, 1),K=0, 2)
30434 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
30435 DATA (AM( 2,K, 1),K=0, 2)
30436 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
30437 DATA (AM( 3,K, 1),K=0, 2)
30438 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
30439 DATA (AM( 4,K, 1),K=0, 2)
30440 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
30441 DATA (AM( 5,K, 1),K=0, 2)
30442 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
30443 DATA (AM( 6,K, 1),K=0, 2)
30444 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
30445 DATA (AM( 7,K, 1),K=0, 2)
30446 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
30447 DATA (AM( 8,K, 1),K=0, 2)
30448 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
30450 DATA MEXVEC( 0) / 8 /
30451 DATA MLFVEC( 0) / 2 /
30452 DATA UT1VEC( 0) / -0.4656819E+00 /
30453 DATA UT2VEC( 0) / -0.2742390E+03 /
30454 DATA ALFVEC( 0) / 0.4491863E+00 /
30455 DATA QMAVEC( 0) / 0.0000000E+00 /
30456 DATA (AM( 0,K, 0),K=0, 2)
30457 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
30458 DATA (AM( 1,K, 0),K=0, 2)
30459 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
30460 DATA (AM( 2,K, 0),K=0, 2)
30461 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
30462 DATA (AM( 3,K, 0),K=0, 2)
30463 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
30464 DATA (AM( 4,K, 0),K=0, 2)
30465 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
30466 DATA (AM( 5,K, 0),K=0, 2)
30467 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
30468 DATA (AM( 6,K, 0),K=0, 2)
30469 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
30470 DATA (AM( 7,K, 0),K=0, 2)
30471 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
30472 DATA (AM( 8,K, 0),K=0, 2)
30473 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
30475 DATA MEXVEC(-1) / 8 /
30476 DATA MLFVEC(-1) / 2 /
30477 DATA UT1VEC(-1) / 0.3862583E+01 /
30478 DATA UT2VEC(-1) / -0.1265969E+01 /
30479 DATA ALFVEC(-1) / 0.2457668E+00 /
30480 DATA QMAVEC(-1) / 0.0000000E+00 /
30481 DATA (AM( 0,K,-1),K=0, 2)
30482 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
30483 DATA (AM( 1,K,-1),K=0, 2)
30484 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
30485 DATA (AM( 2,K,-1),K=0, 2)
30486 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
30487 DATA (AM( 3,K,-1),K=0, 2)
30488 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
30489 DATA (AM( 4,K,-1),K=0, 2)
30490 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
30491 DATA (AM( 5,K,-1),K=0, 2)
30492 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
30493 DATA (AM( 6,K,-1),K=0, 2)
30494 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
30495 DATA (AM( 7,K,-1),K=0, 2)
30496 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
30497 DATA (AM( 8,K,-1),K=0, 2)
30498 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
30500 DATA MEXVEC(-2) / 7 /
30501 DATA MLFVEC(-2) / 2 /
30502 DATA UT1VEC(-2) / 0.1895615E+00 /
30503 DATA UT2VEC(-2) / -0.3069097E+01 /
30504 DATA ALFVEC(-2) / 0.5293999E+00 /
30505 DATA QMAVEC(-2) / 0.0000000E+00 /
30506 DATA (AM( 0,K,-2),K=0, 2)
30507 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
30508 DATA (AM( 1,K,-2),K=0, 2)
30509 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
30510 DATA (AM( 2,K,-2),K=0, 2)
30511 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
30512 DATA (AM( 3,K,-2),K=0, 2)
30513 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
30514 DATA (AM( 4,K,-2),K=0, 2)
30515 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
30516 DATA (AM( 5,K,-2),K=0, 2)
30517 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
30518 DATA (AM( 6,K,-2),K=0, 2)
30519 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
30520 DATA (AM( 7,K,-2),K=0, 2)
30521 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
30523 DATA MEXVEC(-3) / 7 /
30524 DATA MLFVEC(-3) / 2 /
30525 DATA UT1VEC(-3) / 0.3753257E+01 /
30526 DATA UT2VEC(-3) / -0.1113085E+01 /
30527 DATA ALFVEC(-3) / 0.3713141E+00 /
30528 DATA QMAVEC(-3) / 0.0000000E+00 /
30529 DATA (AM( 0,K,-3),K=0, 2)
30530 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
30531 DATA (AM( 1,K,-3),K=0, 2)
30532 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
30533 DATA (AM( 2,K,-3),K=0, 2)
30534 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
30535 DATA (AM( 3,K,-3),K=0, 2)
30536 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
30537 DATA (AM( 4,K,-3),K=0, 2)
30538 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
30539 DATA (AM( 5,K,-3),K=0, 2)
30540 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
30541 DATA (AM( 6,K,-3),K=0, 2)
30542 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
30543 DATA (AM( 7,K,-3),K=0, 2)
30544 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
30546 DATA MEXVEC(-4) / 7 /
30547 DATA MLFVEC(-4) / 2 /
30548 DATA UT1VEC(-4) / 0.4400772E+01 /
30549 DATA UT2VEC(-4) / -0.1356116E+01 /
30550 DATA ALFVEC(-4) / 0.3712017E-01 /
30551 DATA QMAVEC(-4) / 0.1300000E+01 /
30552 DATA (AM( 0,K,-4),K=0, 2)
30553 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
30554 DATA (AM( 1,K,-4),K=0, 2)
30555 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
30556 DATA (AM( 2,K,-4),K=0, 2)
30557 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
30558 DATA (AM( 3,K,-4),K=0, 2)
30559 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
30560 DATA (AM( 4,K,-4),K=0, 2)
30561 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
30562 DATA (AM( 5,K,-4),K=0, 2)
30563 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
30564 DATA (AM( 6,K,-4),K=0, 2)
30565 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
30566 DATA (AM( 7,K,-4),K=0, 2)
30567 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
30569 DATA MEXVEC(-5) / 6 /
30570 DATA MLFVEC(-5) / 2 /
30571 DATA UT1VEC(-5) / 0.5562568E+01 /
30572 DATA UT2VEC(-5) / -0.1801317E+01 /
30573 DATA ALFVEC(-5) / 0.4952010E-02 /
30574 DATA QMAVEC(-5) / 0.4500000E+01 /
30575 DATA (AM( 0,K,-5),K=0, 2)
30576 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
30577 DATA (AM( 1,K,-5),K=0, 2)
30578 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
30579 DATA (AM( 2,K,-5),K=0, 2)
30580 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
30581 DATA (AM( 3,K,-5),K=0, 2)
30582 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
30583 DATA (AM( 4,K,-5),K=0, 2)
30584 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
30585 DATA (AM( 5,K,-5),K=0, 2)
30586 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
30587 DATA (AM( 6,K,-5),K=0, 2)
30588 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
30590 IF(Q .LE. QMAVEC(IFL)) THEN
30595 IF(X .GE. 1.D0) THEN
30600 TMP = LOG(Q/ALFVEC(IFL))
30601 IF(TMP .LE. 0.D0) THEN
30613 DO 100 K = 0, MLFVEC(IFL)
30614 AF(I) = AF(I) + SBX*AM(I,K,IFL)
30620 U = LOG(X/0.00001D0)
30622 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
30623 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
30624 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
30625 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
30626 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
30628 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
30630 C...Include threshold factor.
30631 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
30636 C*********************************************************************
30639 C...Auxiliary function for parametrization of CTEQ5M1.
30640 C...Author: J. Pumplin 9/99.
30642 FUNCTION PYCT5M(IFL,X,Q)
30644 C...Double precision declaration.
30645 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30646 IMPLICIT INTEGER(I-N)
30648 PARAMETER (NEX=8, NLF=2)
30649 DIMENSION AM(0:NEX,0:NLF,-5:2)
30650 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
30651 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
30652 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
30653 DIMENSION AF(0:NEX)
30655 DATA MEXVEC( 2) / 8 /
30656 DATA MLFVEC( 2) / 2 /
30657 DATA UT1VEC( 2) / 0.5141718E+01 /
30658 DATA UT2VEC( 2) / -0.1346944E+01 /
30659 DATA ALFVEC( 2) / 0.5260555E+00 /
30660 DATA QMAVEC( 2) / 0.0000000E+00 /
30661 DATA (AM( 0,K, 2),K=0, 2)
30662 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
30663 DATA (AM( 1,K, 2),K=0, 2)
30664 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
30665 DATA (AM( 2,K, 2),K=0, 2)
30666 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
30667 DATA (AM( 3,K, 2),K=0, 2)
30668 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
30669 DATA (AM( 4,K, 2),K=0, 2)
30670 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
30671 DATA (AM( 5,K, 2),K=0, 2)
30672 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
30673 DATA (AM( 6,K, 2),K=0, 2)
30674 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
30675 DATA (AM( 7,K, 2),K=0, 2)
30676 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
30677 DATA (AM( 8,K, 2),K=0, 2)
30678 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
30680 DATA MEXVEC( 1) / 8 /
30681 DATA MLFVEC( 1) / 2 /
30682 DATA UT1VEC( 1) / 0.4138426E+01 /
30683 DATA UT2VEC( 1) / -0.3221374E+01 /
30684 DATA ALFVEC( 1) / 0.4960962E+00 /
30685 DATA QMAVEC( 1) / 0.0000000E+00 /
30686 DATA (AM( 0,K, 1),K=0, 2)
30687 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
30688 DATA (AM( 1,K, 1),K=0, 2)
30689 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
30690 DATA (AM( 2,K, 1),K=0, 2)
30691 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
30692 DATA (AM( 3,K, 1),K=0, 2)
30693 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
30694 DATA (AM( 4,K, 1),K=0, 2)
30695 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
30696 DATA (AM( 5,K, 1),K=0, 2)
30697 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
30698 DATA (AM( 6,K, 1),K=0, 2)
30699 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
30700 DATA (AM( 7,K, 1),K=0, 2)
30701 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
30702 DATA (AM( 8,K, 1),K=0, 2)
30703 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
30705 DATA MEXVEC( 0) / 8 /
30706 DATA MLFVEC( 0) / 2 /
30707 DATA UT1VEC( 0) / -0.1026789E+01 /
30708 DATA UT2VEC( 0) / -0.9051707E+01 /
30709 DATA ALFVEC( 0) / 0.9462977E+00 /
30710 DATA QMAVEC( 0) / 0.0000000E+00 /
30711 DATA (AM( 0,K, 0),K=0, 2)
30712 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
30713 DATA (AM( 1,K, 0),K=0, 2)
30714 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
30715 DATA (AM( 2,K, 0),K=0, 2)
30716 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
30717 DATA (AM( 3,K, 0),K=0, 2)
30718 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
30719 DATA (AM( 4,K, 0),K=0, 2)
30720 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
30721 DATA (AM( 5,K, 0),K=0, 2)
30722 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
30723 DATA (AM( 6,K, 0),K=0, 2)
30724 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
30725 DATA (AM( 7,K, 0),K=0, 2)
30726 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
30727 DATA (AM( 8,K, 0),K=0, 2)
30728 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
30730 DATA MEXVEC(-1) / 8 /
30731 DATA MLFVEC(-1) / 2 /
30732 DATA UT1VEC(-1) / 0.5243571E+01 /
30733 DATA UT2VEC(-1) / -0.2870513E+01 /
30734 DATA ALFVEC(-1) / 0.6701448E+00 /
30735 DATA QMAVEC(-1) / 0.0000000E+00 /
30736 DATA (AM( 0,K,-1),K=0, 2)
30737 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
30738 DATA (AM( 1,K,-1),K=0, 2)
30739 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
30740 DATA (AM( 2,K,-1),K=0, 2)
30741 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
30742 DATA (AM( 3,K,-1),K=0, 2)
30743 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
30744 DATA (AM( 4,K,-1),K=0, 2)
30745 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
30746 DATA (AM( 5,K,-1),K=0, 2)
30747 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
30748 DATA (AM( 6,K,-1),K=0, 2)
30749 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
30750 DATA (AM( 7,K,-1),K=0, 2)
30751 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
30752 DATA (AM( 8,K,-1),K=0, 2)
30753 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
30755 DATA MEXVEC(-2) / 7 /
30756 DATA MLFVEC(-2) / 2 /
30757 DATA UT1VEC(-2) / 0.4782210E+01 /
30758 DATA UT2VEC(-2) / -0.1976856E+02 /
30759 DATA ALFVEC(-2) / 0.7558374E+00 /
30760 DATA QMAVEC(-2) / 0.0000000E+00 /
30761 DATA (AM( 0,K,-2),K=0, 2)
30762 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
30763 DATA (AM( 1,K,-2),K=0, 2)
30764 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
30765 DATA (AM( 2,K,-2),K=0, 2)
30766 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
30767 DATA (AM( 3,K,-2),K=0, 2)
30768 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
30769 DATA (AM( 4,K,-2),K=0, 2)
30770 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
30771 DATA (AM( 5,K,-2),K=0, 2)
30772 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
30773 DATA (AM( 6,K,-2),K=0, 2)
30774 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
30775 DATA (AM( 7,K,-2),K=0, 2)
30776 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
30778 DATA MEXVEC(-3) / 7 /
30779 DATA MLFVEC(-3) / 2 /
30780 DATA UT1VEC(-3) / 0.4518239E+01 /
30781 DATA UT2VEC(-3) / -0.2690590E+01 /
30782 DATA ALFVEC(-3) / 0.6124079E+00 /
30783 DATA QMAVEC(-3) / 0.0000000E+00 /
30784 DATA (AM( 0,K,-3),K=0, 2)
30785 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
30786 DATA (AM( 1,K,-3),K=0, 2)
30787 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
30788 DATA (AM( 2,K,-3),K=0, 2)
30789 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
30790 DATA (AM( 3,K,-3),K=0, 2)
30791 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
30792 DATA (AM( 4,K,-3),K=0, 2)
30793 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
30794 DATA (AM( 5,K,-3),K=0, 2)
30795 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
30796 DATA (AM( 6,K,-3),K=0, 2)
30797 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
30798 DATA (AM( 7,K,-3),K=0, 2)
30799 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
30801 DATA MEXVEC(-4) / 7 /
30802 DATA MLFVEC(-4) / 2 /
30803 DATA UT1VEC(-4) / 0.2783230E+01 /
30804 DATA UT2VEC(-4) / -0.1746328E+01 /
30805 DATA ALFVEC(-4) / 0.1115653E+01 /
30806 DATA QMAVEC(-4) / 0.1300000E+01 /
30807 DATA (AM( 0,K,-4),K=0, 2)
30808 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
30809 DATA (AM( 1,K,-4),K=0, 2)
30810 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
30811 DATA (AM( 2,K,-4),K=0, 2)
30812 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
30813 DATA (AM( 3,K,-4),K=0, 2)
30814 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
30815 DATA (AM( 4,K,-4),K=0, 2)
30816 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
30817 DATA (AM( 5,K,-4),K=0, 2)
30818 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
30819 DATA (AM( 6,K,-4),K=0, 2)
30820 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
30821 DATA (AM( 7,K,-4),K=0, 2)
30822 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
30824 DATA MEXVEC(-5) / 6 /
30825 DATA MLFVEC(-5) / 2 /
30826 DATA UT1VEC(-5) / 0.1619654E+02 /
30827 DATA UT2VEC(-5) / -0.3367346E+01 /
30828 DATA ALFVEC(-5) / 0.5109891E-02 /
30829 DATA QMAVEC(-5) / 0.4500000E+01 /
30830 DATA (AM( 0,K,-5),K=0, 2)
30831 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
30832 DATA (AM( 1,K,-5),K=0, 2)
30833 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
30834 DATA (AM( 2,K,-5),K=0, 2)
30835 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
30836 DATA (AM( 3,K,-5),K=0, 2)
30837 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
30838 DATA (AM( 4,K,-5),K=0, 2)
30839 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
30840 DATA (AM( 5,K,-5),K=0, 2)
30841 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
30842 DATA (AM( 6,K,-5),K=0, 2)
30843 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
30845 IF(Q .LE. QMAVEC(IFL)) THEN
30850 IF(X .GE. 1.D0) THEN
30855 TMP = LOG(Q/ALFVEC(IFL))
30856 IF(TMP .LE. 0.D0) THEN
30868 DO 100 K = 0, MLFVEC(IFL)
30869 AF(I) = AF(I) + SBX*AM(I,K,IFL)
30875 U = LOG(X/0.00001D0)
30877 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
30878 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
30879 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
30880 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
30881 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
30883 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
30885 C...Include threshold factor.
30886 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
30891 C*********************************************************************
30894 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
30895 C...a few older parametrizations, now obsolete but convenient for
30896 C...backwards checks.
30898 SUBROUTINE PYPDPO(X,Q2,XPPR)
30900 C...Double precision and integer declarations.
30901 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30902 IMPLICIT INTEGER(I-N)
30903 INTEGER PYK,PYCHGE,PYCOMP
30905 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30906 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30907 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30908 COMMON/PYINT1/MINT(400),VINT(400)
30909 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
30910 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
30911 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
30914 C...The following data lines are coefficients needed in the
30915 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
30916 C...parametrizations, see below.
30917 C...Powers of 1-x in different cases.
30918 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
30919 C...Expansion coefficients for up valence quark distribution.
30920 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
30921 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
30922 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
30923 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
30924 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
30925 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
30926 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
30927 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
30928 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
30929 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
30930 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
30931 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
30932 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
30933 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
30934 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
30935 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
30936 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
30937 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
30938 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
30939 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
30940 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
30941 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
30942 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
30943 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
30944 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
30945 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
30946 C...Expansion coefficients for down valence quark distribution.
30947 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
30948 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
30949 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
30950 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
30951 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
30952 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
30953 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
30954 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
30955 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
30956 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
30957 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
30958 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
30959 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
30960 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
30961 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
30962 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
30963 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
30964 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
30965 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
30966 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
30967 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
30968 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
30969 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
30970 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
30971 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
30972 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
30973 C...Expansion coefficients for up and down sea quark distributions.
30974 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
30975 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
30976 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
30977 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
30978 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
30979 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
30980 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
30981 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
30982 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
30983 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
30984 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
30985 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
30986 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
30987 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
30988 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
30989 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
30990 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
30991 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
30992 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
30993 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
30994 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
30995 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
30996 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
30997 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
30998 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
30999 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
31000 C...Expansion coefficients for gluon distribution.
31001 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
31002 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
31003 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
31004 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
31005 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
31006 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
31007 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
31008 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
31009 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
31010 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
31011 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
31012 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
31013 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
31014 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
31015 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
31016 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
31017 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
31018 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
31019 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
31020 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
31021 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
31022 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
31023 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
31024 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
31025 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
31026 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
31027 C...Expansion coefficients for strange sea quark distribution.
31028 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
31029 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
31030 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
31031 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
31032 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
31033 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
31034 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
31035 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
31036 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
31037 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
31038 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
31039 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
31040 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
31041 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
31042 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
31043 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
31044 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
31045 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
31046 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
31047 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
31048 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
31049 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
31050 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
31051 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
31052 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
31053 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
31054 C...Expansion coefficients for charm sea quark distribution.
31055 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
31056 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
31057 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
31058 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
31059 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
31060 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
31061 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
31062 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
31063 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
31064 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
31065 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
31066 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
31067 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
31068 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
31069 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
31070 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
31071 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
31072 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
31073 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
31074 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
31075 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
31076 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
31077 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
31078 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
31079 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
31080 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
31081 C...Expansion coefficients for bottom sea quark distribution.
31082 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
31083 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
31084 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
31085 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
31086 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
31087 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
31088 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
31089 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
31090 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
31091 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
31092 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
31093 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
31094 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
31095 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
31096 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
31097 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
31098 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
31099 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
31100 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
31101 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
31102 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
31103 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
31104 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
31105 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
31106 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
31107 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
31108 C...Expansion coefficients for top sea quark distribution.
31109 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
31110 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
31111 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
31112 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
31113 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
31114 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
31115 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
31116 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
31117 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
31118 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
31119 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
31120 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
31121 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
31122 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
31123 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
31124 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
31125 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
31126 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
31127 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
31128 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
31129 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
31130 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
31131 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
31132 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
31133 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
31134 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
31136 C...The following data lines are coefficients needed in the
31137 C...Duke, Owens proton structure function parametrizations, see below.
31138 C...Expansion coefficients for (up+down) valence quark distribution.
31139 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
31140 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31141 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31142 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
31143 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
31144 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31145 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31146 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
31147 C...Expansion coefficients for down valence quark distribution.
31148 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
31149 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31150 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
31151 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
31152 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
31153 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31154 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
31155 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
31156 C...Expansion coefficients for (up+down+strange) sea quark distribution.
31157 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
31158 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31159 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
31160 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
31161 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
31162 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31163 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
31164 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
31165 C...Expansion coefficients for charm sea quark distribution.
31166 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
31167 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31168 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
31169 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
31170 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
31171 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31172 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
31173 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
31174 C...Expansion coefficients for gluon distribution.
31175 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
31176 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
31177 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
31178 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
31179 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
31180 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
31181 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
31182 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
31184 C...Euler's beta function, requires ordinary Gamma function
31185 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
31187 C...Leading order proton parton distributions from Glueck, Reya and
31188 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
31190 IF(MSTP(51).EQ.11) THEN
31192 C...Determine s expansion variable and some x expressions.
31193 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
31194 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
31199 C...Evaluate valence, gluon and sea distributions.
31200 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
31201 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
31202 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
31203 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
31204 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
31205 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
31206 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
31207 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
31208 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
31209 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
31210 & SQRT(4.066D0*SD**1.218D0*XL)))*
31211 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
31212 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
31213 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
31214 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
31215 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
31216 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
31217 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
31218 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
31219 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
31220 IF(SD.LE.0.888D0) THEN
31223 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
31224 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
31225 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
31227 IF(SD.LE.1.351D0) THEN
31230 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
31231 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
31232 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
31235 C...Put into output array.
31237 XPPR(1)=XFVDD+XFSEA
31238 XPPR(2)=XFVUD-XFVDD+XFSEA
31248 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
31249 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
31250 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
31252 C...Determine set, Lambda and x and t expansion variables.
31254 IF(NSET.EQ.1) ALAM=0.2D0
31255 IF(NSET.EQ.2) ALAM=0.29D0
31256 TMIN=LOG(5D0/ALAM**2)
31257 TMAX=LOG(1D8/ALAM**2)
31258 T=LOG(MAX(1D0,Q2/ALAM**2))
31259 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
31261 IF(X.LE.0.1D0) NX=2
31262 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
31263 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
31265 C...Chebyshev polynomials for x and t expansion.
31268 TX(3)=2D0*VX**2-1D0
31269 TX(4)=4D0*VX**3-3D0*VX
31270 TX(5)=8D0*VX**4-8D0*VX**2+1D0
31271 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
31274 TT(3)=2D0*VT**2-1D0
31275 TT(4)=4D0*VT**3-3D0*VT
31276 TT(5)=8D0*VT**4-8D0*VT**2+1D0
31277 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
31279 C...Calculate structure functions.
31284 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
31287 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
31290 C...Put into output array.
31292 XPPR(1)=XQ(2)+XQ(3)
31293 XPPR(2)=XQ(1)+XQ(3)
31301 C...Special expansion for bottom (threshold effects).
31302 IF(MSTP(58).GE.5) THEN
31303 IF(NSET.EQ.1) TMIN=8.1905D0
31304 IF(NSET.EQ.2) TMIN=7.4474D0
31306 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
31309 TT(3)=2D0*VT**2-1D0
31310 TT(4)=4D0*VT**3-3D0*VT
31311 TT(5)=8D0*VT**4-8D0*VT**2+1D0
31312 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
31316 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
31319 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
31324 C...Special expansion for top (threshold effects).
31325 IF(MSTP(58).GE.6) THEN
31326 IF(NSET.EQ.1) TMIN=11.5528D0
31327 IF(NSET.EQ.2) TMIN=10.8097D0
31328 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
31329 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
31331 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
31334 TT(3)=2D0*VT**2-1D0
31335 TT(4)=4D0*VT**3-3D0*VT
31336 TT(5)=8D0*VT**4-8D0*VT**2+1D0
31337 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
31341 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
31344 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
31349 C...Proton parton distributions from Duke, Owens.
31350 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
31351 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
31353 C...Determine set, Lambda and s expansion parameter.
31355 IF(NSET.EQ.1) ALAM=0.2D0
31356 IF(NSET.EQ.2) ALAM=0.4D0
31357 Q2IN=MIN(1D6,MAX(4D0,Q2))
31358 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
31360 C...Calculate structure functions.
31363 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
31364 & CDO(3,IS,KFL,NSET)*SD**2
31367 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
31368 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
31370 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
31371 & TS(5)*X**2+TS(6)*X**3)
31375 C...Put into output arrays.
31377 XPPR(1)=XQ(2)+XQ(3)/6D0
31378 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
31391 C*********************************************************************
31394 C...Gives threshold attractive/repulsive factor for heavy flavour
31397 FUNCTION PYHFTH(SH,SQM,FRATT)
31399 C...Double precision and integer declarations.
31400 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31401 IMPLICIT INTEGER(I-N)
31402 INTEGER PYK,PYCHGE,PYCOMP
31404 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31405 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31406 COMMON/PYINT1/MINT(400),VINT(400)
31407 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
31409 C...Value for alpha_strong.
31410 IF(MSTP(35).LE.1) THEN
31415 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
31421 C...Evaluate attractive and repulsive factors.
31422 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
31423 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
31424 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
31425 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
31426 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
31432 C*********************************************************************
31435 C...Splits a hadron remnant into two (partons or hadron + parton)
31436 C...in case it is more complicated than just a quark or a diquark.
31438 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
31440 C...Double precision and integer declarations.
31441 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31442 IMPLICIT INTEGER(I-N)
31443 INTEGER PYK,PYCHGE,PYCOMP
31444 C...Commonblocks. PYDAT1 temporary
31445 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31446 COMMON/PYINT1/MINT(400),VINT(400)
31447 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31448 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
31452 C...Preliminaries. Parton composition.
31455 KFL(1)=MOD(KFA/1000,10)
31456 KFL(2)=MOD(KFA/100,10)
31457 KFL(3)=MOD(KFA/10,10)
31458 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
31459 KFL(2)=INT(1.5D0+PYR(0))
31460 IF(MINT(105).EQ.333) KFL(2)=3
31461 IF(MINT(105).EQ.443) KFL(2)=4
31463 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
31466 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
31469 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
31470 KFL(2)=MOD(KFA/10,10)
31471 KFL(3)=MOD(KFA/100,10)
31473 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
31480 C...Subdivide lepton.
31481 IF(KFA.GE.11.AND.KFA.LE.18) THEN
31482 IF(KFLR.EQ.KFA) THEN
31484 ELSEIF(KFLR.EQ.22) THEN
31486 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
31488 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
31490 ELSEIF(KFLR.EQ.21) THEN
31498 C...Subdivide photon.
31499 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
31500 IF(KFLR.NE.21) THEN
31505 IF(RAGR.GT.0.125D0) KFLSP=2
31506 IF(RAGR.GT.0.625D0) KFLSP=3
31507 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
31511 C...Subdivide Reggeon or Pomeron.
31512 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
31513 IF(KFLIN.EQ.21) THEN
31519 C...Subdivide meson.
31520 ELSEIF(KFL(1).EQ.0) THEN
31521 KFL(2)=KFL(2)*(-1)**KFL(2)
31522 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
31523 IF(KFLR.EQ.KFL(2)) THEN
31525 ELSEIF(KFLR.EQ.KFL(3)) THEN
31527 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
31530 ELSEIF(KFLR.EQ.21) THEN
31533 ELSEIF(KFLR*KFL(2).GT.0) THEN
31536 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
31537 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31539 ELSEIF(KFLCH.EQ.0) THEN
31540 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31548 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
31549 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31551 ELSEIF(KFLCH.EQ.0) THEN
31552 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31559 C...Subdivide baryon.
31563 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
31566 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
31569 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
31570 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
31573 IAGR=1.00001D0+2.99998D0*PYR(0)
31576 IF(IAGR.EQ.1) ID1=2
31577 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
31580 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
31581 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
31582 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
31583 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
31584 ELSEIF(MOD(KFA,10).EQ.2) THEN
31585 IF(IAGR.EQ.1) KSP=1
31586 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
31588 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
31589 IF(KFLR.EQ.21) THEN
31591 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
31594 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
31595 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31597 ELSEIF(KFLCH.EQ.0) THEN
31598 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31602 ELSEIF(NAGR.EQ.0) THEN
31605 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
31606 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31608 ELSEIF(KFLCH.EQ.0) THEN
31609 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31617 C...Add on correct sign for result.
31624 C*********************************************************************
31627 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
31628 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
31629 C...(Dover, 1965) 6.1.36.
31633 C...Double precision and integer declarations.
31634 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31635 IMPLICIT INTEGER(I-N)
31636 INTEGER PYK,PYCHGE,PYCOMP
31637 C...Local array and data.
31639 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
31640 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
31649 PYGAMM=PYGAMM+B(I)*DXP
31655 PYGAMM=(X-IX)*PYGAMM
31662 C***********************************************************************
31665 C...Calculates real and imaginary parts of the auxiliary functions W1
31666 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
31667 C...der Bij, Nucl. Phys. B297 (1988) 221.
31669 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
31671 C...Double precision and integer declarations.
31672 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31673 IMPLICIT INTEGER(I-N)
31674 INTEGER PYK,PYCHGE,PYCOMP
31676 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31679 ASINH(X)=LOG(X+SQRT(X**2+1D0))
31680 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
31682 IF(EPS.LT.0D0) THEN
31683 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
31684 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
31686 ELSEIF(EPS.LT.1D0) THEN
31687 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
31688 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
31689 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
31690 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
31692 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
31693 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
31700 C***********************************************************************
31703 C...Calculates real and imaginary parts of the auxiliary function I3;
31704 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
31705 C...Nucl. Phys. B297 (1988) 221.
31707 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
31709 C...Double precision and integer declarations.
31710 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31711 IMPLICIT INTEGER(I-N)
31712 INTEGER PYK,PYCHGE,PYCOMP
31714 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31717 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
31718 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
31720 IF(EPS.LT.0D0) THEN
31721 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31722 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
31723 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
31724 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
31725 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
31726 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
31727 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
31728 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
31730 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
31731 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
31732 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
31733 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
31734 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
31735 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
31736 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
31737 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
31738 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31739 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
31740 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
31741 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
31742 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
31743 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
31744 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
31745 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
31747 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
31748 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
31749 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
31750 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
31751 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
31754 ELSEIF(EPS.LT.1D0) THEN
31755 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31756 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
31757 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
31758 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
31759 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
31760 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
31761 & (0.25D0*(RAT+1D0)*EPS))
31762 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
31763 & (0.25D0*(RAT+1D0)*EPS))
31764 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
31765 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
31766 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
31767 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
31768 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
31769 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
31770 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
31771 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
31772 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31773 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
31774 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
31775 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
31776 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
31777 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
31778 & (1D0+0.25D0*RAT*EPS-GA))
31779 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
31780 & (1D0+0.25D0*RAT*EPS-GA))
31782 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
31783 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
31784 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
31785 & LOG((GA+BE-1D0)/(BE-GA))
31786 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
31789 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
31790 RCTHE=RSQ*(1D0-2D0*BE/EPS)
31791 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
31792 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
31793 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
31795 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
31796 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
31797 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
31798 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
31799 & (PHI-THE)*(PHI+THE-PARU(1))
31800 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
31801 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
31804 Y3RE=2D0/(2D0*BE-1D0)*F3RE
31805 Y3IM=2D0/(2D0*BE-1D0)*F3IM
31810 C***********************************************************************
31813 C...Calculates real and imaginary part of Spence function; see
31814 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
31816 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
31818 C...Double precision and integer declarations.
31819 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31820 IMPLICIT INTEGER(I-N)
31821 INTEGER PYK,PYCHGE,PYCOMP
31823 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31825 C...Local array and data.
31828 &1.000000D+00, -5.000000D-01, 1.666667D-01,
31829 &0.000000D+00, -3.333333D-02, 0.000000D+00,
31830 &2.380952D-02, 0.000000D+00, -3.333333D-02,
31831 &0.000000D+00, 7.575757D-02, 0.000000D+00,
31832 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
31836 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
31837 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
31838 IF(IREIM.EQ.2) PYSPEN=0D0
31842 XMOD=SQRT(XRE**2+XIM**2)
31843 IF(XMOD.LT.1D-6) THEN
31844 IF(IREIM.EQ.1) PYSPEN=0D0
31845 IF(IREIM.EQ.2) PYSPEN=0D0
31849 XARG=SIGN(ACOS(XRE/XMOD),XIM)
31853 IF(XMOD.GT.1D0) THEN
31855 ALGXIM=XARG-SIGN(PARU(1),XARG)
31856 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
31857 SP0IM=-ALGXRE*ALGXIM
31864 IF(XRE.GT.0.5D0) THEN
31869 XMOD=SQRT(XRE**2+XIM**2)
31870 XARG=SIGN(ACOS(XRE/XMOD),XIM)
31873 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
31874 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
31880 XMOD=SQRT(XRE**2+XIM**2)
31881 XARG=SIGN(ACOS(XRE/XMOD),XIM)
31890 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
31891 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
31892 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
31895 SPRE=SPRE+B(I)*TERMRE
31896 SPIM=SPIM+B(I)*TERMIM
31899 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
31900 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
31905 C***********************************************************************
31908 C...Calculates the matrix element for the processes
31909 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
31910 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
31911 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
31913 SUBROUTINE PYQQBH(WTQQBH)
31915 C...Double precision and integer declarations.
31916 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31917 IMPLICIT INTEGER(I-N)
31918 INTEGER PYK,PYCHGE,PYCOMP
31920 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31921 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31922 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31923 COMMON/PYINT1/MINT(400),VINT(400)
31924 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31925 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
31926 C...Local arrays and function.
31927 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
31928 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
31931 C...Mass parameters.
31934 SHPR=SQRT(VINT(26))*VINT(1)
31935 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
31936 PH=SQRT(VINT(21))*VINT(1)
31940 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
31942 PT=SQRT(MAX(0D0,VINT(197+5*I)))
31943 PP(I,1)=PT*COS(VINT(198+5*I))
31944 PP(I,2)=PT*SIN(VINT(198+5*I))
31946 PP(3,1)=-PP(1,1)-PP(2,1)
31947 PP(3,2)=-PP(1,2)-PP(2,2)
31948 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
31949 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
31950 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
31952 PP(3,3)=PMT3*SINH(VINT(211))
31953 PP(3,4)=PMT3*COSH(VINT(211))
31954 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
31955 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
31956 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
31957 PP(2,3)=-PP(1,3)-PP(3,3)
31958 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
31959 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
31961 C...Set up incoming kinematics and derived momentum combinations.
31965 PP(I,3)=-0.5D0*SHPR*(-1)**I
31966 PP(I,4)=-0.5D0*SHPR
31969 PP(6,J)=PP(1,J)+PP(2,J)
31970 PP(7,J)=PP(1,J)+PP(3,J)
31971 PP(8,J)=PP(1,J)+PP(4,J)
31972 PP(9,J)=PP(1,J)+PP(5,J)
31973 PP(10,J)=-PP(2,J)-PP(3,J)
31974 PP(11,J)=-PP(2,J)-PP(4,J)
31975 PP(12,J)=-PP(2,J)-PP(5,J)
31976 PP(13,J)=-PP(4,J)-PP(5,J)
31979 C...Derived kinematics invariants.
32008 C...Define colour coefficients for g + g -> Q + Qbar + H.
32009 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
32013 CLR(I+3,J+3)=16D0/3D0
32014 CLR(I,J+3)=-2D0/3D0
32015 CLR(I+3,J)=-2D0/3D0
32028 CLR(6+K1,6+K2)=12D0
32032 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
32033 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
32034 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
32035 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
32036 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
32037 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
32038 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
32040 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
32041 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
32042 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
32043 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
32044 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
32045 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
32046 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
32047 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
32048 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
32049 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
32050 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
32051 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
32052 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
32053 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
32054 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
32055 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
32056 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
32057 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
32059 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
32060 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
32061 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
32062 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
32063 & +X4*X9*X5+X4*X5**2)
32064 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
32065 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
32066 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
32067 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
32068 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
32069 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
32070 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
32071 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
32072 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
32073 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
32074 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
32075 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
32076 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
32077 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
32078 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
32079 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
32080 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
32081 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
32082 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
32083 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
32085 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
32086 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
32087 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
32088 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
32089 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
32090 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
32091 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
32093 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
32094 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
32095 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
32096 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
32097 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
32098 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
32100 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
32101 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
32102 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
32103 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
32104 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
32105 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
32106 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
32108 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
32109 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
32110 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
32111 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
32112 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
32113 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
32114 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
32115 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
32116 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
32117 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
32118 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
32119 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
32120 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
32121 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
32122 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
32123 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
32124 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
32125 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
32126 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
32127 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
32128 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
32129 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
32130 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
32131 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
32132 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
32133 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
32134 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
32135 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
32136 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
32137 & +X3*X8*X5+X3*X5**2)
32138 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
32139 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
32140 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
32141 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
32142 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
32143 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
32144 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
32146 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
32147 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
32148 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
32149 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
32150 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
32151 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
32152 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
32153 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
32154 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
32155 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
32156 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
32157 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
32158 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
32159 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
32160 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
32161 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
32162 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
32163 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
32164 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
32165 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
32166 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
32167 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
32168 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
32169 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
32170 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
32171 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
32173 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
32174 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
32175 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
32176 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
32177 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
32178 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
32179 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
32180 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
32181 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
32182 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
32183 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
32184 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
32185 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
32186 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
32187 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
32188 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
32189 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
32190 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
32191 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
32192 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
32193 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
32194 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
32195 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
32196 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
32197 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
32198 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
32200 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
32201 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
32202 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
32203 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
32204 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
32205 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
32206 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
32207 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
32208 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
32209 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
32210 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
32211 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
32212 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
32213 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
32214 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
32215 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
32216 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
32217 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
32218 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
32219 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
32220 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
32221 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
32222 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
32223 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
32224 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
32225 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
32226 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
32227 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
32228 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
32229 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
32230 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
32231 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
32232 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
32233 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
32234 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
32235 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
32236 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
32237 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
32238 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
32239 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
32240 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
32241 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
32242 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
32243 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
32245 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
32246 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
32247 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
32248 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
32249 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
32250 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
32251 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
32252 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
32253 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
32254 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
32255 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
32257 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
32258 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
32259 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
32260 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
32261 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
32262 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
32264 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
32265 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
32266 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
32268 FM(9,10)=0.5D0*(FMXX+FM(9,10))
32269 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
32270 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
32271 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
32273 C...Repackage matrix elements.
32279 RM(7,7)=FM(7,7)-2D0*FM(9,9)
32280 RM(7,8)=FM(7,8)-2D0*FM(9,10)
32281 RM(8,8)=FM(8,8)-2D0*FM(10,10)
32283 C...Produce final result: matrix elements * colours * propagators.
32288 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
32291 WTQQBH=-WTQQBH/256D0
32294 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
32295 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
32296 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
32298 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
32299 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
32300 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
32302 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
32303 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
32306 C...Produce final result: matrix elements * propagators.
32308 A12=A12/(DX(7)*DX(8))
32310 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
32316 C*********************************************************************
32319 C...Initializes supersymmetry: finds sparticle masses and
32320 C...branching ratios and stores this information.
32321 C...AUTHOR: STEPHEN MRENNA
32322 C...Baryon- and lepton-number violating parameters by P. Z. Skands.
32326 C...Double precision and integer declarations.
32327 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32328 IMPLICIT INTEGER(I-N)
32329 INTEGER PYK,PYCHGE,PYCOMP
32330 C...Parameter statement to help give large particle numbers.
32331 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32332 &KEXCIT=4000000,KDIMEN=5000000)
32334 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32335 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32336 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32337 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32338 COMMON/PYINT4/MWID(500),WIDS(500,5)
32339 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32340 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
32341 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32342 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
32343 COMMON/PYHTRI/HHH(7)
32344 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
32347 C...Local variables.
32348 DOUBLE PRECISION ALFA,BETA
32349 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
32350 INTEGER I,J,J1,I1,K1
32351 INTEGER KC,LKNT,IDLAM(400,3)
32352 DOUBLE PRECISION XLAM(0:400)
32353 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
32354 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
32355 DOUBLE PRECISION DELM,XMDIF
32356 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
32357 DOUBLE PRECISION ARG,SGNMU,R
32360 INTEGER KFSUSY(36),MWIDSU(36),MDCYSU(36)
32363 &1000001,2000001,1000002,2000002,1000003,2000003,
32364 &1000004,2000004,1000005,2000005,1000006,2000006,
32365 &1000011,2000011,1000012,2000012,1000013,2000013,
32366 &1000014,2000014,1000015,2000015,1000016,2000016,
32367 &1000021,1000022,1000023,1000025,1000035,1000024,
32368 &1000037,1000039, 25, 35, 36, 37/
32371 C...Do nothing if SUSY not requested.
32373 IF(IMSSM.EQ.0) RETURN
32375 C...Save copy of MWID(KC) and MDCY(KC,1) values before
32376 C...they are set to zero for the LSP.
32383 MDCYSU(I)=MDCY(KC,1)
32387 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
32391 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
32393 MDCY(KC,1)=MDCYSU(I)
32397 C...First part of routine: set masses and couplings.
32399 C...Reset mixing values in sfermion sector to pure left/right.
32407 C...Common couplings.
32412 COS2B=COS(2D0*BETA)
32418 C...Define sparticle masses for a general MSSM simulation.
32419 IF(IMSSM.EQ.1) THEN
32420 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
32422 KC=PYCOMP(KSUSY1+I)
32423 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
32424 KC=PYCOMP(KSUSY2+I)
32425 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
32426 KC=PYCOMP(KSUSY1+I+1)
32427 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
32428 KC=PYCOMP(KSUSY2+I+1)
32429 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
32431 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
32432 IF(XARG.LT.0D0) THEN
32433 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
32434 & ' FROM THE SUM RULE. '
32435 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
32441 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
32442 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
32443 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
32444 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
32446 IF(IMSS(8).EQ.1) THEN
32451 C...Alternatively derive masses from SUGRA relations.
32452 ELSEIF(IMSSM.EQ.2) THEN
32455 ELSEIF(IMSSM.EQ.12) THEN
32461 C...Add in extra D-term contributions.
32462 IF(IMSS(7).EQ.1) THEN
32467 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32468 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
32469 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
32470 WRITE(MSTU(11),*) 'C DX = ',DX
32471 WRITE(MSTU(11),*) 'C DY = ',DY
32472 WRITE(MSTU(11),*) 'C DS = ',DS
32473 WRITE(MSTU(11),*) 'C '
32474 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
32475 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
32476 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32477 DQ2=DY/6D0-DX/3D0-DS/3D0
32478 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
32479 DD2=DY/3D0+DX-2D0*DS/3D0
32480 DL2=-DY/2D0+DX-2D0*DS/3D0
32481 DE2=DY-DX/3D0-DS/3D0
32482 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
32483 DHD2=-DY/2D0-2D0*DX/3D0+DS
32484 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
32486 DMA2 = 2D0*DMU2+DHU2+DHD2
32488 KC=PYCOMP(KSUSY1+I)
32489 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
32490 KC=PYCOMP(KSUSY2+I)
32491 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
32492 KC=PYCOMP(KSUSY1+I+1)
32493 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
32494 KC=PYCOMP(KSUSY2+I+1)
32495 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
32498 KC=PYCOMP(KSUSY1+I)
32499 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
32500 KC=PYCOMP(KSUSY2+I)
32501 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
32502 KC=PYCOMP(KSUSY1+I+1)
32503 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
32505 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
32506 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
32509 SGNMU=SIGN(1D0,RMSS(4))
32510 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
32511 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
32512 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
32513 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
32514 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
32515 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
32516 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
32517 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
32518 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
32519 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
32520 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
32521 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
32522 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
32525 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
32526 RMSS(6)=SQRT(RMSS(6)**2+DL2)
32527 RMSS(7)=SQRT(RMSS(7)**2+DE2)
32528 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
32529 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
32530 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
32531 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
32532 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
32535 C...Fix the third generation sfermions.
32538 C...Fix the neutralino--chargino--gluino sector.
32541 C...Fix the Higgs sector.
32544 C...Choose the Gunion-Haber convention.
32548 C...Print information on mass parameters.
32549 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
32550 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32551 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
32552 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
32553 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
32554 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
32555 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
32556 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
32557 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
32558 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
32559 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32561 IF(IMSS(20).EQ.1) THEN
32562 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32563 WRITE(MSTU(11),*) ' DEBUG MODE '
32564 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
32565 & UMIX(2,1),UMIX(2,2)
32566 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
32567 & UMIXI(2,1),UMIXI(2,2)
32568 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
32569 & VMIX(2,1),VMIX(2,2)
32570 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
32571 & VMIXI(2,1),VMIXI(2,2)
32572 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
32573 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
32574 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
32575 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
32576 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
32577 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
32578 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
32579 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
32580 WRITE(MSTU(11),*) ' ALFA = ',ALFA
32581 WRITE(MSTU(11),*) ' BETA = ',BETA
32582 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
32583 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
32584 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32587 C...Set up the Higgs couplings - needed here since initialization
32588 C...in PYINRE did not yet occur when PYWIDT is called below.
32600 C2B=COSB**2-SINB**2
32601 C...tanb (used for H+)
32605 C...Coupling to d-type quarks
32606 PARU(161)=SINA/COSB
32607 C...Coupling to u-type quarks
32608 PARU(162)=-COSA/SINB
32609 C...Coupling to leptons
32610 PARU(163)=PARU(161)
32614 PARU(165)=PARU(164)
32617 C...Coupling to d-type quarks
32618 PARU(171)=-COSA/COSB
32619 C...Coupling to u-type quarks
32620 PARU(172)=-SINA/SINB
32621 C...Coupling to leptons
32622 PARU(173)=PARU(171)
32626 PARU(175)=PARU(174)
32628 IF(IMSS(4).EQ.2) THEN
32629 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
32631 HHH(3)=HHH(3)+HHH(4)+HHH(5)
32632 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
32633 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
32634 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
32635 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
32639 IF(IMSS(4).EQ.2) THEN
32640 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
32642 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
32643 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
32644 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
32645 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
32648 IF(IMSS(4).EQ.2) THEN
32649 PARU(177)=COS(2D0*BE)*COS(BE+AL)
32651 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
32652 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
32653 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
32654 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
32657 IF(IMSS(4).EQ.2) THEN
32658 PARU(178)=PARU(177)
32660 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
32663 C...Coupling to d-type quarks
32665 C...Coupling to u-type quarks
32666 PARU(182)=1D0/PARU(181)
32667 C...Coupling to leptons
32668 PARU(183)=PARU(181)
32671 C...Coupling to Z h
32672 PARU(186)=COS(BE-AL)
32673 C...Coupling to Z H
32674 PARU(187)=SIN(BE-AL)
32680 C...Coupling to W h
32681 PARU(195)=COS(BE-AL)
32683 C...Tell that all Higgs couplings have been set.
32686 C...Set R-Violating couplings.
32687 C...Set lambda couplings to common value or "natural values".
32688 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
32689 VIR3=1D0/(126D0)**3
32693 IF (IRI.NE.IRJ) THEN
32694 IF (IRI.LT.IRJ) THEN
32695 RVLAM(IRI,IRJ,IRK)=RMSS(51)
32696 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
32697 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
32698 & PMAS(9+2*IRK,1)*VIR3)
32700 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
32703 RVLAM(IRI,IRJ,IRK)=0D0
32709 C...Set lambda' couplings to common value or "natural values".
32710 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
32711 VIR3=1D0/(126D0)**3
32715 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
32716 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
32717 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
32718 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
32723 C...Set lambda'' couplings to common value or "natural values".
32724 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
32725 VIR3=1D0/(126D0)**3
32729 IF (IRJ.NE.IRK) THEN
32730 IF (IRJ.LT.IRK) THEN
32731 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
32732 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
32733 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
32734 & PMAS(2*IRK-1,1)*VIR3)
32736 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
32739 RVLAMB(IRI,IRJ,IRK) = 0D0
32746 C...Antisymmetrize couplings set by user
32747 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
32751 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
32752 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
32753 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
32755 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
32756 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
32757 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
32764 C...Second part of routine: set decay modes and branching ratios.
32766 C...Allow chi10 -> gravitino + gamma or not.
32767 KC=PYCOMP(KSUSY1+39)
32768 IF( IMSS(11) .NE. 0 ) THEN
32769 PMAS(KC,1)=RMSS(21)/1000000000D0
32770 PMAS(KC,2)=0.0001D0
32772 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
32773 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
32775 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
32776 & ' ALLOWING SUSY LLE DECAYS'
32777 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
32778 & ' ALLOWING SUSY LQD DECAYS'
32779 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
32780 & ' ALLOWING SUSY UDD DECAYS'
32781 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
32782 & ' --- Warning: R-Violating couplings possibly',
32783 & ' incompatible with proton decay'
32789 C...Loop over sparticle and Higgs species.
32790 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
32791 C...Find the LSP or NLSP for a gravitino LSP
32796 IF(KF.EQ.1000039) GOTO 300
32798 IF(PMAS(KC,1).LT.PMLSP) THEN
32808 C...Sfermion decays.
32810 C...First check to see if sneutrino is lighter than chi10.
32811 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
32812 & PMAS(KC,1).LT.PMCHI1) THEN
32814 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
32818 ELSEIF(I.EQ.25) THEN
32819 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
32820 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
32822 C...Neutralino decays.
32823 ELSEIF(I.GE.26.AND.I.LE.29) THEN
32824 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
32825 C...chi10 stable or chi10 -> gravitino + gamma.
32826 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
32832 C...Chargino decays.
32833 ELSEIF(I.GE.30.AND.I.LE.31) THEN
32834 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
32836 C...Gravitino is stable.
32837 ELSEIF(I.EQ.32) THEN
32842 ELSEIF(I.GE.33.AND.I.LE.36) THEN
32843 C...Calculate decays to non-SUSY particles.
32844 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
32849 DO 330 I1=1,MDCY(KC,3)
32851 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
32852 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
32854 XLAM(0)=XLAM(0)+XLAM(I1)
32856 IDLAM(I1,J1)=KFDP(K1,J1)
32860 C...Add the decays to SUSY particles.
32861 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
32863 C...Zero the branching ratios for use in loop mode
32864 C...thanks to K. Matchev (FNAL)
32865 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
32869 C...Set stable particles.
32877 C...Store branching ratios in the standard tables.
32879 IDC=MDCY(KC,2)+MDCY(KC,3)-1
32885 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
32886 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
32887 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
32888 BRAT(IDC)=XLAM(IL)/XLAM(0)
32890 IF(MDME(IDC,1).GE.1) THEN
32891 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
32892 & PMAS(PYCOMP(KFDP(IDC,2)),1)
32893 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
32894 & PMAS(PYCOMP(KFDP(IDC,3)),1)
32897 IF(XMDIF.GE.0D0) THEN
32898 DELM=MIN(DELM,XMDIF)
32900 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
32901 WRITE(MSTU(11),*) ' KF = ',KF
32902 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
32906 ELSEIF(IDC.EQ.IDCSV) THEN
32907 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
32908 & 'channel not recognized:'
32909 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
32916 C...Store width, cutoff and lifetime.
32918 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
32919 PMAS(KC,3)=PMAS(KC,2)*10D0
32921 PMAS(KC,3)=0.95D0*DELM
32923 IF(PMAS(KC,2).NE.0D0) THEN
32924 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
32932 C*********************************************************************
32935 C...Uses approximate analytical formulae to determine the full set of
32936 C...MSSM parameters from SUGRA input.
32937 C...See M. Drees and S.P. Martin, hep-ph/9504124
32941 C...Double precision and integer declarations.
32942 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32943 IMPLICIT INTEGER(I-N)
32944 INTEGER PYK,PYCHGE,PYCOMP
32945 C...Parameter statement to help give large particle numbers.
32946 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32947 &KEXCIT=4000000,KDIMEN=5000000)
32949 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32950 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32951 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32952 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
32969 SINB=TANB/SQRT(TANB**2+1D0)
32972 DTERM=XMZ2*COS(2D0*BETA)
32973 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
32974 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
32977 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
32978 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
32979 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
32980 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
32982 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
32983 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
32984 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
32985 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
32987 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
32988 IF(XARG.LT.0D0) THEN
32989 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
32990 & ' FROM THE SUM RULE. '
32991 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
32997 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
32998 PMAS(PYCOMP(KSUSY2+I),1)=XMER
32999 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
33000 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
33002 RMT=PYMRUN(6,PMAS(6,1)**2)
33003 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
33004 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
33005 RMB=PYMRUN(5,PMAS(6,1)**2)
33006 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
33007 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
33008 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
33009 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
33012 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
33013 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
33014 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
33015 XMU=SIGN(SQRT(XMU2),RMSS(4))
33017 IF(XMA2.GT.0D0) THEN
33018 RMSS(19)=SQRT(XMA2)
33020 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
33023 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
33024 IF(ARG.GT.0D0) THEN
33027 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
33030 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
33031 IF(ARG.GT.0D0) THEN
33034 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
33037 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
33038 IF(ARG.GT.0D0) THEN
33041 RMSS(10)=-SQRT(-ARG)
33043 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
33044 IF(ARG.GT.0D0) THEN
33047 RMSS(12)=-SQRT(-ARG)
33049 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
33050 IF(ARG.GT.0D0) THEN
33053 RMSS(11)=-SQRT(-ARG)
33059 C*********************************************************************
33062 C...Interface to ISASUSY version 7.61.
33063 C...Warning: if you use earlier versions, change dimension to
33064 C...SUPER(66) in /SSPAR/ and remove MHPNEG and ASM3 from /SUGPAS/.
33065 C...Calls SUGRA (in ISAJET) to perform RGE evolution.
33066 C...Then converts to Gunion-Haber conventions.
33069 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33071 INTEGER PYK,PYCHGE,PYCOMP
33072 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33073 &KEXCIT=4000000,KDIMEN=5000000)
33077 PARAMETER (DOC='22 Nov 2002')
33079 C...ISASUGRA Input:
33080 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
33081 C...ISASUGRA Output
33082 CHARACTER*40 ISAVER,VISAJE
33084 COMMON /SSPAR/ SUPER(69)
33085 COMMON /SUGMG/ MSS(32),GSS(29),MGUTSS,GGUTSS,AGUTSS,FTGUT,
33086 $FBGUT,FTAGUT,FNGUT
33087 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
33088 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
33089 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
33090 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3
33091 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
33092 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
33094 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
33095 C SUPER: Filled by ISASUGRA.
33096 C SUPER(1) = mass of ~g
33097 C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
33098 C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
33099 C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
33101 C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
33102 C SUPER(29) = Higgsino mass = - mu
33103 C SUPER(30) = ratio v2/v1 of vev's
33104 C SUPER(31:34) = Signed neutralino masses
33105 C SUPER(35:50) = Neutralino mixing matrix
33106 C SUPER(51:52) = Signed chargino masses
33107 C SUPER(53:54) = Chargino left, right mixing angles
33108 C SUPER(55:58) = mass of h0, H0, A0, H+
33109 C SUPER(59) = Higgs mixing angle alpha
33110 C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
33111 C SUPER(66) = Gravitino mass
33112 C GSS: Filled by ISASUGRA
33113 C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
33114 C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
33115 C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
33116 C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
33117 C GSS(13) = M_h1^2 GSS(14) = M_h2^2 GSS(15) = M_er^2
33118 C GSS(16) = M_el^2 GSS(17) = M_dnr^2 GSS(18) = M_upr^2
33119 C GSS(19) = M_upl^2 GSS(20) = M_taur^2 GSS(21) = M_taul^2
33120 C GSS(22) = M_btr^2 GSS(23) = M_tpr^2 GSS(24) = M_tpl^2
33121 C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
33122 C GSS(28) = M_nr GSS(29) = A_n
33123 C MSS: Filled by ISASUGRA
33124 C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
33125 C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
33126 C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
33127 C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
33128 C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
33129 C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
33130 C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
33131 C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
33132 C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
33133 C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
33134 C MSS(31) = ha0 MSS(32) = h+
33135 C Unification, filled by ISASUGRA if applicable.
33136 C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
33137 C...SPYTHIA Input/Output:
33139 DOUBLE PRECISION RMSS
33140 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33141 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33142 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33143 SAVE /SUGMG/,/SSPAR/
33145 C...PYTHIA common blocks
33147 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33148 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33149 C...Particle properties + some flavour parameters.
33150 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33151 SAVE /PYDAT2/,/PYSSMT/
33153 C...Start by checking for incompatibilities/inconsistencies:
33155 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
33156 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
33157 & ,' option not used by PYSUGI'
33160 C...ISAJET works with REAL numbers.
33161 MZERO=REAL(RMSS(8))
33163 AZERO=REAL(RMSS(16))
33165 SGNMU=REAL(RMSS(4))
33166 MTOP=REAL(PMAS(6,1))
33167 C...Initialize MSSM parameter array
33172 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,1)
33173 C...Check whether ISASUSY thought the model was OK.
33174 IF (NOGOOD.NE.0) THEN
33175 IF (NOGOOD.EQ.1) CALL PYERRM(26
33176 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
33177 IF (NOGOOD.EQ.2) CALL PYERRM(26
33178 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
33179 IF (NOGOOD.EQ.3) CALL PYERRM(26
33180 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
33181 IF (NOGOOD.EQ.4) CALL PYERRM(26
33182 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
33183 IF (NOGOOD.EQ.7) CALL PYERRM(26
33184 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
33185 IF (NOGOOD.EQ.8) CALL PYERRM(26
33186 & ,'(PYSUGI:) SUSY parameters give m(h0)^2 < 0.')
33187 C...Give warning, but don't stop, if LSP not ~chi_10.
33188 IF (NOGOOD.EQ.5) CALL PYERRM(16
33189 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
33191 C...Warn about possible GUT scale tachyons.
33192 IF (ITACHY.NE.0) CALL PYERRM(16,
33193 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
33200 C...Mu = - Higgsino mass.
33203 C...Slepton and squark masses. 2 first generations.
33204 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
33205 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
33206 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
33207 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
33208 C...Third generation.
33209 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
33214 C...~b, ~t, and ~tau trilinear couplings and mixing angles.
33221 C...Higgs mixing angle alpha (Gunion-Haber convention).
33222 RMSS(18)=-SUPER(59)
33225 C...GUT scale coupling
33227 C...Gravitino mass (for future compatibility)
33230 C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
33232 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
33233 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
33234 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
33235 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
33237 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
33238 C...Squarks and Sleptons.
33241 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
33242 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
33243 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
33244 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
33245 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
33246 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
33247 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
33248 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
33249 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
33251 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
33252 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
33253 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
33255 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
33256 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
33257 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
33258 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
33259 C...Signed masses (extra minus from going to G-H convention).
33265 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
33266 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
33267 C...Signed masses (extra minus from going to G-H convention).
33271 C... Neutralino Mixing.
33273 ZMIX(IN,1)= SUPER(38+4*(IN-1))
33274 ZMIX(IN,2)= SUPER(37+4*(IN-1))
33275 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
33276 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
33278 C...Chargino Mixing (PYTHIA same angle as HERWIG).
33281 IF (SUPER(53).GT.0) THX=-1D0
33282 IF (SUPER(54).GT.0) THY=-1D0
33283 UMIX(1,1) = -SIN(SUPER(53))
33284 UMIX(1,2) = -COS(SUPER(53))
33285 UMIX(2,1) = -THX*COS(SUPER(53))
33286 UMIX(2,2) = THX*SIN(SUPER(53))
33287 VMIX(1,1) = -SIN(SUPER(54))
33288 VMIX(1,2) = -COS(SUPER(54))
33289 VMIX(2,1) = -THY*COS(SUPER(54))
33290 VMIX(2,2) = THY*SIN(SUPER(54))
33291 C...Sfermion mixing (PYTHIA same angle as ISAJET)
33292 SFMIX(5,1)=COS(SUPER(63))
33293 SFMIX(5,2)=SIN(SUPER(63))
33294 SFMIX(5,3)=-SIN(SUPER(63))
33295 SFMIX(5,4)=COS(SUPER(63))
33296 SFMIX(6,1)=COS(SUPER(61))
33297 SFMIX(6,2)=SIN(SUPER(61))
33298 SFMIX(6,3)=-SIN(SUPER(61))
33299 SFMIX(6,4)=COS(SUPER(61))
33300 SFMIX(15,1)=COS(SUPER(65))
33301 SFMIX(15,2)=SIN(SUPER(65))
33302 SFMIX(15,3)=-SIN(SUPER(65))
33303 SFMIX(15,4)=COS(SUPER(65))
33305 IF (MSTP(122).NE.0) THEN
33306 C...Print a few lines to make the user know what's happening
33308 WRITE(MSTU(11),5000) DOC, ISAVER
33309 WRITE(MSTU(11),5100)
33310 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU), MTOP
33311 WRITE(MSTU(11),5300)
33312 WRITE(MSTU(11),5500) 'EW scale masses'
33313 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
33314 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
33315 & ,(SUPER(IP),IP=19,25,2)
33316 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
33318 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
33319 WRITE(MSTU(11),5400)
33320 WRITE(MSTU(11),5500) 'Mixing structure'
33321 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
33322 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
33323 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
33324 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
33325 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
33326 & ),(SFMIX(15,J),J=3,4)
33327 WRITE(MSTU(11),5400)
33328 WRITE(MSTU(11),5500) 'Couplings'
33329 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
33330 WRITE(MSTU(11),5400)
33331 WRITE(MSTU(11),6500)
33334 C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
33335 C...output by ISASUGRA.
33338 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.1: PYTHIA/ISASUGRA '
33339 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
33340 & ,1x,'-',1x,'P.Z. Skands'/1x,'*',2x,A/1x,'*')
33341 5100 FORMAT(1x,'*',1x,'ISASUGRA Input:'/1x,'*',1x,'----------------')
33342 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
33343 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
33344 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUGRA Output:'/1x,'*',1x
33345 & ,'----------------')
33346 5400 FORMAT(1x,'*',1x,A)
33347 5500 FORMAT(1x,'*',1x,A,':')
33348 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
33349 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
33350 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
33351 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
33352 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
33354 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
33355 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
33356 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
33358 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
33359 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
33360 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
33361 6000 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
33362 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
33363 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
33364 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
33365 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
33366 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
33367 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
33368 & ,1x,F6.3,1x),'|')
33369 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
33370 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
33371 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
33372 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
33373 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
33374 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
33375 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
33376 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
33377 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
33378 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
33379 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
33380 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
33381 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
33382 & ,4x,'Alpha_GUT = ',F8.2)
33383 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
33386 C*********************************************************************
33389 C...Determines the running mass of Squarks.
33391 FUNCTION PYRNMQ(ID,DTERM)
33393 C...Double precision and integer declarations.
33394 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33395 IMPLICIT INTEGER(I-N)
33396 INTEGER PYK,PYCHGE,PYCOMP
33398 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33401 C...Local variables.
33402 DOUBLE PRECISION PI,R
33403 DOUBLE PRECISION TOL
33404 DOUBLE PRECISION CI(3)
33406 DOUBLE PRECISION PYALPS
33408 DATA PI,R/3.141592654D0,.61803399D0/
33409 DATA CI/0.47D0,0.07D0,0.02D0/
33413 AG=(0.71D0)**2/4D0/PI
33420 AS=PYALPS(XM02+6D0*XMG2)
33421 CG=8D0/9D0*((AS/AG)**2-1D0)
33422 BX=XM02+(CA+CG)*XMG2+DTERM
33423 AX=MIN(50D0**2,0.5D0*BX)
33424 CX=MAX(2000D0**2,2D0*BX)
33428 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
33436 CG=8D0/9D0*((AS1/AG)**2-1D0)
33437 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
33439 CG=8D0/9D0*((AS2/AG)**2-1D0)
33440 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
33441 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
33448 CG=8D0/9D0*((AS2/AG)**2-1D0)
33449 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
33456 CG=8D0/9D0*((AS1/AG)**2-1D0)
33457 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
33472 C*********************************************************************
33475 C...Calculates the mass eigenstates of the third generation sfermions.
33476 C...Created: 5-31-96
33480 C...Double precision and integer declarations.
33481 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33482 IMPLICIT INTEGER(I-N)
33483 INTEGER PYK,PYCHGE,PYCOMP
33484 C...Parameter statement to help give large particle numbers.
33485 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33486 &KEXCIT=4000000,KDIMEN=5000000)
33488 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33489 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33490 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33491 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33492 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33493 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
33495 C...Local variables.
33496 DOUBLE PRECISION BETA
33497 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
33498 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
33499 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
33500 DOUBLE PRECISION ATR,AMQR,AMQL
33501 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
33502 INTEGER IF,I,J,II,JJ,IT,L
33516 COS2B=COS(2D0*BETA)
33518 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
33528 XMQL2=CTT2*XM12+STT2*XM22
33529 XMQR2=STT2*XM12+CTT2*XM22
33530 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
33531 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
33533 C......SUBTRACT OUT D-TERM AND FERMION MASS
33534 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
33535 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
33536 IF(XMQL2.GE.0D0) THEN
33537 RMSS(10)=SQRT(XMQL2)
33539 RMSS(10)=-SQRT(-XMQL2)
33541 IF(XMQR2.GE.0D0) THEN
33542 RMSS(12)=SQRT(XMQR2)
33544 RMSS(12)=-SQRT(-XMQR2)
33547 C SAME FOR BOTTOM SQUARK
33553 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
33554 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
33555 IF(ABS(CTT).GE..9999D0) THEN
33558 ELSEIF(ABS(CTT).LE.1D-4) THEN
33562 XM12=(XMQL2-STT2*XM22)/CTT2
33563 XMQR2=STT2*XM12+CTT2*XM22
33564 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
33567 C......SUBTRACT OUT D-TERM AND FERMION MASS
33568 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
33569 IF(XMQR2.GE.0D0) THEN
33570 RMSS(11)=SQRT(XMQR2)
33572 RMSS(11)=-SQRT(-XMQR2)
33574 C SAME FOR TAU SLEPTON
33581 XMQL2=CTT2*XM12+STT2*XM22
33582 XMQR2=STT2*XM12+CTT2*XM22
33585 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
33587 C......SUBTRACT OUT D-TERM AND FERMION MASS
33588 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
33589 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
33590 IF(XMQL2.GE.0D0) THEN
33591 RMSS(13)=SQRT(XMQL2)
33593 RMSS(13)=-SQRT(-XMQL2)
33595 IF(XMQR2.GE.0D0) THEN
33596 RMSS(14)=SQRT(XMQR2)
33598 RMSS(14)=-SQRT(-XMQR2)
33603 IF(AMQL.LT.0D0) THEN
33610 IF(AMQR.LT.0D0) THEN
33616 XMF=PYMRUN(IF,PMAS(6,1)**2)
33618 AM2(1,1)=XMQL2+XMF2
33619 AM2(2,2)=XMQR2+XMF2
33620 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
33623 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
33624 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
33625 AM2(1,2)=XMF*(ATR+XMU*TANB)
33626 ELSEIF(L.EQ.2) THEN
33627 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
33628 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
33629 AM2(1,2)=XMF*(ATR+XMU/TANB)
33630 ELSEIF(L.EQ.3) THEN
33631 IF(IMSS(8).EQ.1) THEN
33632 AM2(1,1)=RMSS(6)**2
33633 AM2(2,2)=RMSS(7)**2
33638 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
33639 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
33640 AM2(1,2)=XMF*(ATR+XMU*TANB)
33645 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
33646 IF(DETM.LT.0D0) THEN
33647 WRITE(MSTU(11),*) ID2(L),DETM,AM2
33648 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
33650 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
33651 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
33655 IF(XMF22-XMF12.GT.0D0) THEN
33656 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
33658 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
33659 & AM2(1,2)/(XMF22-XMF12))
33675 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
33681 IF(DI(1,1).GT.DI(2,2)) THEN
33682 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
33683 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
33684 WRITE(MSTU(11),*) AM2
33685 WRITE(MSTU(11),*) DI
33686 WRITE(MSTU(11),*) RT
33697 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
33698 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
33699 & ' OFF DIAGONAL ELEMENTS '
33700 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
33701 WRITE(MSTU(11),*) DI
33702 WRITE(MSTU(11),*) ' ROTATION = ',RT
33704 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
33705 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
33706 & ' NEGATIVE MASSES '
33709 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
33710 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
33711 SFMIX(IF,1)=RT(1,1)
33712 SFMIX(IF,2)=RT(1,2)
33713 SFMIX(IF,3)=RT(2,1)
33714 SFMIX(IF,4)=RT(2,2)
33717 C.....TAU SNEUTRINO MASS...L=3
33719 XARG=AM2(1,1)+XMW2*COS2B
33720 IF(XARG.LT.0D0) THEN
33721 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
33722 & ' FROM THE SUM RULE. '
33723 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
33726 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
33732 C*********************************************************************
33735 C...Finds the mass eigenstates and mixing matrices for neutralinos
33740 C...Double precision and integer declarations.
33741 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33742 IMPLICIT INTEGER(I-N)
33744 C...Parameter statement to help give large particle numbers.
33745 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33746 &KEXCIT=4000000,KDIMEN=5000000)
33748 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33749 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33750 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33751 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33752 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33753 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
33755 C...Local variables.
33756 DOUBLE PRECISION XMW,XMZ,XM(4)
33757 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),AI(4,4)
33758 DOUBLE PRECISION WI(4),FV1(4),FV2(4),FV3(4)
33759 DOUBLE PRECISION COSW,SINW
33760 DOUBLE PRECISION XMU
33761 DOUBLE PRECISION TANB,COSB,SINB
33762 DOUBLE PRECISION XM1,XM2,XM3,BETA
33763 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
33764 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
33765 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
33766 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
33767 DOUBLE PRECISION PYALPS,PYALEM
33768 DOUBLE PRECISION PYRNM3
33769 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
33770 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
33771 DATA KFNCHI/1000022,1000023,1000025,1000035/
33774 IF(IMSS(1).EQ.2) THEN
33777 C...M1, M2, AND M3 ARE INDEPENDENT
33782 ELSEIF(IOPT.GE.1) THEN
33786 A1=AEM/(1D0-PARU(102))
33789 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
33791 XM2=XM1*A2/A1*3D0/5D0
33793 ELSEIF(IOPT.EQ.3) THEN
33794 XM1=XM2*5D0/3D0*A1/A2
33799 IF(XM3.LE.0D0) THEN
33800 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
33806 IF(IMSS(3).EQ.1) THEN
33807 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
33812 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
33813 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
33814 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
33820 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
33821 RM2=PMAS(I,1)**2/XM3**2
33822 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
33823 IF(ARG.GE.0D0) THEN
33824 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
33826 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
33831 ELSEIF(X0.EQ.0D0) THEN
33835 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
33836 & 0.5D0*X0**2*LOG(AX0)
33837 BT=(-1D0-2D0*X0)/4D0
33842 ELSEIF(X1.EQ.0D0) THEN
33846 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
33847 & X1**2*LOG(AX1)+AT
33848 BT=(-1D0-2D0*X1)/4D0+BT
33852 X0=0.5D0*(1D0+RM2-RM1)
33853 Y0=-0.5D0*SQRT(-ARG)
33854 AMGX0=SQRT(X0**2+Y0**2)
33855 AM1X0=SQRT((1D0-X0)**2+Y0**2)
33856 ARGX0=ATAN2(-X0,-Y0)
33857 AR1X0=ATAN2(1D0-X0,Y0)
33862 ARGX1=ATAN2(-X1,-Y1)
33863 AR1X1=ATAN2(1D0-X1,Y1)
33864 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
33865 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
33866 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
33867 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
33868 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
33869 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
33874 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
33875 & /(2D0*PARU(2))*(15D0+AQ))
33878 C...NEUTRALINO MASSES
33887 SINW=SQRT(PARU(102))
33888 COSW=SQRT(1D0-PARU(102))
33895 C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
33896 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
33897 AR(1,1) = XM1*COS(RMSS(30))
33898 AI(1,1) = XM1*SIN(RMSS(30))
33899 AR(2,2) = XM2*COS(RMSS(31))
33900 AI(2,2) = XM2*SIN(RMSS(31))
33905 AR(1,3) = -XMZ*SINW*COSB
33907 AR(1,4) = XMZ*SINW*SINB
33909 AR(2,3) = XMZ*COSW*COSB
33911 AR(2,4) = -XMZ*COSW*SINB
33913 AR(3,4) = -XMU*COS(RMSS(33))
33914 AI(3,4) = -XMU*SIN(RMSS(33))
33915 AR(4,3) = -XMU*COS(RMSS(33))
33916 AI(4,3) = -XMU*SIN(RMSS(33))
33917 C CALL PYEIG4(AR,WR,ZR)
33918 CALL PYEICG(4,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
33920 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
33929 IF(XM(K).LT.XM(J)) THEN
33947 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
33950 S=S+ZR(J,K)**2+ZI(J,K)**2
33953 ZMIX(I,J)=ZR(J,K)/SQRT(S)
33954 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
33955 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
33956 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
33960 C...CHARGINO MASSES
33961 C.....Find eigenvectors of X X^*
33964 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
33965 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
33966 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
33967 &XMU*COS(RMSS(33))*SINB)
33968 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
33969 &XMU*SIN(RMSS(33))*SINB)
33970 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
33971 &XMU*COS(RMSS(33))*SINB)
33972 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
33973 &XMU*SIN(RMSS(33))*SINB)
33974 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
33976 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
33980 IF(WR(2).LT.WR(1)) THEN
33990 S=S+ZR(J,K)**2+ZI(J,K)**2
33993 UMIX(I,J)=ZR(J,K)/SQRT(S)
33994 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
33995 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
33996 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
33999 IF(ABS(SMW(1)).LT.ABS(SMZ(1))) THEN
34000 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
34002 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
34003 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
34005 C.....Find eigenvectors of X^* X
34008 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
34009 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
34010 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
34011 &XMU*COS(RMSS(33))*COSB)
34012 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
34013 &XMU*SIN(RMSS(33))*COSB)
34014 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
34015 &XMU*COS(RMSS(33))*COSB)
34016 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
34017 &XMU*SIN(RMSS(33))*COSB)
34018 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
34020 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
34024 IF(WR(2).LT.WR(1)) THEN
34033 S=S+ZR(J,K)**2+ZI(J,K)**2
34036 VMIX(I,J)=ZR(J,K)/SQRT(S)
34037 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
34038 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
34039 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
34047 C*********************************************************************
34050 C...Calculates the running of M3, the SU(3) gluino mass parameter.
34052 FUNCTION PYRNM3(RGUT)
34054 C...Double precision and integer declarations.
34055 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34056 IMPLICIT INTEGER(I-N)
34057 INTEGER PYK,PYCHGE,PYCOMP
34059 C...Local variables.
34061 DOUBLE PRECISION TOL
34063 DOUBLE PRECISION PYALPS
34065 DATA R/0.61803399D0/
34069 BX=RGUT*PYALPS(RGUT**2)
34070 AX=MIN(50D0,BX*0.5D0)
34071 CX=MAX(2000D0,2D0*BX)
34075 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
34083 F1=ABS(X1-RGUT*AS1)
34085 F2=ABS(X2-RGUT*AS2)
34086 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
34093 F2=ABS(X2-RGUT*AS2)
34100 F1=ABS(X1-RGUT*AS1)
34115 C*********************************************************************
34118 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
34119 C...Specific application: mixing in neutralino sector.
34121 SUBROUTINE PYEIG4(A,W,Z)
34123 C...Double precision and integer declarations.
34124 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34125 IMPLICIT INTEGER(I-N)
34126 INTEGER PYK,PYCHGE,PYCOMP
34128 C...Arrays: in call and local.
34129 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
34131 C...Coefficients of fourth-degree equation from matrix.
34132 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
34133 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
34137 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
34146 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
34147 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
34148 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
34149 B0=B0+(-1D0)**(I+1)*A(1,I)*(
34150 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
34151 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
34152 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
34155 C...Coefficients of third-degree equation needed for
34156 C...separation into two second-degree equations.
34157 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
34160 C0=-B1**2-B0*B3**2+4D0*B0*B2
34161 CQ=C1/3D0-C2**2/9D0
34162 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
34165 C...Cases with one or three real roots.
34166 IF(CQR.GE.0D0) THEN
34167 S1=(CR+SQRT(CQR))**(1D0/3D0)
34168 S2=(CR-SQRT(CQR))**(1D0/3D0)
34172 THE=ACOS(CR/SABS**3)/3D0
34177 C...Find and solve two second-degree equations.
34178 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
34179 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
34180 Q1=U/2D0+SQRT(U**2/4D0-B0)
34181 Q2=U/2D0-SQRT(U**2/4D0-B0)
34182 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
34187 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
34188 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
34189 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
34190 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
34192 C...Order eigenvalues in asceding mass.
34195 DO 130 I2=I1-1,1,-1
34196 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
34202 C...Find equation system for eigenvectors.
34205 D(J1,J1)=A(J1,J1)-W(I)
34212 C...Find largest element in matrix.
34216 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
34219 DAMAX=ABS(D(J1,J2))
34223 C...Subtract others by multiple of row selected above.
34225 DO 210 J3=JA+1,JA+3
34227 RL=D(J1,JB)/D(JA,JB)
34229 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
34230 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
34233 DAMAX=ABS(D(J1,J2))
34237 C...Do one more subtraction of a row.
34239 DO 230 J3=JC+1,JC+3
34241 IF(J1.EQ.JA) GOTO 230
34242 RL=D(J1,JD)/D(JC,JD)
34244 IF(J2.EQ.JB) GOTO 220
34245 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
34246 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
34248 DAMAX=ABS(D(J1,J2))
34252 C...Construct unnormalized eigenvector.
34254 JF2=JD+2-4*((JD+1)/4)
34255 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
34256 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
34259 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
34260 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
34263 C...Normalize and fill in final array.
34264 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
34265 SGN=(-1D0)**INT(PYR(0)+0.5D0)
34274 C*********************************************************************
34277 C...Determines the Higgs boson mass spectrum using several inputs.
34279 SUBROUTINE PYHGGM(ALPHA)
34281 C...Double precision and integer declarations.
34282 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34283 IMPLICIT INTEGER(I-N)
34284 INTEGER PYK,PYCHGE,PYCOMP
34285 C...Parameter statement to help give large particle numbers.
34286 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34287 &KEXCIT=4000000,KDIMEN=5000000)
34289 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34290 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34291 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34292 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34293 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
34295 C...Local variables.
34296 DOUBLE PRECISION AT,AB,XMU,TANB
34297 DOUBLE PRECISION ALPHA
34299 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
34300 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
34301 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
34302 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
34305 IF(IHOPT.EQ.2) THEN
34321 DMC=PMAS(PYCOMP(KSUSY1+37),1)
34328 IF(IHOPT.EQ.0) THEN
34329 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
34330 & DMHCH,DSA,DCA,DTANBA)
34331 ELSEIF(IHOPT.EQ.1) THEN
34332 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
34333 & DMHCH,DSA,DCA,DTANBA)
34334 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
34335 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
34336 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
34342 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
34343 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
34344 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
34345 & PMAS(PYCOMP(1000006),1),DSTOP2
34347 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
34348 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
34349 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
34350 & PMAS(PYCOMP(2000006),1),DSTOP1
34352 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
34353 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
34354 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
34355 & PMAS(PYCOMP(1000005),1),DSBOT2
34357 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
34358 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
34359 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
34360 & PMAS(PYCOMP(2000005),1),DSBOT1
34375 C*********************************************************************
34378 C...This routine computes the renormalization group improved
34379 C...values of Higgs masses and couplings in the MSSM.
34381 C...Program based on the work by M. Carena, J.R. Espinosa,
34382 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
34384 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
34385 C...All masses in GeV units. MA is the CP-odd Higgs mass,
34386 C...MTOP is the physical top mass, MQ and MUR are the soft
34387 C...supersymmetry breaking mass parameters of left handed
34388 C...and right handed stops respectively, AU and AD are the
34389 C...stop and sbottom trilinear soft breaking terms,
34390 C...respectively, and MU is the supersymmetric
34391 C...Higgs mass parameter. We use the conventions from
34392 C...the physics report of Haber and Kane: left right
34393 C...stop mixing term proportional to (AU - MU/TANB)
34394 C...We use as input TANB defined at the scale MTOP
34396 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
34397 C...where MH and HM are the lightest and heaviest CP-even
34398 C...Higgs masses, MHCH is the charged Higgs mass and
34399 C...ALPHA is the Higgs mixing angle
34400 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
34402 C...Range of validity:
34403 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
34404 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
34405 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
34406 C...are the sbottom mass eigenvalues, respectively. This
34407 C...range automatically excludes the existence of tachyons.
34408 C...For the charged Higgs mass computation, the method is
34410 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
34411 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
34412 C...where M_SUSY**2 is the average of the squared stop mass
34413 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
34414 C...masses have been assumed to be of order of the stop ones
34415 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
34417 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
34418 &XMHCH,SA,CA,TANBA)
34420 C...Double precision and integer declarations.
34421 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34422 IMPLICIT INTEGER(I-N)
34423 INTEGER PYK,PYCHGE,PYCOMP
34424 C...Parameter statement to help give large particle numbers.
34425 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34426 &KEXCIT=4000000,KDIMEN=5000000)
34428 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34429 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34430 COMMON/PYHTRI/HHH(7)
34431 SAVE /PYDAT1/,/PYDAT2/
34433 C...Local variables.
34434 DOUBLE PRECISION PYALEM,PYALPS
34435 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
34436 DOUBLE PRECISION XMHCH,SA,CA
34437 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
34438 DOUBLE PRECISION Q02
34439 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
34440 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
34441 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
34442 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
34443 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
34444 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
34445 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
34446 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
34451 ALP1=AEM/(1D0-PARU(102))
34464 C...MBOTTOM(MTOP) = 3. GEV
34465 XMB = PYMRUN(5,XMTOP**2)
34466 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
34467 &LOG(XMTOP**2/XMZ**2))
34469 C...RMTOP= RUNNING TOP QUARK MASS
34470 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
34471 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
34472 T = LOG(XMS**2/XMTOP**2)
34473 SINB = TANB/((1D0 + TANB**2)**0.5D0)
34475 C...IF(MA.LE.XMTOP) TANBA = TANBT
34477 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
34478 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
34479 &LOG(XMA**2/XMTOP**2))
34481 SINBT = TANBT/SQRT(1D0 + TANBT**2)
34482 COSBT = 1D0/SQRT(1D0 + TANBT**2)
34483 C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
34484 G1 = SQRT(ALP1*4D0*PI)
34485 G2 = SQRT(ALP2*4D0*PI)
34486 G3 = SQRT(ALP3*4D0*PI)
34501 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
34502 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
34503 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
34504 &+ 3D0*(AU + AD)**2/XMS2)/6D0
34505 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
34506 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
34507 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
34508 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
34509 &- 16D0*G3**2) *T/16D0/PI2)
34510 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
34511 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
34512 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
34513 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
34514 &- 16D0*G3**2) *T/16D0/PI2)
34515 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
34516 &(HU2 + HD2)*T/16D0/PI2)
34517 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
34518 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
34519 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
34520 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
34521 &- 16D0*G3**2) *T/16D0/PI2)
34522 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
34523 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
34524 &- 16D0*G3**2) *T/16D0/PI2)
34525 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
34526 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
34527 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
34528 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
34530 &(1+ (6D0*HU2 -2D0* HD2
34531 &- 16D0*G3**2) *T/16D0/PI2)
34532 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
34534 &(1+ (6D0*HD2 -2D0* HU2/2D0
34535 &- 16D0*G3**2) *T/16D0/PI2)
34536 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
34537 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
34538 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
34539 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
34540 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
34541 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34542 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
34543 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34544 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
34545 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34546 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
34547 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34555 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
34556 &2D0* XLAM6*SINBT*COSBT
34557 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
34559 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
34561 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
34562 &2D0* XLAM6* COSBT*SINBT
34563 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
34564 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
34565 &((XLAM1* COSBT**2 +2D0*
34566 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
34567 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
34569 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
34570 &+ XLAM4) + XLAM6*COSBT**2
34571 &+ XLAM7* SINBT**2))
34573 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
34574 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
34577 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
34578 XMHCH = SQRT(XMHCH2)
34580 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
34581 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
34582 &XLAM6* COSBT*SINBT
34583 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
34584 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
34585 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
34586 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
34588 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
34589 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
34590 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
34591 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
34592 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
34593 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
34594 &XLAM6* COSBT*SINBT
34595 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
34596 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
34597 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
34607 C*********************************************************************
34610 C...This subroutine computes the CP-even higgs and CP-odd pole
34611 c...Higgs masses and mixing angles.
34613 C...Program based on the work by M. Carena, M. Quiros
34614 C...and C.E.M. Wagner, "Effective potential methods and
34615 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
34617 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
34619 C...where MCHI is the largest chargino mass, MA is the running
34620 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
34621 C...expectaion values at the scale MTOP, MQ is the third generation
34622 C...left handed squark mass parameter, MUR is the third generation
34623 C...right handed stop mass parameter, MDR is the third generation
34624 C...right handed sbottom mass parameter, MTOP is the pole top quark
34625 C...mass; AT,AB are the soft supersymmetry breaking trilinear
34626 C...couplings of the stop and sbottoms, respectively, and MU is the
34627 C...supersymmetric mass parameter
34629 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
34630 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
34631 C...masses are given, what makes the running of the program
34632 c...much faster and it is quite generally a good approximation
34633 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
34634 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
34635 c...and if IHIGGS=3, then h,H,A polarizations are computed
34637 C...Output: MH and MHP which are the lightest CP-even Higgs running
34638 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
34639 C...Higgs running and pole masses, repectively; SA and CA are the
34640 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
34641 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
34642 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
34643 C...the value of TANB at the CP-odd Higgs mass scale
34645 C...This subroutine makes use of CERN library subroutine
34646 C...integration package, which makes the computation of the
34647 C...pole Higgs masses somewhat faster. We thank P. Janot for this
34648 C...improvement. Those who are not able to call the CERN
34649 C...libraries, please use the subroutine SUBHPOLE2.F, which
34650 C...although somewhat slower, gives identical results
34652 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
34653 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
34655 C...Double precision and integer declarations.
34656 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34657 IMPLICIT INTEGER(I-N)
34660 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34662 INTEGER PYK,PYCHGE,PYCOMP
34664 C...Local variables.
34665 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
34666 &SSBOT2(2),B(2,2),COUPB(2,2),
34667 &HCOUPT(2,2),HCOUPB(2,2),
34668 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
34677 RXMT=PYMRUN(6,XMT**2)
34678 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
34679 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
34681 SINB = TANB/(TANB**2+1D0)**0.5D0
34682 COSB = 1D0/(TANB**2+1D0)**0.5D0
34683 COS2B = SINB**2 - COSB**2
34684 SINBPA = SINB*CA + COSB*SA
34685 COSBPA = COSB*CA - SINB*SA
34686 RMBOT = PYMRUN(5,XMT**2)
34689 IF(XMUR.LT.0D0) XMUR2=-XMUR2
34691 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
34692 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
34693 IF(XMST11.LT.0D0) GOTO 500
34694 IF(XMST22.LT.0D0) GOTO 500
34695 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
34696 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
34697 IF(XMSB11.LT.0D0) GOTO 500
34698 IF(XMSB22.LT.0D0) GOTO 500
34699 C WMST11 = RXMT**2 + XMQ2
34700 C WMST22 = RXMT**2 + XMUR2
34701 XMST12 = RXMT*(AT - XMU/TANB)
34702 XMSB12 = RMBOT*(AB - XMU*TANB)
34704 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34705 C...STOP EIGENVALUES CALCULATION
34706 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34708 STOP12 = 0.5D0*(XMST11+XMST22) +
34709 &0.5D0*((XMST11+XMST22)**2 -
34710 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
34711 STOP22 = 0.5D0*(XMST11+XMST22) -
34712 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
34713 &XMST12**2))**0.5D0
34715 IF(STOP22.LT.0D0) GOTO 500
34718 STOP1 = STOP12**0.5D0
34719 STOP2 = STOP22**0.5D0
34723 IF(XMST12.EQ.0D0) XST11 = 1D0
34724 IF(XMST12.EQ.0D0) XST12 = 0D0
34725 IF(XMST12.EQ.0D0) XST21 = 0D0
34726 IF(XMST12.EQ.0D0) XST22 = 1D0
34728 IF(XMST12.EQ.0D0) GOTO 110
34730 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
34731 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
34732 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
34733 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
34740 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
34741 &0.5D0*((XMSB11+XMSB22)**2 -
34742 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
34743 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
34744 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
34745 &XMSB12**2))**0.5D0
34746 IF(SBOT22.LT.0D0) GOTO 500
34747 SBOT1 = SBOT12**0.5D0
34748 SBOT2 = SBOT22**0.5D0
34753 IF(XMSB12.EQ.0D0) XSB11 = 1D0
34754 IF(XMSB12.EQ.0D0) XSB12 = 0D0
34755 IF(XMSB12.EQ.0D0) XSB21 = 0D0
34756 IF(XMSB12.EQ.0D0) XSB22 = 1D0
34758 IF(XMSB12.EQ.0D0) GOTO 130
34760 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
34761 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
34762 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
34763 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
34775 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34776 C...STARTING OF LIGHT HIGGS
34777 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34779 IF(IHIGGS.EQ.0) GOTO 490
34784 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
34785 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
34786 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
34787 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
34796 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
34797 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
34798 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
34799 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
34807 180 ITER = ITER + 1
34810 PR(I3)=PRUN+(I3-2)*EPS/2
34815 POLT = POLT + COUPT(I,J)**2*3D0*
34816 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
34823 POLB = POLB + COUPB(I,J)**2*3D0*
34824 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
34831 & 3D0*RXMT**2/8D0/PI**2/ V **2*
34833 & (-2D0*XMT**2+0.5D0*P2)*
34834 & PYFINT(P2,XMT2,XMT2)
34836 POL = POLT + POLB + POLTT
34837 POLAR(I3) = P2 - XMH**2 - POL
34839 DERIV = (POLAR(3)-POLAR(1))/EPS
34840 DRUN = - POLAR(2)/DERIV
34843 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
34849 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34850 C...END OF LIGHT HIGGS
34851 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34853 250 IF(IHIGGS.EQ.1) GOTO 490
34855 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34856 C... STARTING OF HEAVY HIGGS
34857 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34862 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
34863 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
34864 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
34865 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
34873 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
34874 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
34875 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
34876 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
34885 300 ITER = ITER + 1
34887 PR(I3)=PRUN+(I3-2)*EPS/2
34893 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
34894 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
34901 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
34902 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
34910 & 3D0*RXMT**2/8D0/PI**2/ V **2*
34912 & (-2D0*XMT**2+0.5D0*HP2)*
34913 & PYFINT(HP2,XMT2,XMT2)
34915 HPOL = HPOLT + HPOLB + HPOLTT
34916 POLAR(I3) =HP2-HM**2-HPOL
34918 DERIV = (POLAR(3)-POLAR(1))/EPS
34919 DRUN = - POLAR(2)/DERIV
34922 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
34930 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34931 C... END OF HEAVY HIGGS
34932 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34934 IF(IHIGGS.EQ.2) GOTO 490
34936 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34937 C...BEGINNING OF PSEUDOSCALAR HIGGS
34938 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34943 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
34944 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
34950 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
34951 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
34958 420 ITER = ITER + 1
34960 PR(I3)=PRUN+(I3-2)*EPS/2
34965 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
34966 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
34972 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
34973 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
34979 & 3D0*RXMT**2/8D0/PI**2/ V **2*
34980 & COSB**2/SINB**2 *
34982 & PYFINT(AP2,XMT2,XMT2)
34983 APOL = APOLT + APOLB + APOLTT
34984 POLAR(I3) = AP2 - XMA**2 -APOL
34986 DERIV = (POLAR(3)-POLAR(1))/EPS
34987 DRUN = - POLAR(2)/DERIV
34990 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
34996 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34997 C...END OF PSEUDOSCALAR HIGGS
34998 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35000 IF(IHIGGS.EQ.3) GOTO 490
35005 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
35006 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
35007 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
35008 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
35012 C*********************************************************************
35015 C...Auxiliary to PYPOLE.
35017 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
35018 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
35019 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
35020 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
35023 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35034 C MBOTTOM(MTOP) = 3. GEV
35035 MB = PYMRUN(5,MTOP**2)
35036 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
35037 *LOG(MTOP**2/MZ**2))
35038 C RMTOP= RUNNING TOP QUARK MASS
35039 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
35040 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
35041 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
35042 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
35043 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35045 C NEW DEFINITION, TGLU.
35047 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35048 TGLU = LOG(MGLU**2/MTOP**2)
35049 SINB = TANB/DSQRT(1D0 + TANB**2)
35052 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
35053 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
35054 *LOG(MA**2/MTOP**2))
35055 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
35056 SINB = TANBT/SQRT(1D0 + TANBT**2)
35057 COSB = 1D0/DSQRT(1D0 + TANBT**2)
35058 G1 = SQRT(ALPHA1*4D0*PI)
35059 G2 = SQRT(ALPHA2*4D0*PI)
35060 G3 = SQRT(ALPHA3*4D0*PI)
35063 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
35064 *SBOT1,SBOT2,DELTAMT,DELTAMB)
35065 IF(MQ.GT.MUR) TP = TQ - TU
35066 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
35067 IF(MQ.GT.MUR) TDP = TU
35068 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
35069 IF(MQ.GT.MD) TPD = TQ - TD
35070 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
35071 IF(MQ.GT.MD) TDPD = TD
35072 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
35074 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
35075 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
35076 * HD**2*(G1**2/3D0+G2**2)*TPD
35078 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
35079 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
35080 * HU**2*(-G1**2/3D0+G2**2)*TP
35082 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35084 C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
35085 C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
35086 C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
35090 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35093 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
35094 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
35095 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
35098 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
35099 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
35102 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
35103 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
35106 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
35107 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
35110 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
35111 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
35114 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
35115 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
35120 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
35121 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
35122 *(G2**2-G1**2/3D0)*TPD
35123 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
35124 *1D0/16D0/PI**2*G1**2*HU**2*TP
35125 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
35126 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
35127 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
35128 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
35130 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
35131 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
35132 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
35133 *+ (3D0*HD**2/2D0 + HU**2/2D0
35134 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
35135 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
35136 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
35137 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
35138 *(TP + TDP)/8D0/PI**2)
35139 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
35140 *+ (3D0*HU**2/2D0 + HD**2/2D0
35141 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
35142 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
35143 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
35144 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
35145 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
35146 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
35147 LAMBDA4 = (- G2**2/2D0)*(1D0
35148 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
35149 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
35155 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
35156 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
35158 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
35159 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
35160 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
35161 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
35164 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35165 CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
35166 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35168 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
35170 IF(MCHI.GT.MSSUSY) GOTO 100
35171 IF(MCHI.LT.MTOP) MCHI=MTOP
35173 TCHAR=LOG(MSSUSY**2/MCHI**2)
35175 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
35176 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
35177 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
35179 DELTAM112=2D0*DELTAL12*V**2*COSB**2
35180 DELTAM222=2D0*DELTAL12*V**2*SINB**2
35181 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
35183 M2(1,1)=M2(1,1)+DELTAM112
35184 M2(2,2)=M2(2,2)+DELTAM222
35185 M2(1,2)=M2(1,2)+DELTAM122
35186 M2(2,1)=M2(2,1)+DELTAM122
35190 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35191 CCC END OF CHARGINOS/NEUTRALINOS
35192 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35196 M2P(I,J) = M2(I,J) + VH(I,J)
35199 TRM2P = M2P(1,1) + M2P(2,2)
35200 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
35201 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
35202 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
35204 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
35206 IF(MH2P.LT.0.) GOTO 130
35208 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
35209 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
35210 IF(COS2ALPHA.GE.0.) THEN
35211 ALPHA = ASIN(SIN2ALPHA)/2D0
35213 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
35217 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35219 C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
35220 C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
35221 C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
35224 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35225 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
35226 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
35231 C*********************************************************************
35234 C...Auxiliary to PYRGHM.
35236 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
35237 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
35238 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
35239 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
35241 INTEGER MSTU,MSTJ,KCHG
35242 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35243 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35244 SAVE /PYDAT1/,/PYDAT2/
35246 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
35248 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
35249 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
35251 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
35256 SINBA = TANBA/DSQRT(TANBA**2+1D0)
35257 COSBA = SINBA/TANBA
35259 SINB = TANB/DSQRT(TANB**2+1D0)
35265 SW = 1D0-MW**2/MZ**2
35268 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
35269 G2 = DSQRT(0.0336D0*4D0*PI)
35270 G1 = DSQRT(0.0101D0*4D0*PI)
35272 IF(MQ.GT.MUR) MST = MQ
35273 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
35275 MSUSYT = DSQRT(MST**2 + MTOP**2)
35277 IF(MQ.GT.MD) MSB = MQ
35278 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
35280 MB = PYMRUN(5,MSB**2)
35281 MSUSYB = DSQRT(MSB**2 + MB**2)
35282 TT = LOG(MSUSYT**2/MTOP**2)
35283 TB = LOG(MSUSYB**2/MTOP**2)
35285 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
35286 HT = RMTOP/(V*SINB)
35289 G32 = ALPHA3*4D0*PI
35290 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
35291 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
35292 AL2 = 3D0/8D0/PI**2*HT**2
35293 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
35294 C ALST = 3./8./PI**2*HTST**2
35295 AL1 = 3D0/8D0/PI**2*HB**2
35298 AL(1,2) = (AL2+AL1)/2D0
35299 AL(2,1) = (AL2+AL1)/2D0
35302 IF(MA.GT.MTOP) THEN
35303 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
35304 * LOG(MTOP**2/MA**2))
35307 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
35308 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
35309 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
35310 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
35315 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
35316 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
35317 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
35318 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
35322 SINBT = TANBST/DSQRT(1D0+TANBST**2)
35325 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
35326 COSBB = SINBB/TANBSB
35331 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
35332 MTOP2 = DSQRT(MTOP4)
35333 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
35334 * /(1D0+DELTAMB)**4
35335 MBOT2 = DSQRT(MBOT4)
35337 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
35338 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35339 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35340 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
35341 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
35342 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35343 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35344 * MQ2 - MUR2)**2*0.25D0
35345 * + MTOP2*(AT-XMU/TANBST)**2)
35346 IF(STOP22.LT.0.) GOTO 120
35347 SBOT12 = (MQ2 + MD2)*.5D0
35348 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35349 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35350 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35351 SBOT22 = (MQ2 + MD2)*.5D0
35352 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35353 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35354 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35355 IF(SBOT22.LT.0.) SBOT22 = 10000D0
35357 STOP1 = DSQRT(STOP12)
35358 STOP2 = DSQRT(STOP22)
35359 SBOT1 = DSQRT(SBOT12)
35360 SBOT2 = DSQRT(SBOT22)
35362 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35364 C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
35365 C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
35366 C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
35367 C INDUCED CORRECTIONS.
35369 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35374 IF(X.EQ.Y) X = X - 0.00001D0
35375 IF(X.EQ.Z) X = X - 0.00002D0
35376 IF(Y.EQ.Z) Y = Y - 0.00003D0
35382 IF(X.EQ.Y) X = X - 0.00001D0
35383 IF(X.EQ.Z) X = X - 0.00002D0
35384 IF(Y.EQ.Z) Y = Y - 0.00003D0
35386 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
35387 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
35391 IF(X.EQ.Y) X = X - 0.00001D0
35392 IF(X.EQ.Z) X = X - 0.00002D0
35393 IF(Y.EQ.Z) Y = Y - 0.00003D0
35395 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
35397 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35399 C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
35400 C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
35401 C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
35402 C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
35403 C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
35404 C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
35405 C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
35406 C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
35407 C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
35408 C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
35409 C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
35412 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35414 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
35415 MTOP2 = DSQRT(MTOP4)
35416 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
35417 * /(1D0+DELTAMB)**4
35418 MBOT2 = DSQRT(MBOT4)
35420 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
35421 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35422 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35423 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
35424 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
35425 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35426 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35427 * MQ2 - MUR2)**2*0.25D0
35428 * + MTOP2*(AT-XMU/TANBST)**2)
35430 IF(STOP22.LT.0.) GOTO 120
35431 SBOT12 = (MQ2 + MD2)*.5D0
35432 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35433 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35434 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35435 SBOT22 = (MQ2 + MD2)*.5D0
35436 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35437 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35438 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35439 IF(SBOT22.LT.0.) GOTO 120
35442 STOP1 = DSQRT(STOP12)
35443 STOP2 = DSQRT(STOP22)
35444 SBOT1 = DSQRT(SBOT12)
35445 SBOT2 = DSQRT(SBOT22)
35447 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35449 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35452 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
35454 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
35455 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
35457 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
35459 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
35460 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
35462 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
35463 * (-.5D0*LOG(STOP12/STOP22)
35464 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
35465 * G(STOP12,STOP22))
35467 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
35468 * (.5D0*LOG(SBOT12/SBOT22)
35469 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
35470 * G(SBOT12,SBOT22))
35472 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
35473 * (MQ2+MBOT2)/(MD2+MBOT2))
35474 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
35475 * LOG(SBOT1**2/SBOT2**2)) +
35476 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
35477 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
35480 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
35481 * -STOP2**2))**2*G(STOP12,STOP22)
35483 VH3B(1,1)=VH3B(1,1)+
35484 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
35486 VH3T(1,1) = VH3T(1,1) +
35487 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
35489 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
35490 * (MQ2+MTOP2)/(MUR2+MTOP2))
35491 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
35492 * LOG(STOP1**2/STOP2**2)) +
35493 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
35494 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
35497 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
35498 * -SBOT2**2))**2*G(SBOT12,SBOT22)
35500 VH3T(2,2)=VH3T(2,2)+
35501 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
35502 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
35504 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
35505 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
35506 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
35509 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
35510 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
35511 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
35514 VH3T(1,2)=VH3T(1,2) +
35515 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
35517 VH3B(1,2)=VH3B(1,2) +
35518 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
35520 VH3T(2,1) = VH3T(1,2)
35521 VH3B(2,1) = VH3B(1,2)
35523 C TQ = LOG((MQ2 + MTOP2)/MTOP2)
35524 C TU = LOG((MUR2+MTOP2)/MTOP2)
35525 C TQD = LOG((MQ2 + MB**2)/MB**2)
35526 C TD = LOG((MD2+MB**2)/MB**2)
35531 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
35532 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
35533 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
35534 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
35553 C*********************************************************************
35556 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
35558 FUNCTION PYFINT(A,B,C)
35560 C...Double precision and integer declarations.
35561 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35562 IMPLICIT INTEGER(I-N)
35563 INTEGER PYK,PYCHGE,PYCOMP
35565 COMMON/PYINTS/XXM(20)
35568 C...Local variables.
35570 DOUBLE PRECISION PYFISB
35577 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
35582 C*********************************************************************
35585 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
35589 C...Double precision and integer declarations.
35590 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35591 IMPLICIT INTEGER(I-N)
35592 INTEGER PYK,PYCHGE,PYCOMP
35594 COMMON/PYINTS/XXM(20)
35597 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
35598 &(X*(XXM(2)-XXM(3))+XXM(3)))
35603 C*********************************************************************
35606 C...Calculates decays of sfermions.
35608 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
35610 C...Double precision and integer declarations.
35611 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35612 IMPLICIT INTEGER(I-N)
35613 INTEGER PYK,PYCHGE,PYCOMP
35614 C...Parameter statement to help give large particle numbers.
35615 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35616 &KEXCIT=4000000,KDIMEN=5000000)
35618 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35619 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35620 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35621 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35622 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35623 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
35625 C...Local variables.
35626 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
35627 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
35629 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
35630 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
35631 DOUBLE PRECISION PYLAMF,XL
35632 DOUBLE PRECISION TANW,XW,AEM,C1,AS
35633 DOUBLE PRECISION AL,AR,BL,BR
35634 DOUBLE PRECISION CH1,CH2,CH3,CH4
35635 DOUBLE PRECISION XMBOT,XMTOP
35636 DOUBLE PRECISION XLAM(0:400)
35637 INTEGER IDLAM(400,3)
35638 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
35639 DOUBLE PRECISION SR2
35640 DOUBLE PRECISION CBETA,SBETA
35641 DOUBLE PRECISION CW
35642 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
35643 DOUBLE PRECISION COSA,SINA,TANB
35644 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
35645 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
35647 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
35648 DATA IGG/23,25,35,36/
35649 DATA PI/3.141592654D0/
35650 DATA SR2/1.4142136D0/
35651 DATA KFNCHI/1000022,1000023,1000025,1000035/
35652 DATA KFCCHI/1000024,1000037/
35654 C...COUNT THE NUMBER OF DECAY MODES
35658 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
35659 &KFIN.EQ.KSUSY2+16) RETURN
35665 TANW = SQRT(XW/(1D0-XW))
35670 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
35675 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
35676 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
35682 C...ILR is 1 for left and 2 for right.
35684 C...IFL is matching non-SUSY flavour.
35685 IFL=MOD(KFIN,KSUSY1)
35686 C...IDU is weak isospin, 1 for down and 2 for up.
35697 XMBOT=PYMRUN(5,XMI2)
35698 XMTOP=PYMRUN(6,XMI2)
35712 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
35714 IF(IMSS(11).EQ.1) THEN
35717 XMGR=PMAS(PYCOMP(IDG),1)
35718 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
35721 ELSEIF(IFL.EQ.6) THEN
35726 IF(XMI.GT.XMGR+XMF) THEN
35731 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
35735 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
35737 C...CHARGED DECAYS:
35739 C...DI -> U CHI1-,CHI2-
35743 C...UI -> D CHI1+,CHI2+
35750 IF(XMI.GE.AXMJ+XMFP) THEN
35757 ELSEIF(IFL.LT.6) THEN
35762 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
35763 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
35769 ELSEIF(IFL.LT.5) THEN
35774 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
35775 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
35779 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
35780 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
35781 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
35782 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
35798 XL=PYLAMF(XMI2,XMA2,XMB2)
35799 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
35800 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
35801 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
35804 IDLAM(LKNT,1)=-KFCCHI(IX)
35805 IDLAM(LKNT,2)=IFL+1
35807 IDLAM(LKNT,1)=KFCCHI(IX)
35808 IDLAM(LKNT,2)=IFL-1
35819 IF(XMI.GE.AXMJ+XMF) THEN
35825 ELSEIF(IFL.LT.5) THEN
35828 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
35829 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
35830 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
35835 ELSEIF(IFL.LT.5) THEN
35838 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
35839 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
35840 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
35844 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
35845 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
35846 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
35847 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
35863 XL=PYLAMF(XMI2,XMA2,XMB2)
35864 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
35865 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
35866 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
35867 IDLAM(LKNT,1)=KFNCHI(IX)
35873 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
35877 IF(ILR.EQ.1) GOTO 160
35879 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
35880 IF(XMI.LT.XMSF1+XMB) GOTO 160
35882 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
35885 ELSEIF(IG.EQ.25) THEN
35888 ELSEIF(IFL.EQ.6) THEN
35890 ELSEIF(IFL.LT.5) THEN
35896 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
35897 & XMF**2/XMW*COSA/SBETA
35898 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
35899 & XMF**2/XMW*COSA/SBETA
35901 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
35902 & XMF**2/XMW*(-SINA)/CBETA
35903 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
35904 & XMF**2/XMW*(-SINA)/CBETA
35908 ELSEIF(IFL.EQ.6) THEN
35910 ELSEIF(IFL.EQ.15) THEN
35915 C.........need to complexify
35917 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
35920 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
35926 ELSEIF(IG.EQ.35) THEN
35929 ELSEIF(IFL.EQ.6) THEN
35931 ELSEIF(IFL.LT.5) THEN
35937 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
35938 & XMF**2/XMW*SINA/SBETA
35939 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
35940 & XMF**2/XMW*SINA/SBETA
35942 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
35943 & XMF**2/XMW*COSA/CBETA
35944 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
35945 & XMF**2/XMW*COSA/CBETA
35949 ELSEIF(IFL.EQ.6) THEN
35951 ELSEIF(IFL.EQ.15) THEN
35956 C.........Need to complexify
35958 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
35961 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
35967 ELSEIF(IG.EQ.36) THEN
35972 ELSEIF(IFL.EQ.6) THEN
35974 ELSEIF(IFL.LT.5) THEN
35981 ELSEIF(IFL.EQ.6) THEN
35983 ELSEIF(IFL.EQ.15) THEN
35988 C.........Need to complexify
35990 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
35992 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
35998 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
35999 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
36000 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
36001 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36004 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
36006 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
36009 IDLAM(LKNT,1)=KFIN-KSUSY1
36015 IF(MOD(IFL,2).EQ.0) THEN
36021 XMSF1=PMAS(PYCOMP(KF1),1)
36022 XMSF2=PMAS(PYCOMP(KF2),1)
36023 IF(XMI.GT.XMB+XMSF1) THEN
36024 IF(MOD(IFL,2).EQ.0) THEN
36026 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
36028 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
36032 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
36034 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
36037 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36039 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
36042 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
36044 IF(XMI.GT.XMB+XMSF2) THEN
36045 IF(MOD(IFL,2).EQ.0) THEN
36047 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
36049 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
36053 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
36055 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
36058 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
36060 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
36063 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
36068 IF(MOD(IFL,2).EQ.0) THEN
36074 XMSF1=PMAS(PYCOMP(KF1),1)
36075 XMSF2=PMAS(PYCOMP(KF2),1)
36076 IF(XMI.GT.XMB+XMSF1) THEN
36081 IF(MOD(IFL,2).EQ.0) THEN
36084 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
36085 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
36086 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
36087 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
36090 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
36091 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
36092 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
36093 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
36104 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
36105 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
36106 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
36107 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
36110 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
36111 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
36112 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
36113 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
36122 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36124 C.......Need to complexify
36125 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
36126 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
36127 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
36128 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
36131 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
36133 IF(XMI.GT.XMB+XMSF2) THEN
36138 IF(MOD(IFL,2).EQ.0) THEN
36141 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
36142 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
36143 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
36144 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
36147 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
36148 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
36149 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
36150 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
36161 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
36162 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
36163 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
36164 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
36167 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
36168 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
36169 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
36170 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
36179 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36181 C.......Need to complexify
36182 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
36183 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
36184 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
36185 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
36188 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
36191 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
36196 IF(IFL.EQ.6) XMF=PMAS(6,1)
36197 IF(IFL.EQ.5) XMF=PMAS(5,1)
36198 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
36200 IF(XMI.GE.AXMJ+XMF) THEN
36217 XL=PYLAMF(XMI2,XMA2,XMB2)
36218 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
36219 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
36220 IDLAM(LKNT,1)=KSUSY1+21
36226 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
36227 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
36228 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
36229 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
36230 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
36231 C...M*M = C1**2 * G**2/(16PI**2)
36232 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
36234 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
36235 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
36236 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
36237 IDLAM(LKNT,1)=KSUSY1+22
36242 C...R-violating sfermion decays (SKANDS).
36243 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
36248 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
36249 XLAM(0)=XLAM(0)+XLAM(I)
36251 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
36256 C*********************************************************************
36259 C...Calculates gluino decay modes.
36261 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
36263 C...Double precision and integer declarations.
36264 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36265 IMPLICIT INTEGER(I-N)
36266 INTEGER PYK,PYCHGE,PYCOMP
36267 C...Parameter statement to help give large particle numbers.
36268 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36269 &KEXCIT=4000000,KDIMEN=5000000)
36271 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36272 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36273 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36274 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36275 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36277 C COMMON/PYINTS/XXM(20)
36279 COMMON/PYINTC/XXC(10),CXC(8)
36280 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
36282 C...Local variables
36283 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
36284 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
36285 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
36286 DOUBLE PRECISION PYLAMF,XL
36287 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
36288 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
36289 DOUBLE PRECISION XLAM(0:400)
36290 INTEGER IDLAM(400,3)
36291 INTEGER LKNT,IX,ILR,I,IKNT,IFL
36292 DOUBLE PRECISION SR2
36293 DOUBLE PRECISION GAM
36294 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
36295 EXTERNAL PYGAUS,PYXXZ6
36296 DOUBLE PRECISION PYGAUS,PYXXZ6
36297 DOUBLE PRECISION PREC
36298 INTEGER KFNCHI(4),KFCCHI(2)
36299 DATA PI/3.141592654D0/
36300 DATA SR2/1.4142136D0/
36302 DATA KFNCHI/1000022,1000023,1000025,1000035/
36303 DATA KFCCHI/1000024,1000037/
36305 C...COUNT THE NUMBER OF DECAY MODES
36307 IF(KFIN.NE.KSUSY1+21) RETURN
36311 TANW = SQRT(XW/(1D0-XW))
36321 XMI=SIGN(XMI,RMSS(3))
36323 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
36325 IF(IMSS(11).EQ.1) THEN
36328 XMGR=PMAS(PYCOMP(IDG),1)
36329 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
36330 IF(AXMI.GT.XMGR) THEN
36339 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
36343 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
36346 IF(AXMI.GE.AXMJ+XMF) THEN
36347 C...Minus sign difference from gluino-quark-squark feynman rules
36364 XL=PYLAMF(XMI2,XMA2,XMB2)
36365 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
36366 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
36367 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
36371 XLAM(LKNT)=XLAM(LKNT-1)
36372 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36373 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36379 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
36380 C...GLUINO -> NI Q QBAR
36384 IF(AXMI.GE.AXMJ) THEN
36386 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
36388 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
36395 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
36396 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
36402 T3I=SIGN(1D0,EI+1D-6)/2D0
36403 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36404 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36408 CXC(4)=DCONJG(GLIJ)
36412 CXC(8)=-DCONJG(GRIJ)
36414 S12MAX=(AXMI-AXMJ)**2
36415 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
36416 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
36418 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
36419 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
36420 IDLAM(LKNT,1)=KFNCHI(IX)
36424 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
36426 XLAM(LKNT)=XLAM(LKNT-1)
36427 IDLAM(LKNT,1)=KFNCHI(IX)
36432 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
36433 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
36434 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
36436 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
36437 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
36439 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
36442 IDLAM(LKNT,1)=KFNCHI(IX)
36445 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
36450 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
36451 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
36452 C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
36456 T3I=SIGN(1D0,EI+1D-6)/2D0
36457 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36458 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36460 CXC(4)=DCONJG(GLIJ)
36462 CXC(8)=-DCONJG(GRIJ)
36463 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
36464 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
36466 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
36467 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
36468 IDLAM(LKNT,1)=KFNCHI(IX)
36472 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
36474 XLAM(LKNT)=XLAM(LKNT-1)
36475 IDLAM(LKNT,1)=KFNCHI(IX)
36480 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
36481 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
36483 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
36484 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
36485 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
36487 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
36488 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
36490 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
36493 IDLAM(LKNT,1)=KFNCHI(IX)
36496 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
36502 C...GLUINO -> CI Q QBAR'
36506 IF(AXMI.GE.AXMJ) THEN
36508 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
36509 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
36512 S12MAX=(AXMI-AXMJ)**2
36517 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
36518 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
36521 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
36523 CXC(1)=DCMPLX(0D0,0D0)
36524 CXC(3)=DCMPLX(0D0,0D0)
36525 CXC(5)=DCMPLX(0D0,0D0)
36526 CXC(7)=DCMPLX(0D0,0D0)
36527 CXC(2)=UMIXC(IX,1)*OLPP/SR2
36528 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
36529 CXC(6)=DCMPLX(0D0,0D0)
36530 CXC(8)=DCMPLX(0D0,0D0)
36531 IF(XXC(5).LT.AXMI) THEN
36533 ELSEIF(XXC(6).LT.AXMI) THEN
36538 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
36539 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
36541 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
36542 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36543 IDLAM(LKNT,1)=KFCCHI(IX)
36547 XLAM(LKNT)=XLAM(LKNT-1)
36548 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36549 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36550 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36552 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
36554 XLAM(LKNT)=XLAM(LKNT-1)
36555 IDLAM(LKNT,1)=KFCCHI(IX)
36559 XLAM(LKNT)=XLAM(LKNT-1)
36560 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36561 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36562 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36568 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
36569 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
36570 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
36571 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
36572 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
36573 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
36574 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
36575 IF(XMI.GT.PMOLT2+XMF) PMOLT2=100D0*AXMI
36576 IF(XMI.GT.PMOLT1+XMF) PMOLT1=100D0*AXMI
36577 IF(XMI.GT.PMOLB2+XMFP) PMOLB2=100D0*AXMI
36578 IF(XMI.GT.PMOLB1+XMFP) PMOLB1=100D0*AXMI
36579 CALL PYTBBC(IX,100,XMI,GAM)
36582 IDLAM(LKNT,1)=KFCCHI(IX)
36586 XLAM(LKNT)=XLAM(LKNT-1)
36587 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36588 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36589 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36590 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
36591 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
36592 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
36593 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
36599 C...R-parity violating (3-body) decays.
36600 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
36605 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
36606 XLAM(0)=XLAM(0)+XLAM(I)
36608 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
36613 C*********************************************************************
36616 C...Calculates the three-body decay of gluinos into
36617 C...neutralinos and third generation fermions.
36619 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
36621 C...Double precision and integer declarations.
36622 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36623 IMPLICIT INTEGER(I-N)
36624 INTEGER PYK,PYCHGE,PYCOMP
36625 C...Parameter statement to help give large particle numbers.
36626 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36627 &KEXCIT=4000000,KDIMEN=5000000)
36629 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36630 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36631 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36632 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36633 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36634 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
36636 C...Local variables.
36637 EXTERNAL PYSIMP,PYLAMF
36638 DOUBLE PRECISION PYSIMP,PYLAMF
36640 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
36641 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
36642 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
36643 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
36644 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
36645 DOUBLE PRECISION XLN1,XLN2,B1,B2
36646 DOUBLE PRECISION E,XMGLU,GAM
36647 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
36648 SAVE HRB,HLB,FLB,FRB
36649 DOUBLE PRECISION ALPHAW,ALPHAS
36650 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
36651 SAVE HLT,HRT,FLT,FRT
36652 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
36654 DOUBLE PRECISION AMBOT,SINC,COSC
36655 DOUBLE PRECISION AMTOP,SINA,COSA
36656 DOUBLE PRECISION SINW,COSW,TANW
36657 DOUBLE PRECISION ROT1(4,4)
36660 DATA IFIRST/.TRUE./
36663 SINB=TANB/SQRT(1D0+TANB**2)
36674 AMBOT=PYMRUN(5,XMGLU**2)
36675 AMTOP=PYMRUN(6,XMGLU**2)
36677 FAKT1=AMBOT/W2/AMW/COSB
36678 FAKT2=AMTOP/W2/AMW/SINB
36689 ROT1(2,1)=-ROT1(1,2)
36690 ROT1(2,2)=ROT1(1,1)
36693 ROT1(4,3)=-ROT1(3,4)
36694 ROT1(4,4)=ROT1(3,3)
36698 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
36703 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
36704 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
36705 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
36707 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
36708 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
36709 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
36710 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
36713 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
36714 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
36715 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
36716 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
36717 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
36718 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
36719 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
36723 C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
36724 C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
36725 C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
36726 C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
36730 IF(NINT(3D0*E).EQ.2) THEN
36737 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
36738 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
36747 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
36748 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
36754 SIN2D=SIND*COSD*2D0
36768 ALPHAW=PYALEM(XMG2)
36769 ALPHAS=PYALPS(XMG2)
36773 XM24=(XMG2+XM2)*(XM2+XMR2)
36775 SMAX=(XMG-ABS(XMR))**2
36776 XMQA=XMG2+2D0*XM2+XMR2
36778 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
36780 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
36782 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
36783 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
36784 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
36785 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
36786 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
36787 & +2D0*(FF*SIND2-HH*COSD2))*W
36788 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
36789 & +4D0*HFL*XM*XMR)*XLN1
36790 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
36791 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
36792 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
36793 & +8D0*HFL*XMQ4*SIN2D)*B1
36794 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
36795 & +4D0*HFR*XMR*XM)*XLN2
36796 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
36797 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
36798 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
36799 & -8D0*HFR*XMQ4*SIN2D)*B2
36800 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
36801 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
36802 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
36803 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
36804 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
36805 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
36806 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
36807 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
36808 G(5)=(2D0*(HH*COSD2-FF*SIND2)
36809 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
36810 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
36811 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
36812 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
36813 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
36814 & +COS2D*XM*(SBAR+XMG2-XMR2))
36815 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
36816 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
36817 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
36818 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
36819 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
36820 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
36821 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
36824 SUMME(LIN)=SUMME(LIN)+G(J)
36829 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
36830 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
36835 C*********************************************************************
36838 C...Calculates the three-body decay of gluinos into
36839 C...charginos and third generation fermions.
36841 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
36843 C...Double precision and integer declarations.
36844 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36845 IMPLICIT INTEGER(I-N)
36846 INTEGER PYK,PYCHGE,PYCOMP
36847 C...Parameter statement to help give large particle numbers.
36848 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36849 &KEXCIT=4000000,KDIMEN=5000000)
36851 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36852 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36853 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36854 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36855 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36856 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
36858 C...Local variables.
36859 EXTERNAL PYSIMP,PYLAMF
36860 DOUBLE PRECISION PYSIMP,PYLAMF
36862 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
36863 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
36864 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
36865 DOUBLE PRECISION SUMME(0:100),A(4,8)
36866 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
36867 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
36868 DOUBLE PRECISION XMGLU,GAM
36869 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
36870 &DDD(2),EEE(2),FFF(2)
36871 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
36872 DOUBLE PRECISION ALPHAW,ALPHAS
36873 DOUBLE PRECISION AMC(2)
36875 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
36876 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
36880 DATA IFIRST/.TRUE./
36883 SINB=TANB/SQRT(1D0+TANB**2)
36891 AMBOT=PYMRUN(5,XMGLU**2)
36892 AMTOP=PYMRUN(6,XMGLU**2)
36895 FAKT1=AMBOT/W2/AMW/COSB
36896 FAKT2=AMTOP/W2/AMW/SINB
36901 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
36902 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
36903 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
36904 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
36905 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
36906 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
36907 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
36908 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
36910 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
36911 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
36912 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
36913 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
36917 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
36918 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
36919 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
36920 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
36922 COS2A=COSA**2-SINA**2
36923 SIN2A=SINA*COSA*2D0
36924 COS2C=COSC**2-SINC**2
36925 SIN2C=SINC*COSC*2D0
36932 ALPHAW=PYALEM(XMG2)
36933 ALPHAS=PYALPS(XMG2)
36937 XMQ2=XMG2+XMT2+XMB2+XMR2
36938 XMQ4=XMG*XMT*XMB*XMR
36939 XMQ3=XMG2*XMR2+XMT2*XMB2
36940 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
36941 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
36943 XMST(1)=AMST(1)*AMST(1)
36944 XMST(2)=AMST(1)*AMST(1)
36945 XMST(3)=AMST(2)*AMST(2)
36946 XMST(4)=AMST(2)*AMST(2)
36947 XMSB(1)=AMSB(1)*AMSB(1)
36948 XMSB(2)=AMSB(2)*AMSB(2)
36949 XMSB(3)=AMSB(1)*AMSB(1)
36950 XMSB(4)=AMSB(2)*AMSB(2)
36952 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
36953 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
36954 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
36955 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
36956 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
36957 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
36958 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
36959 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
36961 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
36962 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
36963 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
36964 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
36965 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
36966 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
36967 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
36968 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
36970 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
36971 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
36972 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
36973 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
36974 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
36975 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
36976 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
36977 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
36979 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
36980 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
36981 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
36982 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
36983 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
36984 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
36985 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
36986 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
36988 SMAX=(XMG-ABS(XMR))**2
36989 SMIN=(XMB+XMT)**2+0.1D0
36992 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
36993 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
36995 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
36996 W=DSQRT(W)/2D0/SBAR
36997 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
36998 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
36999 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
37000 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
37001 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
37002 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
37003 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
37004 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
37005 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
37006 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
37007 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
37008 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
37009 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
37010 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
37011 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
37012 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
37013 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
37014 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
37015 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
37016 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
37017 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
37018 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
37019 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
37020 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
37021 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
37022 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
37023 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
37024 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
37025 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
37026 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
37027 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
37028 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
37029 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
37030 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
37031 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
37032 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
37033 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
37034 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
37035 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
37036 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
37037 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
37038 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
37039 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
37041 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
37042 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
37043 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
37044 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
37045 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
37046 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
37047 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
37048 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
37049 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
37050 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
37051 & -A(J,6)*(XMG2+XMR2-SBAR)
37052 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
37053 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
37054 & /(GRS+XMSB(J)+XMST(J))
37058 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
37059 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
37064 C*********************************************************************
37067 C...Calculates decay widths for the neutralinos (admixtures of
37068 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
37070 C...Input: KCIN = KF code for particle
37071 C...Output: XLAM = widths
37072 C... IDLAM = KF codes for decay particles
37073 C... IKNT = number of decay channels defined
37074 C...AUTHOR: STEPHEN MRENNA
37076 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
37077 C...when CHIGAMMA .NE. 0
37078 C...10 FEB 96: Calculate this decay for small tan(beta)
37080 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
37082 C...Double precision and integer declarations.
37083 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37084 IMPLICIT INTEGER(I-N)
37085 INTEGER PYK,PYCHGE,PYCOMP
37086 C...Parameter statement to help give large particle numbers.
37087 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37088 &KEXCIT=4000000,KDIMEN=5000000)
37090 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37091 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37092 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
37093 c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37095 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37096 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
37097 C COMMON/PYINTS/XXM(20)
37099 COMMON/PYINTC/XXC(10),CXC(8)
37100 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
37102 C...Local variables.
37103 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
37104 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
37106 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
37107 &XMZ,XMZ2,AXMJ,AXMI
37108 DOUBLE PRECISION S12MIN,S12MAX
37109 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
37110 DOUBLE PRECISION PYLAMF,XL
37111 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
37112 DOUBLE PRECISION PYX2XH,PYX2XG
37113 DOUBLE PRECISION XLAM(0:400)
37114 INTEGER IDLAM(400,3)
37115 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
37116 INTEGER ITH(3),KF1,KF2
37118 DOUBLE PRECISION DH(3),EH(3)
37119 DOUBLE PRECISION SR2
37120 DOUBLE PRECISION CBETA,SBETA
37121 DOUBLE PRECISION GAMCON,XMT1,XMT2
37122 DOUBLE PRECISION PYALEM,PI,PYALPS
37123 DOUBLE PRECISION RAT1,RAT2
37124 DOUBLE PRECISION T3T,FCOL
37125 DOUBLE PRECISION ALFA,BETA,TANB
37126 DOUBLE PRECISION PYXXGA
37127 EXTERNAL PYGAUS,PYXXZ6
37128 DOUBLE PRECISION PYGAUS,PYXXZ6
37129 DOUBLE PRECISION PREC
37130 INTEGER KFNCHI(4),KFCCHI(2)
37134 DATA PI/3.141592654D0/
37135 DATA SR2/1.4142136D0/
37136 DATA KFNCHI/1000022,1000023,1000025,1000035/
37137 DATA KFCCHI/1000024,1000037/
37139 C...COUNT THE NUMBER OF DECAY MODES
37148 TANW = SQRT(XW/XW1)
37150 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
37152 IF(KFIN.EQ.KFNCHI(2)) IX=2
37153 IF(KFIN.EQ.KFNCHI(3)) IX=3
37154 IF(KFIN.EQ.KFNCHI(4)) IX=4
37174 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
37179 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
37180 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
37184 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
37185 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
37187 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
37188 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
37192 GAMCON=AEM**3/8D0/PI/XMW2/XW
37193 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
37194 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
37195 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
37196 IDLAM(LKNT,1)=KSUSY1+22
37199 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
37203 C...GRAVITINO DECAY MODES
37205 IF(IMSS(11).EQ.1) THEN
37208 XMGR=PMAS(PYCOMP(IDG),1)
37211 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
37212 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
37217 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
37219 IF(AXMI.GT.XMGR+XMZ) THEN
37224 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
37225 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
37226 & (1D0-XMZ2/XMI2)**4
37228 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
37233 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
37234 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
37236 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
37241 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
37242 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
37244 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
37249 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
37250 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
37252 IF(IX.EQ.1) GOTO 300
37260 C...CHI0_I -> CHI0_J + GAMMA
37261 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
37262 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
37263 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
37264 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
37265 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
37266 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
37267 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
37269 IDLAM(LKNT,1)=KFNCHI(IJ)
37272 GAMCON=AEM**3/8D0/PI/XMW2/XW
37273 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
37274 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
37275 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
37279 C...CHI0_I -> CHI0_J + Z0
37280 IF(AXMI.GE.AXMJ+XMZ) THEN
37282 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
37283 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
37285 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37286 GLR=DBLE(OLPP*DCONJG(ORPP))
37287 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
37288 IDLAM(LKNT,1)=KFNCHI(IJ)
37291 ELSEIF(AXMI.GE.AXMJ) THEN
37298 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
37299 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
37301 C...CHARGED LEPTONS
37303 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37304 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37306 T3I=SIGN(1D0,EI+1D-6)/2D0
37307 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37308 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37309 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37310 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37312 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37313 CXC(4)=DCONJG(GLIJ)
37314 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37316 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37317 CXC(8)=-DCONJG(GRIJ)
37319 S12MAX=(AXMI-AXMJ)**2
37320 IF( XXC(5).LT.AXMI ) THEN
37323 IF(XXC(6).LT.AXMI ) THEN
37329 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
37331 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37332 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37333 IDLAM(LKNT,1)=KFNCHI(IJ)
37336 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
37338 XLAM(LKNT)=XLAM(LKNT-1)
37339 IDLAM(LKNT,1)=KFNCHI(IJ)
37345 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
37346 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
37347 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
37349 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
37350 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
37352 IF( XXC(5).LT.AXMI ) THEN
37355 IF(XXC(6).LT.AXMI ) THEN
37361 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
37363 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37364 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37365 IDLAM(LKNT,1)=KFNCHI(IJ)
37373 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37374 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37376 T3I=SIGN(1D0,EI+1D-6)/2D0
37377 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37378 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37379 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37380 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37382 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37383 CXC(4)=DCONJG(GLIJ)
37384 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37386 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37387 CXC(8)=-DCONJG(GRIJ)
37389 S12MAX=(AXMI-AXMJ)**2
37390 IF( XXC(5).LT.AXMI ) THEN
37393 IF( XXC(6).LT.AXMI ) THEN
37400 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37401 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37402 IDLAM(LKNT,1)=KFNCHI(IJ)
37406 XLAM(LKNT)=XLAM(LKNT-1)
37407 IDLAM(LKNT,1)=KFNCHI(IJ)
37412 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
37414 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
37415 IF( XXC(5).LT.AXMI ) THEN
37420 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37421 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37424 XLAM(LKNT)=XLAM(LKNT-1)
37426 IDLAM(LKNT,1)=KFNCHI(IJ)
37432 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37433 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37435 T3I=SIGN(1D0,EI+1D-6)/2D0
37436 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37437 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37438 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37439 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37441 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37442 CXC(4)=DCONJG(GLIJ)
37443 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37445 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37446 CXC(8)=-DCONJG(GRIJ)
37448 S12MAX=(AXMI-AXMJ)**2
37449 IF( XXC(5).LT.AXMI ) THEN
37452 IF( XXC(6).LT.AXMI ) THEN
37458 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
37460 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37461 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
37462 IDLAM(LKNT,1)=KFNCHI(IJ)
37465 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
37467 XLAM(LKNT)=XLAM(LKNT-1)
37468 IDLAM(LKNT,1)=KFNCHI(IJ)
37474 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
37475 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
37476 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
37478 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
37479 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
37481 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
37482 IF(XXC(5).LT.AXMI) THEN
37484 ELSEIF(XXC(6).LT.AXMI) THEN
37489 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
37491 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37492 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
37493 IDLAM(LKNT,1)=KFNCHI(IJ)
37501 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37502 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37504 T3I=SIGN(1D0,EI+1D-6)/2D0
37505 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37506 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37507 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37508 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37510 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37511 CXC(4)=DCONJG(GLIJ)
37512 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37514 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37515 CXC(8)=-DCONJG(GRIJ)
37517 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
37518 IF(XXC(5).LT.AXMI) THEN
37520 ELSEIF(XXC(6).LT.AXMI) THEN
37526 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
37528 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37529 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
37530 IDLAM(LKNT,1)=KFNCHI(IJ)
37533 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
37535 XLAM(LKNT)=XLAM(LKNT-1)
37536 IDLAM(LKNT,1)=KFNCHI(IJ)
37544 C...CHI0_I -> CHI0_J + H0_K
37551 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
37552 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
37553 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
37554 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
37555 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
37556 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
37557 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
37558 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
37560 XMH=PMAS(ITH(IH),1)
37562 IF(AXMI.GE.AXMJ+XMH) THEN
37564 XL=PYLAMF(XMI2,XMJ2,XMH2)
37565 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
37567 C...SIGN OF MASSES I,J
37569 IF(IH.EQ.3) XMK=-XMK
37570 GX2=ABS(F21K)**2+ABS(F12K)**2
37571 GLR=DBLE(F21K*DCONJG(F12K))
37572 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
37573 IDLAM(LKNT,1)=KFNCHI(IJ)
37574 IDLAM(LKNT,2)=ITH(IH)
37580 C...CHI0_I -> CHI+_J + W-
37585 IF(AXMI.GE.AXMJ+XMW) THEN
37587 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
37588 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
37589 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
37590 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
37591 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
37592 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
37593 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
37594 IDLAM(LKNT,1)=KFCCHI(IJ)
37598 XLAM(LKNT)=XLAM(LKNT-1)
37599 IDLAM(LKNT,1)=-KFCCHI(IJ)
37602 ELSEIF(AXMI.GE.AXMJ) THEN
37604 S12MAX=(AXMI-AXMJ)**2
37605 RT2I = 1D0/SQRT(2D0)
37606 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
37607 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
37608 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
37609 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
37610 CXC(5)=DCMPLX(0D0,0D0)
37611 CXC(7)=DCMPLX(0D0,0D0)
37615 T3I=SIGN(1D0,EI+1D-6)/2D0
37617 T3J=SIGN(1D0,EJ+1D-6)/2D0
37618 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
37619 & TANW+ZMIXC(IX,2)*T3J)*RT2I
37620 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
37621 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
37622 CXC(6)=DCMPLX(0D0,0D0)
37623 CXC(8)=DCMPLX(0D0,0D0)
37628 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
37629 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
37632 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
37633 IF(XXC(5).LT.AXMI) THEN
37635 ELSEIF(XXC(6).LT.AXMI) THEN
37640 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
37642 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37643 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37644 IDLAM(LKNT,1)=KFCCHI(IJ)
37648 XLAM(LKNT)=XLAM(LKNT-1)
37649 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37650 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37651 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37652 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
37654 XLAM(LKNT)=XLAM(LKNT-1)
37655 IDLAM(LKNT,1)=KFCCHI(IJ)
37659 XLAM(LKNT)=XLAM(LKNT-1)
37660 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37661 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37662 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37666 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
37667 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
37668 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
37670 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
37671 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
37673 IF(XXC(5).LT.AXMI) THEN
37676 IF(XXC(6).LT.AXMI) THEN
37681 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
37683 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37684 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37685 XLAM(LKNT)=XLAM(LKNT-1)
37686 IDLAM(LKNT,1)=KFCCHI(IJ)
37690 XLAM(LKNT)=XLAM(LKNT-1)
37691 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37692 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37693 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37696 C...NOW, DO THE QUARKS
37701 T3I=SIGN(1D0,EI+1D-6)/2D0
37703 T3J=SIGN(1D0,EJ+1D-6)/2D0
37704 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
37705 & TANW+ZMIXC(IX,2)*T3J)
37706 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
37707 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
37708 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
37709 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
37710 IF(XXC(5).LT.AXMI) THEN
37713 IF(XXC(6).LT.AXMI) THEN
37718 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
37720 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
37721 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37722 IDLAM(LKNT,1)=KFCCHI(IJ)
37726 XLAM(LKNT)=XLAM(LKNT-1)
37727 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37728 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37729 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37730 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
37732 XLAM(LKNT)=XLAM(LKNT-1)
37733 IDLAM(LKNT,1)=KFCCHI(IJ)
37737 XLAM(LKNT)=XLAM(LKNT-1)
37738 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37739 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37740 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37748 C...CHI0_I -> CHI+_I + H-
37754 IF(AXMI.GE.AXMJ+XMHP) THEN
37756 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
37757 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
37758 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
37759 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
37761 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37762 GLR=DBLE(OLPP*DCONJG(ORPP))
37763 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
37764 IDLAM(LKNT,1)=KFCCHI(IJ)
37765 IDLAM(LKNT,2)=-ITHC
37768 XLAM(LKNT)=XLAM(LKNT-1)
37769 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37770 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37771 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37777 C...2-BODY DECAYS TO FERMION SFERMION
37779 IF(J.GE.7.AND.J.LE.10) GOTO 290
37782 XMSF1=PMAS(PYCOMP(KF1),1)
37783 XMSF2=PMAS(PYCOMP(KF2),1)
37793 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
37794 IF(MOD(J,2).EQ.0) THEN
37795 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
37796 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
37797 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
37800 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
37801 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
37802 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
37807 IF(AXMI.GE.XMF+XMSF1) THEN
37811 XL=PYLAMF(XMI2,XMA2,XMB2)
37812 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
37813 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
37814 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37815 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37820 XLAM(LKNT)=XLAM(LKNT-1)
37821 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37822 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37827 IF(AXMI.GE.XMF+XMSF2) THEN
37831 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
37832 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
37833 XL=PYLAMF(XMI2,XMA2,XMB2)
37834 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37835 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37840 XLAM(LKNT)=XLAM(LKNT-1)
37841 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37842 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37847 C...3-BODY DECAY TO Q Q~ GLUINO
37848 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
37849 IF(AXMI.GE.XMJ) THEN
37850 RT2I = 1D0/SQRT(2D0)
37851 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
37859 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37860 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37861 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
37867 T3I=SIGN(1D0,EI+1D-6)/2D0
37868 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
37869 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
37873 CXC(4)=DCONJG(GLIJ)
37877 CXC(8)=-DCONJG(GRIJ)
37879 S12MAX=(AXMI-AXMJ)**2
37880 C...ALL QUARKS BUT T
37881 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
37883 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
37884 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37885 IDLAM(LKNT,1)=KSUSY1+21
37888 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
37890 XLAM(LKNT)=XLAM(LKNT-1)
37891 IDLAM(LKNT,1)=KSUSY1+21
37897 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
37898 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
37899 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
37901 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
37902 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
37904 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
37907 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
37909 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
37910 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37911 IDLAM(LKNT,1)=KSUSY1+21
37918 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37919 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37920 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
37924 T3I=SIGN(1D0,EI+1D-6)/2D0
37925 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
37926 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
37928 CXC(4)=DCONJG(GLIJ)
37930 CXC(8)=-DCONJG(GRIJ)
37931 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
37933 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
37934 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37935 IDLAM(LKNT,1)=KSUSY1+21
37938 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
37940 XLAM(LKNT)=XLAM(LKNT-1)
37941 IDLAM(LKNT,1)=KSUSY1+21
37949 C...R-violating decay modes (SKANDS).
37950 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
37955 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
37956 XLAM(0)=XLAM(0)+XLAM(I)
37958 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
37963 C*********************************************************************
37966 C...Calculate decay widths for the charginos (admixtures of
37967 C...charged Wino and charged Higgsino.
37969 C...Input: KCIN = KF code for particle
37970 C...Output: XLAM = widths
37971 C... IDLAM = KF codes for decay particles
37972 C... IKNT = number of decay channels defined
37973 C...AUTHOR: STEPHEN MRENNA
37975 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
37976 C...when CHIENU .NE. 0
37978 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
37980 C...Double precision and integer declarations.
37981 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37982 IMPLICIT INTEGER(I-N)
37983 INTEGER PYK,PYCHGE,PYCOMP
37984 C...Parameter statement to help give large particle numbers.
37985 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37986 &KEXCIT=4000000,KDIMEN=5000000)
37988 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37989 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37990 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
37991 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37992 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
37994 C COMMON/PYINTS/XXM(20)
37996 COMMON/PYINTC/XXC(10),CXC(8)
37997 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
37999 C...Local variables
38000 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
38001 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
38003 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
38004 &XMZ,XMZ2,AXMJ,AXMI
38005 DOUBLE PRECISION S12MIN,S12MAX
38006 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
38007 DOUBLE PRECISION PYLAMF,XL
38008 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
38009 DOUBLE PRECISION PYX2XH,PYX2XG
38010 DOUBLE PRECISION XLAM(0:400)
38011 INTEGER IDLAM(400,3)
38012 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
38015 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
38016 DOUBLE PRECISION SR2
38017 DOUBLE PRECISION CBETA,SBETA,TANB
38019 DOUBLE PRECISION PYALEM,PI,PYALPS
38020 DOUBLE PRECISION FCOL
38021 INTEGER KF1,KF2,ISF
38022 INTEGER KFNCHI(4),KFCCHI(2)
38024 DOUBLE PRECISION TEMP
38025 EXTERNAL PYGAUS,PYXXZ6
38026 DOUBLE PRECISION PYGAUS,PYXXZ6
38027 DOUBLE PRECISION PREC
38030 DATA ETAH/1D0,1D0,-1D0/
38031 DATA SR2/1.4142136D0/
38032 DATA PI/3.141592654D0/
38034 DATA KFNCHI/1000022,1000023,1000025,1000035/
38035 DATA KFCCHI/1000024,1000037/
38037 C...COUNT THE NUMBER OF DECAY MODES
38045 TANW = SQRT(XW/XW1)
38047 C...1 OR 2 DEPENDING ON CHARGINO TYPE
38049 IF(KFIN.EQ.KFCCHI(2)) IX=2
38067 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
38068 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
38072 C...GRAVITINO DECAY MODES
38074 IF(IMSS(11).EQ.1) THEN
38077 XMGR=PMAS(PYCOMP(IDG),1)
38079 C COSW=SQRT(1D0-XW)
38080 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
38081 IF(AXMI.GT.XMGR+XMW) THEN
38087 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
38088 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
38089 & (1D0-XMW2/XMI2)**4
38091 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
38096 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
38097 & (ABS(UMIXC(IX,2))*SBETA)**2))
38098 & *(1D0-PMAS(37,1)**2/XMI2)**4
38102 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
38103 IF(IX.EQ.1) GOTO 170
38108 C...CHI_2+ -> CHI_1+ + Z0
38109 IF(AXMI.GE.AXMJ+XMZ) THEN
38112 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
38113 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
38114 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
38115 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
38116 GX2=ABS(OLPP)**2+ABS(ORPP)**2
38117 GLR=DBLE(OLPP*DCONJG(ORPP))
38118 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
38119 IDLAM(LKNT,1)=KFCCHI(1)
38123 C...CHARGED LEPTONS
38124 ELSEIF(AXMI.GE.AXMJ) THEN
38126 S12MAX=(AXMI-AXMJ)**2
38129 EI=KCHG(IABS(IA),1)/3D0
38130 T3I=SIGN(1D0,EI+1D-6)/2D0
38135 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38140 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
38141 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
38142 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
38143 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
38144 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38145 CXC(2)=DCMPLX(0D0,0D0)
38146 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38147 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
38148 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38149 CXC(6)=DCMPLX(0D0,0D0)
38150 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38151 CXC(8)=DCMPLX(0D0,0D0)
38152 IF( XXC(5).LT.AXMI ) THEN
38157 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
38159 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
38160 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38161 IDLAM(LKNT,1)=KFCCHI(1)
38164 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
38166 XLAM(LKNT)=XLAM(LKNT-1)
38167 IDLAM(LKNT,1)=KFCCHI(1)
38171 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
38173 XLAM(LKNT)=XLAM(LKNT-1)
38174 IDLAM(LKNT,1)=KFCCHI(1)
38184 EI=KCHG(IABS(IA),1)/3D0
38185 T3I=SIGN(1D0,EI+1D-6)/2D0
38186 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38188 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38189 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38190 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
38191 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38192 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38193 IF( XXC(5).LT.AXMI ) THEN
38198 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
38200 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
38201 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38202 IDLAM(LKNT,1)=KFCCHI(1)
38206 XLAM(LKNT)=XLAM(LKNT-1)
38207 IDLAM(LKNT,1)=KFCCHI(1)
38211 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
38212 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
38213 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
38215 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
38217 IF( XXC(5).LT.AXMI ) THEN
38222 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
38223 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38224 IDLAM(LKNT,1)=KFCCHI(1)
38233 EI=KCHG(IABS(IA),1)/3D0
38234 T3I=SIGN(1D0,EI+1D-6)/2D0
38235 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38237 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38238 CXC(2)=DCMPLX(0D0,0D0)
38239 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38240 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
38241 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38242 CXC(6)=DCMPLX(0D0,0D0)
38243 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38244 CXC(8)=DCMPLX(0D0,0D0)
38245 IF( XXC(5).LT.AXMI ) THEN
38250 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
38252 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38253 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38254 IDLAM(LKNT,1)=KFCCHI(1)
38257 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
38259 XLAM(LKNT)=XLAM(LKNT-1)
38260 IDLAM(LKNT,1)=KFCCHI(1)
38265 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
38266 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
38267 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
38269 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
38271 IF( XXC(5).LT.AXMI ) THEN
38276 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38277 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38278 IDLAM(LKNT,1)=KFCCHI(1)
38287 EI=KCHG(IABS(IA),1)/3D0
38288 T3I=SIGN(1D0,EI+1D-6)/2D0
38289 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38291 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38292 CXC(2)=DCMPLX(0D0,0D0)
38293 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38294 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
38295 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38296 CXC(6)=DCMPLX(0D0,0D0)
38297 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38298 CXC(8)=DCMPLX(0D0,0D0)
38299 IF( XXC(5).LT.AXMI ) THEN
38304 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
38306 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38307 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38308 IDLAM(LKNT,1)=KFCCHI(1)
38311 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
38313 XLAM(LKNT)=XLAM(LKNT-1)
38314 IDLAM(LKNT,1)=KFCCHI(1)
38322 C...CHI_2+ -> CHI_1+ + H0_K
38330 XMH=PMAS(ITH(IH),1)
38332 C...NO 3-BODY OPTION
38333 IF(AXMI.GE.AXMJ+XMH) THEN
38335 XL=PYLAMF(XMI2,XMJ2,XMH2)
38336 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
38337 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
38338 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
38339 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
38341 GX2=ABS(OLPP)**2+ABS(ORPP)**2
38342 GLR=DBLE(OLPP*DCONJG(ORPP))
38343 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
38344 IDLAM(LKNT,1)=KFCCHI(1)
38345 IDLAM(LKNT,2)=ITH(IH)
38350 C...CHI1 JUMPS TO HERE
38353 C...CHI+_I -> CHI0_J + W+
38358 IF(AXMI.GE.AXMJ+XMW) THEN
38361 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
38363 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
38364 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
38365 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
38366 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
38367 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
38368 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
38369 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
38370 IDLAM(LKNT,1)=KFNCHI(IJ)
38374 ELSEIF(AXMI.GE.AXMJ) THEN
38376 S12MAX=(AXMI-AXMJ)**2
38378 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
38380 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
38381 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
38382 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
38383 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
38384 CXC(5)=DCMPLX(0D0,0D0)
38385 CXC(7)=DCMPLX(0D0,0D0)
38389 T3I=SIGN(1D0,EI+1D-6)/2D0
38391 T3J=SIGN(1D0,EJ+1D-6)/2D0
38392 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
38393 & TANW+ZMIXC(IJ,2)*T3J)/SR2
38394 CXC(4)=-DCONJG(UMIXC(IX,1))*(
38395 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
38396 CXC(6)=DCMPLX(0D0,0D0)
38397 CXC(8)=DCMPLX(0D0,0D0)
38402 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38403 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
38406 CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
38407 IF(XXC(5).LT.AXMI) THEN
38409 ELSEIF(XXC(6).LT.AXMI) THEN
38414 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
38415 C...--> 1/(16PI)/M**3*(AEM/XW)**2
38416 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
38418 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38419 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
38420 IDLAM(LKNT,1)=KFNCHI(IJ)
38423 C...ONLY DECAY CHI+1 -> E+ NU_E
38424 IF( IMSS(12).NE. 0 ) GOTO 260
38425 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
38427 XLAM(LKNT)=XLAM(LKNT-1)
38428 IDLAM(LKNT,1)=KFNCHI(IJ)
38433 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
38435 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
38436 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
38438 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
38440 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
38441 IF(XXC(5).LT.AXMI) THEN
38443 ELSEIF(XXC(6).LT.AXMI) THEN
38448 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38449 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
38450 IDLAM(LKNT,1)=KFNCHI(IJ)
38455 C...NOW, DO THE QUARKS
38460 T3I=SIGN(1D0,EI+1D-6)/2D0
38462 T3J=SIGN(1D0,EJ+1D-6)/2D0
38463 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
38464 & TANW+ZMIXC(IX,2)*T3J)
38465 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
38466 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
38467 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38468 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
38469 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
38470 IF(XXC(5).LT.AXMI) THEN
38473 IF(XXC(6).LT.AXMI) THEN
38478 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
38480 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38481 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38482 IDLAM(LKNT,1)=KFNCHI(IJ)
38485 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
38487 XLAM(LKNT)=XLAM(LKNT-1)
38488 IDLAM(LKNT,1)=KFNCHI(IJ)
38497 C...CHI+_I -> CHI0_J + H+
38503 IF(AXMI.GE.AXMJ+XMHP) THEN
38505 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
38506 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
38507 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
38508 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
38510 GX2=ABS(OLPP)**2+ABS(ORPP)**2
38511 GLR=DBLE(OLPP*DCONJG(ORPP))
38512 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
38513 IDLAM(LKNT,1)=KFNCHI(IJ)
38521 C...2-BODY DECAYS TO FERMION SFERMION
38523 IF(J.GE.7.AND.J.LE.10) GOTO 240
38524 IF(MOD(J,2).EQ.0) THEN
38530 XMSF1=PMAS(PYCOMP(KF1),1)
38531 XMSF2=PMAS(PYCOMP(KF2),1)
38540 IF(MOD(J,2).EQ.0) THEN
38543 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
38544 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
38550 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
38552 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
38557 IF(AXMI.GE.XMF+XMSF1) THEN
38561 XL=PYLAMF(XMI2,XMA2,XMB2)
38562 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
38563 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
38564 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
38565 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
38567 IF(MOD(J,2).EQ.0) THEN
38577 IF(AXMI.GE.XMF+XMSF2) THEN
38581 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
38582 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
38583 XL=PYLAMF(XMI2,XMA2,XMB2)
38584 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
38585 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
38587 IF(MOD(J,2).EQ.0) THEN
38597 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
38598 C...A 2-BODY -- 2-BODY CHAIN
38599 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
38600 IF(AXMI.GE.XMJ) THEN
38603 S12MAX=(AXMI-AXMJ)**2
38608 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
38609 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
38612 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
38614 CXC(1)=DCMPLX(0D0,0D0)
38615 CXC(3)=DCMPLX(0D0,0D0)
38616 CXC(5)=DCMPLX(0D0,0D0)
38617 CXC(7)=DCMPLX(0D0,0D0)
38618 CXC(2)=UMIXC(IX,1)*OLPP/SR2
38619 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
38620 CXC(6)=DCMPLX(0D0,0D0)
38621 CXC(8)=DCMPLX(0D0,0D0)
38622 IF(XXC(5).LT.AXMI) THEN
38624 ELSEIF(XXC(6).LT.AXMI) THEN
38629 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
38630 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
38632 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
38633 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38634 IDLAM(LKNT,1)=KSUSY1+21
38637 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
38639 XLAM(LKNT)=XLAM(LKNT-1)
38640 IDLAM(LKNT,1)=KSUSY1+21
38648 C...R-violating decay modes (SKANDS).
38649 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
38654 XLAM(0)=XLAM(0)+XLAM(I)
38655 IF(XLAM(I).LT.0D0) THEN
38656 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
38657 & (IDLAM(I,J),J=1,3)
38661 IF(XLAM(0).EQ.0D0) THEN
38663 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
38664 WRITE(MSTU(11),*) LKNT
38665 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
38671 C*********************************************************************
38674 C...Used in the calculation of inoi -> inoj + f + ~f.
38678 C...Double precision and integer declarations.
38679 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38680 IMPLICIT INTEGER(I-N)
38681 INTEGER PYK,PYCHGE,PYCOMP
38682 C...Parameter statement to help give large particle numbers.
38683 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38684 &KEXCIT=4000000,KDIMEN=5000000)
38686 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38687 C COMMON/PYINTS/XXM(20)
38689 COMMON/PYINTC/XXC(10),CXC(8)
38690 SAVE /PYDAT1/,/PYINTC/
38692 C...Local variables.
38693 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
38694 DOUBLE PRECISION PYXXZ6,X
38695 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
38696 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
38697 DOUBLE PRECISION SIJ
38698 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
38699 DOUBLE PRECISION OL2
38700 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
38703 C...Statement functions.
38704 C...Integral from x to y of (t-a)(b-t) dt.
38705 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
38706 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
38707 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
38708 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
38709 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
38710 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
38711 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
38712 C...Integral from x to y of (t-a)/(b-t) dt.
38713 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
38714 C...Integral from x to y of 1/(t-a) dt.
38715 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
38723 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
38724 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
38725 &( (X-XM22-S)**2 -4D0*XM22*S ) )
38727 S23MIN=(S23AVE-S23DEL)
38728 S23MAX=(S23AVE+S23DEL)
38745 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
38746 SIJ=2D0*XXC(2)*XXC(4)*S13
38747 IF(XMV.LE.1000D0) THEN
38748 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
38749 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
38750 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
38751 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
38752 IF(XXC(5).LE.10000D0) THEN
38753 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
38754 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
38755 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
38756 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
38757 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
38758 & *(S13-XMV**2)/WPROP2
38763 IF(XXC(6).LE.10000D0) THEN
38764 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
38765 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
38766 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
38767 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
38768 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
38769 & *(S13-XMV**2)/WPROP2
38778 IF(XXC(5).LE.10000D0) THEN
38779 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
38780 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
38781 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
38782 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
38786 IF(XXC(6).LE.10000D0) THEN
38787 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
38788 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
38789 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
38790 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
38795 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
38797 IF(PYXXZ6.LT.0D0) THEN
38798 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
38799 WRITE(MSTU(11),*) XXc(1),XXc(2),XXc(3),XXc(4)
38800 WRITE(MSTU(11),*) (XXc(I),I=5,8)
38801 WRITE(MSTU(11),*) (XXc(I),I=9,12)
38802 WRITE(MSTU(11),*) (XXc(I),I=13,16)
38803 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
38804 WRITE(MSTU(11),*) S23MIN,S23MAX
38812 C*********************************************************************
38815 C...Calculates chi0_i -> chi0_j + gamma.
38817 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
38819 C...Double precision and integer declarations.
38820 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38821 IMPLICIT INTEGER(I-N)
38822 INTEGER PYK,PYCHGE,PYCOMP
38824 C...Local variables.
38825 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
38826 DOUBLE PRECISION F1,F2
38828 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
38829 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
38830 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
38831 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
38836 C*********************************************************************
38839 C...Calculates the decay rate for ino -> ino + gauge boson.
38841 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
38843 C...Double precision and integer declarations.
38844 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38845 IMPLICIT INTEGER(I-N)
38846 INTEGER PYK,PYCHGE,PYCOMP
38848 C...Local variables.
38849 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
38850 DOUBLE PRECISION XL,PYLAMF,C1
38851 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
38857 XL=PYLAMF(XMI2,XMJ2,XMV2)
38858 PYX2XG=C1/8D0/XMI3*SQRT(XL)
38859 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
38860 &12D0*GLR*XM1*XM2*XMV2)
38865 C*********************************************************************
38868 C...Calculates the decay rate for ino -> ino + H.
38870 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
38872 C...Double precision and integer declarations.
38873 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38874 IMPLICIT INTEGER(I-N)
38875 INTEGER PYK,PYCHGE,PYCOMP
38877 C...Local variables.
38878 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
38879 DOUBLE PRECISION XL,PYLAMF,C1
38880 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
38886 XL=PYLAMF(XMI2,XMJ2,XMV2)
38887 PYX2XH=C1/8D0/XMI3*SQRT(XL)
38888 &*(GX2*(XMI2+XMJ2-XMV2)+
38894 C*********************************************************************
38897 C...Calculates the non-standard decay modes of the Higgs boson.
38899 C...Author: Stephen Mrenna
38900 C...Last Update: April 2001
38901 C......Allow complex values for Z,U, and V
38903 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
38905 C...Double precision and integer declarations.
38906 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38907 IMPLICIT INTEGER(I-N)
38908 INTEGER PYK,PYCHGE,PYCOMP
38909 C...Parameter statement to help give large particle numbers.
38910 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38911 &KEXCIT=4000000,KDIMEN=5000000)
38913 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38914 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38915 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38916 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
38917 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
38918 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
38919 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
38921 C...Local variables.
38922 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
38923 COMPLEX*16 QIJ,RIJ,F21K,F12K
38925 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
38926 DOUBLE PRECISION XMI2,XMI3,XMJ2
38927 DOUBLE PRECISION PYLAMF,XL,CF,EI
38929 DOUBLE PRECISION TANW,XW,AEM,C1,AS
38930 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
38931 DOUBLE PRECISION XLAM(0:400)
38932 INTEGER IDLAM(400,3)
38933 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
38935 INTEGER KFNCHI(4),KFCCHI(2)
38936 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
38937 DOUBLE PRECISION SR2
38938 DOUBLE PRECISION BETA,ALFA
38939 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
38940 DOUBLE PRECISION PYALEM
38941 DOUBLE PRECISION AL,AR,ALR
38942 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
38943 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
38944 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
38945 DATA ITH/25,35,36,37/
38946 DATA ETAH/1D0,1D0,-1D0/
38947 DATA SR2/1.4142136D0/
38948 DATA KFNCHI/1000022,1000023,1000025,1000035/
38949 DATA KFCCHI/1000024,1000037/
38951 C...COUNT THE NUMBER OF DECAY MODES
38958 TANW = SQRT(XW/(1D0-XW))
38961 C...1 - 4 DEPENDING ON Higgs species.
38963 IF(KFIN.EQ.ITH(2)) IH=2
38964 IF(KFIN.EQ.ITH(3)) IH=3
38965 IF(KFIN.EQ.ITH(4)) IH=4
38988 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
38993 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
38994 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
38999 IF(IH.EQ.4) GOTO 220
39001 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
39002 C...H0_K -> CHI0_I + CHI0_J
39015 IF(AXMI.GE.AXMJ+AXMK) THEN
39017 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
39018 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
39019 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
39020 & ZMIXC(IJ,3)*ZMIXC(IK,1))
39021 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
39022 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
39023 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
39024 & ZMIXC(IJ,4)*ZMIXC(IK,1))
39025 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
39026 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
39027 C...SIGN OF MASSES I,J
39029 GX2=ABS(F12K)**2+ABS(F21K)**2
39030 GLR=DBLE(F12K*DCONJG(F21K))
39031 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
39032 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
39033 IDLAM(LKNT,1)=KFNCHI(IJ)
39034 IDLAM(LKNT,2)=KFNCHI(IK)
39040 C...H0_K -> CHI+_I CHI-_J
39047 IF(AXMI.GE.AXMJ+AXMK) THEN
39049 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
39050 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
39051 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
39052 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
39053 GX2=ABS(OLPP)**2+ABS(ORPP)**2
39054 GLR=DBLE(OLPP*DCONJG(ORPP))
39056 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
39057 IDLAM(LKNT,1)=KFCCHI(IJ)
39058 IDLAM(LKNT,2)=-KFCCHI(IK)
39064 C...HIGGS TO SFERMION SFERMION
39066 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
39068 XMJL=PMAS(PYCOMP(IJ),1)
39069 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
39070 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
39073 XL=PYLAMF(XMI2,XMJ2,XMJ2)
39080 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
39081 & XMF**2/XMW*SINA/CBETA
39082 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
39083 & XMF**2/XMW*SINA/CBETA
39085 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
39087 ELSEIF(IFL.EQ.15) THEN
39088 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
39094 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
39095 & XMF**2/XMW*COSA/SBETA
39096 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
39097 & XMF**2/XMW*COSA/SBETA
39099 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
39106 ELSEIF(IH.EQ.2) THEN
39108 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
39109 & XMF**2/XMW*COSA/CBETA
39110 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
39111 & XMF**2/XMW*COSA/CBETA
39113 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
39115 ELSEIF(IFL.EQ.15) THEN
39116 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
39122 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
39123 & XMF**2/XMW*SINA/SBETA
39124 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
39125 & XMF**2/XMW*SINA/SBETA
39127 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
39134 ELSEIF(IH.EQ.3) THEN
39140 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
39141 ELSEIF(IFL.EQ.15) THEN
39142 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
39146 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
39150 IF(IH.EQ.3) GOTO 180
39154 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
39161 IF(AXMI.GE.2D0*XMJ) THEN
39163 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39165 & +2D0*GHLR*ALR)**2
39171 IF(AXMI.GE.2D0*XMJR) THEN
39175 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
39178 XL=PYLAMF(XMI2,XMJ2,XMJ2)
39179 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39181 & +2D0*GHLR*ALR)**2
39182 IDLAM(LKNT,1)=IJ+KSUSY1
39183 IDLAM(LKNT,2)=-(IJ+KSUSY1)
39188 IF(AXMI.GE.XMJL+XMJR) THEN
39190 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
39191 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
39192 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
39195 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
39196 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39197 & (GHLL*AL+GHRR*AR)**2
39199 IDLAM(LKNT,2)=-(IJ+KSUSY1)
39203 IDLAM(LKNT,2)=IJ+KSUSY1
39205 XLAM(LKNT)=XLAM(LKNT-1)
39215 C...H+ -> CHI+_I + CHI0_J
39223 IF(AXMI.GE.AXMJ+AXMK) THEN
39225 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
39226 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
39227 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
39228 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
39229 GX2=ABS(OLPP)**2+ABS(ORPP)**2
39230 GLR=DBLE(OLPP*DCONJG(ORPP))
39231 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
39232 IDLAM(LKNT,1)=KFNCHI(IJ)
39233 IDLAM(LKNT,2)=KFCCHI(IK)
39239 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
39240 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
39246 XM1=PMAS(PYCOMP(KSUSY1+6),1)
39247 XM2=PMAS(PYCOMP(KSUSY1+5),1)
39248 IF(XMI.GE.XM1+XM2) THEN
39249 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39251 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39252 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
39253 IDLAM(LKNT,1)=KSUSY1+6
39254 IDLAM(LKNT,2)=-(KSUSY1+5)
39259 XM1=PMAS(PYCOMP(KSUSY2+6),1)
39260 XM2=PMAS(PYCOMP(KSUSY1+5),1)
39261 IF(XMI.GE.XM1+XM2) THEN
39262 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39264 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39265 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
39266 IDLAM(LKNT,1)=KSUSY2+6
39267 IDLAM(LKNT,2)=-(KSUSY1+5)
39272 XM1=PMAS(PYCOMP(KSUSY1+6),1)
39273 XM2=PMAS(PYCOMP(KSUSY2+5),1)
39274 IF(XMI.GE.XM1+XM2) THEN
39275 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39277 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39278 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
39279 IDLAM(LKNT,1)=KSUSY1+6
39280 IDLAM(LKNT,2)=-(KSUSY2+5)
39285 XM1=PMAS(PYCOMP(KSUSY2+6),1)
39286 XM2=PMAS(PYCOMP(KSUSY2+5),1)
39287 IF(XMI.GE.XM1+XM2) THEN
39288 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39290 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39291 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
39292 IDLAM(LKNT,1)=KSUSY2+6
39293 IDLAM(LKNT,2)=-(KSUSY2+5)
39298 GL=-XMW/SR2*SIN(2D0*BETA)
39300 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
39301 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
39302 IF(XMI.GE.XM1+XM2) THEN
39303 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39305 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
39306 IDLAM(LKNT,1)=-(KSUSY1+IJ)
39307 IDLAM(LKNT,2)=KSUSY1+IJ+1
39315 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
39316 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
39317 IF(XMI.GE.XM1+XM2) THEN
39318 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39320 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
39321 IDLAM(LKNT,1)=-(KSUSY1+IJ)
39322 IDLAM(LKNT,2)=KSUSY1+IJ+1
39327 C...H+ -> TAU1 NUTAUL
39328 XM1=PMAS(PYCOMP(KSUSY1+15),1)
39329 XM2=PMAS(PYCOMP(KSUSY1+16),1)
39330 IF(XMI.GE.XM1+XM2) THEN
39331 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39333 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
39334 IDLAM(LKNT,1)=-(KSUSY1+15)
39335 IDLAM(LKNT,2)= KSUSY1+16
39339 C...H+ -> TAU2 NUTAUL
39340 XM1=PMAS(PYCOMP(KSUSY2+15),1)
39341 XM2=PMAS(PYCOMP(KSUSY1+16),1)
39342 IF(XMI.GE.XM1+XM2) THEN
39343 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39345 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
39346 IDLAM(LKNT,1)=-(KSUSY2+15)
39347 IDLAM(LKNT,2)= KSUSY1+16
39355 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
39356 XLAM(0)=XLAM(0)+XLAM(I)
39358 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
39363 C*********************************************************************
39366 C...Calculates the decay rate for a Higgs to an ino pair.
39368 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
39370 C...Double precision and integer declarations.
39371 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39372 IMPLICIT INTEGER(I-N)
39373 INTEGER PYK,PYCHGE,PYCOMP
39375 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39378 C...Local variables.
39379 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
39380 DOUBLE PRECISION XL,PYLAMF,C1
39381 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
39387 XL=PYLAMF(XMI2,XMJ2,XMK2)
39388 PYH2XX=C1/4D0/XMI3*SQRT(XL)
39389 &*(GX2*(XMI2-XMJ2-XMK2)-
39391 IF(PYH2XX.LT.0D0) THEN
39392 WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
39393 WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GX2,GLR,XM1,XM2,XM3
39400 C*********************************************************************
39403 C...Integration by adaptive Gaussian quadrature.
39404 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
39406 FUNCTION PYGAUS(F, A, B, EPS)
39408 C...Double precision and integer declarations.
39409 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39410 IMPLICIT INTEGER(I-N)
39411 INTEGER PYK,PYCHGE,PYCOMP
39413 C...Local declarations.
39415 DOUBLE PRECISION F,W(12), X(12)
39416 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
39417 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
39418 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
39419 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
39420 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
39421 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
39422 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
39423 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
39424 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
39425 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
39426 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
39427 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
39429 C...The Gaussian quadrature algorithm.
39431 IF(B .EQ. A) GOTO 140
39432 CONST = 5D-3 / ABS(B-A)
39443 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
39448 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
39451 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
39453 IF(BB .NE. B) GOTO 100
39456 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
39458 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
39467 C*********************************************************************
39470 C...Integration by adaptive Gaussian quadrature.
39471 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
39472 C...Carbon copy of PYGAUS, but avoids having to use it recursively.
39474 FUNCTION PYGAU2(F, A, B, EPS)
39476 C...Double precision and integer declarations.
39477 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39478 IMPLICIT INTEGER(I-N)
39479 INTEGER PYK,PYCHGE,PYCOMP
39481 C...Local declarations.
39483 DOUBLE PRECISION F,W(12), X(12)
39484 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
39485 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
39486 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
39487 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
39488 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
39489 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
39490 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
39491 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
39492 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
39493 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
39494 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
39495 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
39497 C...The Gaussian quadrature algorithm.
39499 IF(B .EQ. A) GOTO 140
39500 CONST = 5D-3 / ABS(B-A)
39511 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
39516 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
39519 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
39521 IF(BB .NE. B) GOTO 100
39524 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
39526 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
39535 C*********************************************************************
39538 C...Simpson formula for an integral.
39540 FUNCTION PYSIMP(Y,X0,X1,N)
39542 C...Double precision and integer declarations.
39543 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39544 IMPLICIT INTEGER(I-N)
39545 INTEGER PYK,PYCHGE,PYCOMP
39547 C...Local variables.
39548 DOUBLE PRECISION Y,X0,X1,H,S
39554 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
39561 C*********************************************************************
39564 C...The standard lambda function.
39566 FUNCTION PYLAMF(X,Y,Z)
39568 C...Double precision and integer declarations.
39569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39570 IMPLICIT INTEGER(I-N)
39571 INTEGER PYK,PYCHGE,PYCOMP
39573 C...Local variables.
39574 DOUBLE PRECISION PYLAMF,X,Y,Z
39576 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
39577 IF(PYLAMF.LT.0D0) PYLAMF=0D0
39582 C*********************************************************************
39585 C...Generates 3-body decays of gauginos.
39587 SUBROUTINE PYTBDY(IDIN)
39589 C...Double precision and integer declarations.
39590 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39591 IMPLICIT INTEGER(I-N)
39592 INTEGER PYK,PYCHGE,PYCOMP
39593 C...Parameter statement to help give large particle numbers.
39594 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
39595 &KEXCIT=4000000,KDIMEN=5000000)
39597 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39598 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39599 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39600 C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
39601 C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39602 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
39603 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
39604 C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
39605 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
39607 C...Local variables.
39608 DOUBLE PRECISION XM(5)
39609 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
39610 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
39611 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
39612 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
39613 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
39614 DOUBLE PRECISION CPHI1,SPHI1
39615 DOUBLE PRECISION S23DEL,EPS
39616 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
39617 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
39618 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
39620 DATA INOID/22,23,25,35/
39631 S12MIN=(XM(1)+XM(2))**2
39632 S12MAX=(XM(5)-XM(3))**2
39633 YJACO1=S12MAX-S12MIN
39635 C...Initialize some parameters
39644 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
39645 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
39647 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
39648 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
39649 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
39650 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
39655 EI=KCHG(IABS(IA),1)/3D0
39656 T3I=SIGN(1D0,EI+1D-6)/2D0
39657 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
39659 ELSEIF(IZID1*IZID2.NE.0) THEN
39661 GMMZ=PMAS(23,1)*PMAS(23,2)
39663 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
39664 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
39666 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
39667 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
39669 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
39671 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
39673 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
39674 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
39675 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
39676 XM1M2=SMZ(IZID1)*SMZ(IZID2)
39677 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
39679 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
39681 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
39683 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
39685 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
39686 IF(IZID1.NE.0) THEN
39687 XM1M2=SMZ(IZID1)*SMW(IWID2)
39691 XM1M2=SMZ(IZID2)*SMW(IWID1)
39694 RT2I = 1D0/SQRT(2D0)
39696 GMMZ=PMAS(24,1)*PMAS(24,2)
39698 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
39699 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
39702 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
39704 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
39705 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
39706 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
39707 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
39709 T3J=SIGN(1D0,EJ+1D-6)/2D0
39710 QRLS=DCMPLX(0D0,0D0)
39716 XLR2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
39717 XLL2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
39718 IF(MOD(IA,2).EQ.0) THEN
39719 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
39720 & TANW+ZMIXC(IZID2,2)*T3I)
39721 QLRT=-DCONJG(UMIXC(IZID1,1))*(
39722 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
39724 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
39725 & TANW+ZMIXC(IZID2,2)*T3J)
39726 QLRT=-DCONJG(UMIXC(IZID1,1))*(
39727 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
39729 ELSEIF(IWID1*IWID2.NE.0) THEN
39732 XM1M2=SMW(IWID1)*SMW(IWID2)
39734 GMMZ=PMAS(23,1)*PMAS(23,2)
39736 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
39737 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
39738 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
39739 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
39741 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
39742 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
39743 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
39744 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
39745 QRLS=-DCMPLX(EI/XW1)*ORPP
39746 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
39747 QRRS=-DCMPLX(EI/XW1)*OLPP
39748 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
39749 IF(MOD(IA,2).EQ.0) THEN
39750 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
39751 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
39753 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
39754 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
39756 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
39763 IF(ISKIP.NE.0) THEN
39766 S12=S12MIN+YJACO1*(KT-1)/99
39767 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
39768 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
39769 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
39770 & -(2D0*XM(1)*XM(2))**2
39771 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
39772 & -(2D0*XM(3)*XM(5))**2
39775 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
39777 S23MIN=S23AVE-S23DEL
39778 S23MAX=S23AVE+S23DEL
39779 YJACO2=S23MAX-S23MIN
39782 S23=S23MIN+YJACO2*(KS-1)/99
39785 WU2 = (UH-ZM12)*(UH-ZM22)
39786 WT2 = (TH-ZM12)*(TH-ZM22)
39788 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
39789 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
39790 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
39791 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
39792 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
39793 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
39794 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
39795 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
39796 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
39797 IF(WT0.GT.WTMAX) WTMAX=WT0
39807 BX=S12MIN+0.5D0*YJACO1
39810 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
39818 C...SOLVE FOR F1 AND F2
39819 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
39820 &-(2D0*XM(1)*XM(2))**2
39821 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
39822 &-(2D0*XM(3)*XM(5))**2
39825 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
39827 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
39828 &-(2D0*XM(1)*XM(2))**2
39829 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
39830 &-(2D0*XM(3)*XM(5))**2
39833 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
39836 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
39837 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
39843 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
39844 & -(2D0*XM(1)*XM(2))**2
39845 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
39846 & -(2D0*XM(3)*XM(5))**2
39849 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
39856 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
39857 & -(2D0*XM(1)*XM(2))**2
39858 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
39859 & -(2D0*XM(3)*XM(5))**2
39862 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
39867 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
39877 180 S12=S12MIN+PYR(0)*YJACO1
39880 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
39881 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
39882 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
39883 &-(2D0*XM(1)*XM(2))**2
39884 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
39885 &-(2D0*XM(3)*XM(5))**2
39888 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
39890 S23MIN=S23AVE-S23DEL
39891 S23MAX=S23AVE+S23DEL
39892 YJACO2=S23MAX-S23MIN
39893 S23=S23MIN+PYR(0)*YJACO2
39895 C...CHECK THE SAMPLING
39896 IF(IKNT.GT.100) THEN
39897 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
39900 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
39902 IF(ISKIP.EQ.0) GOTO 190
39908 WU2 = (UH-ZM12)*(UH-ZM22)
39909 WT2 = (TH-ZM12)*(TH-ZM22)
39911 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
39912 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
39914 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
39915 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
39916 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
39917 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
39918 c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
39919 c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
39920 c &/DCMPLX(TH-XML2)
39921 c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
39922 c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
39923 c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
39924 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
39925 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
39926 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
39928 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
39929 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
39931 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
39932 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
39934 P1=SQRT(D1*D1-XM(1)**2)
39935 P2=SQRT(D2*D2-XM(2)**2)
39936 P3=SQRT(D3*D3-XM(3)**2)
39937 CTHE1=2D0*PYR(0)-1D0
39938 ANG1=2D0*PYR(0)*PARU(1)
39942 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
39944 P(N+1,1)=P1*STHE1*CPHI1
39945 P(N+1,2)=P1*STHE1*SPHI1
39950 ANG3=2D0*PYR(0)*PARU(1)
39953 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
39955 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
39957 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
39958 &+P3*STHE3*SPHI3*SPHI1
39959 &+P3*CTHE3*STHE1*CPHI1
39960 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
39961 &-P3*STHE3*SPHI3*CPHI1
39962 &+P3*CTHE3*STHE1*SPHI1
39963 P(N+3,3)=P3*STHE3*CPHI3*STHE1
39968 P(N+2,I)=-P(N+1,I)-P(N+3,I)
39975 C*********************************************************************
39978 C...Finds the s-hat dependent eigenvalues of the inverse propagator
39979 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
39980 C...phase space generation.
39982 SUBROUTINE PYTECM(S1,S2)
39984 C...Double precision and integer declarations.
39985 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39986 IMPLICIT INTEGER(I-N)
39987 INTEGER PYK,PYCHGE,PYCOMP
39988 C...Parameter statement to help give large particle numbers.
39989 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
39990 &KEXCIT=4000000,KDIMEN=5000000)
39992 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39993 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39994 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39995 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
39996 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
39998 C...Local variables.
39999 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12),
40000 &AT(4,4),WI(4),FV1(4),FV2(4),FV3(4),sh,aem,tanw,ct2w,qupd,alprht,
40001 &far,fao,fzr,fzo,shr,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5)
40004 SH=PMAS(PYCOMP(KTECHN+113),1)**2
40007 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
40008 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
40009 QUPD=2D0*RTCM(2)-1D0
40011 ALPRHT=2.91D0*(3D0/DBLE(ITCM(1)))
40012 FAR=SQRT(AEM/ALPRHT)
40018 AR(2,2) = SH-PMAS(23,1)**2
40019 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
40020 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
40040 CALL PYWIDT(23,SH,WDTP,WDTE)
40041 AT(2,2) = WDTP(0)*SHR
40042 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
40043 AT(3,3) = WDTP(0)*SHR
40044 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
40045 AT(4,4) = WDTP(0)*SHR
40047 CALL PYEICG(4,4,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
40049 WI(I)=SQRT(ABS(SH-WR(I)))
40052 R1=MIN(WR(1),WR(2),WR(3),WR(4))
40057 IF(ABS(WR(I)-R1).LT.1D-6) THEN
40061 IF(WR(I).LE.R2) THEN
40071 C*********************************************************************
40074 C...Finds eigenvalues of a general complex matrix
40076 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
40077 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
40078 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
40079 C OF A COMPLEX GENERAL MATRIX.
40083 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
40084 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40085 C DIMENSION STATEMENT.
40087 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
40089 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
40090 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
40092 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
40093 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
40094 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
40098 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
40099 C RESPECTIVELY, OF THE EIGENVALUES.
40101 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
40102 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
40104 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
40105 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
40106 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
40108 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
40110 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40111 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40113 C THIS VERSION DATED AUGUST 1983.
40116 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
40118 INTEGER N,NM,IS1,IS2,IERR,MATZ
40119 DOUBLE PRECISION AR(4,4),AI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
40120 X FV1(4),FV2(4),FV3(4)
40121 IF (N .LE. NM) GOTO 100
40125 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
40126 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
40127 IF (MATZ .NE. 0) GOTO 110
40128 C .......... FIND EIGENVALUES ONLY ..........
40129 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
40131 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
40132 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
40133 IF (IERR .NE. 0) GOTO 120
40134 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
40138 C*********************************************************************
40141 C...Auxiliary to PYEICG.
40143 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
40144 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
40146 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
40147 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
40148 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
40150 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
40151 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
40155 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
40156 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40157 C DIMENSION STATEMENT.
40159 C N IS THE ORDER OF THE MATRIX.
40161 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
40162 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
40163 C SET LOW=1, IGH=N.
40165 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
40166 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
40167 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
40168 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
40169 C THE REDUCTION BY CORTH, IF PERFORMED.
40173 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
40174 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
40175 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
40176 C EIGENVECTORS IS TO BE PERFORMED.
40178 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
40179 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
40180 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
40181 C FOR INDICES IERR+1,...,N.
40184 C ZERO FOR NORMAL RETURN,
40185 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
40186 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
40188 C CALLS PYCDIV FOR COMPLEX DIVISION.
40189 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
40190 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
40192 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40193 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40195 C THIS VERSION DATED AUGUST 1983.
40198 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
40200 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
40201 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4)
40202 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
40206 IF (LOW .EQ. IGH) GOTO 130
40207 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
40212 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
40213 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
40214 YR = HR(I,I-1) / NORM
40215 YI = HI(I,I-1) / NORM
40220 SI = YR * HI(I,J) - YI * HR(I,J)
40221 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
40226 SI = YR * HI(J,I) + YI * HR(J,I)
40227 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
40232 C .......... STORE ROOTS ISOLATED BY CBAL ..........
40233 130 DO 140 I = 1, N
40234 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
40243 C .......... SEARCH FOR NEXT EIGENVALUE ..........
40244 150 IF (EN .LT. LOW) GOTO 320
40247 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
40248 C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
40249 160 DO 170 LL = LOW, EN
40251 IF (L .EQ. LOW) GOTO 180
40252 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
40253 X + DABS(HR(L,L)) + DABS(HI(L,L))
40254 TST2 = TST1 + DABS(HR(L,L-1))
40255 IF (TST2 .EQ. TST1) GOTO 180
40257 C .......... FORM SHIFT ..........
40258 180 IF (L .EQ. EN) GOTO 300
40259 IF (ITN .EQ. 0) GOTO 310
40260 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
40263 XR = HR(ENM1,EN) * HR(EN,ENM1)
40264 XI = HI(ENM1,EN) * HR(EN,ENM1)
40265 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
40266 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
40267 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
40268 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
40269 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
40272 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
40276 C .......... FORM EXCEPTIONAL SHIFT ..........
40277 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
40280 210 DO 220 I = LOW, EN
40281 HR(I,I) = HR(I,I) - SR
40282 HI(I,I) = HI(I,I) - SI
40289 C .......... REDUCE TO TRIANGLE (ROWS) ..........
40295 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
40296 XR = HR(I-1,I-1) / NORM
40298 XI = HI(I-1,I-1) / NORM
40301 HI(I-1,I-1) = 0.0D0
40302 HI(I,I-1) = SR / NORM
40309 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
40310 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
40311 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
40312 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
40318 IF (SI .EQ. 0.0D0) GOTO 250
40319 NORM = PYTHAG(HR(EN,EN),SI)
40320 SR = HR(EN,EN) / NORM
40324 C .......... INVERSE OPERATION (COLUMNS) ..........
40325 250 DO 280 J = LP1, EN
40334 IF (I .EQ. J) GOTO 260
40336 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
40337 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
40338 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
40339 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
40344 IF (SI .EQ. 0.0D0) GOTO 160
40349 HR(I,EN) = SR * YR - SI * YI
40350 HI(I,EN) = SR * YI + SI * YR
40354 C .......... A ROOT FOUND ..........
40355 300 WR(EN) = HR(EN,EN) + TR
40356 WI(EN) = HI(EN,EN) + TI
40359 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
40360 C CONVERGED AFTER 30*N ITERATIONS ..........
40365 C*********************************************************************
40368 C...Auxiliary to PYEICG.
40370 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
40371 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
40373 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
40374 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
40375 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
40377 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
40378 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
40379 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
40380 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
40381 C THIS GENERAL MATRIX TO HESSENBERG FORM.
40385 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
40386 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40387 C DIMENSION STATEMENT.
40389 C N IS THE ORDER OF THE MATRIX.
40391 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
40392 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
40393 C SET LOW=1, IGH=N.
40395 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
40396 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
40397 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
40398 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
40399 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
40401 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
40402 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
40403 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
40404 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
40405 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
40406 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
40411 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
40412 C HAVE BEEN DESTROYED.
40414 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
40415 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
40416 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
40417 C FOR INDICES IERR+1,...,N.
40419 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
40420 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
40421 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
40422 C THE EIGENVECTORS HAS BEEN FOUND.
40425 C ZERO FOR NORMAL RETURN,
40426 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
40427 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
40429 C CALLS PYCDIV FOR COMPLEX DIVISION.
40430 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
40431 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
40433 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40434 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40436 C THIS VERSION DATED OCTOBER 1989.
40438 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
40439 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
40442 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
40444 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
40445 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
40446 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
40448 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
40452 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
40461 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
40462 C FROM THE INFORMATION LEFT BY CORTH ..........
40463 IEND = IGH - LOW - 1
40464 IF (IEND.LT.0) GOTO 220
40465 IF (IEND.EQ.0) GOTO 170
40466 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
40467 DO 160 II = 1, IEND
40469 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
40470 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
40471 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
40472 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
40475 DO 120 K = IP1, IGH
40476 ORTR(K) = HR(K,I-1)
40477 ORTI(K) = HI(K,I-1)
40485 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
40486 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
40493 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
40494 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
40500 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
40505 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
40506 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
40507 YR = HR(I,I-1) / NORM
40508 YI = HI(I,I-1) / NORM
40513 SI = YR * HI(I,J) - YI * HR(I,J)
40514 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
40519 SI = YR * HI(J,I) + YI * HR(J,I)
40520 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
40524 DO 200 J = LOW, IGH
40525 SI = YR * ZI(J,I) + YI * ZR(J,I)
40526 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
40531 C .......... STORE ROOTS ISOLATED BY CBAL ..........
40532 220 DO 230 I = 1, N
40533 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
40542 C .......... SEARCH FOR NEXT EIGENVALUE ..........
40543 240 IF (EN .LT. LOW) GOTO 430
40546 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
40547 C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
40548 250 DO 260 LL = LOW, EN
40550 IF (L .EQ. LOW) GOTO 270
40551 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
40552 X + DABS(HR(L,L)) + DABS(HI(L,L))
40553 TST2 = TST1 + DABS(HR(L,L-1))
40554 IF (TST2 .EQ. TST1) GOTO 270
40556 C .......... FORM SHIFT ..........
40557 270 IF (L .EQ. EN) GOTO 420
40558 IF (ITN .EQ. 0) GOTO 550
40559 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
40562 XR = HR(ENM1,EN) * HR(EN,ENM1)
40563 XI = HI(ENM1,EN) * HR(EN,ENM1)
40564 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
40565 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
40566 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
40567 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
40568 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
40571 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
40575 C .......... FORM EXCEPTIONAL SHIFT ..........
40576 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
40579 300 DO 310 I = LOW, EN
40580 HR(I,I) = HR(I,I) - SR
40581 HI(I,I) = HI(I,I) - SI
40588 C .......... REDUCE TO TRIANGLE (ROWS) ..........
40594 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
40595 XR = HR(I-1,I-1) / NORM
40597 XI = HI(I-1,I-1) / NORM
40600 HI(I-1,I-1) = 0.0D0
40601 HI(I,I-1) = SR / NORM
40608 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
40609 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
40610 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
40611 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
40617 IF (SI .EQ. 0.0D0) GOTO 350
40618 NORM = PYTHAG(HR(EN,EN),SI)
40619 SR = HR(EN,EN) / NORM
40623 IF (EN .EQ. N) GOTO 350
40629 HR(EN,J) = SR * YR + SI * YI
40630 HI(EN,J) = SR * YI - SI * YR
40632 C .......... INVERSE OPERATION (COLUMNS) ..........
40633 350 DO 390 J = LP1, EN
40642 IF (I .EQ. J) GOTO 360
40644 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
40645 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
40646 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
40647 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
40650 DO 380 I = LOW, IGH
40655 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
40656 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
40657 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
40658 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
40663 IF (SI .EQ. 0.0D0) GOTO 250
40668 HR(I,EN) = SR * YR - SI * YI
40669 HI(I,EN) = SR * YI + SI * YR
40672 DO 410 I = LOW, IGH
40675 ZR(I,EN) = SR * YR - SI * YI
40676 ZI(I,EN) = SR * YI + SI * YR
40680 C .......... A ROOT FOUND ..........
40681 420 HR(EN,EN) = HR(EN,EN) + TR
40683 HI(EN,EN) = HI(EN,EN) + TI
40687 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
40688 C VECTORS OF UPPER TRIANGULAR FORM ..........
40694 TR = DABS(HR(I,J)) + DABS(HI(I,J))
40695 IF (TR .GT. NORM) NORM = TR
40698 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
40699 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
40707 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
40708 DO 490 II = 1, ENM1
40715 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
40716 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
40721 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
40724 460 YR = 0.01D0 * YR
40726 IF (TST2 .GT. TST1) GOTO 460
40728 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
40729 C .......... OVERFLOW CONTROL ..........
40730 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
40731 IF (TR .EQ. 0.0D0) GOTO 490
40733 TST2 = TST1 + 1.0D0/TST1
40734 IF (TST2 .GT. TST1) GOTO 490
40736 HR(J,EN) = HR(J,EN)/TR
40737 HI(J,EN) = HI(J,EN)/TR
40743 C .......... END BACKSUBSTITUTION ..........
40744 C .......... VECTORS OF ISOLATED ROOTS ..........
40746 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
40754 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
40755 C VECTORS OF ORIGINAL FULL MATRIX.
40756 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
40761 DO 540 I = LOW, IGH
40766 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
40767 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
40775 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
40776 C CONVERGED AFTER 30*N ITERATIONS ..........
40781 C*********************************************************************
40784 C...Auxiliary to PYCMQR
40786 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
40789 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
40791 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
40792 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
40794 S = DABS(BR) + DABS(BI)
40799 S = BRS**2 + BIS**2
40800 CR = (ARS*BRS + AIS*BIS)/S
40801 CI = (AIS*BRS - ARS*BIS)/S
40805 C*********************************************************************
40808 C...Auxiliary to PYCMQR
40810 C (YR,YI) = COMPLEX DSQRT(XR,XI)
40811 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
40814 SUBROUTINE PYCSRT(XR,XI,YR,YI)
40816 DOUBLE PRECISION XR,XI,YR,YI
40817 DOUBLE PRECISION S,TR,TI,PYTHAG
40821 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
40822 IF (TR .GE. 0.0D0) YR = S
40823 IF (TI .LT. 0.0D0) S = -S
40824 IF (TR .LE. 0.0D0) YI = S
40825 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
40826 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
40830 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
40831 DOUBLE PRECISION A,B
40833 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
40835 DOUBLE PRECISION P,R,S,T,U
40836 P = DMAX1(DABS(A),DABS(B))
40837 IF (P .EQ. 0.0D0) GOTO 110
40838 R = (DMIN1(DABS(A),DABS(B))/P)**2
40841 IF (T .EQ. 4.0D0) GOTO 110
40843 U = 1.0D0 + 2.0D0*S
40851 C*********************************************************************
40854 C...Auxiliary to PYEICG
40856 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
40857 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
40858 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
40859 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
40861 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
40862 C EIGENVALUES WHENEVER POSSIBLE.
40866 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
40867 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40868 C DIMENSION STATEMENT.
40870 C N IS THE ORDER OF THE MATRIX.
40872 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
40873 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
40877 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
40878 C RESPECTIVELY, OF THE BALANCED MATRIX.
40880 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
40881 C ARE EQUAL TO ZERO IF
40882 C (1) I IS GREATER THAN J AND
40883 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
40885 C SCALE CONTAINS INFORMATION DETERMINING THE
40886 C PERMUTATIONS AND SCALING FACTORS USED.
40888 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
40889 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
40890 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
40891 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
40892 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
40893 C = D(J,J) J = LOW,...,IGH
40894 C = P(J) J = IGH+1,...,N.
40895 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
40898 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
40900 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
40901 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
40902 C K,L HAVE BEEN REVERSED.)
40904 C ARITHMETIC IS REAL THROUGHOUT.
40906 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40907 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40909 C THIS VERSION DATED AUGUST 1983.
40912 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
40914 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
40915 DOUBLE PRECISION AR(4,4),AI(4,4),SCALE(4)
40916 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
40925 C .......... IN-LINE PROCEDURE FOR ROW AND
40926 C COLUMN EXCHANGE ..........
40928 IF (J .EQ. M) GOTO 130
40948 130 IF(IEXC.EQ.1) GOTO 140
40949 IF(IEXC.EQ.2) GOTO 180
40950 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
40951 C AND PUSH THEM DOWN ..........
40952 140 IF (L .EQ. 1) GOTO 320
40954 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
40955 150 DO 170 JJ = 1, L
40959 IF (I .EQ. J) GOTO 160
40960 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
40969 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
40970 C AND PUSH THEM LEFT ..........
40973 190 DO 210 J = K, L
40976 IF (I .EQ. J) GOTO 200
40977 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
40984 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
40986 220 SCALE(I) = 1.0D0
40987 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
40988 230 NOCONV = .FALSE.
40995 IF (J .EQ. I) GOTO 240
40996 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
40997 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
40999 C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
41000 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
41004 250 IF (C .GE. G) GOTO 260
41009 270 IF (C .LT. G) GOTO 280
41013 C .......... NOW BALANCE ..........
41014 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
41016 SCALE(I) = SCALE(I) * F
41020 AR(I,J) = AR(I,J) * G
41021 AI(I,J) = AI(I,J) * G
41025 AR(J,I) = AR(J,I) * F
41026 AI(J,I) = AI(J,I) * F
41031 IF (NOCONV) GOTO 230
41038 C*********************************************************************
41041 C...Auxiliary to PYEICG.
41043 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
41044 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
41045 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
41046 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
41048 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
41049 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
41050 C BALANCED MATRIX DETERMINED BY CBAL.
41054 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
41055 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
41056 C DIMENSION STATEMENT.
41058 C N IS THE ORDER OF THE MATRIX.
41060 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
41062 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
41063 C AND SCALING FACTORS USED BY CBAL.
41065 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
41067 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
41068 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
41069 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
41073 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
41074 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
41075 C IN THEIR FIRST M COLUMNS.
41077 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
41078 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
41080 C THIS VERSION DATED AUGUST 1983.
41083 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
41085 INTEGER I,J,K,M,N,II,NM,IGH,LOW
41086 DOUBLE PRECISION SCALE(4),ZR(4,4),ZI(4,4)
41089 IF (M .EQ. 0) GOTO 150
41090 IF (IGH .EQ. LOW) GOTO 120
41092 DO 110 I = LOW, IGH
41094 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
41095 C IF THE FOREGOING STATEMENT IS REPLACED BY
41096 C S=1.0D0/SCALE(I). ..........
41098 ZR(I,J) = ZR(I,J) * S
41099 ZI(I,J) = ZI(I,J) * S
41103 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
41104 C IGH+1 STEP 1 UNTIL N DO -- ..........
41105 120 DO 140 II = 1, N
41107 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
41108 IF (I .LT. LOW) I = LOW - II
41110 IF (K .EQ. I) GOTO 140
41126 C*********************************************************************
41129 C...Auxiliary to PYEICG.
41131 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
41132 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
41133 C BY MARTIN AND WILKINSON.
41134 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
41136 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
41137 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
41138 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
41139 C UNITARY SIMILARITY TRANSFORMATIONS.
41143 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
41144 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
41145 C DIMENSION STATEMENT.
41147 C N IS THE ORDER OF THE MATRIX.
41149 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
41150 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
41151 C SET LOW=1, IGH=N.
41153 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
41154 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
41158 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
41159 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
41160 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
41161 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
41162 C HESSENBERG MATRIX.
41164 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
41165 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
41167 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
41169 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
41170 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
41172 C THIS VERSION DATED AUGUST 1983.
41175 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
41177 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
41178 DOUBLE PRECISION AR(4,4),AI(4,4),ORTR(4),ORTI(4)
41179 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
41183 IF (LA .LT. KP1) GOTO 210
41190 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
41192 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
41194 IF (SCALE .EQ. 0.0D0) GOTO 200
41196 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
41199 ORTR(I) = AR(I,M-1) / SCALE
41200 ORTI(I) = AI(I,M-1) / SCALE
41201 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
41205 F = PYTHAG(ORTR(M),ORTI(M))
41206 IF (F .EQ. 0.0D0) GOTO 120
41209 ORTR(M) = (1.0D0 + G) * ORTR(M)
41210 ORTI(M) = (1.0D0 + G) * ORTI(M)
41215 C .......... FORM (I-(U*UT)/H) * A ..........
41216 130 DO 160 J = M, N
41219 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
41222 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
41223 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
41230 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
41231 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
41235 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
41239 C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
41242 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
41243 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
41250 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
41251 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
41256 ORTR(M) = SCALE * ORTR(M)
41257 ORTI(M) = SCALE * ORTI(M)
41258 AR(M,M-1) = -G * AR(M,M-1)
41259 AI(M,M-1) = -G * AI(M,M-1)
41265 C*********************************************************************
41268 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
41271 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
41273 INTEGER N,NP,INDX(N)
41275 COMPLEX*16 A(NP,NP)
41276 PARAMETER (TINY=1.0D-20)
41278 REAL*8 AAMAX,VV(6),DUM
41279 COMPLEX*16 SUM,DUMC
41285 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
41287 IF (AAMAX.EQ.0D0) PAUSE 'SINGULAR MATRIX IN PYLDCM'
41294 SUM=SUM-A(I,K)*A(K,J)
41302 SUM=SUM-A(I,K)*A(K,J)
41306 IF (DUM.GE.AAMAX) THEN
41321 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
41324 A(I,J)=A(I,J)/A(J,J)
41332 C*********************************************************************
41335 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
41338 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
41340 INTEGER N,NP,INDX(N)
41341 COMPLEX*16 A(NP,NP),B(N)
41352 SUM=SUM-A(I,J)*B(J)
41354 ELSE IF (ABS(SUM).NE.0D0) THEN
41362 SUM=SUM-A(I,J)*B(J)
41369 C***********************************************************************
41372 C...Calculates full and partial widths of resonances.
41373 C....copy of PYWIDT, used for techniparticle widths
41375 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
41377 C...Double precision and integer declarations.
41378 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41379 IMPLICIT INTEGER(I-N)
41380 INTEGER PYK,PYCHGE,PYCOMP
41381 C...Parameter statement to help give large particle numbers.
41382 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
41383 &KEXCIT=4000000,KDIMEN=5000000)
41385 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41386 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41387 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
41388 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
41389 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41390 COMMON/PYINT1/MINT(400),VINT(400)
41391 COMMON/PYINT4/MWID(500),WIDS(500,5)
41392 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41393 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
41394 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
41395 &/PYINT4/,/PYMSSM/,/PYTCSM/
41396 C...Local arrays and saved variables.
41397 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
41399 SAVE MOFSV,WIDWSV,WID2SV
41400 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
41402 C...Compressed code and sign; mass.
41409 C...Reset width information.
41417 C...Common electroweak and strong constants.
41420 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
41423 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
41425 RADC=1D0+AS/PARU(1)
41427 IF(KFLA.EQ.23) THEN
41430 XWC=1D0/(16D0*XW*XW1)
41431 FAC=(AEM*XWC/3D0)*SHR
41433 DO 130 I=1,MDCY(KC,3)
41435 IF(MDME(IDC,1).LT.0) GOTO 130
41436 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
41437 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
41438 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
41443 AF=SIGN(1D0,EF+0.1D0)
41446 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
41447 IF(I.EQ.6) WID2=WIDS(6,1)
41448 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
41449 ELSEIF(I.LE.16) THEN
41450 C...Z0 -> l+ + l-, nu + nubar
41452 AF=SIGN(1D0,EF+0.1D0)
41455 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
41457 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
41458 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
41460 WDTP(0)=WDTP(0)+WDTP(I)
41461 IF(MDME(IDC,1).GT.0) THEN
41462 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
41463 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
41464 & WDTE(I,MDME(IDC,1))
41465 WDTE(I,0)=WDTE(I,MDME(IDC,1))
41466 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
41471 ELSEIF(KFLA.EQ.24) THEN
41473 FAC=(AEM/(24D0*XW))*SHR
41474 DO 140 I=1,MDCY(KC,3)
41476 IF(MDME(IDC,1).LT.0) GOTO 140
41477 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
41478 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
41479 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
41482 C...W+/- -> q + qbar'
41483 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
41485 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
41486 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
41487 IF(I.GE.13) WID2=WID2*WIDS(7,3)
41489 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
41490 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
41491 IF(I.GE.13) WID2=WID2*WIDS(7,2)
41493 ELSEIF(I.LE.20) THEN
41494 C...W+/- -> l+/- + nu
41497 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
41499 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
41502 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
41503 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
41504 WDTP(0)=WDTP(0)+WDTP(I)
41505 IF(MDME(IDC,1).GT.0) THEN
41506 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
41507 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
41508 WDTE(I,0)=WDTE(I,MDME(IDC,1))
41509 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
41513 C.....V8 -> quark anti-quark
41514 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
41517 IF(ITCM(2).EQ.0) THEN
41519 ELSEIF(ITCM(2).EQ.1) THEN
41522 DO 150 I=1,MDCY(KC,3)
41524 IF(MDME(IDC,1).LT.0) GOTO 150
41525 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
41527 IF(RM1.GT.0.25D0) GOTO 150
41529 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
41534 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
41535 IF(I.EQ.6) WID2=WIDS(6,1)
41536 WDTP(0)=WDTP(0)+WDTP(I)
41537 IF(MDME(IDC,1).GT.0) THEN
41538 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
41539 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
41540 WDTE(I,0)=WDTE(I,MDME(IDC,1))
41541 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
41549 C*********************************************************************
41552 C...Calculates R-violating decays of sfermions.
41555 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
41557 C...Double precision and integer declarations.
41558 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41559 IMPLICIT INTEGER(I-N)
41560 C...Parameter statement to help give large particle numbers.
41561 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
41562 &KEXCIT=4000000,KDIMEN=5000000)
41564 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41565 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41566 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
41567 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
41568 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
41569 C...Local variables.
41570 DOUBLE PRECISION XLAM(0:400)
41571 INTEGER IDLAM(400,3), PYCOMP
41572 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
41574 C...IS R-VIOLATION ON ?
41575 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
41576 C...Mass eigenstate counter
41577 ICNT=INT(KFIN/KSUSY1)
41578 C...SM KF code of SUSY particle
41579 KFSM=KFIN-ICNT*KSUSY1
41580 C...Squared Sparticle Mass
41581 SM=PMAS(PYCOMP(KFIN),1)**2
41582 C... Squared mass of top quark
41583 SMT=PMAS(PYCOMP(6),1)**2
41584 C...IS L-VIOLATION ON ?
41585 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
41586 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
41587 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
41593 C...~e,~mu,~tau -> nu_I + lepton-_J
41595 IDLAM(LKNT,1)= 12 +2*(I-1)
41596 IDLAM(LKNT,2)= 11 +2*(J-1)
41599 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41600 IF (IMSS(51).NE.0) XLAM(LKNT) =
41601 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41602 C...KINEMATICS CHECK
41603 IF (XLAM(LKNT).EQ.0D0) THEN
41609 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
41615 IDLAM(LKNT,1)=-12 -2*(I-1)
41616 IDLAM(LKNT,2)= 11 +2*(K-1)
41619 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41620 IF (IMSS(51).NE.0) XLAM(LKNT) =
41621 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41622 C...KINEMATICS CHECK
41623 IF (XLAM(LKNT).EQ.0D0) THEN
41629 C...~e,~mu,~tau -> u_Jbar + d_K
41634 IDLAM(LKNT,1)=-2 -2*(J-1)
41635 IDLAM(LKNT,2)= 1 +2*(K-1)
41638 IF (IMSS(52).NE.0) THEN
41639 C...Use massive top quark
41640 IF (IDLAM(LKNT,1).EQ.-6) THEN
41641 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
41644 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
41645 C...If no top quark, all decay products massless
41647 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41649 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41651 C...KINEMATICS CHECK
41652 IF (XLAM(LKNT).EQ.0D0) THEN
41659 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
41660 C...No right-handed neutrinos
41662 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
41667 C...~nu_J -> lepton+_I + lepton-_K
41669 IDLAM(LKNT,1)=-11 -2*(I-1)
41670 IDLAM(LKNT,2)= 11 +2*(K-1)
41673 RM2=RVLAM(I,J,K)**2 * SM
41674 IF (IMSS(51).NE.0) XLAM(LKNT) =
41675 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41676 C...KINEMATICS CHECK
41677 IF (XLAM(LKNT).EQ.0D0) THEN
41683 C...~nu_I -> dbar_J + d_K
41688 IDLAM(LKNT,1)=-1 -2*(J-1)
41689 IDLAM(LKNT,2)= 1 +2*(K-1)
41692 RM2=3*RVLAMP(I,J,K)**2 * SM
41693 IF (IMSS(52).NE.0) XLAM(LKNT) =
41694 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41695 C...KINEMATICS CHECK
41696 IF (XLAM(LKNT).EQ.0D0) THEN
41703 C * SDOWN -> NU(BAR) + D and LEPTON- + U
41704 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
41708 C...~d_J -> nu_Ibar + d_K
41710 IDLAM(LKNT,1)=-12 -2*(I-1)
41711 IDLAM(LKNT,2)= 1 +2*(K-1)
41714 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41715 IF (IMSS(52).NE.0) XLAM(LKNT) =
41716 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41717 C...KINEMATICS CHECK
41718 IF (XLAM(LKNT).EQ.0D0) THEN
41726 C...~d_K -> nu_I + d_J
41728 IDLAM(LKNT,1)= 12 +2*(I-1)
41729 IDLAM(LKNT,2)= 1 +2*(J-1)
41732 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41733 IF (IMSS(52).NE.0) XLAM(LKNT) =
41734 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41735 C...KINEMATICS CHECK
41736 IF (XLAM(LKNT).EQ.0D0) THEN
41739 C...~d_K -> lepton_I- + u_J
41741 IDLAM(LKNT,1)= 11 +2*(I-1)
41742 IDLAM(LKNT,2)= 2 +2*(J-1)
41745 IF (IMSS(52).NE.0) THEN
41746 C...Use massive top quark
41747 IF (IDLAM(LKNT,2).EQ.6) THEN
41748 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
41750 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
41751 C...If no top quark, all decay products massless
41753 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41755 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41757 C...KINEMATICS CHECK
41758 IF (XLAM(LKNT).EQ.0D0) THEN
41765 C * SUP -> LEPTON+ + D
41766 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
41770 C...~u_J -> lepton_I+ + d_K
41772 IDLAM(LKNT,1)=-11 -2*(I-1)
41773 IDLAM(LKNT,2)= 1 +2*(K-1)
41776 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41777 IF (IMSS(52).NE.0) XLAM(LKNT) =
41778 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41779 C...KINEMATICS CHECK
41780 IF (XLAM(LKNT).EQ.0D0) THEN
41787 C...BARYON NUMBER VIOLATING DECAYS
41788 IF (IMSS(53).GE.1) THEN
41789 C * SUP -> DBAR + DBAR
41790 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
41794 C...~u_I -> dbar_J + dbar_K
41796 C...(anti-) symmetry J <-> K.
41798 IDLAM(LKNT,1) = -1 -2*(J-1)
41799 IDLAM(LKNT,2) = -1 -2*(K-1)
41802 RM2 = 2.*(RVLAMB(I,J,K)**2)
41803 & * SFMIX(KFSM,2*ICNT)**2 * SM
41805 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41806 C...KINEMATICS CHECK
41807 IF (XLAM(LKNT).EQ.0D0) THEN
41814 C * SDOWN -> UBAR + DBAR
41815 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
41819 C...LAMB coupling antisymmetric in J and K.
41821 C...~d_K -> ubar_I + dbar_K
41823 IDLAM(LKNT,1)= -2 -2*(I-1)
41824 IDLAM(LKNT,2)= -1 -2*(J-1)
41827 C...Use massive top quark
41828 IF (IDLAM(LKNT,1).EQ.-6) THEN
41829 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
41832 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
41833 C...If no top quark, all decay products massless
41835 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41837 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41839 C...KINEMATICS CHECK
41840 IF (XLAM(LKNT).EQ.0D0) THEN
41853 C*********************************************************************
41856 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
41859 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
41861 C...Double precision and integer declarations.
41862 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41863 IMPLICIT INTEGER(I-N)
41864 C...Parameter statement to help give large particle numbers.
41865 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
41866 &KEXCIT=4000000,KDIMEN=5000000)
41868 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41869 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41870 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41871 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
41872 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
41873 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
41874 C...Local variables.
41875 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
41877 DOUBLE PRECISION XLAM(0:400)
41878 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
41879 INTEGER IDLAM(400,3), PYCOMP
41881 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
41883 C...R-VIOLATING DECAYS
41884 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
41886 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
41887 C...WHICH NEUTRALINO ?
41889 IF (KFSM.EQ.23) NCHI=2
41890 IF (KFSM.EQ.25) NCHI=3
41891 IF (KFSM.EQ.35) NCHI=4
41892 C...SIGN OF MASS (Opposite convention as HERWIG)
41894 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
41896 C...Useful parameters for the calculation of the A and B constants.
41897 WMASS = PMAS(PYCOMP(24),1)
41898 ECHG = 2*SQRT(PARU(103)*PARU(1))
41899 COSB=1/(SQRT(1+RMSS(5)**2))
41900 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
41901 COSW=SQRT(1-PARU(102))
41902 SINW=SQRT(PARU(102))
41903 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
41904 C...Run quark masses to neutralino mass squared (for Higgs-type
41906 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
41908 RMQ(I)=PYMRUN(I,SQMCHI)
41910 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
41912 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
41913 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
41914 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
41915 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
41917 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
41918 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
41919 C2=ECHG*ZPMIX(NCHI,1)
41920 C3=GW*ZPMIX(NCHI,2)/COSW
41924 C x=1-2 : Select A or B constant (1:A ; 2:B)
41925 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
41926 C 11-16:e,nu_e,mu,...)
41927 C z=1-2 : Mass eigenstate number
41928 C...CALCULATE COUPLINGS
41930 CMS=PMAS(PYCOMP(I),1)
41931 C...Intermediate sleptons
41932 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
41933 & *(C2-C3*SINW**2))
41934 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
41935 & *(C2-C3*SINW**2))
41936 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
41938 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
41940 C...Inermediate sneutrinos
41942 AB(2,I+1,1)=5D-1*C3
41945 C...Inermediate sdown
41948 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
41949 & *ED*(C2-C3*SINW**2))
41950 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
41951 & *ED*(C2-C3*SINW**2))
41952 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
41953 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
41954 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
41955 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
41956 C...Inermediate sup
41959 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
41960 & *EU*(C2-C3*SINW**2))
41961 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
41962 & *EU*(C2-C3*SINW**2))
41963 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
41964 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
41965 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
41966 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
41969 IF (IMSS(51).GE.1) THEN
41970 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
41971 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
41972 C...STEP IN I,J,K USING SINGLE COUNTER
41974 C...LAMBDA COUPLING ASYM IN I,J
41975 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
41977 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
41978 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
41979 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
41981 C...Set coupling, and decay product masses on/off
41982 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
41983 & ,MOD(ISC,3)+1)**2
41985 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
41987 C...Resonance KF codes (1=I,2=J,3=K)
41988 KFR(1)=-IDLAM(LKNT,1)
41989 KFR(2)=-IDLAM(LKNT,2)
41990 KFR(3)=-IDLAM(LKNT,3)
41991 C...Calculate width.
41992 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
41993 & IDLAM(LKNT,3),XLAM(LKNT))
41994 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
41995 C...Charge conjugate mode.
41997 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
41998 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
41999 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42000 XLAM(LKNT)=XLAM(LKNT-1)
42001 C...KINEMATICS CHECK
42002 IF (XLAM(LKNT).EQ.0D0) THEN
42009 IF (IMSS(52).GE.1) THEN
42010 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
42011 C * CHI0 -> NUBAR_I + DBAR_J + D_K
42014 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
42015 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42016 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42018 C...Set coupling, and decay product masses on/off
42019 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
42020 & ,MOD(ISC,3)+1)**2
42022 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
42024 C...Resonance KF codes (1=I,2=J,3=K)
42025 KFR(1)=-IDLAM(LKNT,1)
42026 KFR(2)=-IDLAM(LKNT,2)
42027 KFR(3)=-IDLAM(LKNT,3)
42028 C...Calculate width.
42029 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42031 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42032 C...Charge conjugate mode.
42034 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42035 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42036 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42037 XLAM(LKNT)=XLAM(LKNT-1)
42038 C...KINEMATICS CHECK
42039 IF (XLAM(LKNT).EQ.0D0) THEN
42043 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
42045 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42046 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
42047 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42049 C...Set coupling, and decay product masses on/off
42050 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
42051 & ,MOD(ISC,3)+1)**2
42053 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
42054 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
42055 C...Resonance KF codes (1=I,2=J,3=K)
42056 KFR(1)=-IDLAM(LKNT,1)
42057 KFR(2)=-IDLAM(LKNT,2)
42058 KFR(3)=-IDLAM(LKNT,3)
42059 C...Calculate width.
42060 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42062 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42063 C...Charge conjugate mode.
42065 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42066 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42067 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42068 XLAM(LKNT)=XLAM(LKNT-1)
42069 C...KINEMATICS CHECK
42070 IF (XLAM(LKNT).EQ.0D0) THEN
42076 IF (IMSS(53).GE.1) THEN
42077 C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
42078 C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
42080 C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
42081 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
42083 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
42084 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42085 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42087 C...Set coupling, and decay product masses on/off
42088 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
42089 & +1,MOD(ISC,3)+1)**2
42091 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
42092 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
42093 C...Resonance KF codes (1=I,2=J,3=K)
42094 KFR(1) = IDLAM(LKNT,1)
42095 KFR(2) = IDLAM(LKNT,2)
42096 KFR(3) = IDLAM(LKNT,3)
42097 C...Calculate width.
42098 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42099 & IDLAM(LKNT,3),XLAM(LKNT))
42100 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42101 C...Charge conjugate mode.
42103 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42104 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42105 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42106 XLAM(LKNT)=XLAM(LKNT-1)
42107 C...KINEMATICS CHECK
42108 IF (XLAM(LKNT).EQ.0D0) THEN
42120 C*********************************************************************
42123 C...Calculates R-violating chargino decay widths.
42126 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
42128 C...Double precision and integer declarations.
42129 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42130 IMPLICIT INTEGER(I-N)
42131 C...Parameter statement to help give large particle numbers.
42132 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42133 &KEXCIT=4000000,KDIMEN=5000000)
42135 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42136 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42137 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42138 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42139 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42140 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
42141 C...Local variables.
42142 DOUBLE PRECISION XLAM(0:400)
42143 INTEGER IDLAM(400,3), PYCOMP
42144 C...Information from main routine to PYRVGW
42145 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
42147 C...Auxiliary variables needed for BV (RV Gauge STOre)
42148 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
42150 C...Running quark masses
42151 DOUBLE PRECISION RMQ(6)
42152 C...Decay product masses on/off
42154 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
42158 C...IF R-VIOLATION ON.
42159 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
42161 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
42162 C...WHICH CHARGINO ?
42164 IF (KFSM.EQ.37) NCHI = 2
42166 C...Useful parameters for calculating the A and B constants.
42167 C...SIGN OF MASS (Opposite convention as HERWIG)
42169 IF (SMW(NCHI).LT.0D0) ISM = -1
42170 WMASS = PMAS(PYCOMP(24),1)
42171 COSB = 1/(SQRT(1+RMSS(5)**2))
42172 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
42173 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
42174 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
42175 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
42178 C...Running masses at Q^2=MCHI^2.
42179 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
42181 RMQ(I)=PYMRUN(I,SQMCHI)
42184 C... AB(x,y,z) coefficients:
42185 C x=1-2 : A or B coefficient (1:A ; 2:B)
42186 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
42187 C 11-16:e,nu_e,mu,...)
42188 C z=1-2 : Mass eigenstate number
42190 C...Intermediate sleptons
42193 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
42195 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
42197 C...Intermediate sneutrinos
42198 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
42200 AB(2,I+1,1) = ISM*C3
42202 C...Intermediate sdown
42204 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
42205 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
42206 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
42207 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
42208 C...Intermediate sup
42210 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
42211 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
42212 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
42213 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
42216 C...LLE TYPE R-VIOLATION
42217 IF (IMSS(51).GE.1) THEN
42218 C...LOOP OVER DECAY MODES
42221 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
42222 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
42224 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
42225 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
42226 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
42228 C...Set coupling, and decay product masses on/off
42229 RVLAMC = GW2 * 5D-1 *
42230 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
42233 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
42234 C...Resonance KF codes (1=I,2=J,3=K).
42237 KFR(3) = -IDLAM(LKNT,3)+1
42238 C...Calculate width.
42239 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42240 & IDLAM(LKNT,3),XLAM(LKNT))
42241 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42242 C...KINEMATICS CHECK
42243 IF (XLAM(LKNT).EQ.0D0) THEN
42247 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
42248 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
42250 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
42251 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
42252 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
42254 C...Set coupling, and decay product masses on/off
42255 RVLAMC = GW2 * 5D-1 *
42256 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42257 C...I,J SYMMETRY => FACTOR 2
42260 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
42261 C...Resonance KF codes (1=I,2=J,3=K)
42262 KFR(1)=IDLAM(LKNT,1)-1
42263 KFR(2)=IDLAM(LKNT,2)-1
42265 C...Calculate width.
42266 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42267 & IDLAM(LKNT,3),XLAM(LKNT))
42268 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42269 C...KINEMATICS CHECK
42270 IF (XLAM(LKNT).EQ.0D0) THEN
42275 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
42277 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42278 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
42279 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
42281 C...Set coupling, and decay product masses on/off
42282 RVLAMC = GW2 * 5D-1 *
42283 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42284 C...I,J SYMMETRY => FACTOR 2
42287 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
42288 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
42289 C...Resonance KF codes (1=I,2=J,3=K)
42290 KFR(1) =-IDLAM(LKNT,1)+1
42291 KFR(2) =-IDLAM(LKNT,2)+1
42293 C...Calculate width.
42294 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42295 & IDLAM(LKNT,3),XLAM(LKNT))
42296 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42297 C...KINEMATICS CHECK
42298 IF (XLAM(LKNT).EQ.0D0) THEN
42305 C...LQD TYPE R-VIOLATION
42306 IF (IMSS(52).GE.1) THEN
42307 C...LOOP OVER DECAY MODES
42310 C...CHI+ -> NUBAR_I + DBAR_J + U_K
42312 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
42313 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42314 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
42316 C...Set coupling, and decay product masses on/off
42317 RVLAMC = 3. * GW2 * 5D-1 *
42318 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42320 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
42322 C...Resonance KF codes (1=I,2=J,3=K)
42325 KFR(3)=-IDLAM(LKNT,3)+1
42326 C...Calculate width.
42327 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42329 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42330 C...KINEMATICS CHECK
42331 IF (XLAM(LKNT).EQ.0D0) THEN
42335 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
42337 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42338 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
42339 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
42341 C...Set coupling, and decay product masses on/off
42342 RVLAMC = 3. * GW2 * 5D-1 *
42343 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42345 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
42346 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
42347 C...Resonance KF codes (1=I,2=J,3=K)
42350 KFR(3)=-IDLAM(LKNT,3)+1
42351 C...Calculate width.
42352 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42354 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42355 C...KINEMATICS CHECK
42356 IF (XLAM(LKNT).EQ.0D0) THEN
42360 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
42362 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42363 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42364 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42366 C...Set coupling, and decay product masses on/off
42367 RVLAMC = 3. * GW2 * 5D-1 *
42368 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42370 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
42371 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
42372 C...Resonance KF codes (1=I,2=J,3=K)
42373 KFR(1)=-IDLAM(LKNT,1)+1
42374 KFR(2)=-IDLAM(LKNT,2)+1
42376 C...Calculate width.
42377 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42379 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42380 C...KINEMATICS CHECK
42381 IF (XLAM(LKNT).EQ.0D0) THEN
42385 C * CHI+ -> NU_I + U_J + DBAR_K.
42387 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
42388 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
42389 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42391 C...Set coupling, and decay product masses on/off
42393 RVLAMC = 3. * GW2 * 5D-1 *
42394 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42395 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
42397 C...Resonance KF codes (1=I,2=J,3=K)
42398 KFR(1)=IDLAM(LKNT,1)-1
42399 KFR(2)=IDLAM(LKNT,2)-1
42401 C...Calculate width.
42402 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42404 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42405 C...KINEMATICS CHECK
42406 IF (XLAM(LKNT).EQ.0D0) THEN
42413 C...UDD TYPE R-VIOLATION
42414 C...These decays need special treatment since more than one BV coupling
42415 C...contributes (with interference). Consider e.g. (symbolically)
42416 C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
42417 C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
42418 C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
42419 C...The problem is that a single call to PYRVGW would evaluate all
42420 C...these terms and sum them, but without the different couplings. The
42421 C...way out is to call PYRVGW three times, once for the first line, once
42422 C...for the second line, and then once for all the lines (it is
42423 C...impossible to get just the last line out) without multiplying by
42424 C...couplings. The last line is then obtained as the result of the third
42425 C...call minus the results of the two first calls. Each term is then
42426 C...multiplied by its respective coupling before the whole thing is
42427 C...summed up in XLAM.
42428 C...Note that with three interfering resonances, this procedure becomes
42429 C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
42431 IF (IMSS(53).GE.1) THEN
42432 C...LOOP OVER DECAY MODES
42435 C...CHI+ -> U_I + U_J + D_K
42436 C...Decay mode I<->J symmetric.
42437 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
42439 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
42440 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
42441 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42443 C...Set coupling, and decay product masses on/off
42444 RVLAMC= 6. * GW2 * 5D-1
42445 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
42447 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
42449 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
42452 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
42453 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
42454 C...Resonance KF codes (1=I,2=J,3=K)
42455 KFR(1) = -IDLAM(LKNT,1)+1
42458 C...Calculate width.
42459 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42460 & IDLAM(LKNT,3),XRESI)
42461 C...Resonance KF codes (1=I,2=J,3=K)
42463 KFR(2) = -IDLAM(LKNT,2)+1
42465 C...Calculate width.
42466 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42467 & IDLAM(LKNT,3),XRESJ)
42468 C...Resonance KF codes (1=I,2=J,3=K)
42469 KFR(1) = -IDLAM(LKNT,1)+1
42470 KFR(2) = -IDLAM(LKNT,2)+1
42472 C...Calculate width.
42473 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42474 & IDLAM(LKNT,3),XRESIJ)
42475 IF (ABS((XRESI+XRESJ)/XRESIJ-1.).GT.1D-4) THEN
42476 XRESIJ = XRESIJ-XRESI-XRESJ
42480 C...CALCULATE TOTAL WIDTH
42481 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
42482 & + RVLJIK*RVLIJK * XRESIJ
42483 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42484 C...KINEMATICS CHECK
42485 IF (XLAM(LKNT).EQ.0D0) THEN
42489 C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
42490 C...Symmetry I<->J<->K.
42491 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
42492 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
42494 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
42495 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42496 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42498 C...Set coupling, and decay product masses on/off
42499 RVLAMC = 6. * GW2 * 5D-1
42500 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
42502 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
42504 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
42507 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
42508 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
42509 C...Collect symmetry factors
42510 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
42511 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
42512 & RVLAMC = 5D-1 * RVLAMC
42513 C...Resonance KF codes (1=I,2=J,3=K)
42514 KFR(1) = IDLAM(LKNT,1)-1
42517 C...Calculate width.
42518 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42519 & IDLAM(LKNT,3),XRESI)
42520 C...Resonance KF codes (1=I,2=J,3=K)
42522 KFR(2) = IDLAM(LKNT,2)-1
42524 C...Calculate width.
42525 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42526 & IDLAM(LKNT,3),XRESJ)
42527 C...Resonance KF codes (1=I,2=J,3=K)
42530 KFR(3) = IDLAM(LKNT,3)-1
42531 C...Calculate width.
42532 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42533 & IDLAM(LKNT,3),XRESK)
42534 C...Resonance KF codes (1=I,2=J,3=K)
42535 KFR(1) = IDLAM(LKNT,1)-1
42536 KFR(2) = IDLAM(LKNT,2)-1
42538 C...Calculate width.
42539 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42540 & IDLAM(LKNT,3),XRESIJ)
42541 IF (ABS(XRESIJ/(XRESI+XRESJ)-1.).GT.1D-4) THEN
42542 XRESIJ = XRESI+XRESJ-XRESIJ
42546 C...Resonance KF codes (1=I,2=J,3=K)
42548 KFR(2) = IDLAM(LKNT,2)-1
42549 KFR(3) = IDLAM(LKNT,3)-1
42550 C...Calculate width.
42551 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42552 & IDLAM(LKNT,3),XRESJK)
42553 IF (ABS(XRESJK/(XRESJ+XRESK)-1.).GT.1D-4) THEN
42554 XRESJK = XRESJ+XRESK-XRESJK
42558 C...Resonance KF codes (1=I,2=J,3=K)
42559 KFR(1) = IDLAM(LKNT,1)-1
42561 KFR(3) = IDLAM(LKNT,3)-1
42562 C...Calculate width.
42563 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42564 & IDLAM(LKNT,3),XRESIK)
42565 IF (ABS(XRESIK/(XRESI+XRESK)-1.).GT.1D-4) THEN
42566 XRESIK = XRESI+XRESK-XRESIK
42570 C...CALCULATE TOTAL WIDTH
42572 & RVLIJK**2 * XRESI
42573 & + RVLJKI**2 * XRESJ
42574 & + RVLKIJ**2 * XRESK
42575 & + RVLIJK*RVLJKI * XRESIJ
42576 & + RVLIJK*RVLKIJ * XRESIK
42577 & + RVLJKI*RVLKIJ * XRESJK
42578 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
42579 C...KINEMATICS CHECK
42580 IF (XLAM(LKNT).EQ.0D0) THEN
42592 C*********************************************************************
42595 C...Calculates R-violating gluino decay widths.
42596 C...See BV part of PYRVCH for comments about the way the BV decay width
42597 C...is calculated. Same comments apply here.
42600 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
42602 C...Double precision and integer declarations.
42603 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42604 IMPLICIT INTEGER(I-N)
42605 C...Parameter statement to help give large particle numbers.
42606 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42607 &KEXCIT=4000000,KDIMEN=5000000)
42609 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42610 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42611 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42612 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42613 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42614 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
42615 C...Local variables.
42616 DOUBLE PRECISION XLAM(0:400)
42617 INTEGER IDLAM(400,3), PYCOMP
42618 C...Information from main routine to PYRVGW
42619 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
42621 C...Auxiliary variables needed for BV (RV Gauge STOre)
42622 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
42624 C...Running quark masses
42625 DOUBLE PRECISION RMQ(6)
42626 C...Decay product masses on/off
42628 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
42631 C...IF LQD OR UDD TYPE R-VIOLATION ON.
42632 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
42636 C x=1-2 : Select A or B coupling (1:A ; 2:B)
42637 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
42638 C 11-16:e,nu_e,mu,... not used here)
42639 C z=1-2 : Mass eigenstate number
42642 AB(1,I,1) = SFMIX(I,2)
42643 AB(1,I,2) = SFMIX(I,4)
42645 AB(2,I,1) = -SFMIX(I,1)
42646 AB(2,I,2) = -SFMIX(I,3)
42648 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
42650 IF (IMSS(52).GE.1) THEN
42651 C...STEP IN I,J,K USING SINGLE COUNTER
42653 C * GLUINO -> NUBAR_I + DBAR_J + D_K.
42655 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
42656 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42657 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42659 C...Set coupling, and decay product masses on/off
42660 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42663 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
42664 C...Resonance KF codes (1=I,2=J,3=K)
42666 KFR(2) = -IDLAM(LKNT,2)
42667 KFR(3) = -IDLAM(LKNT,3)
42668 C...Calculate width.
42669 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42672 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42673 C...Charge conjugate mode.
42675 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
42676 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
42677 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
42678 XLAM(LKNT) = XLAM(LKNT-1)
42679 C...KINEMATICS CHECK
42680 IF (XLAM(LKNT).EQ.0D0) THEN
42684 C * GLUINO -> LEPTON+_I + UBAR_J + D_K
42686 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42687 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
42688 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42690 C...Set coupling, and decay product masses on/off
42691 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
42692 & **2* 5D-1 * GSTR2
42694 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
42695 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
42696 C...Resonance KF codes (1=I,2=J,3=K)
42698 KFR(2) = -IDLAM(LKNT,2)
42699 KFR(3) = -IDLAM(LKNT,3)
42700 C...Calculate width.
42701 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42703 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42704 C...Charge conjugate mode.
42706 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
42707 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
42708 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
42709 XLAM(LKNT) = XLAM(LKNT-1)
42710 C...KINEMATICS CHECK
42711 IF (XLAM(LKNT).EQ.0D0) THEN
42719 IF (IMSS(53).GE.1) THEN
42720 C...STEP IN I,J,K USING SINGLE COUNTER
42722 C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
42723 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
42725 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
42726 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42727 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42729 C...Set coupling, and decay product masses on/off. A factor of 2 for
42730 C...(N_C-1) has been used to cancel a factor 0.5.
42731 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
42734 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
42735 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
42736 C...Resonance KF codes (1=I,2=J,3=K)
42737 KFR(1) = IDLAM(LKNT,1)
42740 C...Calculate width.
42741 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42743 C...Resonance KF codes (1=I,2=J,3=K)
42745 KFR(2) = IDLAM(LKNT,2)
42747 C...Calculate width.
42748 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42750 C...Resonance KF codes (1=I,2=J,3=K)
42753 KFR(3) = IDLAM(LKNT,3)
42754 C...Calculate width.
42755 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42757 C...Resonance KF codes (1=I,2=J,3=K)
42758 KFR(1) = IDLAM(LKNT,1)
42759 KFR(2) = IDLAM(LKNT,2)
42761 C...Calculate width.
42762 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42764 C...Calculate interference function. (Factor -1/2 to make up for factor
42766 IF (ABS((XRESI+XRESJ)/XRESIJ-1D0).GT.1D-4) THEN
42767 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
42771 C...Resonance KF codes (1=I,2=J,3=K)
42773 KFR(2) = IDLAM(LKNT,2)
42774 KFR(3) = IDLAM(LKNT,3)
42775 C...Calculate width.
42776 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42778 IF (ABS((XRESJ+XRESK)/XRESJK-1).GT.1D-4) THEN
42779 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
42783 C...Resonance KF codes (1=I,2=J,3=K)
42784 KFR(1) = IDLAM(LKNT,1)
42786 KFR(3) = IDLAM(LKNT,3)
42787 C...Calculate width.
42788 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42790 IF (ABS((XRESI+XRESK)/XRESIK-1).GT.1D-4) THEN
42791 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
42795 C...Calculate total width (factor 1/2 from 1/(N_C-1))
42796 XLAM(LKNT) = XRESI + XRESJ + XRESK
42797 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
42799 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42800 C...Charge conjugate mode.
42802 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
42803 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
42804 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
42805 XLAM(LKNT) = XLAM(LKNT-1)
42806 C...KINEMATICS CHECK
42807 IF (XLAM(LKNT).EQ.0D0) THEN
42817 C*********************************************************************
42820 C...Auxiliary function to PYRVSF for calculating R-Violating
42821 C...sfermion widths. Though the decay products are most often treated
42822 C...as massless in the calculation, the kinematical boundary of phase
42823 C...space is tested using the true masses.
42824 C...MODE = 1: All decay products massive
42825 C...MODE = 2: Decay product 1 massless
42826 C...MODE = 3: Decay product 2 massless
42827 C...MODE = 4: All decay products massless
42829 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
42831 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42832 IMPLICIT INTEGER (I-N)
42833 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42834 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42835 SAVE /PYDAT1/,/PYDAT2/
42836 DOUBLE PRECISION SM(3)
42837 INTEGER PYCOMP, KC(3)
42841 SM(1)=PMAS(KC(1),1)**2
42842 SM(2)=PMAS(KC(2),1)**2
42843 SM(3)=PMAS(KC(3),1)**2
42844 C...Kinematics check
42845 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
42849 C...CM momenta squared
42850 IF (MODE.EQ.1) THEN
42851 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
42852 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
42853 ELSE IF (MODE.EQ.2) THEN
42854 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
42855 ELSE IF (MODE.EQ.3) THEN
42856 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
42860 C...Calculate Width
42861 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
42865 C*********************************************************************
42868 C...Generalized Matrix Element for R-Violating 3-body widths.
42870 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
42872 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42873 IMPLICIT INTEGER (I-N)
42874 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42875 &KEXCIT=4000000,KDIMEN=5000000)
42876 PARAMETER (EPS=1D-4)
42877 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42878 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
42880 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42881 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42882 DOUBLE PRECISION XLIM(3,3)
42883 INTEGER KC(0:3), PYCOMP
42884 LOGICAL DCMASS, DCHECK(6)
42885 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
42889 KC(0) = PYCOMP(KFIN)
42890 KC(1) = PYCOMP(ID1)
42891 KC(2) = PYCOMP(ID2)
42892 KC(3) = PYCOMP(ID3)
42893 RMS(0) = PMAS(KC(0),1)
42894 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
42895 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
42896 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
42897 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
42898 XLIM(1,1)=(RMS(1)+RMS(2))**2
42899 XLIM(1,2)=(RMS(0)-RMS(3))**2
42900 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
42901 XLIM(2,1)=(RMS(2)+RMS(3))**2
42902 XLIM(2,2)=(RMS(0)-RMS(1))**2
42903 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
42904 XLIM(3,1)=(RMS(1)+RMS(3))**2
42905 XLIM(3,2)=(RMS(0)-RMS(2))**2
42906 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
42907 C...Check Phase Space
42908 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
42912 C...INITIALIZE RESONANCE INFORMATION
42915 IRES = 2*(JRES-1)+IMASS
42917 DCHECK(IRES) =.FALSE.
42918 C...NO RIGHT-HANDED NEUTRINOS
42919 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
42920 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
42921 & .KFR(JRES).EQ.0) GOTO 100
42922 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
42923 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
42924 INTRES(IRES,1) = IABS(KFR(JRES))
42925 INTRES(IRES,2) = IMASS
42926 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
42927 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
42931 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
42933 C...RESONANCE CONTRIBUTIONS
42934 C...(Only sum contributions where the resonance is off shell).
42935 C...Store whether diagram on/off in DCHECK.
42936 C...LOOP OVER MASS STATES
42939 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
42940 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
42941 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
42942 DCHECK(IDR) =.TRUE.
42943 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
42947 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
42948 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
42949 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
42950 DCHECK(IDR) =.TRUE.
42951 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
42955 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
42956 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
42957 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
42958 DCHECK(IDR) =.TRUE.
42959 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
42962 C... L-R INTERFERENCES
42963 C... (Only add contributions where both contributing diagrams
42964 C... are non-resonant).
42966 IF (DCHECK(1).AND.DCHECK(2)) THEN
42967 C...Bug corrected 11/12 2001. Skands.
42968 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
42969 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
42970 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
42974 IF (DCHECK(3).AND.DCHECK(4)) THEN
42975 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
42976 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
42977 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
42981 IF (DCHECK(5).AND.DCHECK(6)) THEN
42982 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
42983 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
42984 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
42986 C... TRUE INTERFERENCES
42987 C... (Only add contributions where both contributing diagrams
42988 C... are non-resonant).
42990 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
42995 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
42996 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
42997 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
42998 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
43003 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
43004 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
43005 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
43006 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
43011 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
43012 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
43013 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
43014 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
43022 C*********************************************************************
43025 C...Function to integrate resonance contributions
43027 FUNCTION PYRVI1(ID1,ID2,ID3)
43030 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
43031 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
43032 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
43033 LOGICAL MFLAG,DCMASS
43034 EXTERNAL PYRVG1,PYGAUS
43035 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
43037 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43038 SAVE/PYRVNV/,/PYRVPM/
43039 C...Initialize mass and width information
43045 RESM(1)= RES(IDR,1)
43046 RESW(1)= RES(IDR,2)
43047 C...A->B and B->A for antisparticles
43048 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43049 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43050 C...Integration boundaries and mass flag
43051 LO = (RM(1)+RM(2))**2
43052 HI = (RM(0)-RM(3))**2
43054 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
43058 C*********************************************************************
43061 C...Function to integrate L-R interference contributions
43063 FUNCTION PYRVI2(ID1,ID2,ID3)
43066 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
43067 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
43068 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
43069 LOGICAL MFLAG,DCMASS
43070 EXTERNAL PYRVG2,PYGAUS
43071 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
43073 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43074 SAVE/PYRVNV/,/PYRVPM/
43075 C...Initialize mass and width information
43081 RESM(1)= RES(IDR,1)
43082 RESW(1)= RES(IDR,2)
43083 RESM(2)= RES(IDR+1,1)
43084 RESW(2)= RES(IDR+1,2)
43085 C...A->B and B->A for antisparticles
43086 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43087 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43088 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
43089 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
43090 C...Boundaries and mass flag
43091 LO = (RM(1)+RM(2))**2
43092 HI = (RM(0)-RM(3))**2
43094 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
43098 C*********************************************************************
43101 C...Function to integrate true interference contributions
43103 FUNCTION PYRVI3(ID1,ID2,ID3)
43106 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
43107 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
43108 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
43109 LOGICAL MFLAG,DCMASS
43110 EXTERNAL PYRVG3,PYGAUS
43111 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
43113 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43114 SAVE/PYRVNV/,/PYRVPM/
43115 C...Initialize mass and width information
43121 RESM(1)= RES(IDR,1)
43122 RESW(1)= RES(IDR,2)
43123 RESM(2)= RES(IDR2,1)
43124 RESW(2)= RES(IDR2,2)
43125 C...A -> B and B -> A for antisparticles
43126 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43127 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43128 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
43129 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
43130 C...Boundaries and mass flag
43131 LO = (RM(1)+RM(2))**2
43132 HI = (RM(0)-RM(3))**2
43134 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
43138 C*********************************************************************
43141 C...Integrand for resonance contributions
43146 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43147 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
43148 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
43151 RVR = PYRVR(X,RESM(1),RESW(1))
43152 C1 = 2D0*SQRT(MAX(0D0,X))
43153 IF (.NOT.MFLAG) THEN
43155 E3 = (RM(0)**2-X)/C1
43157 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
43159 E2 = (X-RM(1)**2+RM(2)**2)/C1
43160 E3 = (RM(0)**2-X-RM(3)**2)/C1
43161 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
43162 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
43163 DELTAY = 4D0*SR1*SR2
43164 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
43165 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
43166 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
43171 C*********************************************************************
43174 C...Integrand for L-R interference contributions
43179 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43180 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
43181 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
43184 C1 = 2D0*SQRT(MAX(0D0,X))
43185 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
43186 IF (.NOT.MFLAG) THEN
43188 E3 = (RM(0)**2-X)/C1
43190 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
43192 E2 = (X-RM(1)**2+RM(2)**2)/C1
43193 E3 = (RM(0)**2-X-RM(3)**2)/C1
43194 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
43195 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
43196 DELTAY = 4D0*SR1*SR2
43197 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
43198 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
43199 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
43204 C*********************************************************************
43207 C...Function to do Y integration over true interference contributions
43212 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43213 C...Second Dalitz variable for PYRVG4
43215 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
43216 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
43217 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
43219 EXTERNAL PYGAU2,PYRVG4
43220 SAVE/PYRVPM/,/PYG2DX/
43222 C1=2D0*SQRT(MAX(1D-9,X))
43224 IF (.NOT.MFLAG) THEN
43226 E3 = (RM(0)**2-X)/C1
43230 E2 = (X-RM(1)**2+RM(2)**2)/C1
43231 E3 = (RM(0)**2-X-RM(3)**2)/C1
43233 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
43234 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
43235 YMIN = SQ1-(SR1+SR2)**2
43236 YMAX = SQ1-(SR1-SR2)**2
43238 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
43242 C*********************************************************************
43245 C...Integrand for true intereference contributions
43250 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43252 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
43254 SAVE /PYRVPM/,/PYG2DX/
43256 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
43257 IF (.NOT.MFLAG) THEN
43258 PYRVG4 = RVS*B(1)*B(2)*X*Y
43260 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
43261 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
43262 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
43263 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
43268 C*********************************************************************
43271 C...Breit-Wigner for resonance contributions
43273 FUNCTION PYRVR(Mab2,RM,RW)
43276 DOUBLE PRECISION Mab2,RM,RW,PYRVR
43277 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
43281 C*********************************************************************
43284 C...Interference function
43286 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
43289 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
43290 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
43295 C*********************************************************************
43298 C...Stores one parton/particle in commonblock PYJETS.
43300 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
43302 C...Double precision and integer declarations.
43303 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43304 IMPLICIT INTEGER(I-N)
43305 INTEGER PYK,PYCHGE,PYCOMP
43307 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43308 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43309 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43310 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43312 C...Standard checks.
43314 IF(MSTU(12).GE.1) CALL PYLIST(0)
43315 IPA=MAX(1,IABS(IP))
43316 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
43317 &'(PY1ENT:) writing outside PYJETS memory')
43319 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
43321 C...Find mass. Reset K, P and V vectors.
43323 IF(MSTU(10).EQ.1) PM=P(IPA,5)
43324 IF(MSTU(10).GE.2) PM=PYMASS(KF)
43331 C...Store parton/particle in K and P vectors.
43333 IF(IP.LT.0) K(IPA,1)=2
43336 P(IPA,4)=MAX(PE,PM)
43337 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
43338 P(IPA,1)=PA*SIN(THE)*COS(PHI)
43339 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
43340 P(IPA,3)=PA*COS(THE)
43342 C...Set N. Optionally fragment/decay.
43344 IF(IP.EQ.0) CALL PYEXEC
43349 C*********************************************************************
43352 C...Stores two partons/particles in their CM frame,
43353 C...with the first along the +z axis.
43355 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
43357 C...Double precision and integer declarations.
43358 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43359 IMPLICIT INTEGER(I-N)
43360 INTEGER PYK,PYCHGE,PYCOMP
43362 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43363 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43364 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43365 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43367 C...Standard checks.
43369 IF(MSTU(12).GE.1) CALL PYLIST(0)
43370 IPA=MAX(1,IABS(IP))
43371 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
43372 &'(PY2ENT:) writing outside PYJETS memory')
43375 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
43376 &'(PY2ENT:) unknown flavour code')
43378 C...Find masses. Reset K, P and V vectors.
43380 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
43381 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
43383 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
43384 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
43393 C...Check flavours.
43394 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
43395 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
43396 IF(MSTU(19).EQ.1) THEN
43399 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
43400 & '(PY2ENT:) unphysical flavour combination')
43405 C...Store partons/particles in K vectors for normal case.
43408 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
43411 C...Store partons in K vectors for parton shower evolution.
43415 K(IPA,4)=MSTU(5)*(IPA+1)
43417 K(IPA+1,4)=MSTU(5)*IPA
43418 K(IPA+1,5)=K(IPA+1,4)
43421 C...Check kinematics and store partons/particles in P vectors.
43422 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
43423 &'(PY2ENT:) energy smaller than sum of masses')
43424 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
43427 P(IPA,4)=SQRT(PM1**2+PA**2)
43430 P(IPA+1,4)=SQRT(PM2**2+PA**2)
43433 C...Set N. Optionally fragment/decay.
43435 IF(IP.EQ.0) CALL PYEXEC
43440 C*********************************************************************
43443 C...Stores three partons or particles in their CM frame,
43444 C...with the first along the +z axis and the third in the (x,z)
43445 C...plane with x > 0.
43447 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
43449 C...Double precision and integer declarations.
43450 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43451 IMPLICIT INTEGER(I-N)
43452 INTEGER PYK,PYCHGE,PYCOMP
43454 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43455 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43456 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43457 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43459 C...Standard checks.
43461 IF(MSTU(12).GE.1) CALL PYLIST(0)
43462 IPA=MAX(1,IABS(IP))
43463 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
43464 &'(PY3ENT:) writing outside PYJETS memory')
43468 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
43469 &'(PY3ENT:) unknown flavour code')
43471 C...Find masses. Reset K, P and V vectors.
43473 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
43474 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
43476 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
43477 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
43479 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
43480 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
43489 C...Check flavours.
43490 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
43491 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
43492 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
43493 IF(MSTU(19).EQ.1) THEN
43495 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
43496 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
43497 & KQ1+KQ3.EQ.4)) THEN
43499 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
43505 C...Store partons/particles in K vectors for normal case.
43508 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
43510 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
43513 C...Store partons in K vectors for parton shower evolution.
43519 IF(KQ1.EQ.-1) KCS=5
43520 K(IPA,KCS)=MSTU(5)*(IPA+1)
43521 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
43522 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
43523 K(IPA+1,9-KCS)=MSTU(5)*IPA
43524 K(IPA+2,KCS)=MSTU(5)*IPA
43525 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
43528 C...Check kinematics.
43530 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
43531 &0.5D0*X3*PECM.LE.PM3) MKERR=1
43532 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
43533 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
43534 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
43535 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
43536 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
43537 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
43538 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
43539 IF(MKERR.NE.0) CALL PYERRM(13,
43540 &'(PY3ENT:) unphysical kinematical variable setup')
43542 C...Store partons/particles in P vectors.
43544 P(IPA,4)=SQRT(PA1**2+PM1**2)
43546 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
43547 P(IPA+2,3)=PA3*CTHE3
43548 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
43550 P(IPA+1,1)=-P(IPA+2,1)
43551 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
43552 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
43555 C...Set N. Optionally fragment/decay.
43557 IF(IP.EQ.0) CALL PYEXEC
43562 C*********************************************************************
43565 C...Stores four partons or particles in their CM frame, with
43566 C...the first along the +z axis, the last in the xz plane with x > 0
43567 C...and the second having y < 0 and y > 0 with equal probability.
43569 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
43571 C...Double precision and integer declarations.
43572 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43573 IMPLICIT INTEGER(I-N)
43574 INTEGER PYK,PYCHGE,PYCOMP
43576 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43577 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43578 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43579 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43581 C...Standard checks.
43583 IF(MSTU(12).GE.1) CALL PYLIST(0)
43584 IPA=MAX(1,IABS(IP))
43585 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
43586 &'(PY4ENT:) writing outside PYJETS momory')
43591 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
43592 &'(PY4ENT:) unknown flavour code')
43594 C...Find masses. Reset K, P and V vectors.
43596 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
43597 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
43599 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
43600 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
43602 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
43603 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
43605 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
43606 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
43615 C...Check flavours.
43616 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
43617 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
43618 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
43619 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
43620 IF(MSTU(19).EQ.1) THEN
43622 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
43623 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
43624 & KQ1+KQ4.EQ.4)) THEN
43625 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
43628 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
43635 C...Store partons/particles in K vectors for normal case.
43638 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
43640 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
43643 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
43646 C...Store partons for parton shower evolution from q-g-g-qbar or
43648 ELSEIF(KQ1+KQ2.NE.0) THEN
43654 IF(KQ1.EQ.-1) KCS=5
43655 K(IPA,KCS)=MSTU(5)*(IPA+1)
43656 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
43657 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
43658 K(IPA+1,9-KCS)=MSTU(5)*IPA
43659 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
43660 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
43661 K(IPA+3,KCS)=MSTU(5)*IPA
43662 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
43664 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
43670 K(IPA,4)=MSTU(5)*(IPA+1)
43672 K(IPA+1,4)=MSTU(5)*IPA
43673 K(IPA+1,5)=K(IPA+1,4)
43674 K(IPA+2,4)=MSTU(5)*(IPA+3)
43675 K(IPA+2,5)=K(IPA+2,4)
43676 K(IPA+3,4)=MSTU(5)*(IPA+2)
43677 K(IPA+3,5)=K(IPA+3,4)
43680 C...Check kinematics.
43682 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
43683 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
43685 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
43686 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
43687 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
43688 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
43689 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
43690 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
43691 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
43692 STHE4=SQRT(1D0-CTHE4**2)
43693 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
43694 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
43695 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
43696 STHE2=SQRT(1D0-CTHE2**2)
43697 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
43698 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
43699 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
43700 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
43701 IF(MKERR.EQ.1) CALL PYERRM(13,
43702 &'(PY4ENT:) unphysical kinematical variable setup')
43704 C...Store partons/particles in P vectors.
43706 P(IPA,4)=SQRT(PA1**2+PM1**2)
43708 P(IPA+3,1)=PA4*STHE4
43709 P(IPA+3,3)=PA4*CTHE4
43710 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
43712 P(IPA+1,1)=PA2*STHE2*CPHI2
43713 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
43714 P(IPA+1,3)=PA2*CTHE2
43715 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
43717 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
43718 P(IPA+2,2)=-P(IPA+1,2)
43719 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
43720 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
43723 C...Set N. Optionally fragment/decay.
43725 IF(IP.EQ.0) CALL PYEXEC
43730 C*********************************************************************
43733 C...An interface from a two-fermion generator to include
43734 C...parton showers and hadronization.
43736 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
43738 C...Double precision and integer declarations.
43739 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43740 IMPLICIT INTEGER(I-N)
43741 INTEGER PYK,PYCHGE,PYCOMP
43743 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43744 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43745 SAVE /PYJETS/,/PYDAT1/
43747 DIMENSION IJOIN(2),INTAU(2)
43749 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
43755 C...Loop through entries and pick up all final fermions/antifermions.
43759 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
43761 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
43762 IF(K(I,2).GT.0) THEN
43766 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
43772 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
43778 C...Check that event is arranged according to conventions.
43779 IF(I1.EQ.0.OR.I2.EQ.0) THEN
43780 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
43783 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
43786 C...Check whether fermion pair is quarks or leptons.
43787 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
43789 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
43792 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
43795 C...Decide whether to allow or not photon radiation in showers.
43797 IF(IRAD.EQ.0) MSTJ(41)=1
43799 C...Do colour joining and parton showers.
43802 IF(IQL12.EQ.1) THEN
43805 CALL PYJOIN(2,IJOIN)
43807 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
43808 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
43809 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
43810 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
43813 C...Do fragmentation and decays. Possibly except tau decay.
43817 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
43831 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
43839 C*********************************************************************
43842 C...An interface from a four-fermion generator to include
43843 C...parton showers and hadronization.
43845 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
43847 C...Double precision and integer declarations.
43848 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43849 IMPLICIT INTEGER(I-N)
43850 INTEGER PYK,PYCHGE,PYCOMP
43852 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43853 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43854 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43855 COMMON/PYINT1/MINT(400),VINT(400)
43856 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
43858 DIMENSION IJOIN(2),INTAU(4)
43860 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
43866 C...Loop through entries and pick up all final fermions/antifermions.
43872 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
43874 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
43875 IF(K(I,2).GT.0) THEN
43878 ELSEIF(I3.EQ.0) THEN
43881 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
43886 ELSEIF(I4.EQ.0) THEN
43889 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
43895 C...Check that event is arranged according to conventions.
43896 IF(I3.EQ.0.OR.I4.EQ.0) THEN
43897 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
43899 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
43900 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
43903 C...Check which fermion pairs are quarks and which leptons.
43904 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
43906 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
43909 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
43911 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
43913 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
43916 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
43919 C...Decide whether to allow or not photon radiation in showers.
43921 IF(IRAD.EQ.0) MSTJ(41)=1
43923 C...Decide on dipole pairing.
43928 IF(IQL12.EQ.IQL34) THEN
43931 DELTA=ATOTSQ-A1SQ-A2SQ
43932 IF(ISTRAT.EQ.1) THEN
43933 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
43934 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
43935 ELSEIF(ISTRAT.EQ.2) THEN
43936 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
43937 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
43939 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
43945 C...If colour reconnection then bookkeep W+W- or Z0Z0
43946 C...and copy q qbar q qbar consecutively.
43947 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
43956 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
43960 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
43974 P(N+1,J)=P(IP1,J)+P(IP2,J)
43975 P(N+2,J)=P(IP3,J)+P(IP4,J)
43987 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
43989 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
43995 C...Remove original q qbar q qbar and update counters.
43996 K(IP1,1)=K(IP1,1)+10
43997 K(IP2,1)=K(IP2,1)+10
43998 K(IP3,1)=K(IP3,1)+10
43999 K(IP4,1)=K(IP4,1)+10
44010 C...Do colour joinings and parton showers.
44011 IF(IQL12.EQ.1) THEN
44014 CALL PYJOIN(2,IJOIN)
44016 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
44017 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
44018 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
44019 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
44022 IF(IQL34.EQ.1) THEN
44025 CALL PYJOIN(2,IJOIN)
44027 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
44028 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
44029 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
44030 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
44033 C...Optionally do colour reconnection.
44036 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
44037 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
44041 C...Do fragmentation and decays. Possibly except tau decay.
44045 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
44059 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
44067 C*********************************************************************
44070 C...An interface from a six-fermion generator to include
44071 C...parton showers and hadronization.
44073 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
44075 C...Double precision and integer declarations.
44076 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44077 IMPLICIT INTEGER(I-N)
44078 INTEGER PYK,PYCHGE,PYCOMP
44080 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44081 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44082 SAVE /PYJETS/,/PYDAT1/
44084 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
44086 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
44092 C...Loop through entries and pick up all final fermions/antifermions.
44100 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
44102 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
44103 IF(K(I,2).GT.0) THEN
44106 ELSEIF(I3.EQ.0) THEN
44108 ELSEIF(I5.EQ.0) THEN
44111 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
44116 ELSEIF(I4.EQ.0) THEN
44118 ELSEIF(I6.EQ.0) THEN
44121 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
44127 C...Check that event is arranged according to conventions.
44128 IF(I5.EQ.0.OR.I6.EQ.0) THEN
44129 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
44131 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
44132 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
44135 C...Check which fermion pairs are quarks and which leptons.
44136 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
44138 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
44141 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
44143 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
44145 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
44148 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
44150 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
44152 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
44155 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
44158 C...Decide whether to allow or not photon radiation in showers.
44160 IF(IRAD.EQ.0) MSTJ(41)=1
44162 C...Allow dipole pairings only among leptons and quarks separately.
44165 IF(IQL34.EQ.IQL56) P13D=P13
44167 IF(IQL12.EQ.IQL34) P21D=P21
44169 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
44171 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
44173 IF(IQL12.EQ.IQL56) P32D=P32
44175 C...Decide whether t+tbar.
44177 IF(PYR(0).LT.PTOP) THEN
44180 C...If t+tbar: reconstruct t's.
44186 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
44187 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
44195 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
44197 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
44201 C...If t+tbar: colour join t's and let them shower.
44204 CALL PYJOIN(2,IJOIN)
44205 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
44206 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
44207 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
44209 C...If t+tbar: pick up the t's after shower.
44213 IF(K(I,2).EQ.6) ITNEW=I
44214 IF(K(I,2).EQ.-6) ITBNEW=I
44217 C...If t+tbar: loop over two top systems.
44232 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
44233 & '(PY6FRM:) not b in t decay')
44235 C...If t+tbar: find boost from original to new top frame.
44237 BETAO(J)=P(ITO,J)/P(ITO,4)
44238 BETAN(J)=P(ITN,J)/P(ITN,4)
44241 C...If t+tbar: boost copy of b by t shower and connect it in colour.
44251 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
44252 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
44253 K(IB,4)=MSTU(5)*ITN
44254 K(IB,5)=MSTU(5)*ITN
44255 K(ITN,4)=K(ITN,4)+IB
44256 K(ITN,5)=K(ITN,5)+IB
44257 K(ITN,1)=K(ITN,1)+10
44258 K(IBO,1)=K(IBO,1)+10
44260 C...If t+tbar: construct W recoiling against b.
44268 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
44269 IF(IABS(KCHW).EQ.3) THEN
44270 K(IW,2)=ISIGN(24,KCHW)
44272 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
44276 C...If t+tbar: construct W momentum, including boost by t shower.
44278 P(IW,J)=P(IW1,J)+P(IW2,J)
44280 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
44282 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
44283 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
44285 C...If t+tbar: boost b and W to top rest frame.
44287 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
44289 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44290 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44292 C...If t+tbar: let b shower and pick up modified W.
44293 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
44294 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
44295 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
44297 IF(IABS(K(I,2)).EQ.24) IWM=I
44300 C...If t+tbar: take copy of W decay products.
44309 K(IW1,1)=K(IW1,1)+10
44310 K(IW2,1)=K(IW2,1)+10
44311 K(IWM,1)=K(IWM,1)+10
44325 C...If t+tbar: boost W decay products, first by effects of t shower,
44326 C...then by those of b shower. b and its shower simple boost back.
44327 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
44328 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
44329 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44330 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
44331 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
44332 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
44333 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
44334 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
44335 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
44339 C...Decide on dipole pairing.
44343 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
44344 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
44348 ELSEIF(PRN.LT.P12D+P13D) THEN
44352 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
44356 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
44360 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
44370 C...Do colour joinings and parton showers
44371 C...(except ones already made for t+tbar).
44373 IF(IQL12.EQ.1) THEN
44376 CALL PYJOIN(2,IJOIN)
44378 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
44379 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
44380 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
44381 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
44384 IF(IQL34.EQ.1) THEN
44387 CALL PYJOIN(2,IJOIN)
44389 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
44390 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
44391 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
44392 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
44394 IF(IQL56.EQ.1) THEN
44397 CALL PYJOIN(2,IJOIN)
44399 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
44400 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
44401 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
44402 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
44405 C...Do fragmentation and decays. Possibly except tau decay.
44409 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
44423 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
44431 C*********************************************************************
44434 C...An interface from a four-parton generator to include
44435 C...parton showers and hadronization.
44437 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
44439 C...Double precision and integer declarations.
44440 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44441 IMPLICIT INTEGER(I-N)
44442 INTEGER PYK,PYCHGE,PYCOMP
44444 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44445 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44446 SAVE /PYJETS/,/PYDAT1/
44448 DIMENSION IJOIN(2),PTOT(4),BETA(3)
44450 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
44456 C...Loop through entries and pick up all final partons.
44462 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
44464 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
44465 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
44468 ELSEIF(I3.EQ.0) THEN
44471 CALL PYERRM(16,'(PY4JET:) more than two quarks')
44473 ELSEIF(K(I,2).LT.0) THEN
44476 ELSEIF(I4.EQ.0) THEN
44479 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
44484 ELSEIF(I4.EQ.0) THEN
44487 CALL PYERRM(16,'(PY4JET:) more than two gluons')
44493 C...Check that event is arranged according to conventions.
44494 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
44495 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
44497 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
44498 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
44501 C...Check whether second pair are quarks or gluons.
44502 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
44504 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
44507 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
44510 C...Boost partons to their cm frame.
44512 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
44514 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
44516 BETA(J)=PTOT(J)/PTOT(4)
44518 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44519 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44520 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44521 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44524 C...Decide and set up shower history for q qbar q' qbar' events.
44525 IF(IQG34.EQ.1) THEN
44526 W1=PY4JTW(0,I1,I3,I4)
44527 W2=PY4JTW(0,I2,I3,I4)
44528 IF(W1.GT.PYR(0)*(W1+W2)) THEN
44529 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
44531 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
44534 C...Decide and set up shower history for q qbar g g events.
44536 W1=PY4JTW(I1,I3,I2,I4)
44537 W2=PY4JTW(I1,I4,I2,I3)
44538 W3=PY4JTW(0,I3,I1,I4)
44539 W4=PY4JTW(0,I4,I1,I3)
44540 W5=PY4JTW(0,I3,I2,I4)
44541 W6=PY4JTW(0,I4,I2,I3)
44542 W7=PY4JTW(0,I1,I3,I4)
44543 W8=PY4JTW(0,I2,I3,I4)
44544 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
44546 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
44547 ELSEIF(W1+W2.GT.WR) THEN
44548 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
44549 ELSEIF(W1+W2+W3.GT.WR) THEN
44550 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
44551 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
44552 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
44553 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
44554 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
44555 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
44556 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
44557 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
44558 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
44560 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
44564 C...Boost back original partons and mark them as deleted.
44565 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
44566 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
44567 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
44568 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
44574 C...Rotate shower initiating partons to be along z axis.
44575 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
44576 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
44577 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
44578 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
44580 C...Set up copy of shower initiating partons as on mass shell.
44590 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
44601 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
44602 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
44604 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
44606 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
44609 C...Decide whether to allow or not photon radiation in showers.
44610 C...Connect up colours.
44612 IF(IRAD.EQ.0) MSTJ(41)=1
44615 CALL PYJOIN(2,IJOIN)
44617 C...Decide on maximum virtuality and do parton shower.
44618 IF(PMAX.LT.PARJ(82)) THEN
44623 CALL PYSHOW(NSAV+1,-8,PQMAX)
44625 C...Rotate and boost back system.
44626 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
44628 C...Do fragmentation and decays.
44631 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
44640 C*********************************************************************
44643 C...Auxiliary to PY4JET, to evaluate weight of configuration.
44645 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
44647 C...Double precision and integer declarations.
44648 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44649 IMPLICIT INTEGER(I-N)
44650 INTEGER PYK,PYCHGE,PYCOMP
44652 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44655 C...First case: when both original partons radiate.
44656 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
44659 P(N+1,J)=P(IA1,J)+P(IA2,J)
44660 P(N+2,J)=P(IA3,J)+P(IA4,J)
44662 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44664 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44666 Z1=P(IA1,4)/P(N+1,4)
44667 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
44668 Z2=P(IA3,4)/P(N+2,4)
44669 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
44671 C...Second case: when one original parton radiates to three.
44672 C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
44675 P(N+2,J)=P(IA3,J)+P(IA4,J)
44676 P(N+1,J)=P(N+2,J)+P(IA2,J)
44678 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44680 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44682 IF(K(IA2,2).EQ.21) THEN
44683 Z1=P(N+2,4)/P(N+1,4)
44684 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
44687 Z1=P(IA2,4)/P(N+1,4)
44688 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
44691 Z2=P(IA3,4)/P(N+2,4)
44692 IF(K(IA2,2).EQ.21) THEN
44693 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
44695 ELSEIF(K(IA3,2).EQ.21) THEN
44696 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
44698 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
44708 C*********************************************************************
44711 C...Auxiliary to PY4JET, to set up chosen configuration.
44713 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
44715 C...Double precision and integer declarations.
44716 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44717 IMPLICIT INTEGER(I-N)
44718 INTEGER PYK,PYCHGE,PYCOMP
44720 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44732 C...First case: when both original partons radiate.
44733 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
44736 C...Set up flavour and history pointers for new partons.
44754 C...Set up momenta for new partons.
44756 P(N+1,J)=P(IA1,J)+P(IA2,J)
44757 P(N+2,J)=P(IA3,J)+P(IA4,J)
44763 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44765 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44767 QMAX=MIN(P(N+1,5),P(N+2,5))
44769 C...Second case: q radiates twice.
44770 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
44771 C...IA5=N+2 does not radiate.
44772 ELSEIF(K(IA2,2).EQ.21) THEN
44774 C...Set up flavour and history pointers for new partons.
44792 C...Set up momenta for new partons.
44794 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
44796 P(N+3,J)=P(IA3,J)+P(IA4,J)
44801 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44803 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
44807 C...Third case: q radiates g, g branches.
44808 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
44809 C...IA5=N+2 does not radiate.
44812 C...Set up flavour and history pointers for new partons.
44830 C...Set up momenta for new partons.
44832 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
44835 P(N+4,J)=P(IA3,J)+P(IA4,J)
44839 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44841 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
44851 C*********************************************************************
44854 C...Connects a sequence of partons with colour flow indices,
44855 C...as required for subsequent shower evolution (or other operations).
44857 SUBROUTINE PYJOIN(NJOIN,IJOIN)
44859 C...Double precision and integer declarations.
44860 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44861 IMPLICIT INTEGER(I-N)
44862 INTEGER PYK,PYCHGE,PYCOMP
44864 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44865 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44866 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44867 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
44871 C...Check that partons are of right types to be connected.
44872 IF(NJOIN.LT.2) GOTO 120
44876 IF(I.LE.0.OR.I.GT.N) GOTO 120
44877 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
44879 IF(KC.EQ.0) GOTO 120
44880 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
44881 IF(KQ.EQ.0) GOTO 120
44882 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
44883 IF(KQ.NE.2) KQSUM=KQSUM+KQ
44884 IF(IJN.EQ.1) KQS=KQ
44886 IF(KQSUM.NE.0) GOTO 120
44888 C...Connect the partons sequentially (closing for gluon loop).
44890 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
44894 IF(IJN.NE.1) IP=IJOIN(IJN-1)
44895 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
44896 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
44897 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
44898 K(I,KCS)=MSTU(5)*IN
44899 K(I,9-KCS)=MSTU(5)*IP
44900 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
44901 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
44904 C...Error exit: no action taken.
44906 120 CALL PYERRM(12,
44907 &'(PYJOIN:) given entries can not be joined by one string')
44912 C*********************************************************************
44915 C...Sets values of commonblock variables.
44917 SUBROUTINE PYGIVE(CHIN)
44919 C...Double precision and integer declarations.
44920 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44921 IMPLICIT INTEGER(I-N)
44922 INTEGER PYK,PYCHGE,PYCOMP
44924 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44925 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44926 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44927 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44928 COMMON/PYDAT4/CHAF(500,2)
44930 COMMON/PYDATR/MRPY(6),RRPY(100)
44931 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
44932 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44933 COMMON/PYINT1/MINT(400),VINT(400)
44934 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
44935 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
44936 COMMON/PYINT4/MWID(500),WIDS(500,5)
44937 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
44938 COMMON/PYINT6/PROC(0:500)
44940 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
44941 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
44943 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44944 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44945 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
44946 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
44947 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
44948 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/
44949 C...Local arrays and character variables.
44950 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
44951 &CHNEW2*28,CHNAM*6,CHVAR(54)*6,CHALP(2)*26,CHIND*8,CHINI*10,
44953 DIMENSION MSVAR(54,8)
44955 C...For each variable to be translated give: name,
44956 C...integer/real/character, no. of indices, lower&upper index bounds.
44957 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
44958 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
44959 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
44960 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
44961 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
44962 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
44964 DATA ((MSVAR(I,J),J=1,8),I=1,54)/ 1,7*0, 1,2,1,4000,1,5,2*0,
44965 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
44966 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
44967 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
44968 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
44969 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
44970 &1,1,1,6,4*0, 2,1,1,100,4*0,
44971 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
44972 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
44973 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
44974 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
44975 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
44976 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
44977 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
44978 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
44979 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
44980 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
44981 &1,1,0,99,4*0, 2,1,0,99,4*0/
44982 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
44983 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
44985 C...Length of character variable. Subdivide it into instructions.
44986 IF(MSTU(12).GE.1) CALL PYLIST(0)
44990 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
44993 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
44995 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
45000 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
45002 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
45004 C...Peel off any text following exclamation mark.
45006 DO 140 LLOW2=LHIG2,1,-1
45007 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
45009 IF(LBIT.EQ.0) RETURN
45011 C...Identify commonblock variable.
45014 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
45015 &LNAM.LE.6) GOTO 150
45016 CHNAM=CHBIT(1:LNAM-1)//' '
45017 DO 170 LCOM=1,LNAM-1
45019 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
45020 & CHALP(2)(LALP:LALP)
45025 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
45028 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
45030 IF(LLOW.LT.LTOT) GOTO 120
45034 C...Identify any indices.
45039 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
45042 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
45044 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
45045 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
45046 & IVAR.EQ.37)) THEN
45047 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
45048 READ(CHIND,'(I8)') KF
45050 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
45052 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
45055 IF(LLOW.LT.LTOT) GOTO 120
45058 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
45059 READ(CHIND,'(I8)') I1
45062 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
45065 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
45068 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
45070 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
45071 READ(CHIND,'(I8)') I2
45073 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
45076 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
45079 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
45081 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
45082 READ(CHIND,'(I8)') I3
45087 C...Check that indices allowed.
45089 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
45090 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
45092 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
45094 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
45096 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
45098 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
45101 IF(LLOW.LT.LTOT) GOTO 120
45105 C...Save old value of variable.
45108 ELSEIF(IVAR.EQ.2) THEN
45110 ELSEIF(IVAR.EQ.3) THEN
45112 ELSEIF(IVAR.EQ.4) THEN
45114 ELSEIF(IVAR.EQ.5) THEN
45116 ELSEIF(IVAR.EQ.6) THEN
45118 ELSEIF(IVAR.EQ.7) THEN
45120 ELSEIF(IVAR.EQ.8) THEN
45122 ELSEIF(IVAR.EQ.9) THEN
45124 ELSEIF(IVAR.EQ.10) THEN
45126 ELSEIF(IVAR.EQ.11) THEN
45128 ELSEIF(IVAR.EQ.12) THEN
45130 ELSEIF(IVAR.EQ.13) THEN
45132 ELSEIF(IVAR.EQ.14) THEN
45134 ELSEIF(IVAR.EQ.15) THEN
45136 ELSEIF(IVAR.EQ.16) THEN
45138 ELSEIF(IVAR.EQ.17) THEN
45140 ELSEIF(IVAR.EQ.18) THEN
45142 ELSEIF(IVAR.EQ.19) THEN
45144 ELSEIF(IVAR.EQ.20) THEN
45146 ELSEIF(IVAR.EQ.21) THEN
45148 ELSEIF(IVAR.EQ.22) THEN
45150 ELSEIF(IVAR.EQ.23) THEN
45152 ELSEIF(IVAR.EQ.24) THEN
45154 ELSEIF(IVAR.EQ.25) THEN
45156 ELSEIF(IVAR.EQ.26) THEN
45158 ELSEIF(IVAR.EQ.27) THEN
45160 ELSEIF(IVAR.EQ.28) THEN
45162 ELSEIF(IVAR.EQ.29) THEN
45164 ELSEIF(IVAR.EQ.30) THEN
45166 ELSEIF(IVAR.EQ.31) THEN
45168 ELSEIF(IVAR.EQ.32) THEN
45170 ELSEIF(IVAR.EQ.33) THEN
45171 IOLD=ICOL(I1,I2,I3)
45172 ELSEIF(IVAR.EQ.34) THEN
45174 ELSEIF(IVAR.EQ.35) THEN
45176 ELSEIF(IVAR.EQ.36) THEN
45178 ELSEIF(IVAR.EQ.37) THEN
45180 ELSEIF(IVAR.EQ.38) THEN
45182 ELSEIF(IVAR.EQ.39) THEN
45184 ELSEIF(IVAR.EQ.40) THEN
45186 ELSEIF(IVAR.EQ.41) THEN
45188 ELSEIF(IVAR.EQ.42) THEN
45189 ROLD=SIGT(I1,I2,I3)
45190 ELSEIF(IVAR.EQ.43) THEN
45192 ELSEIF(IVAR.EQ.44) THEN
45194 ELSEIF(IVAR.EQ.45) THEN
45196 ELSEIF(IVAR.EQ.46) THEN
45198 ELSEIF(IVAR.EQ.47) THEN
45200 ELSEIF(IVAR.EQ.48) THEN
45202 ELSEIF(IVAR.EQ.49) THEN
45204 ELSEIF(IVAR.EQ.50) THEN
45205 ROLD=RVLAM(I1,I2,I3)
45206 ELSEIF(IVAR.EQ.51) THEN
45207 ROLD=RVLAMP(I1,I2,I3)
45208 ELSEIF(IVAR.EQ.52) THEN
45209 ROLD=RVLAMB(I1,I2,I3)
45210 ELSEIF(IVAR.EQ.53) THEN
45212 ELSEIF(IVAR.EQ.54) THEN
45216 C...Print current value of variable. Loop back.
45217 IF(LNAM.GE.LBIT) THEN
45219 CHBIT(15:60)=' has the value '
45220 IF(MSVAR(IVAR,1).EQ.1) THEN
45221 WRITE(CHBIT(51:60),'(I10)') IOLD
45222 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
45223 WRITE(CHBIT(47:60),'(F14.5)') ROLD
45224 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
45229 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45231 IF(LLOW.LT.LTOT) GOTO 120
45235 C...Read in new variable value.
45236 IF(MSVAR(IVAR,1).EQ.1) THEN
45238 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
45239 READ(CHINI,'(I10)') INEW
45240 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
45242 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
45244 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
45245 CHNEW=CHBIT(LNAM+1:LBIT)//' '
45247 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
45250 C...Store new variable value.
45253 ELSEIF(IVAR.EQ.2) THEN
45255 ELSEIF(IVAR.EQ.3) THEN
45257 ELSEIF(IVAR.EQ.4) THEN
45259 ELSEIF(IVAR.EQ.5) THEN
45261 ELSEIF(IVAR.EQ.6) THEN
45263 ELSEIF(IVAR.EQ.7) THEN
45265 ELSEIF(IVAR.EQ.8) THEN
45267 ELSEIF(IVAR.EQ.9) THEN
45269 ELSEIF(IVAR.EQ.10) THEN
45271 ELSEIF(IVAR.EQ.11) THEN
45273 ELSEIF(IVAR.EQ.12) THEN
45275 ELSEIF(IVAR.EQ.13) THEN
45277 ELSEIF(IVAR.EQ.14) THEN
45279 ELSEIF(IVAR.EQ.15) THEN
45281 ELSEIF(IVAR.EQ.16) THEN
45283 ELSEIF(IVAR.EQ.17) THEN
45285 ELSEIF(IVAR.EQ.18) THEN
45287 ELSEIF(IVAR.EQ.19) THEN
45289 ELSEIF(IVAR.EQ.20) THEN
45291 ELSEIF(IVAR.EQ.21) THEN
45293 ELSEIF(IVAR.EQ.22) THEN
45295 ELSEIF(IVAR.EQ.23) THEN
45297 ELSEIF(IVAR.EQ.24) THEN
45299 ELSEIF(IVAR.EQ.25) THEN
45301 ELSEIF(IVAR.EQ.26) THEN
45303 ELSEIF(IVAR.EQ.27) THEN
45305 ELSEIF(IVAR.EQ.28) THEN
45307 ELSEIF(IVAR.EQ.29) THEN
45309 ELSEIF(IVAR.EQ.30) THEN
45311 ELSEIF(IVAR.EQ.31) THEN
45313 ELSEIF(IVAR.EQ.32) THEN
45315 ELSEIF(IVAR.EQ.33) THEN
45316 ICOL(I1,I2,I3)=INEW
45317 ELSEIF(IVAR.EQ.34) THEN
45319 ELSEIF(IVAR.EQ.35) THEN
45321 ELSEIF(IVAR.EQ.36) THEN
45323 ELSEIF(IVAR.EQ.37) THEN
45325 ELSEIF(IVAR.EQ.38) THEN
45327 ELSEIF(IVAR.EQ.39) THEN
45329 ELSEIF(IVAR.EQ.40) THEN
45331 ELSEIF(IVAR.EQ.41) THEN
45333 ELSEIF(IVAR.EQ.42) THEN
45334 SIGT(I1,I2,I3)=RNEW
45335 ELSEIF(IVAR.EQ.43) THEN
45337 ELSEIF(IVAR.EQ.44) THEN
45339 ELSEIF(IVAR.EQ.45) THEN
45341 ELSEIF(IVAR.EQ.46) THEN
45343 ELSEIF(IVAR.EQ.47) THEN
45345 ELSEIF(IVAR.EQ.48) THEN
45347 ELSEIF(IVAR.EQ.49) THEN
45349 ELSEIF(IVAR.EQ.50) THEN
45350 RVLAM(I1,I2,I3)=RNEW
45351 ELSEIF(IVAR.EQ.51) THEN
45352 RVLAMP(I1,I2,I3)=RNEW
45353 ELSEIF(IVAR.EQ.52) THEN
45354 RVLAMB(I1,I2,I3)=RNEW
45355 ELSEIF(IVAR.EQ.53) THEN
45357 ELSEIF(IVAR.EQ.54) THEN
45361 C...Write old and new value. Loop back.
45363 CHBIT(15:60)=' changed from to '
45364 IF(MSVAR(IVAR,1).EQ.1) THEN
45365 WRITE(CHBIT(33:42),'(I10)') IOLD
45366 WRITE(CHBIT(51:60),'(I10)') INEW
45367 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45368 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
45369 WRITE(CHBIT(29:42),'(F14.5)') ROLD
45370 WRITE(CHBIT(47:60),'(F14.5)') RNEW
45371 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45372 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
45375 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45377 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
45378 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
45381 IF(LLOW.LT.LTOT) GOTO 120
45383 C...Format statement for output on unit MSTU(11) (by default 6).
45384 5000 FORMAT(5X,A60)
45385 5100 FORMAT(5X,A88)
45390 C*********************************************************************
45393 C...Administrates the fragmentation and decay chain.
45397 C...Double precision and integer declarations.
45398 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45399 IMPLICIT INTEGER(I-N)
45400 INTEGER PYK,PYCHGE,PYCOMP
45402 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45403 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45404 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45405 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45406 COMMON/PYINT4/MWID(500),WIDS(500,5)
45407 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
45409 DIMENSION PS(2,6),IJOIN(100)
45411 C...Initialize and reset.
45413 IF(MSTU(12).GE.1) CALL PYLIST(0)
45415 MSTU(31)=MSTU(31)+1
45419 IF(MSTU(17).LE.0) MSTU(90)=0
45422 C...Sum up momentum, energy and charge for starting entries.
45430 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
45432 PS(1,J)=PS(1,J)+P(I,J)
45434 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
45438 C...Start by all decays of coloured resonances involved in shower.
45441 IF(K(I,1).EQ.3) THEN
45443 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
45447 C...Prepare system for subsequent fragmentation/decay.
45450 C...Loop through jet fragmentation and particle decays.
45456 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
45459 C...Deal with any remaining undecayed resonance
45460 C...(normally the task of PYEVNT, so seldom used).
45461 ELSEIF(MWID(KC).NE.0) THEN
45463 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
45466 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
45467 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
45470 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
45471 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
45474 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
45483 C...Particle decay if unstable and allowed. Save long-lived particle
45484 C...decays until second pass after Bose-Einstein effects.
45485 ELSEIF(KCHG(KC,2).EQ.0) THEN
45486 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
45487 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
45490 C...Decay products may develop a shower.
45491 IF(MSTJ(92).GT.0) THEN
45493 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
45494 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
45495 CALL PYSHOW(IP1,IP1+1,QMAX)
45498 ELSEIF(MSTJ(92).LT.0) THEN
45500 CALL PYSHOW(IP1,-3,P(IP,5))
45505 C...Jet fragmentation: string or independent fragmentation.
45506 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
45508 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
45509 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
45510 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
45511 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
45512 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
45515 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
45516 IF(MFRAG.EQ.2) CALL PYINDF(IP)
45517 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
45518 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
45521 C...Loop back if enough space left in PYJETS and no error abort.
45522 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
45523 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
45525 ELSEIF(IP.LT.N) THEN
45526 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
45529 C...Include simple Bose-Einstein effect parametrization if desired.
45530 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
45535 C...Check that momentum, energy and charge were conserved.
45537 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
45539 PS(2,J)=PS(2,J)+P(I,J)
45541 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
45543 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
45544 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
45545 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
45546 &'(PYEXEC:) four-momentum was not conserved')
45547 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
45548 &'(PYEXEC:) charge was not conserved')
45553 C*********************************************************************
45556 C...Rearranges partons along strings.
45557 C...Special considerations for systems with junctions, with
45558 C...possibility of junction-antijunction annihilation.
45559 C...Allows small systems to collapse into one or two particles.
45560 C...Checks flavours and colour singlet invariant masses.
45562 SUBROUTINE PYPREP(IP)
45564 C...Double precision and integer declarations.
45565 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45566 INTEGER PYK,PYCHGE,PYCOMP
45568 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45569 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45570 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45571 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45572 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
45574 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
45575 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
45576 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
45577 &IJCP(0:6),TJUOLD(5)
45579 C...Function to give four-product.
45580 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)
45582 C...Rearrange parton shower product listing along strings: begin loop.
45590 DO 160 I=MAX(1,IP),N
45592 C...Special treatment for junctions
45593 IF(K(I,1).EQ.42) THEN
45594 C...First, just store positions
45595 IF (MQGST.EQ.1) THEN
45599 C...Then look for junction-junction strings (not detected in the
45600 C...main search below).
45601 ELSE IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
45602 IF (NJJSTR.EQ.0) THEN
45603 NJJSTR = (3*NJUNC-NPIECE)/2
45605 C...Check how many already identified strings end on this junction
45608 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
45610 C...If only 2, third one must be to another junction
45612 C...The colour information in the junction is unreadable for the
45613 C...colour space search further down in this routine, so we must
45614 C...start on the colour mother of this junction and then "artificially"
45615 C...prevent the colour mother from connecting here again.
45616 IA=MOD(K(I,4),MSTU(5))
45618 IF (MOD(MOD(K(I,4)/MSTU(5),MSTU(5)),2).EQ.1) KCS=5
45619 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
45620 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
45624 ELSE IF (ILC.NE.3) THEN
45625 C...This could happen if 2 legs of a junction connect to other
45628 & '(PYPREP:) Too many junction-junction strings.')
45633 C...Look for coloured string endpoint, or (later) leftover gluon.
45634 IF(K(I,1).NE.3) GOTO 160
45636 IF(KC.EQ.0) GOTO 160
45638 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 160
45640 C...Pick up loose string end.
45642 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
45648 IF(NSTP.GT.4*N) THEN
45649 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
45653 C...Copy undecayed parton. Finished if reached string endpoint.
45654 IF(K(IA,1).EQ.3) THEN
45655 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
45656 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
45661 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
45671 IF(K(I1,1).EQ.1) GOTO 160
45674 C...Also finished (for now) if reached junction; then copy to end.
45675 IF(K(IA,1).EQ.42) THEN
45677 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
45678 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
45681 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
45682 DO 140 ICOPY=1,NCOPY
45684 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
45685 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
45686 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
45692 IPIECE(NPIECE,1)=MSTU32+1
45693 IPIECE(NPIECE,2)=MSTU32+NCOPY
45694 IPIECE(NPIECE,3)=IB
45695 IPIECE(NPIECE,4)=IA
45696 MSTU32=MSTU32+NCOPY
45701 C...GOTO next parton in colour space.
45703 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
45705 IA=MOD(K(IB,KCS),MSTU(5))
45706 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
45709 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
45710 & MSTU(5)).EQ.0) KCS=9-KCS
45711 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
45712 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
45715 IF(IA.LE.0.OR.IA.GT.N) THEN
45716 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
45719 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
45720 & MSTU(5)).EQ.IB) THEN
45721 IF(MREV.EQ.1) KCS=9-KCS
45722 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
45723 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
45725 IF(MREV.EQ.0) KCS=9-KCS
45726 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
45727 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
45729 IF(IA.NE.I) GOTO 110
45734 C...Junction systems remain.
45740 180 IJUCNT=IJUCNT+1
45741 IF (IJUCNT.LE.NJUNC) THEN
45742 C...If we are not processing a j-j string, treat this junction as new.
45743 IF (IJJSTR.EQ.0) THEN
45744 IJU=IJUNC(IJUCNT,0)
45746 C...If junction has already been read, ignore it.
45747 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 180
45748 C...If we are on a j-j string, goto second j-j junction.
45753 C...Mark selected junction read.
45755 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
45758 C...Determine junction type
45759 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
45760 C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
45761 C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
45762 C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
45763 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
45766 C...Find which quarks belong to given junction.
45767 IF(IHK.EQ.1) IEND=MOD(K(IJU,5),MSTU(5))
45768 IF(IHK.EQ.2) IEND=MOD(K(IJU,5)/MSTU(5),MSTU(5))
45769 C...IHK = 3 is special. Either normal string piece, or j-j string.
45771 IEND=MOD(K(IJU,4),MSTU(5))
45772 IF (MREV.NE.1) THEN
45773 DO 210 IPC=1,NPIECE
45774 C...If there is a j-j string starting on the present junction which has
45775 C...zero length, insert next junction immediately.
45776 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
45777 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
45783 C...If MREV is 1 and IHK is 3 we are finished with this system.
45790 C...If we've gotten this far, then either IHK < 3, or
45791 C...an interjunction string exists, or just a third normal string.
45792 IJUNC(IJUCNT,IHK)=0
45794 C..Order pieces belonging to this junction. Also look for j-j.
45795 DO 220 IPC=1,NPIECE
45796 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
45797 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
45798 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
45799 IJUNC(IJUCNT,IHK)=IPC
45804 C...Copy back chains in proper order. MREV=0/1 : descending/ascending
45805 IPC=IJUNC(IJUCNT,IHK)
45806 DO 240 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
45809 K(I1,J)=K(MSTU(4)-ICP,J)
45810 P(I1,J)=P(MSTU(4)-ICP,J)
45811 V(I1,J)=V(MSTU(4)-ICP,J)
45815 C...Mark last quark.
45816 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
45817 C...Do not insert junctions at wrong places.
45818 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 270
45819 C...Insert junction.
45822 C...Shift to end junction if a j-j string has been processed.
45823 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
45833 K(IJUS,1)=K(IJUS,1)+10
45836 270 IF (IHK.LT.3) GOTO 200
45838 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
45840 IF (IJUCNT.NE.NJUNC) GOTO 180
45844 C...Rearrange three strings from junction, e.g. in case one has been
45845 C...shortened by shower, so the last is the largest-energy one.
45846 IF(NJUNC.GE.1) THEN
45847 C...Find systems with exactly one junction.
45851 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
45852 ELSEIF(K(I,1).EQ.41) THEN
45854 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
45859 C...Sum up energy-momentum in each junction string.
45866 DO 300 I1=NBEG,NEND
45867 IF(K(I1,2).NE.21) THEN
45872 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
45875 C...Find which of them has highest energy (minus mass) in rest frame.
45877 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
45879 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
45882 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
45883 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
45885 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
45886 C...Decide how to rearrange so that new last has highest energy.
45887 IF(PJU(1,6).LT.PJU(2,6)) THEN
45889 IRNG(1,2)=IJUR(2)-1
45891 IRNG(2,2)=IJUR(3)+1
45892 IRNG(4,1)=IJUR(3)-1
45896 IRNG(1,2)=IJUR(3)+1
45898 IRNG(2,2)=IJUR(3)-1
45899 IRNG(4,1)=IJUR(2)-1
45904 C...Copy in correct order below bottom of current event record.
45907 DO 340 I1=IRNG(II,1),IRNG(II,2),
45908 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
45915 IF(K(I2,1).EQ.1) K(I2,1)=2
45919 C...Copy back up, overwriting but now in correct order.
45920 DO 370 I1=NBEG,NEND
45934 C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
45935 C...to two q-qbar systems.
45936 C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
45937 IF (MSTJ(19).NE.1) THEN
45941 C...Force collapse when MSTJ(19)=2.
45942 IF (MSTJ(19).EQ.2) THEN
45946 C...Find systems with exactly two junctions.
45948 C...Count junctions
45949 IF (K(I,1).EQ.41) THEN
45951 C...Check for interjunction gluons
45952 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
45955 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
45956 C...If end of system reached with either zero or one junction, restart
45957 C...with next system.
45961 ELSEIF(K(I,1).EQ.1) THEN
45962 C...If end of system reached with exactly two junctions, compute string
45963 C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
45964 C...length measure for the (q-qbar)(q-qbar) topology.
45966 C...Loop down through chain.
45968 DO 390 I1=NBEG,NEND
45969 C...Store string piece division locations in event record
45970 IF (K(I1,2).NE.21) THEN
45975 C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
45977 IF (PYR(0).LT.0.5D0) ISW=1
45978 C...Randomly choose which qqbar string gets the jj gluons.
45980 IF (PYR(0).GT.0.5D0) IGS=2
45981 C...Only compute string lengths when no topology forced.
45982 IF (MSTJ(19).EQ.0) THEN
45983 C...Repeat following for each junction
45985 C...Initialize iterative procedure for finding JRF
45991 C...Start iteration. Sum up momenta in string pieces
45993 C...JD=-1 for first junction, +1 for second junction.
45994 C...Find out where piece starts and ends and which direction to go.
45997 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
45998 IB = IJCP((IJU-1)*7 - JD*IJS)
45999 ELSEIF (IJS.EQ.3) THEN
46001 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
46002 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
46004 C...Initialize junction pull 4-vector.
46008 C...Initialize weight
46011 C...Sum up (weighted) momenta along each string piece
46012 DO 440 ISP=IA,IB,JD
46013 C...If present parton not last in chain
46014 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
46015 C...If last parton was a junction, store present weight
46016 IF (K(ISP-JD,2).EQ.88) THEN
46018 C...If last parton was a quark, reset to stored weight.
46019 ELSEIF (K(ISP-JD,2).NE.21) THEN
46023 C...Skip next parton if weight already large
46024 IF (PWT.GT.10D0) GOTO 440
46025 C...Compute momentum in TJUOLD frame:
46026 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
46028 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
46030 TMP=P(ISP,J)+TJUOLD(J)*BFC
46031 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
46034 TMP=TJUOLD(4)*P(ISP,4)+TDP
46035 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
46037 PWT=PWT+TMP/PARJ(48)
46038 C...Put |p| rather than m in 5th slot
46039 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
46046 C...Combine new boost (T) with old boost (TJUOLD)
46047 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
46049 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
46052 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
46054 C...If last boost small, accept JRF, else iterate.
46055 C...Also prevent possibility of infinite loop.
46056 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
46057 & IJRFIT.LT.MSTJ(18))THEN
46059 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
46060 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
46062 C...Store final boost, with change of sign since TJJ motion vector.
46064 TJJ(IJU,IX)=-TJUOLD(IX)
46066 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
46069 C...String length measure for (q-qbar)(q-qbar) topology.
46070 C...Note only momenta of nearest partons used (since rest of system
46072 IF (JJGLUE.EQ.0) THEN
46073 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
46074 & -1,IJCP(5-ISW)+1)
46076 C...Put jj gluons on selected string (IGS selected randomly above).
46078 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
46079 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
46081 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
46082 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
46086 C...String length measure for q-q-j-j-q-q topology.
46095 C...Note only momenta of nearest partons used (since rest of system
46098 IF (IX.EQ.4) ISGN=1
46099 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
46100 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
46101 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
46102 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
46103 IF (JJGLUE.EQ.0) THEN
46104 C...Junction motion vector dot product gives length when inter-junction
46106 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
46108 C...Junction motion vector dot products with gluon momenta give length
46109 C...when inter-junction gluons present.
46110 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
46111 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
46114 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
46115 IF (JJGLUE.EQ.0) THEN
46116 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
46118 DELMJJ=DELMJJ*4D0*T1G1*T2G2
46121 C...If delmjj > delmqq collapse string system to q-qbar q-qbar
46122 C...(Always the case for MSTJ(19)=2 due to initialization above)
46123 IF (DELMJJ.GT.DELMQQ) THEN
46124 C...Put new system at end of event record
46127 DO 510 ICOP=IJCP(IST),IJCP(IST+1)-1
46130 P(NCOP,IX)=P(ICOP,IX)
46131 K(NCOP,IX)=K(ICOP,IX)
46134 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
46135 C...Insert inter-junction gluon string piece (reversed)
46137 DO 530 ICOP=IJCP(4)-1,IJCP(3)+1,-1
46141 P(NCOP,IX)=P(ICOP,IX)
46142 K(NCOP,IX)=K(ICOP,IX)
46147 DO 550 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
46150 P(NCOP,IX)=P(ICOP,IX)
46151 K(NCOP,IX)=K(ICOP,IX)
46156 C...Copy system back in right order
46157 DO 580 ICOP=NBEG,NEND-2
46159 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
46160 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
46163 C...Shift down rest of event record
46164 DO 600 ICOP=NEND+1,N
46166 P(ICOP-2,IX)=P(ICOP,IX)
46167 K(ICOP-2,IX)=K(ICOP,IX)
46170 C...Update length of event record.
46180 C...Done if no checks on small-mass systems.
46181 IF(MSTJ(14).LT.0) RETURN
46182 IF(MSTJ(14).EQ.0) GOTO 1050
46184 C...Find lowest-mass colour singlet jet system.
46189 DO 680 I=MAX(1,IP),N
46190 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
46191 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
46198 DPS(5)=PYMASS(K(I,2))
46199 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
46201 DPS(J)=DPS(J)+P(I,J)
46204 DPS(5)=DPS(5)+PYMASS(K(I,2))
46205 ELSEIF(K(I,1).EQ.2) THEN
46207 DPS(J)=DPS(J)+P(I,J)
46209 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
46211 DPS(J)=DPS(J)+P(I,J)
46214 DPS(5)=DPS(5)+PYMASS(K(I,2))
46215 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
46217 IF(PD.LT.PDMIN) THEN
46231 C...Done if lowest-mass system above threshold for string frag.
46232 IF(PDMIN.GE.PARJ(32)) GOTO 1050
46234 C...Fill small-mass system as cluster.
46236 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
46246 C...Set up history, assuming cluster -> 2 hadrons.
46252 IF(MSTU(16).NE.2) THEN
46267 C...Find total flavour content - complicated by presence of junctions.
46271 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
46274 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
46278 C...If several diquarks, split up one to give even number of flavours.
46279 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
46281 IF(IABS(KFQ(3)).LT.1000) I1=1
46282 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
46283 KFQ(I1)=KFQ(I1)/1000
46288 C...If four quark ends, join two to diquark.
46289 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
46292 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
46293 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
46294 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
46295 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
46296 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
46297 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
46303 C...If two quark ends, plus quark or diquark, join quarks to diquark.
46307 IF(IABS(KFQ(I1)).GT.1000) I1=3
46308 IF(IABS(KFQ(I2)).GT.1000) I2=3
46309 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
46310 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
46311 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
46312 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
46318 C...Form two particles from flavours of lowest-mass system, if feasible.
46320 700 NTRY = NTRY + 1
46322 C...Open string with two specified endpoint flavours.
46326 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1050
46327 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
46328 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
46329 IF(KQ1+KQ2.NE.0) GOTO 1050
46330 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
46332 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
46334 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
46335 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
46336 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 710
46338 C...Open string with four specified flavours.
46339 ELSEIF(NQ.EQ.4) THEN
46344 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1050
46345 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
46346 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
46347 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
46348 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
46349 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1050
46350 C...Combine flavours pairwise to form two hadrons.
46353 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
46354 & IABS(KFQ(2)).GT.1000)) I2=3
46355 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
46356 & IABS(KFQ(3)).GT.1000))) I2=4
46360 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
46361 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
46362 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 720
46366 IF(IABS(K(IC2,2)).NE.21) GOTO 1050
46367 C...No room for popcorn mesons in closed string -> 2 hadrons.
46369 730 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
46370 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
46371 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
46372 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 730
46374 P(N+2,5)=PYMASS(K(N+2,2))
46375 P(N+3,5)=PYMASS(K(N+3,2))
46377 C...If it does not work: try again (a number of times), give up (if no
46378 C...place to shuffle momentum or too many flavours), or form one hadron.
46379 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
46380 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
46382 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
46389 C...Perform two-particle decay of jet system.
46390 C...First step: find reference axis in decaying system rest frame.
46391 C...(Borrow slot N+2 for temporary direction.)
46395 DO 760 I=IC1+1,IC2-1
46396 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
46397 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
46398 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
46400 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
46404 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
46406 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
46407 PHI1=PYANGL(P(N+2,1),P(N+2,2))
46409 C...Second step: generate isotropic/anisotropic decay.
46410 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
46411 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
46413 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
46414 PT2=(1D0-UE(3)**2)*PA**2
46415 IF(MSTJ(16).LE.0) THEN
46418 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 770
46419 PR1=P(N+2,5)**2+PT2
46420 PR2=P(N+3,5)**2+PT2
46421 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
46423 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
46424 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
46426 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
46428 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
46429 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
46434 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
46435 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
46437 C...Third step: move back to event frame and set production vertex.
46438 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
46448 C...Else form one particle, if possible.
46456 C...Select hadron flavour from available quark flavours.
46457 820 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
46459 ELSEIF(NQ.EQ.2) THEN
46460 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
46462 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
46463 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
46465 IF(K(N+2,2).EQ.0) GOTO 820
46466 P(N+2,5)=PYMASS(K(N+2,2))
46468 C...Use old algorithm for E/p conservation? (EN)
46469 IF (MSTJ(16).LE.0) GOTO 990
46471 C...Find the string piece closest to the cluster by a loop
46472 C...over the undecayed partons not in present cluster. (EN)
46477 DO 850 I1=MAX(1,IP),N-1
46478 IF(K(I,1).EQ.1) NJUNC=0
46479 IF(K(I,1).EQ.41) NJUNC=NJUNC+1
46480 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
46482 ELSEIF(K(I1,1).EQ.2) THEN
46486 IF(K(I2,1).EQ.41) GOTO 850
46487 IF(K(I2,1).GT.10) GOTO 830
46488 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 830
46489 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
46490 & NJUNC.EQ.0) GOTO 850
46491 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 850
46493 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
46495 E1(J)=P(I1,J)/P(I1,4)
46496 E2(J)=P(I2,J)/P(I2,4)
46497 ECL(J)=P(N+1,J)/P(N+1,4)
46502 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
46503 E3S=E3(1)**2+E3(2)**2+E3(3)**2
46504 E4S=E4(1)**2+E4(2)**2+E4(3)**2
46505 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
46506 IF(E34.LE.0D0) THEN
46508 ELSEIF(E34.LT.E3S) THEN
46509 DDMIN=E4S-E34**2/E3S
46511 DDMIN=E4S-2D0*E34+E3S
46514 C...Is this the smallest so far?
46515 IF(DDMIN.LT.DGLOMI) THEN
46520 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
46525 C... Check if there are any strings to connect to the new gluon. (EN)
46526 IF (IBEG.EQ.0) GOTO 990
46528 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
46529 IF (P(N+1,5).GE.P(N+2,5)) THEN
46531 C...Construct 'gluon' that is needed to put hadron on the mass shell.
46532 FRAC=P(N+2,5)/P(N+1,5)
46534 P(N+2,J)=FRAC*P(N+1,J)
46535 PG(J)=(1D0-FRAC)*P(N+1,J)
46538 C... Copy string with new gluon put in.
46542 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 870
46543 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 870
46564 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 870
46567 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
46568 C...from string piece endpoints.
46571 C...Begin by copying string that should give energy to cluster.
46575 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 900
46576 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 900
46588 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 900
46591 C...Set initial Phad.
46593 P(NSAV+2,J)=P(NSAV+1,J)
46596 C...Calculate Pg, a part of which will be added to Phad later. (EN)
46597 930 IF(MSTJ(16).EQ.1) THEN
46601 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
46602 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
46605 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
46607 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
46609 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
46610 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
46612 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
46613 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
46614 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
46616 C...If all gluon energy eaten, zero it and take a step back.
46618 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3) THEN
46621 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
46627 IF(K(I1,1).EQ.41) ITER=-1
46629 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N) THEN
46632 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
46638 IF(K(I2,1).EQ.41) ITER=-1
46640 IF(ITER.EQ.1) GOTO 930
46642 C...If also all endpoint energy eaten, revert to old procedure.
46643 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
46644 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
46655 C... Construct the collapsed hadron and modified string partons.
46657 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
46658 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
46659 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
46661 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
46662 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
46664 C...Finished with string collapse in new scheme.
46668 C... Use old algorithm; by choice or when in trouble.
46670 C...Find parton/particle which combines to largest extra mass.
46675 IF(IR.NE.0) GOTO 1010
46676 DO 1000 I=MAX(1,IP),N
46677 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
46678 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1000
46679 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
46680 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1000
46681 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1000
46682 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
46684 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
46685 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
46686 IF(HSR.GT.HSM) THEN
46694 C...Shuffle energy and momentum to put new particle on mass shell.
46699 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
46700 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
46701 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
46703 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
46704 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
46708 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
46712 C...Mark collapsed system and store daughter pointers. Iterate.
46713 1030 DO 1040 I=IC1,IC2
46714 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
46715 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
46717 IF(MSTU(16).NE.2) THEN
46722 K(I,5)=NSAV+1+NBODY
46725 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
46727 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 620
46729 C...Check flavours and invariant masses in parton systems.
46737 DO 1090 I=MAX(1,IP),N
46738 IF(K(I,1).EQ.41) NJU=NJU+1
46739 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1090
46741 IF(KC.EQ.0) GOTO 1090
46742 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
46743 IF(KQ.EQ.0) GOTO 1090
46749 DPS(5)=DPS(5)+PYMASS(K(I,2))
46752 DPS(J)=DPS(J)+P(I,J)
46754 IF(K(I,1).EQ.1) THEN
46756 IF(NJU.EQ.0.AND.NP.NE.1) THEN
46757 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
46758 ELSEIF(NJU.EQ.1) THEN
46759 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
46760 ELSEIF(NJU.EQ.2) THEN
46761 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
46762 ELSEIF(NJU.GE.3) THEN
46765 IF(NFERR.EQ.1) CALL
46766 & PYERRM(2,'(PYPREP:) unphysical flavour combination')
46767 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
46768 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
46769 & '(PYPREP:) too small mass in jet system')
46783 C*********************************************************************
46786 C...Handles the fragmentation of an arbitrary colour singlet
46787 C...jet system according to the Lund string fragmentation model.
46789 SUBROUTINE PYSTRF(IP)
46791 C...Double precision and integer declarations.
46792 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46793 IMPLICIT INTEGER(I-N)
46794 INTEGER PYK,PYCHGE,PYCOMP
46796 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
46797 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46798 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46799 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
46800 C...Local arrays. All MOPS variables ends with MO
46801 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
46802 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
46803 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
46804 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
46805 &PBST(3,5),TJUOLD(5)
46807 C...Function: four-product of two vectors.
46808 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)
46809 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
46812 C...Reset counters.
46827 C...Identify parton system.
46830 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
46831 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
46832 IF(MSTU(21).GE.1) RETURN
46834 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
46836 IF(KC.EQ.0) GOTO 110
46837 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
46838 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
46839 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
46840 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
46841 IF(MSTU(21).GE.1) RETURN
46844 C...Take copy of partons to be considered. Check flavour sum.
46849 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
46851 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
46853 IF(KQ.NE.2) KQSUM=KQSUM+KQ
46854 IF(K(I,1).EQ.41) THEN
46855 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
46863 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
46864 IF(MOD(KQSUM,3).NE.0) THEN
46865 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
46866 IF(MSTU(21).GE.1) RETURN
46868 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
46870 C...Boost copied system to CM frame (for better numerical precision).
46871 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
46874 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
46878 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
46880 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
46881 IF(P(I,3).GT.0D0) THEN
46882 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
46883 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
46884 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
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)
46893 C...Search for very nearby partons that may be recombined.
46901 140 IF(NR.GE.3) THEN
46904 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
46906 IF(I.EQ.N+NR) I1=N+1
46907 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
46908 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
46910 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
46912 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
46913 & P(I1,2)**2+P(I1,3)**2))
46914 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
46915 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
46916 IF(PDR.LT.PDRMIN) THEN
46922 C...Recombine very nearby partons to avoid machine precision problems.
46923 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
46925 P(N+1,J)=P(N+1,J)+P(N+NR,J)
46927 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
46931 ELSEIF(PDRMIN.LT.PARU12) THEN
46933 P(IR,J)=P(IR,J)+P(IR+1,J)
46935 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
46937 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
46938 DO 190 I=IR+1,N+NR-1
46945 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
46947 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
46948 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
46954 C...Reset particle counter. Skip ahead if no junctions are present;
46955 C...this is usually the case!
46956 NRS=MAX(5*NR+11,NP)
46959 IF(NTRY.GT.100.AND.NTRYR.LE.8) THEN
46963 ELSEIF(NTRY.GT.100) THEN
46964 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
46965 IF(MSTU(21).GE.1) RETURN
46969 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 640
46970 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
46971 & ' junction strings not handled by MSTJ(12)>3 options')
46974 IF(MJU(JT).EQ.0) GOTO 630
46978 C...Find and sum up momentum on three sides of junction.
46979 C...Begin with previous boost = zero.
46986 C...Beginning and end of string system in event record.
46987 I1BEG=N+1+(JT-1)*(NR-1)
46988 I1END=N+NR+(JT-1)*(1-NR)
46989 C...Look for junction string piece end points
46990 DO 230 I1=I1BEG,I1END,JS
46991 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
46992 C...Store junction string piece end points.
46993 C 1-junction systems 2-junction systems
46994 C IU : 1 2 3 4 1 2 3 4 5 6
46995 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
46999 C...Sum over momenta, from junction outwards.
47003 C...Initialize junction drag and string piece 4-vectors.
47008 C...First two branches. Inwards out means opposite direction to JS.
47009 C...(JS is 1 for JT=1, -1 for JT=2)
47014 C...Last branch (gq or gjgqgq). Direction now reversed.
47020 DO 270 I1=I1A,I1B,IDIR
47021 C...Sum up momentum directions with exponential suppression
47022 C...for use in finding junction rest frame below.
47023 IF (K(I1,2).EQ.88) THEN
47024 C...gjgqgq type system encountered. Use current PWT as start
47025 C...for both strings.
47028 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
47029 C...Sum up string piece (boosted) 4-momenta.
47031 PJU(IU,J)=PJU(IU,J)+P(I1,J)
47033 C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
47034 C...boost is zero, see above). Skip parton if suppression factor large.
47035 IF (PWT.GT.10D0) GOTO 270
47036 C...Compute momentum in current frame:
47037 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
47038 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
47040 PTMP=P(I1,J)+TJUOLD(J)*BFC
47041 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
47044 PTMP=TJUOLD(4)*P(I1,4)+TDP
47045 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
47046 PWT=PWT+PTMP/PARJ(48)
47049 C...Put |p| rather than m in 5th slot.
47050 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
47051 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
47054 C...Calculate boost from present frame to next JRF candidate.
47056 CALL PYJURF(PBST,TJU)
47058 C...Combine new boost (TJU) with old boost (TJUOLD)
47059 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
47061 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
47063 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
47065 C...If last boost small, accept JRF, else iterate.
47066 C...Also prevent possibility of infinite loop.
47067 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
47068 & IJRFIT.LT.MSTJ(18)) THEN
47070 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
47071 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
47074 C...Now store total boost in TJU and change perception.
47075 C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
47076 C...TJU = junction motion vector in string CM, so the sign changes.
47080 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
47084 C...Calculate string piece energies in junction rest frame.
47086 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
47088 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
47089 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
47092 C...Start preparing for fragmentation of two strings from junction.
47095 320 NTRYER=NTRYER+1
47098 NS=IABS(IJU(IU+1)-IJU(IU))
47100 C...Junction strings: find longitudinal string directions.
47102 IS1=IJU(IU)+JS*(IS-1)
47105 DP(1,J)=0.5D0*P(IS1,J)
47106 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
47107 DP(2,J)=0.5D0*P(IS2,J)
47108 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
47109 & (PJU(IU,5)/PBST(IU,5))
47111 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
47112 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
47116 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
47117 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47118 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47123 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
47124 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
47125 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
47127 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
47129 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
47130 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
47134 C...Junction strings: initialize flavour, momentum and starting pos.
47138 IF(NTRY.GT.100.AND.NTRYR.LE.8) THEN
47142 ELSEIF(NTRY.GT.100) THEN
47143 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
47144 IF(MSTU(21).GE.1) RETURN
47149 IE(1)=K(N+1+(JT/2)*(NP-1),3)
47154 DO 370 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
47160 KFL(1)=K(IJU(IU),2)
47168 C...Junction strings: find initial transverse directions.
47171 DP(2,J)=P(IN(4)+1,J)
47175 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47176 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47177 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47178 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47179 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47180 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47181 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47182 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47183 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47185 DHCX1=DFOUR(3,1)/DHC12
47186 DHCX2=DFOUR(3,2)/DHC12
47187 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47188 DHCY1=DFOUR(4,1)/DHC12
47189 DHCY2=DFOUR(4,2)/DHC12
47190 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47191 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47193 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47195 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47199 C...Junction strings: produce new particle, origin.
47201 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
47202 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
47203 IF(MSTU(21).GE.1) RETURN
47211 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
47212 430 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
47213 IF(K(I,2).EQ.0) GOTO 360
47214 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
47215 & IABS(KFL(3)).GT.10) THEN
47216 IF(PYR(0).GT.PARJ(19)) GOTO 430
47218 P(I,5)=PYMASS(K(I,2))
47219 CALL PYPTDI(KFL(1),PX(3),PY(3))
47220 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
47221 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
47222 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
47223 & MSTU(90).LT.8) THEN
47224 MSTU(90)=MSTU(90)+1
47225 MSTU(90+MSTU(90))=I
47226 PARU(90+MSTU(90))=Z
47228 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
47233 C...Junction strings: stepping within 'low' string region.
47234 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
47235 & P(IN(1),5)**2.GE.PR(1)) THEN
47236 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
47237 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
47239 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
47242 C...Has used up energy of junction string, i.e. no more hadrons in it.
47243 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
47248 C...Stepping from 'low' string region
47249 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
47250 P(IN(2)+2,4)=P(IN(2)+2,3)
47253 IF(IN(2).GT.N+NR+4*NS) GOTO 360
47254 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47255 P(IN(1)+2,4)=P(IN(1)+2,3)
47261 C...Junction strings: find new transverse directions.
47262 470 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
47263 & IN(1).GT.IN(2)) GOTO 360
47264 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
47271 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47272 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47274 IF(DHC12.LE.1D-2) THEN
47275 P(IN(1)+2,4)=P(IN(1)+2,3)
47281 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47282 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47283 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47284 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47285 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47286 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47287 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47288 DHCX1=DFOUR(3,1)/DHC12
47289 DHCX2=DFOUR(3,2)/DHC12
47290 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47291 DHCY1=DFOUR(4,1)/DHC12
47292 DHCY2=DFOUR(4,2)/DHC12
47293 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47294 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47296 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47298 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47301 C...Express pT with respect to new axes, if sensible.
47302 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
47303 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
47304 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
47310 C...Junction strings: sum up known four-momentum, coefficients for m2.
47313 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
47314 & PY(3)*P(IN(3)+1,J)
47315 DO 500 IN1=IN(4),IN(1)-4,4
47316 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
47318 DO 510 IN2=IN(5),IN(2)-4,4
47319 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
47323 DHM(2)=2D0*FOUR(I,IN(1))
47324 DHM(3)=2D0*FOUR(I,IN(2))
47325 DHM(4)=2D0*FOUR(IN(1),IN(2))
47327 C...Junction strings: find coefficients for Gamma expression.
47328 DO 540 IN2=IN(1)+1,IN(2),4
47329 DO 530 IN1=IN(1),IN2-1,4
47330 DHC=2D0*FOUR(IN1,IN2)
47331 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
47332 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
47333 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
47334 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
47338 C...Junction strings: solve (m2, Gamma) equation system for energies.
47339 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
47340 IF(ABS(DHS1).LT.1D-4) GOTO 360
47341 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
47342 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
47343 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
47344 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
47345 & ABS(DHS1)-DHS2/DHS1)
47346 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
47347 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
47348 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
47350 C...Junction strings: step to new region if necessary.
47351 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
47352 P(IN(2)+2,4)=P(IN(2)+2,3)
47355 IF(IN(2).GT.N+NR+4*NS) GOTO 360
47356 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47357 P(IN(1)+2,4)=P(IN(1)+2,3)
47362 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
47363 P(IN(1)+2,4)=P(IN(1)+2,3)
47369 C...Junction strings: particle four-momentum, remainder, loop back.
47371 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
47372 & P(IN(2)+2,4)*P(IN(2),J)
47373 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
47375 IF(P(I,4).LT.P(I,5)) GOTO 360
47376 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
47377 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
47378 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
47383 IF(IN(3).NE.IN(6)) THEN
47385 P(IN(6),J)=P(IN(3),J)
47386 P(IN(6)+1,J)=P(IN(3)+1,J)
47391 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
47392 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
47397 C...Junction strings: save quantities left after each string.
47398 IF(IABS(KFL(1)).GT.10) GOTO 360
47402 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
47405 C...Junction strings: loopback if much unused energy in both strings.
47406 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
47407 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
47408 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
47410 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
47411 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
47412 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
47413 & .AND.NTRYER.LT.10) GOTO 320
47415 C...Junction strings: put together to new effective string endpoint.
47417 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
47418 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
47419 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
47420 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
47422 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
47423 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
47425 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
47430 C...Open versus closed strings. Choose breakup region for latter.
47431 640 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
47434 ELSEIF(MJU(1).NE.0) THEN
47437 ELSEIF(MJU(2).NE.0) THEN
47440 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
47447 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
47448 W2SUM=W2SUM+P(N+NR+IS,1)
47453 W2SUM=W2SUM-P(N+NR+NB,1)
47454 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 660
47457 C...Find longitudinal string directions (i.e. lightlike four-vectors).
47459 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
47460 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
47463 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
47464 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
47466 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
47467 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
47469 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
47470 & DP(1,2)**2-DP(1,3)**2))
47471 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
47472 & DP(2,2)**2-DP(2,3)**2))
47476 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
47477 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
47478 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
47479 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
47481 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
47483 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
47484 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
47488 C...Begin initialization: sum up energy, set starting position.
47492 IF(NTRY.GT.100.AND.NTRYR.LE.8) THEN
47496 ELSEIF(NTRY.GT.100) THEN
47497 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
47498 IF(MSTU(21).GE.1) RETURN
47505 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
47510 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
47511 IF(NS.GT.NR) IRANK(JT)=1
47513 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
47514 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
47515 IN(3*JT+2)=IN(3*JT+1)+1
47516 IN(3*JT+3)=N+NR+4*NS+2*JT-1
47517 DO 730 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
47524 C.. MOPS variables and switches
47530 C...Initialize flavour and pT variables for open string.
47534 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
47538 KFL(JT)=K(IE(JT),2)
47539 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
47540 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
47542 PMQ(JT)=PYMASS(KFL(JT))
47546 C...Closed string: random initial breakup flavour, pT and vertex.
47548 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
47550 760 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
47551 C.. Closed string: first vertex diq attempt => enforced second
47553 IF(IABS(KFL(1)).GT.10)THEN
47558 IF(IBMO.EQ.1) MSTU(121)=-1
47560 CALL PYPTDI(KFL(1),PX(1),PY(1))
47563 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
47564 770 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
47565 ZR=PR3/(Z*P(N+NR+1,5)**2)
47566 IF(ZR.GE.1D0) GOTO 770
47569 PMQ(JT)=PYMASS(KFL(JT))
47570 GAM(JT)=PR3*(1D0-Z)/Z
47571 IN1=N+NR+3+4*(JT/2)*(NS-1)
47574 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
47577 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
47583 PM2QMO(JT)=PMQ(JT)**2
47584 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
47587 C...Find initial transverse directions (i.e. spacelike four-vectors).
47589 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
47598 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47599 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47600 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47601 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47602 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47603 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47604 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47605 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47606 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47608 DHCX1=DFOUR(3,1)/DHC12
47609 DHCX2=DFOUR(3,2)/DHC12
47610 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47611 DHCY1=DFOUR(4,1)/DHC12
47612 DHCY2=DFOUR(4,2)/DHC12
47613 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47614 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47616 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47618 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47623 P(IN3+2,J)=P(IN3,J)
47624 P(IN3+3,J)=P(IN3+1,J)
47629 C...Remove energy used up in junction string fragmentation.
47630 IF(MJU(1)+MJU(2).GT.0) THEN
47632 IF(NJS(JT).EQ.0) GOTO 850
47634 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
47638 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
47639 WMIN=PARJST+PMQ(1)+PMQ(2)
47640 WREM2=FOUR(N+NRS,N+NRS)
47641 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
47643 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
47648 C...Produce new particle: side, origin.
47650 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
47651 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
47652 IF(MSTU(21).GE.1) RETURN
47654 C.. New side priority for popcorn systems
47655 IF(MSTU(121).LE.0)THEN
47657 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
47658 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
47662 IRANK(JT)=IRANK(JT)+1
47667 C...Generate flavour, hadron and pT.
47669 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
47670 IF(K(I,2).EQ.0) GOTO 700
47672 IF(MSTU(121).EQ.-1) GOTO 900
47673 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
47674 &IABS(KFL(3)).GT.10) THEN
47675 IF(PYR(0).GT.PARJ(19)) GOTO 870
47677 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47679 P(I,5)=PYMASS(K(I,2))
47680 CALL PYPTDI(KFL(JT),PX(3),PY(3))
47681 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
47683 C...Final hadrons for small invariant mass.
47685 PMQ(3)=PYMASS(KFL(3))
47687 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
47688 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
47689 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
47690 &WMIN-0.5D0*PARJ(36)*PMQ(3)
47691 WREM2=FOUR(N+NRS,N+NRS)
47692 IF(WREM2.LT.0.10D0) GOTO 700
47693 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
47694 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1070
47696 C...Choose z, which gives Gamma. Shift z for heavy flavours.
47697 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
47698 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
47699 &MSTU(90).LT.8) THEN
47700 MSTU(90)=MSTU(90)+1
47701 MSTU(90+MSTU(90))=I
47702 PARU(90+MSTU(90))=Z
47706 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
47707 &MOD(KFL2A/1000,10)).GE.4) THEN
47708 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
47709 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
47710 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
47711 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
47712 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1070
47714 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
47716 C.. MOPS baryon model modification
47717 XTMO3=(1D0-Z)*XTMO(JT)
47718 IF(IABS(KFL(3)).LE.10) NRVMO=0
47719 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
47723 IF(IABS(KFL(JT)).LE.10)THEN
47724 XBMO=MIN(XTMO3,1D0-(2D-10))
47727 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
47728 GTSTMO=1D0-PARF(192)**PGMO
47730 IF(IRANK(JT).EQ.1) THEN
47735 IF(XBMO.LT.1D0-(1D-10))THEN
47736 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
47737 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
47740 IF(MSTJ(12).GE.5)THEN
47741 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
47742 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
47743 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
47748 C.. MOPS Accepting popcorn system hadron.
47749 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
47750 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
47752 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
47754 & '(PYSTRF:) no more memory left in PYJETS')
47755 IF(MSTU(21).GE.1) RETURN
47767 DO 880 LINE=1,I-N-NR
47768 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
47769 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
47776 C..Reject popcorn system, flag=-1 if enforcing new one
47778 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
47783 C..Lift restoring string outside MOPS block
47784 900 IF(MSTU(121).LT.0) THEN
47785 IF(MSTU(121).EQ.-2) MSTU(121)=0
47788 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 870
47799 DO 910 LINE=1,I-N-NR
47800 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
47801 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
47809 C.. MOPS end of modification
47815 C...Stepping within or from 'low' string region easy.
47816 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
47817 &P(IN(1),5)**2.GE.PR(JT)) THEN
47818 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
47819 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
47821 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
47824 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
47825 P(IN(JR)+2,4)=P(IN(JR)+2,3)
47828 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 700
47829 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47830 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47836 C...Find new transverse directions (i.e. spacelike string vectors).
47837 950 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
47838 &IN(1).GT.IN(2)) GOTO 700
47839 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
47846 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47847 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47849 IF(DHC12.LE.1D-2) THEN
47850 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47856 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47857 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47858 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47859 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47860 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47861 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47862 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47863 DHCX1=DFOUR(3,1)/DHC12
47864 DHCX2=DFOUR(3,2)/DHC12
47865 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47866 DHCY1=DFOUR(4,1)/DHC12
47867 DHCY2=DFOUR(4,2)/DHC12
47868 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47869 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47871 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47873 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47876 C...Express pT with respect to new axes, if sensible.
47877 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
47878 & FOUR(IN(3*JT+3)+1,IN(3)))
47879 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
47880 & FOUR(IN(3*JT+3)+1,IN(3)+1))
47881 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
47887 C...Sum up known four-momentum. Gives coefficients for m2 expression.
47890 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
47891 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
47892 DO 980 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
47893 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
47895 DO 990 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
47896 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
47900 DHM(2)=2D0*FOUR(I,IN(1))
47901 DHM(3)=2D0*FOUR(I,IN(2))
47902 DHM(4)=2D0*FOUR(IN(1),IN(2))
47904 C...Find coefficients for Gamma expression.
47905 DO 1020 IN2=IN(1)+1,IN(2),4
47906 DO 1010 IN1=IN(1),IN2-1,4
47907 DHC=2D0*FOUR(IN1,IN2)
47908 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
47909 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
47910 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
47911 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
47915 C...Solve (m2, Gamma) equation system for energies taken.
47916 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
47917 IF(ABS(DHS1).LT.1D-4) GOTO 700
47918 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
47919 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
47920 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
47921 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
47922 &ABS(DHS1)-DHS2/DHS1)
47923 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 700
47924 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
47925 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
47927 C...Step to new region if necessary.
47928 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
47929 P(IN(JR)+2,4)=P(IN(JR)+2,3)
47932 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 700
47933 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47934 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47939 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
47940 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47946 C...Four-momentum of particle. Remaining quantities. Loop back.
47948 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
47949 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
47951 IF(P(I,4).LT.P(I,5)) GOTO 700
47957 IF(IN(3).NE.IN(3*JT+3)) THEN
47959 P(IN(3*JT+3),J)=P(IN(3),J)
47960 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
47965 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
47966 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
47968 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47972 C...Final hadron: side, flavour, hadron, mass.
47978 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
47979 IF(K(I,2).EQ.0) GOTO 700
47980 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
47982 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47984 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47986 P(I,5)=PYMASS(K(I,2))
47987 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
47989 C...Final two hadrons: find common setup of four-vectors.
47991 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
47992 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
47993 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
47994 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
47995 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
47996 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
47997 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
47998 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
47999 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
48000 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
48003 C...Solve kinematics for final two hadrons, if possible.
48004 WREM2=2D0*DHR1*DHR2*DHC12
48005 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
48006 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
48007 IF(FD.GE.1D0) GOTO 700
48008 FA=WREM2+PR(JT)-PR(JR)
48009 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
48011 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
48012 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
48013 FB=SIGN(FB,JS*(PYR(0)-PREV))
48016 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
48017 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
48018 &4D0*WREM2*PR(JT))),DBLE(JS))
48020 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
48021 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
48022 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
48023 P(I,J)=P(N+NRS,J)-P(I-1,J)
48025 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 700
48026 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
48027 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
48028 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
48030 IF(NTRYFN.LT.100) GOTO 140
48031 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
48034 C...Mark jets as fragmented and give daughter pointers.
48036 DO 1090 I=NSAV+1,NSAV+NP
48039 IF(MSTU(16).NE.2) THEN
48048 C...Document string system. Move up particles.
48059 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
48063 K(I,J)=K(I+NRS-1,J)
48064 P(I,J)=P(I+NRS-1,J)
48069 DO 1130 IZ=MSTU90+1,MSTU91
48070 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
48071 PARU9T(IZ)=PARU(90+IZ)
48075 C...Order particles in rank along the chain. Update mother pointer.
48078 K(I-NSAV+N,J)=K(I,J)
48079 P(I-NSAV+N,J)=P(I,J)
48083 DO 1180 I=N+1,2*N-NSAV
48084 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1180
48090 IF(MSTU(16).NE.2) K(I1,3)=NSAV
48091 DO 1170 IZ=MSTU90+1,MSTU91
48092 IF(MSTU9T(IZ).EQ.I) THEN
48093 MSTU(90)=MSTU(90)+1
48094 MSTU(90+MSTU(90))=I1
48095 PARU(90+MSTU(90))=PARU9T(IZ)
48099 DO 1210 I=2*N-NSAV,N+1,-1
48100 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1210
48106 IF(MSTU(16).NE.2) K(I1,3)=NSAV
48107 DO 1200 IZ=MSTU90+1,MSTU91
48108 IF(MSTU9T(IZ).EQ.I) THEN
48109 MSTU(90)=MSTU(90)+1
48110 MSTU(90+MSTU(90))=I1
48111 PARU(90+MSTU(90))=PARU9T(IZ)
48116 C...Boost back particle system. Set production vertices.
48119 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
48123 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
48124 IF(P(I,3).GT.0D0) THEN
48125 HHPEZ=(P(I,4)+P(I,3))*HHBZ
48126 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
48127 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
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)
48144 C*********************************************************************
48147 C...From three given input vectors in PJU the boost VJU from
48148 C...the "lab frame" to the junction rest frame is constructed.
48150 SUBROUTINE PYJURF(PJU,VJU)
48152 C...Double precision and integer declarations.
48153 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48154 IMPLICIT INTEGER(I-N)
48156 C...Input, output and local arrays.
48157 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
48158 DATA TWOPI/6.283186D0/
48160 C...Calculate masses and other invariants.
48162 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
48164 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
48165 PSUM(5)=SQRT(PSUM2)
48168 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
48169 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
48173 C...Pick I to be most massive parton and J to be the one closest to I.
48176 IF(A(2,2).GT.A(1,1)) I=2
48177 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
48181 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
48192 C...Trivial find new parton energies if all three partons are massless.
48193 IF(PMI2.LT.1D-4) THEN
48194 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
48195 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
48196 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
48198 C...Else find momentum range for parton I and values at extremes.
48204 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
48205 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
48206 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
48207 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
48208 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
48209 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
48210 HI=PEIMAX**2-0.25D0*PAIMAX**2
48211 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
48212 & 0.5D0*PAIMAX*AIJ)/HI
48213 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
48214 & 0.5D0*PAIMAX*AIK)/HI
48215 PEJMAX=SQRT(PAJMAX**2+PMJ2)
48216 PEKMAX=SQRT(PAKMAX**2+PMK2)
48217 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
48219 C...If unexpected values at upper endpoint then pick another parton.
48220 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
48222 IF(A(I1,I1).GE.1D-4) THEN
48228 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
48234 C..Start binary + linear search to find solution inside range.
48238 PAI=0.5D0*(PAIMIN+PAIMAX)
48241 C...Derive momentum of other two partons and distance to root.
48242 PEI=SQRT(PAI**2+PMI2)
48243 HI=PEI**2-0.25D0*PAI**2
48244 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
48245 PEJ=SQRT(PAJ**2+PMJ2)
48246 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
48247 PEK=SQRT(PAK**2+PMK2)
48248 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
48250 C...Pick next I momentum to explore, hopefully closer to root.
48251 IF(FNOW.GT.0D0) THEN
48260 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
48262 PAI=0.5D0*(PAIMIN+PAIMAX)
48264 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
48265 & ABS(FNOW).GT.1D-12*PSUM2) THEN
48266 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
48271 C...Now know energies in junction rest frame.
48276 C...Boost (copy of) partons to their rest frame.
48277 VXCM=-PSUM(1)/PSUM(5)
48278 VYCM=-PSUM(2)/PSUM(5)
48279 VZCM=-PSUM(3)/PSUM(5)
48280 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
48282 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
48283 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
48284 PCM(I,1)=PJU(I,1)+FAC2*VXCM
48285 PCM(I,2)=PJU(I,2)+FAC2*VYCM
48286 PCM(I,3)=PJU(I,3)+FAC2*VZCM
48287 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
48288 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
48291 C...Construct difference vectors and boost to junction rest frame.
48293 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
48294 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
48296 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
48297 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
48298 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
48299 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
48300 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
48301 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
48302 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
48303 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
48304 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
48305 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
48306 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
48308 C...Add two boosts, giving final result.
48309 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
48310 VJU(1)=VXJU+FCM*VXCM
48311 VJU(2)=VYJU+FCM*VYCM
48312 VJU(3)=VZJU+FCM*VZCM
48313 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
48316 C...In case of error in reconstruction: revert to CM frame of system.
48317 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
48318 &(PCM(1,5)*PCM(2,5))
48319 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
48320 &(PCM(1,5)*PCM(3,5))
48321 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
48322 &(PCM(2,5)*PCM(3,5))
48323 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
48324 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
48326 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
48327 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
48328 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
48329 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
48330 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
48331 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
48332 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
48334 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
48335 &(PCM(1,5)*PCM(2,5))
48336 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
48337 &(PCM(1,5)*PCM(3,5))
48338 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
48339 &(PCM(2,5)*PCM(3,5))
48340 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
48341 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
48342 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
48352 C*********************************************************************
48355 C...Handles the fragmentation of a jet system (or a single
48356 C...jet) according to independent fragmentation models.
48358 SUBROUTINE PYINDF(IP)
48360 C...Double precision and integer declarations.
48361 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48362 IMPLICIT INTEGER(I-N)
48363 INTEGER PYK,PYCHGE,PYCOMP
48365 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48366 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48367 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48368 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
48370 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
48371 &KFLO(2),PXO(2),PYO(2),WO(2)
48373 C.. MOPS error message
48374 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
48375 &' are not treated as expected in independent fragmentation')
48377 C...Reset counters. Identify parton system and take copy. Check flavour.
48387 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
48388 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
48389 IF(MSTU(21).GE.1) RETURN
48391 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
48393 IF(KC.EQ.0) GOTO 110
48394 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
48395 IF(KQ.EQ.0) GOTO 110
48397 IF(KQ.NE.2) KQSUM=KQSUM+KQ
48399 K(NSAV+NJET,J)=K(I,J)
48400 P(NSAV+NJET,J)=P(I,J)
48401 DPS(J)=DPS(J)+P(I,J)
48404 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
48405 &K(I+1,1).EQ.2)) GOTO 110
48406 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
48407 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
48408 IF(MSTU(21).GE.1) RETURN
48411 C...Boost copied system to CM frame. Find CM energy and sum flavours.
48414 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
48415 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
48421 DO 140 I=NSAV+1,NSAV+NJET
48425 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
48426 ELSEIF(KFA.GT.1000) THEN
48427 KFLA=MOD(KFA/1000,10)
48428 KFLB=MOD(KFA/100,10)
48429 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
48430 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
48434 C...Loop over attempts made. Reset counters.
48437 IF(NTRY.GT.200) THEN
48438 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
48439 IF(MSTU(21).GE.1) RETURN
48449 C...Loop over jets to be fragmented.
48450 DO 230 IP1=NSAV+1,NSAV+NJET
48455 C...Initial flavour and momentum values. Jet along +z axis.
48456 KFLH=IABS(K(IP1,2))
48457 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
48459 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
48461 C...Initial values for quark or diquark jet.
48462 170 IF(IABS(K(IP1,2)).NE.21) THEN
48465 CALL PYPTDI(0,PXO(1),PYO(1))
48468 C...Initial values for gluon treated like random quark jet.
48469 ELSEIF(MSTJ(2).LE.2) THEN
48471 IF(MSTJ(2).EQ.2) MSTJ(91)=1
48472 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
48473 CALL PYPTDI(0,PXO(1),PYO(1))
48476 C...Initial values for gluon treated like quark-antiquark jet pair,
48477 C...sharing energy according to Altarelli-Parisi splitting function.
48480 IF(MSTJ(2).EQ.4) MSTJ(91)=1
48481 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
48483 CALL PYPTDI(0,PXO(1),PYO(1))
48486 WO(1)=WF*PYR(0)**(1D0/3D0)
48490 C...Initial values for rank, flavour, pT and W+.
48500 C...New hadron. Generate flavour and hadron species.
48502 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
48503 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
48504 IF(MSTU(21).GE.1) RETURN
48511 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
48512 IF(K(I,2).EQ.0) GOTO 180
48513 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
48514 IF(PYR(0).GT.PARJ(19)) GOTO 200
48517 C...Find hadron mass. Generate four-momentum.
48518 P(I,5)=PYMASS(K(I,2))
48519 CALL PYPTDI(KFL1,PX2,PY2)
48522 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
48523 CALL PYZDIS(KFL1,KFL2,PR,Z)
48525 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
48527 MSTU(90)=MSTU(90)+1
48528 MSTU(90+MSTU(90))=I
48529 PARU(90+MSTU(90))=Z
48531 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
48532 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
48533 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
48534 & P(I,3).LE.0.001D0) THEN
48535 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
48541 C...Remaining flavour and momentum.
48550 C...Check if pL acceptable. Go back for new hadron if enough energy.
48551 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
48553 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
48555 IF(W.GT.PARJ(31)) GOTO 190
48558 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
48559 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
48561 C...Rotate jet to new direction.
48562 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
48563 PHI=PYANGL(P(IP1,1),P(IP1,2))
48565 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
48566 K(K(IP1,3),4)=NSAV1+1
48569 C...End of jet generation loop. Skip conservation in some cases.
48571 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
48572 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
48574 C...Subtract off produced hadron flavours, finished if zero.
48575 DO 240 I=NSAV+NJET+1,N
48577 KFLA=MOD(KFA/1000,10)
48578 KFLB=MOD(KFA/100,10)
48579 KFLC=MOD(KFA/10,10)
48581 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
48582 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
48584 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
48585 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
48586 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
48589 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
48590 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
48591 IF(NREQ.EQ.0) GOTO 320
48593 C...Take away flavour of low-momentum particles until enough freedom.
48597 DO 260 I=NSAV+NJET+1,N
48598 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
48599 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
48600 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
48602 IF(IREM.EQ.0) GOTO 150
48604 KFA=IABS(K(IREM,2))
48605 KFLA=MOD(KFA/1000,10)
48606 KFLB=MOD(KFA/100,10)
48607 KFLC=MOD(KFA/10,10)
48608 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
48609 IF(K(IREM,1).EQ.8) GOTO 250
48611 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
48612 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
48613 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
48615 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
48616 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
48617 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
48620 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
48621 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
48622 IF(NREQ.GT.NREM) GOTO 250
48623 DO 270 I=NSAV+NJET+1,N
48624 IF(K(I,1).EQ.8) K(I,1)=1
48627 C...Find combination of existing and new flavours for hadron.
48629 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
48630 IF(NREQ.LT.NREM) NFET=1
48631 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
48633 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
48634 KFLF(J)=ISIGN(1,NFL(1))
48635 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
48636 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
48638 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
48640 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
48641 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
48642 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
48643 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
48644 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
48645 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
48646 IF(NFET.LE.2) KFLF(3)=0
48647 IF(KFLF(3).NE.0) THEN
48648 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
48649 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
48650 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
48651 & KFLFC=KFLFC+ISIGN(2,KFLFC)
48655 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
48656 IF(KF.EQ.0) GOTO 280
48657 DO 300 J=1,MAX(2,NFET)
48658 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
48661 C...Store hadron at random among free positions.
48662 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
48663 DO 310 I=NSAV+NJET+1,N
48664 IF(K(I,1).EQ.7) NPOS=NPOS-1
48665 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
48668 P(I,5)=PYMASS(K(I,2))
48669 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48672 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
48673 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
48674 IF(NREM.GT.0) GOTO 280
48676 C...Compensate for missing momentum in global scheme (3 options).
48677 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
48680 DO 330 I=NSAV+NJET+1,N
48681 PSI(J)=PSI(J)+P(I,J)
48684 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
48686 DO 350 I=NSAV+NJET+1,N
48687 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
48688 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
48689 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
48690 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
48692 DO 370 I=NSAV+NJET+1,N
48693 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
48694 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
48695 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
48696 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
48698 P(I,J)=P(I,J)-PSI(J)*PW/PWS
48700 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48703 C...Compensate for missing momentum withing each jet separately.
48704 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
48705 DO 390 I=N+1,N+NJET
48711 DO 410 I=NSAV+NJET+1,N
48714 K(IR2,1)=K(IR2,1)+1
48715 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
48716 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
48718 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
48720 P(IR2,4)=P(IR2,4)+P(I,4)
48721 P(IR2,5)=P(IR2,5)+PLS
48724 DO 420 I=N+1,N+NJET
48725 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
48727 DO 440 I=NSAV+NJET+1,N
48730 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
48731 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
48733 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
48736 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48740 C...Scale momenta for energy conservation.
48741 IF(MOD(MSTJ(3),5).NE.0) THEN
48745 DO 450 I=NSAV+NJET+1,N
48748 PQS=PQS+P(I,5)**2/P(I,4)
48750 IF(PMS.GE.PECM) GOTO 150
48753 PFAC=(PECM-PQS)/(PES-PQS)
48756 DO 480 I=NSAV+NJET+1,N
48760 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48762 PQS=PQS+P(I,5)**2/P(I,4)
48764 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
48767 C...Origin of produced particles and parton daughter pointers.
48768 490 DO 500 I=NSAV+NJET+1,N
48769 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
48770 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
48772 DO 510 I=NSAV+1,NSAV+NJET
48775 IF(MSTU(16).NE.2) THEN
48779 K(I1,4)=K(I1,4)-NJET+1
48780 K(I1,5)=K(I1,5)-NJET+1
48781 IF(K(I1,5).LT.K(I1,4)) THEN
48788 C...Document independent fragmentation system. Remove copy of jets.
48799 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
48801 DO 540 I=NSAV+NJET,N
48803 K(I-NJET+1,J)=K(I,J)
48804 P(I-NJET+1,J)=P(I,J)
48805 V(I-NJET+1,J)=V(I,J)
48809 DO 550 IZ=MSTU90+1,MSTU(90)
48810 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
48813 C...Boost back particle system. Set production vertices.
48814 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
48815 &DPS(2)/DPS(4),DPS(3)/DPS(4))
48825 C*********************************************************************
48828 C...Handles the decay of unstable particles.
48830 SUBROUTINE PYDECY(IP)
48832 C...Double precision and integer declarations.
48833 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48834 IMPLICIT INTEGER(I-N)
48835 INTEGER PYK,PYCHGE,PYCOMP
48837 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48838 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48839 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48840 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
48841 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
48843 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
48844 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
48846 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
48848 C...Functions: momentum in two-particle decays and four-product.
48849 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
48850 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)
48852 C...Initial values.
48856 KFS=ISIGN(1,K(IP,2))
48860 C...Choose lifetime and determine decay vertex.
48861 IF(K(IP,1).EQ.5) THEN
48863 ELSEIF(K(IP,1).NE.4) THEN
48864 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
48867 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
48870 C...Determine whether decay allowed or not.
48872 IF(MSTJ(22).EQ.2) THEN
48873 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
48874 ELSEIF(MSTJ(22).EQ.3) THEN
48875 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
48876 ELSEIF(MSTJ(22).EQ.4) THEN
48877 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
48878 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
48880 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
48885 C...Interface to external tau decay library (for tau polarization).
48886 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
48888 C...Starting values for pointers and momenta.
48892 PCMTAU(J)=P(ITAU,J)
48895 C...Iterate to find position and code of mother of tau.
48897 120 IMTAU=K(IMTAU,3)
48899 IF(IMTAU.EQ.0) THEN
48900 C...If no known origin then impossible to do anything further.
48904 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
48905 C...If tau -> tau + gamma then add gamma energy and loop.
48906 IF(K(K(IMTAU,4),2).EQ.22) THEN
48908 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
48910 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
48912 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
48917 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
48918 C...If coming from weak decay of hadron then W is not stored in record,
48919 C...but can be reconstructed by adding neutrino momentum.
48920 KFORIG=-ISIGN(24,K(ITAU,2))
48922 DO 160 II=K(IMTAU,4),K(IMTAU,5)
48923 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
48925 PCMTAU(J)=PCMTAU(J)+P(II,J)
48931 C...If coming from resonance decay then find latest copy of this
48932 C...resonance (may not completely agree).
48935 DO 170 II=IMTAU+1,IP-1
48936 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
48937 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
48940 PCMTAU(J)=P(IORIG,J)
48944 C...Boost tau to rest frame of production process (where known)
48945 C...and rotate it to sit along +z axis.
48947 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
48949 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
48950 & -DBETAU(2),-DBETAU(3))
48951 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
48952 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
48953 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
48954 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
48956 C...Call tau decay routine (if meaningful) and fill extra info.
48957 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
48958 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
48959 DO 200 II=NSAV+1,NSAV+NDECAY
48968 C...Boost back decay tau and decay products.
48972 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
48973 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
48974 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
48975 & DBETAU(2),DBETAU(3))
48977 C...Skip past ordinary tau decay treatment.
48985 C...B-Bbar mixing: flip sign of meson appropriately.
48987 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
48989 IF(KFA.EQ.531) XBBMIX=PARJ(77)
48990 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
48991 IF(MMIX.EQ.1) KFS=-KFS
48994 C...Check existence of decay channels. Particle/antiparticle rules.
48996 IF(MDCY(KC,2).GT.0) THEN
48997 MDMDCY=MDME(MDCY(KC,2),2)
48998 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
49000 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
49001 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
49004 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
49005 IF(KCHG(KC,3).EQ.0) THEN
49008 IF(PYR(0).GT.0.5D0) KFS=-KFS
49009 ELSEIF(KFS.GT.0) THEN
49017 C...Sum branching ratios of allowed decay channels.
49020 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
49021 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
49022 & KFSN*MDME(IDL,1).NE.3) GOTO 230
49023 IF(MDME(IDL,2).GT.100) GOTO 230
49025 BRSU=BRSU+BRAT(IDL)
49028 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
49032 C...Select decay channel among allowed ones.
49033 240 RBR=BRSU*PYR(0)
49036 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
49037 &KFSN*MDME(IDL,1).NE.3) THEN
49038 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
49039 ELSEIF(MDME(IDL,2).GT.100) THEN
49040 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
49044 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
49047 C...Start readout of decay channel: matrix element, reset counters.
49050 IF(MOD(NTRY,200).EQ.0) THEN
49051 WRITE(CIDC,'(I4)') IDC
49052 C...Do not print warning for some well-known special cases.
49053 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
49054 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
49058 IF(NTRY.GT.1000) THEN
49059 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
49060 IF(MSTU(21).GE.1) RETURN
49066 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
49069 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
49071 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
49077 IF(KFA.GT.80) MHADDY=1
49078 C.. Random flavour and popcorn system memory.
49084 C...Read out decay products. Convert to standard flavour code.
49086 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
49088 IF(JT.LE.5) KP=KFDP(IDC,JT)
49089 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
49090 IF(KP.EQ.0) GOTO 280
49093 IF(KPA.GT.80) MHADDY=1
49094 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
49096 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
49098 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
49099 KFP=-KFS*MOD(KFA/10,10)
49100 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
49101 KFP=KFS*(100*MOD(KFA/10,100)+3)
49102 ELSEIF(KPA.EQ.81) THEN
49103 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
49104 ELSEIF(KP.EQ.82) THEN
49105 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
49106 IF(KFP.EQ.0) GOTO 260
49110 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
49111 ELSEIF(KP.EQ.-82) THEN
49114 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
49116 C...Add decay product to event record or to quark flavour list.
49119 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
49122 C...set rndmflav popcorn system pointer
49123 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
49125 PSQ=PSQ+PYMASS(KFLO(NQ))
49126 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
49127 & MOD(NQ,2).EQ.1) THEN
49132 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
49133 IF(K(I,2).EQ.0) GOTO 260
49135 P(I,5)=PYMASS(K(I,2))
49140 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
49141 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
49143 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
49144 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
49154 C...Check masses for resonance decays.
49155 IF(MHADDY.EQ.0) THEN
49156 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
49159 C...Choose decay multiplicity in phase space model.
49160 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
49162 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
49163 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
49165 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
49166 IF(IRNDMO.EQ.0) THEN
49169 ELSEIF(IRNDMO.EQ.1) THEN
49174 IF(NTRY.GT.1000) THEN
49175 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
49176 IF(MSTU(21).GE.1) RETURN
49178 IF(MMAT.LE.20) THEN
49179 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
49180 & SIN(PARU(2)*PYR(0))
49181 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
49182 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
49183 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
49184 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
49185 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
49189 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
49191 IF(MSTU(121).GT.MSTU(125)) GOTO 300
49193 C...Form hadrons from flavour content.
49197 IF(ND.EQ.NP+NQ/2) GOTO 330
49198 DO 320 I=N+NP+1,N+ND-NQ/2
49199 C.. Stick to started popcorn system, else pick side at random
49201 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
49202 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
49203 IF(K(I,2).EQ.0) GOTO 300
49204 MSTU(125)=MSTU(125)-1
49206 IF(MSTU(121).GT.0) JTMO=JT
49212 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
49213 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
49214 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
49217 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
49218 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
49219 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
49220 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
49222 C...Check that sum of decay product masses not too large.
49224 DO 340 I=N+NP+1,N+ND
49229 P(I,5)=PYMASS(K(I,2))
49232 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
49234 C...Rescale energy to subtract off spectator quark mass.
49235 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
49236 & .AND.NP.GE.3) THEN
49238 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
49240 P(N+NP,J)=PQT*PV(1,J)
49241 PV(1,J)=(1D0-PQT)*PV(1,J)
49243 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
49247 C...Fully specified final state: check mass broadening effects.
49249 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
49253 C...Determine position of grandmother, number of sisters.
49259 IF(IM.LT.0.OR.IM.GE.IP) IM=0
49260 IF(IM.NE.0) KFAM=IABS(K(IM,2))
49262 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
49263 IF(K(IL,3).EQ.IM) NM=NM+1
49264 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
49266 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
49267 & MOD(KFAM/1000,10).NE.0) NM=0
49269 KFAS=IABS(K(ISIS,2))
49270 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
49271 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
49276 C...Kinematics of one-particle decays.
49284 C...Calculate maximum weight ND-particle decay.
49287 WTMAX=1D0/WTCOR(ND-2)
49288 PMAX=PV(1,5)-PS+P(N+ND,5)
49290 DO 380 IL=ND-1,1,-1
49291 PMAX=PMAX+P(N+IL,5)
49292 PMIN=PMIN+P(N+IL+1,5)
49293 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
49297 C...Find virtual gamma mass in Dalitz decay.
49298 390 IF(ND.EQ.2) THEN
49299 ELSEIF(MMAT.EQ.2) THEN
49300 PMES=4D0*PMAS(11,1)**2
49301 PMRHO2=PMAS(131,1)**2
49302 PGRHO2=PMAS(131,2)**2
49303 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
49304 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
49305 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
49306 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
49307 IF(WT.LT.PYR(0)) GOTO 400
49308 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
49310 C...M-generator gives weight. If rejected, try again.
49315 DO 420 IL2=IL1-1,1,-1
49316 IF(RSAV.LE.RORD(IL2)) GOTO 430
49317 RORD(IL2+1)=RORD(IL2)
49319 430 RORD(IL2+1)=RSAV
49323 DO 450 IL=ND-1,1,-1
49324 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
49326 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
49328 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
49331 C...Perform two-particle decays in respective CM frame.
49332 460 DO 480 IL=1,ND-1
49333 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
49334 UE(3)=2D0*PYR(0)-1D0
49336 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
49337 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
49340 PV(IL+1,J)=-PA*UE(J)
49342 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
49343 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
49346 C...Lorentz transform decay products to lab frame.
49350 DO 530 IL=ND-1,1,-1
49352 BE(J)=PV(IL,J)/PV(IL,4)
49354 GA=PV(IL,4)/PV(IL,5)
49356 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
49358 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
49360 P(I,4)=GA*(P(I,4)+BEP)
49364 C...Check that no infinite loop in matrix element weight.
49366 IF(NTRY.GT.800) GOTO 560
49368 C...Matrix elements for omega and phi decays.
49370 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
49371 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
49372 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
49373 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
49375 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
49376 ELSEIF(MMAT.EQ.2) THEN
49377 FOUR12=FOUR(N+1,N+2)
49378 FOUR13=FOUR(N+1,N+3)
49379 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
49380 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
49381 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
49383 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
49384 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
49385 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
49386 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
49388 FOUR12=FOUR(IP,N+1)
49389 FOUR02=FOUR(IM,N+1)
49393 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
49394 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
49395 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
49396 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
49397 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
49398 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
49400 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
49401 ELSEIF(MMAT.EQ.4) THEN
49402 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
49403 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
49404 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
49405 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
49406 & ((1D0-HX3)/(HX1*HX2))**2
49407 IF(WT.LT.2D0*PYR(0)) GOTO 390
49408 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
49411 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
49412 ELSEIF(MMAT.EQ.41) THEN
49413 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
49414 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
49415 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
49417 C...Matrix elements for weak decays (only semileptonic for c and b)
49418 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
49419 & .AND.ND.EQ.3) THEN
49420 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
49421 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
49422 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
49423 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
49427 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
49430 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
49431 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
49432 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
49435 C...Scale back energy and reattach spectator.
49436 560 IF(MREM.EQ.1) THEN
49438 PV(1,J)=PV(1,J)/(1D0-PQT)
49444 C...Low invariant mass for system with spectator quark gives particle,
49445 C...not two jets. Readjust momenta accordingly.
49446 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
49448 PM2=PYMASS(K(N+2,2))
49450 PM3=PYMASS(K(N+3,2))
49451 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
49452 & (PARJ(32)+PM2+PM3)**2) GOTO 630
49455 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
49456 IF(K(N+2,2).EQ.0) GOTO 260
49457 P(N+2,5)=PYMASS(K(N+2,2))
49458 PS=P(N+1,5)+P(N+2,5)
49463 ELSEIF(MMAT.EQ.44) THEN
49465 PM3=PYMASS(K(N+3,2))
49467 PM4=PYMASS(K(N+4,2))
49468 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
49469 & (PARJ(32)+PM3+PM4)**2) GOTO 600
49472 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
49473 IF(K(N+3,2).EQ.0) GOTO 260
49474 P(N+3,5)=PYMASS(K(N+3,2))
49476 P(N+3,J)=P(N+3,J)+P(N+4,J)
49478 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)
49479 HA=P(N+1,4)**2-P(N+2,4)**2
49480 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
49481 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
49482 & (P(N+1,3)-P(N+2,3))**2
49483 HD=(PV(1,4)-P(N+3,4))**2
49484 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
49487 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
49489 PCOR=HH*(P(N+1,J)-P(N+2,J))
49490 P(N+1,J)=P(N+1,J)+PCOR
49491 P(N+2,J)=P(N+2,J)-PCOR
49493 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)
49494 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)
49498 C...Check invariant mass of W jets. May give one particle or start over.
49499 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
49500 &.AND.IABS(K(N+1,2)).LT.10) THEN
49501 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
49503 PM1=PYMASS(K(N+1,2))
49505 PM2=PYMASS(K(N+2,2))
49506 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
49507 KFLDUM=INT(1.5D0+PYR(0))
49508 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
49509 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
49510 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
49511 PSM=PYMASS(KF1)+PYMASS(KF2)
49512 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
49513 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
49514 IF(MMAT.EQ.48) GOTO 390
49515 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
49518 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
49519 IF(K(N+1,2).EQ.0) GOTO 260
49520 P(N+1,5)=PYMASS(K(N+1,2))
49523 PS=P(N+1,5)+P(N+2,5)
49524 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
49531 C...Phase space decay of partons from W decay.
49532 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
49538 PV(1,J)=P(N+1,J)+P(N+2,J)
49547 PSQ=PYMASS(KFLO(1))
49549 PSQ=PSQ+PYMASS(KFLO(2))
49554 C...Boost back for rapidly moving particle.
49558 BE(J)=P(IP,J)/P(IP,4)
49562 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
49564 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
49566 P(I,4)=GA*(P(I,4)+BEP)
49570 C...Fill in position of decay vertex.
49578 C...Set up for parton shower evolution from jets.
49579 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
49583 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
49584 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
49585 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
49586 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
49587 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
49588 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
49590 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
49593 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
49594 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
49595 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
49596 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
49598 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
49599 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
49602 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
49603 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
49604 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
49605 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
49607 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
49608 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
49610 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
49615 KCP=PYCOMP(K(NSAV+1,2))
49616 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
49618 IF(KQP.LT.0) JCON=5
49619 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
49620 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
49621 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
49622 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
49624 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
49627 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
49628 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
49629 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
49630 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
49634 C...Mark decayed particle; special option for B-Bbar mixing.
49635 IF(K(IP,1).EQ.5) K(IP,1)=15
49636 IF(K(IP,1).LE.10) K(IP,1)=11
49637 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
49645 C*********************************************************************
49648 C...Handles flavour production in the decay of unstable particles
49649 C...and small string clusters.
49651 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
49653 C...Double precision and integer declarations.
49654 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49655 IMPLICIT INTEGER(I-N)
49656 INTEGER PYK,PYCHGE,PYCOMP
49658 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49659 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49660 SAVE /PYDAT1/,/PYDAT2/
49663 C.. Call PYKFDI directly if no popcorn option is on
49664 IF(MSTJ(12).LT.2) THEN
49665 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
49672 IF(KFL1.EQ.0) RETURN
49677 NMAX=MIN(MSTU(125),10)
49679 C.. Identify rank 0 cluster qq
49681 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
49684 C.. Join jets: Fails if store not empty
49685 IF(MSTU(121).GT.0) THEN
49689 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
49690 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
49691 C.. Pick popcorn meson from store, return same qq, decrease store
49692 KF=MSTU(NSTO+MSTU(121))
49694 MSTU(121)=MSTU(121)-1
49696 C.. Generate new flavour. Then done if no diquark is generated
49697 100 CALL PYKFDI(KFL1,0,KFL3,KF)
49698 IF(MSTU(121).EQ.-1) GOTO 100
49700 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
49702 C.. Simple case if no dynamical popcorn suppressions are considered
49703 IF(MSTJ(12).LT.4) THEN
49704 IF(MSTU(121).EQ.0) RETURN
49707 CALL PYKFDI(KFPREV,0,KFL3,KFM)
49708 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
49709 IF(IABS(KFL3).LE.10)THEN
49716 C test output qq against fake Gamma, then return if no popcorn.
49719 CALL PYZDIS(1,2103,5D0,Z)
49721 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
49726 IF(MSTU(121).EQ.0) RETURN
49728 C..Set store size memory. Pick fake dynamical variables of qq.
49730 CALL PYPTDI(1,PX3,PY3)
49736 C.. Pick next popcorn meson, test with fake dynamical variables
49740 CALL PYKFDI(KFPREV,0,KFL3,KFM)
49741 IF(MSTU(121).EQ.-1) GOTO 100
49742 CALL PYPTDI(KFL3,PX3,PY3)
49743 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
49744 CALL PYZDIS(KFPREV,KFL3,PM,Z)
49751 IF(MSTJ(12).GT.4)THEN
49752 POPMN=SQRT((1D0-X)*(G/X-GB))
49753 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
49754 PTST=EXP((POPM-POPMN)*PARF(193))
49759 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
49762 IF(RTST.GT.PTST*GTST)THEN
49764 IF(RTST.GT.PTST) MSTU(121)=-1
49769 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
49770 IF(MSTU(121).GT.0) GOTO 110
49772 C.. Test accepted system size. If OK set global popcorn size variable.
49773 IF(NMES.GT.NMAX)THEN
49784 C********************************************************************
49787 C...Generates a new flavour pair and combines off a hadron
49789 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
49791 C...Double precision and integer declarations.
49792 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49793 IMPLICIT INTEGER(I-N)
49794 INTEGER PYK,PYCHGE,PYCOMP
49796 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49797 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49798 SAVE /PYDAT1/,/PYDAT2/
49802 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
49804 C...Default flavour values. Input consistency checks.
49809 IF(KF1A.EQ.0) RETURN
49811 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
49812 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
49813 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
49816 C...Check if tabulated flavour probabilities are to be used.
49817 IF(MSTJ(15).EQ.1) THEN
49818 IF(MSTJ(12).GE.5) CALL PYERRM(29,
49819 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
49820 & ' together with MSTJ(12)>=5 modification')
49822 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
49823 KFL1A=MOD(KF1A/1000,10)
49824 KFL1B=MOD(KF1A/100,10)
49826 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
49827 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
49828 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
49829 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
49833 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
49834 KFL2A=MOD(KF2A/1000,10)
49835 KFL2B=MOD(KF2A/100,10)
49837 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
49838 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
49839 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
49841 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
49844 C.. Recognize rank 0 diquark case
49846 KFDIQ=MAX(KF1A,KF2A)
49847 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
49849 C.. Join two flavours to meson or baryon. Test for popcorn.
49852 IF(KFDIQ.GT.10) THEN
49853 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
49854 & CALL PYNMES(KFDIQ)
49855 IF(MSTU(121).NE.0) THEN
49866 C.. Separate incoming flavours, curtain flavour consistency check
49872 KFL1A=MOD(KF1A/1000,10)
49873 KFL1B=MOD(KF1A/100,10)
49876 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
49877 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
49878 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
49880 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
49884 KFQOLD=KFL1A+KFL1B-KFQPOP
49887 C...Meson/baryon choice. Set number of mesons if starting a popcorn
49890 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
49891 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
49895 ELSEIF(KF1A.GT.10)THEN
49897 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
49898 IF(MSTU(121).GT.0) MBARY=-1
49901 C..x->H+q: Choose single vertex quark. Jump to form hadron.
49902 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
49903 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
49904 KFL3=ISIGN(KFQVER,-KFIN)
49908 C..x->H+qq: (IDW=proper PARF position for diquark weights)
49911 IF(MSTU(121).EQ.0) IDW=150
49913 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
49914 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
49915 C.. Shift to s-curtain parameters if needed
49916 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
49917 PARF(194)=PARF(138)*PARF(139)
49918 PARF(193)=PARJ(8)+PARJ(9)
49922 C.. x->H+qq: Get vertex quark
49923 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
49925 MSTU(121)=MSTU(121)-1
49926 IF(IDW.EQ.170) THEN
49927 IF(MSTU(121).EQ.0)THEN
49928 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
49930 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
49933 IF(MSTU(121).EQ.0)THEN
49934 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
49936 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
49942 RMES=PYR(0)*PARF(194)
49944 RMES=RMES-PARF(IPOS+IMES)
49945 IF(IMES.EQ.30) THEN
49950 IF(RMES.GT.0D0) GOTO 120
49953 IF(KMUL.EQ.2) KFJ=10003
49954 IF(KMUL.EQ.3) KFJ=10001
49955 IF(KMUL.EQ.4) KFJ=20003
49956 IF(KMUL.EQ.5) KFJ=5
49958 KFQVER=MOD(IMES,5)+1
49959 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
49960 IF(KFQVER.GT.3)THEN
49965 IF(MBARY.EQ.-1) IDW=170
49967 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
49968 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
49969 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
49970 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
49972 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
49976 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
49978 IF(KFQPOP.NE.KFQVER)THEN
49980 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
49981 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
49982 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
49984 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
49986 KFL3=ISIGN(KFDIQ,KFIN)
49988 C..x->M+y: flavour for meson.
49989 130 IF(MBARY.LE.0)THEN
49990 KFLA=MAX(KFQOLD,KFQVER)
49991 KFLB=MIN(KFQOLD,KFQVER)
49993 IF(KFLA.NE.KFQOLD) KFS=-KFS
49994 C... Form meson, with spin and flavour mixing for diagonal states.
49995 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
49996 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
49997 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
50000 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
50001 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
50002 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
50003 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
50004 IF(PYR(0).LT.PARJ(14)) KMUL=2
50005 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
50007 IF(RMUL.LT.PARJ(15)) KMUL=3
50008 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
50009 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
50012 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
50013 IF(KMUL.EQ.5) KFLS=5
50014 IF(KFLA.NE.KFLB)THEN
50015 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
50018 IMIX=2*KFLA+10*KMUL
50019 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
50020 & INT(RMIX+PARF(IMIX)))+KFLS
50021 IF(KFLA.GE.4) KF=110*KFLA+KFLS
50023 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
50024 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
50026 C..Optional extra suppression of eta and eta'.
50027 C..Allow shift to qq->B+q in old version (set IRANK to 0)
50028 IF(KF.EQ.221.OR.KF.EQ.331)THEN
50029 IF(PYR(0).GT.PARJ(25+KF/300))THEN
50030 IF(KF2A.GT.0) GOTO 130
50031 IF(MSTJ(12).LT.4) IRANK=0
50037 C.. x->B+y: Flavour for baryon
50040 IF(KF1A.LE.10) KFLA=KFQOLD
50041 KFLB=MOD(KFDIQ/1000,10)
50042 KFLC=MOD(KFDIQ/100,10)
50043 KFLDS=MOD(KFDIQ,10)
50044 KFLD=MAX(KFLA,KFLB,KFLC)
50045 KFLF=MIN(KFLA,KFLB,KFLC)
50046 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
50048 C... SU(6) factors for formation of baryon.
50052 IF(KFLB.NE.KFLC)THEN
50055 IF(KFLB.GT.2) KDMAX=KDMAX+2
50057 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
50062 SU6MAX=PARF(140+KDMAX)
50065 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
50070 SU6OCT=PARF(60+KBARY)
50071 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
50072 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
50073 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
50075 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
50077 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
50079 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
50080 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
50082 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
50086 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
50089 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
50090 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
50092 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
50094 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
50095 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
50099 C...Use tabulated probabilities to select new flavour and hadron.
50100 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
50103 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
50106 ELSEIF(KTAB2.EQ.0) THEN
50115 DO 150 KT3=KT3L,KT3U
50116 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
50122 DO 170 KT3=KT3L,KT3U
50124 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
50125 IF(RFL.LE.0D0) GOTO 190
50130 C...Reconstruct flavour of produced quark/diquark.
50131 IF(KTAB3.LE.6) THEN
50134 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
50137 IF(KTAB3.GE.8) KFL3A=2
50138 IF(KTAB3.GE.11) KFL3A=3
50139 IF(KTAB3.GE.16) KFL3A=4
50140 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
50141 KFL3=1000*KFL3A+100*KFL3B+1
50142 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
50144 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
50147 C...Reconstruct meson code.
50148 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
50150 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
50151 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
50153 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
50154 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
50155 & 25*KTABS)) KF=330+2*KTABS+1
50156 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
50157 KFLA=MAX(KTAB1,KTAB3)
50158 KFLB=MIN(KTAB1,KTAB3)
50160 IF(KFLA.NE.KF1A) KFS=-KFS
50161 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
50162 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
50164 IF(KFL1A.EQ.KFL3A) THEN
50165 KFLA=MAX(KFL1B,KFL3B)
50166 KFLB=MIN(KFL1B,KFL3B)
50167 IF(KFLA.NE.KFL1B) KFS=-KFS
50168 ELSEIF(KFL1A.EQ.KFL3B) THEN
50172 ELSEIF(KFL1B.EQ.KFL3A) THEN
50175 ELSEIF(KFL1B.EQ.KFL3B) THEN
50176 KFLA=MAX(KFL1A,KFL3A)
50177 KFLB=MIN(KFL1A,KFL3A)
50178 IF(KFLA.NE.KFL1A) KFS=-KFS
50180 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
50183 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
50185 C...Reconstruct baryon code.
50187 IF(KTAB1.GE.7) THEN
50196 KFLD=MAX(KFLA,KFLB,KFLC)
50197 KFLF=MIN(KFLA,KFLB,KFLC)
50198 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
50199 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
50200 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
50203 C...Check that constructed flavour code is an allowed one.
50204 IF(KFL2.NE.0) KFL3=0
50207 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
50215 C*********************************************************************
50218 C...Generates number of popcorn mesons and stores some relevant
50221 SUBROUTINE PYNMES(KFDIQ)
50223 C...Double precision and integer declarations.
50224 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50225 IMPLICIT INTEGER(I-N)
50226 INTEGER PYK,PYCHGE,PYCOMP
50228 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50229 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50230 SAVE /PYDAT1/,/PYDAT2/
50233 IF(MSTJ(12).LT.2) RETURN
50235 C..Old version: Get 1 or 0 popcorn mesons
50236 IF(MSTJ(12).LT.5)THEN
50238 IF(KFDIQ.NE.0) THEN
50240 KFA=MOD(KFDIQA/1000,10)
50241 KFB=MOD(KFDIQA/100,10)
50244 IF(KFA.EQ.3) POPWT=PARF(133)
50245 IF(KFB.EQ.3) POPWT=PARF(134)
50246 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
50248 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
50252 C..New version: Store popcorn- or rank 0 diquark parameters
50255 PARF(194)=PARF(139)
50256 IF(KFDIQ.NE.0) THEN
50259 PARF(194)=PARF(140)
50261 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
50262 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
50263 & '(PYNMES:) Neglecting too large popcorn possibility')
50267 C..New version: Get number of popcorn mesons
50270 110 MSTU(121)=MSTU(121)+1
50271 RTST=RTST/PARF(194)
50272 IF(RTST.LT.1D0) GOTO 110
50273 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
50274 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
50278 C***************************************************************
50281 C...Precalculates a set of diquark and popcorn weights.
50285 C...Double precision and integer declarations.
50286 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50287 IMPLICIT INTEGER(I-N)
50288 INTEGER PYK,PYCHGE,PYCOMP
50290 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50291 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50292 SAVE /PYDAT1/,/PYDAT2/
50294 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
50298 C..Diquark indices for dimensional variables
50307 C.. *** SU(6) factors **
50308 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
50310 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
50311 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
50312 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
50315 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
50317 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
50318 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
50320 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
50321 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
50324 C..SU(6)max q q' s,c,b
50325 SU6MUD =MAX(SU6(1) , SU6(8) )
50326 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
50327 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
50328 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
50329 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
50330 SU6M(IUS0)=SU6M(ISU0)
50331 SU6M(ISS1)=SU6M(IUU1)
50332 SU6M(IUS1)=SU6M(ISU1)
50334 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
50336 PARF(142)=SU6M(IUD1)
50337 PARF(143)=SU6M(ISU0)
50338 PARF(144)=SU6M(ISU1)
50339 PARF(145)=SU6M(ISS1)
50341 C..diquark SU(6) survival =
50342 C..sum over quark (quark tunnel weight)*(SU(6)).
50343 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
50344 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
50345 DMB(IUS0)=DMB(ISU0)
50346 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
50347 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
50348 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
50349 DMB(IUS1)=DMB(ISU1)
50350 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
50352 C.. *** Tunneling factors for Diquark production***
50353 C.. T: half a curtain pair = sqrt(curtain pair factor)
50354 IF(MSTJ(12).GE.5) THEN
50356 PMUD1=PYMASS(2103)-PMUD0
50357 PMUS0=PYMASS(3201)-PMUD0
50358 PMUS1=PYMASS(3203)-PMUS0-PMUD0
50359 PMSS1=PYMASS(3303)-PMUS0-PMUD0
50360 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
50361 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
50362 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
50363 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
50364 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
50365 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
50366 QBB(IUD1)=QBB(IUU1)
50368 PAR2M=SQRT(PARJ(2))
50369 PAR3M=SQRT(PARJ(3))
50370 PAR4M=SQRT(PARJ(4))
50371 QBB(ISU0)=PAR2M*PAR3M
50373 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
50375 QBB(ISU1)=PAR4M*QBB(ISU0)
50376 QBB(IUS1)=PAR4M*QBB(IUS0)
50380 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
50381 QBM(ISU0)=QBB(ISU0)
50382 QBM(IUS0)=PARJ(2)*QBB(IUS0)
50383 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
50384 QBM(IUU1)=6D0*QBB(IUU1)
50385 QBM(ISU1)=3D0*QBB(ISU1)
50386 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
50387 QBM(IUD1)=3D0*QBB(IUD1)
50389 C.. Combine T and tau to diquark weight for q-> B+B+..
50391 QBB(I)=QBB(I)*QBM(I)
50394 IF(MSTJ(12).GE.5)THEN
50395 C..New version: tau for rank 0 diquark.
50396 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
50397 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
50398 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
50399 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
50400 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
50401 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
50402 DMB(7+IUD1)=DMB(7+IUU1)/2D0
50404 C..New version: curtain flavour ratios.
50405 C.. s/u for q->B+M+...
50406 C.. s/u for rank 0 diquark: su -> ...M+B+...
50407 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
50408 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
50409 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
50410 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
50411 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
50412 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
50413 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
50415 C..Old version: reset unused rank 0 diquark weights and
50416 C.. unused diquark SU(6) survival weights
50418 IF(MSTJ(12).LT.3) DMB(I)=1D0
50422 C..Old version: Shuffle PARJ(7) into tau
50423 QBM(IUS0)=QBM(IUS0)*PARJ(7)
50424 QBM(ISS1)=QBM(ISS1)*PARJ(7)
50425 QBM(IUS1)=QBM(IUS1)*PARJ(7)
50427 C..Old version: curtain flavour ratios.
50428 C.. s/u for q->B+M+...
50429 C.. s/u for rank 0 diquark: su -> ...M+B+...
50430 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
50431 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
50432 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
50433 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
50434 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
50437 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
50438 C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
50440 DMB(7+I)=DMB(7+I)*DMB(I)
50441 DMB(I)=DMB(I)*QBM(I)
50442 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
50443 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
50446 C.. *** Popcorn factors ***
50448 IF(MSTJ(12).LT.5)THEN
50449 C.. Old version: Resulting popcorn weights.
50451 WS=PARF(135)*PARF(138)
50453 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
50455 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
50456 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
50457 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
50458 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
50459 & (1D0+QBB(IUD1)+QBB(IUU1)+
50460 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
50462 C..New version: Store weights for popcorn mesons,
50463 C..get prel. popcorn weights.
50464 DO 150 IPOS=201,1400
50473 IF(MR.EQ.7) PARF(193)=PARJ(10)
50474 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
50475 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
50476 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
50478 IF(NMES.EQ.1) SQWT=PARJ(2)
50480 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
50481 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
50482 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
50484 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
50485 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
50488 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
50490 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
50491 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
50497 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
50498 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
50499 IF(PJWT.LE.0D0) GOTO 190
50500 IF(PJWT.GT.1D0) PJWT=1D0
50502 IMIX=2*KFQOLD+10*KMUL
50504 IF(KMUL.EQ.2) KFJ=10003
50505 IF(KMUL.EQ.3) KFJ=10001
50506 IF(KMUL.EQ.4) KFJ=20003
50507 IF(KMUL.EQ.5) KFJ=5
50509 KFLA=MAX(KFQOLD,KFQVER)
50510 KFLB=MIN(KFQOLD,KFQVER)
50511 SWT=PARJ(11+KFLA/3+KFLA/4)
50512 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
50514 QWT=SQWT/(2D0+SQWT)
50515 IF(KFQVER.LT.3)THEN
50516 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
50517 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
50519 IF(KFQVER.NE.KFQOLD)THEN
50521 KFM=100*KFLA+10*KFLB+KFJ
50522 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
50523 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
50524 WTTOT=WTTOT+PARF(IPOS+IMES)
50527 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
50528 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
50529 IF(ID.EQ.5) DWT=PARF(IMIX)
50531 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
50532 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
50533 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
50534 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
50535 PARF(IPOS+5*KMUL+ID)=
50536 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
50538 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
50544 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
50546 IF(MR.EQ.7) PARF(140)=
50547 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
50548 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
50549 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
50555 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
50560 C..Recombine diquark weights to flavour and spin ratios
50561 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
50562 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
50563 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
50564 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
50565 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
50566 PARF(155)=QBB(ISU1)/QBB(ISU0)
50567 PARF(156)=QBB(IUS1)/QBB(IUS0)
50568 PARF(157)=QBB(IUD1)
50570 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
50571 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
50572 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
50573 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
50574 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
50575 PARF(165)=QBM(ISU1)/QBM(ISU0)
50576 PARF(166)=QBM(IUS1)/QBM(IUS0)
50577 PARF(167)=QBM(IUD1)
50579 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
50580 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
50581 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
50582 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
50583 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
50584 PARF(175)=DMB(ISU1)/DMB(ISU0)
50585 PARF(176)=DMB(IUS1)/DMB(IUS0)
50586 PARF(177)=DMB(IUD1)
50588 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
50589 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
50590 PARF(187)=DMB(7+IUD1)
50596 C*********************************************************************
50599 C...Generates transverse momentum according to a Gaussian.
50601 SUBROUTINE PYPTDI(KFL,PX,PY)
50603 C...Double precision and integer declarations.
50604 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50605 IMPLICIT INTEGER(I-N)
50606 INTEGER PYK,PYCHGE,PYCOMP
50608 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50611 C...Generate p_T and azimuthal angle, gives p_x and p_y.
50613 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
50614 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
50615 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
50616 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
50624 C*********************************************************************
50627 C...Generates the longitudinal splitting variable z.
50629 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
50631 C...Double precision and integer declarations.
50632 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50633 IMPLICIT INTEGER(I-N)
50634 INTEGER PYK,PYCHGE,PYCOMP
50636 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50637 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50638 SAVE /PYDAT1/,/PYDAT2/
50640 C...Check if heavy flavour fragmentation.
50644 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
50646 C...Lund symmetric scaling function: determine parameters of shape.
50647 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
50648 &MSTJ(11).GE.4) THEN
50650 IF(MSTJ(91).EQ.1) FA=PARJ(43)
50651 IF(KFLB.GE.10) FA=FA+PARJ(45)
50653 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
50656 IF(KFLA.GE.10) FC=FC-PARJ(45)
50657 IF(KFLB.GE.10) FC=FC+PARJ(45)
50658 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
50660 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
50661 FC=FC+FRED*FBB*PARF(100+KFLH)**2
50664 IF(ABS(FC-1D0).GT.0.01D0) MC=2
50666 C...Determine position of maximum. Special cases for a = 0 or a = c.
50667 IF(FA.LT.0.02D0) THEN
50670 IF(FC.GT.FB) ZMAX=FB/FC
50671 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
50676 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
50677 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
50680 C...Subdivide z range if distribution very peaked near endpoint.
50682 IF(ZMAX.LT.0.1D0) THEN
50688 ZDIVC=ZDIV**(1D0-FC)
50689 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
50691 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
50693 FSCB=SQRT(4D0+(FC/FB)**2)
50694 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
50695 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
50696 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
50697 FINT=1D0+FB*(1D0-ZDIV)
50700 C...Choice of z, preweighted for peaks at low or high z.
50704 IF(FINT*PYR(0).LE.1D0) THEN
50706 ELSEIF(MC.EQ.1) THEN
50710 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
50713 ELSEIF(MMAX.EQ.3) THEN
50714 IF(FINT*PYR(0).LE.1D0) THEN
50716 FPRE=EXP(FB*(Z-ZDIV))
50718 Z=ZDIV+Z*(1D0-ZDIV)
50722 C...Weighting according to correct formula.
50723 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
50724 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
50725 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
50726 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
50727 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
50729 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
50731 FC=PARJ(50+MAX(1,KFLH))
50732 IF(MSTJ(91).EQ.1) FC=PARJ(59)
50734 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
50735 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
50736 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
50737 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
50740 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
50741 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
50748 C*********************************************************************
50751 C...Generates timelike parton showers from given partons.
50753 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
50755 C...Double precision and integer declarations.
50756 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50757 IMPLICIT INTEGER(I-N)
50758 INTEGER PYK,PYCHGE,PYCOMP
50759 C...Parameter statement to help give large particle numbers.
50760 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50761 &KEXCIT=4000000,KDIMEN=5000000)
50763 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50764 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50765 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50766 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
50768 DIMENSION PMTH(5,50),PS(5),PMA(19),PMSD(10),IEP(10),IPA(10),
50769 &KFLA(10),KFLD(10),KFL(10),ITRY(10),ISI(10),ISL(10),DP(10),
50770 &DPT(5,4),KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
50771 &PHIIIS(2,2),ISII(2),ISSET(3),ISCOL(0:40),ISCHG(0:40),
50774 C...Check that QMAX not too low.
50775 IF(MSTJ(41).LE.0) THEN
50777 ELSEIF(MSTJ(41).EQ.1) THEN
50778 IF(QMAX.LE.PARJ(82).AND.IP2.GT.-8) RETURN
50780 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GT.-8)
50784 C...Initialization of cutoff masses etc.
50792 PMTH(1,21)=PYMASS(21)
50793 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
50794 PMTH(3,21)=2D0*PMTH(2,21)
50795 PMTH(4,21)=PMTH(3,21)
50796 PMTH(5,21)=PMTH(3,21)
50797 PMTH(1,22)=PYMASS(22)
50798 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
50799 PMTH(3,22)=2D0*PMTH(2,22)
50800 PMTH(4,22)=PMTH(3,22)
50801 PMTH(5,22)=PMTH(3,22)
50803 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
50804 PMQT1E=MIN(PMQTH1,PARJ(90))
50806 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
50807 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
50810 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
50812 PMTH(1,IFL)=PYMASS(IFL)
50813 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
50814 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
50815 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
50816 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
50819 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
50820 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
50821 PMTH(1,IFL)=PYMASS(IFL)
50822 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
50823 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
50824 PMTH(4,IFL)=PMTH(3,IFL)
50825 PMTH(5,IFL)=PMTH(3,IFL)
50827 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
50829 ALFM=LOG(PT2MIN/ALAMS)
50831 C...Store positions of shower initiating partons.
50833 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
50836 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
50841 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
50842 & .AND.IP2.GE.-7) THEN
50847 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
50855 & '(PYSHOW:) failed to reconstruct showering system')
50856 IF(MSTU(21).GE.1) RETURN
50859 C...Check on phase space available for emission.
50867 KFLA(I)=IABS(K(IPA(I),2))
50869 C...Special cutoff masses for initial partons (may be a heavy quark,
50870 C...squark, ..., and need not be on the mass shell).
50872 IF(NPA.LE.1) IREF(I)=IR
50873 IF(NPA.GE.2) IREF(I+1)=IR
50874 IF(KFLA(I).LE.8) THEN
50876 IF(MSTJ(41).GE.2) ISCHG(IR)=1
50877 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
50878 & KFLA(I).EQ.17) THEN
50879 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
50880 ELSEIF(KFLA(I).EQ.21) THEN
50882 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
50883 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
50885 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
50888 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
50890 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
50891 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
50892 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
50893 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
50894 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
50895 ELSEIF(ISCOL(IR).EQ.1) THEN
50896 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
50897 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
50898 PMTH(4,IR)=PMTH(3,IR)
50899 PMTH(5,IR)=PMTH(3,IR)
50900 ELSEIF(ISCHG(IR).EQ.1) THEN
50901 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
50902 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
50903 PMTH(4,IR)=PMTH(3,IR)
50904 PMTH(5,IR)=PMTH(3,IR)
50906 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
50908 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
50910 PS(J)=PS(J)+P(IPA(I),J)
50913 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
50914 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
50915 IF(NPA.EQ.1) PS(5)=PS(4)
50916 IF(PS(5).LE.PM+PMQT1E) RETURN
50918 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
50921 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
50922 KFSRCE=IABS(K(K(IP1,3),2))
50924 IPAR1=MAX(1,K(IP1,3))
50925 IPAR2=MAX(1,K(IP2,3))
50926 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
50927 & KFSRCE=IABS(K(K(IPAR1,3),2))
50930 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
50931 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
50932 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
50933 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
50934 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
50935 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
50936 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
50937 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
50939 C...Identify two primary showerers.
50941 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
50942 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
50943 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
50944 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
50945 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
50946 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
50947 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
50948 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
50950 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
50951 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
50952 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
50953 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
50954 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
50955 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
50956 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
50957 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
50959 C...Order of showerers. Presence of gluino.
50960 ITYPMN=MIN(ITYPE1,ITYPE2)
50961 ITYPMX=MAX(ITYPE1,ITYPE2)
50963 IF(ITYPE1.GT.ITYPE2) IORD=2
50965 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
50967 C...Check if 3-jet matrix elements to be used.
50970 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
50971 IF(MSTJ(38).NE.0) THEN
50975 ELSEIF(MSTJ(47).GE.6) THEN
50981 C...Vector/axial vector -> q + qbar; q -> q + V.
50982 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
50983 & ITYPES.EQ.3)) THEN
50985 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
50987 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
50988 & K(IP1,2)+K(IP2,2).EQ.0)) THEN
50989 C...gamma*/Z0: assume e+e- initial state if unknown.
50991 IF(KFSRCE.EQ.23) THEN
50992 IANNFL=K(K(IP1,3),3)
50993 IF(IANNFL.NE.0) THEN
50994 KANNFL=IABS(K(IANNFL,2))
50995 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
50998 AI=SIGN(1D0,EI+0.1D0)
50999 VI=AI-4D0*EI*PARU(102)
51000 EF=KCHG(KFLA(1),1)/3D0
51001 AF=SIGN(1D0,EF+0.1D0)
51002 VF=AF-4D0*EF*PARU(102)
51003 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
51006 SQWZ=PS(5)*PMAS(23,2)
51007 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
51008 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
51009 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
51010 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
51012 ALPHA=VECT/(VECT+AXIV)
51013 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
51016 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
51017 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
51019 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
51020 & ITYPES.EQ.1)) THEN
51023 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
51024 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
51026 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
51028 ELSEIF(KFSRCE.EQ.36) THEN
51031 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
51032 & ITYPES.EQ.1)) THEN
51035 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
51036 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
51037 & ITYPES.EQ.3)) THEN
51039 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
51040 & ITYPES.EQ.2)) THEN
51042 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
51044 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
51045 & ITYPES.EQ.2)) THEN
51048 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
51049 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
51050 & ITYPES.EQ.5)) THEN
51052 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
51053 & ITYPES.EQ.2)) THEN
51055 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
51056 & ITYPES.EQ.1)) THEN
51059 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
51060 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
51062 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
51063 & ITYPES.EQ.2)) THEN
51065 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
51066 & ITYPES.EQ.1)) THEN
51069 C...g -> ~g + ~g (eikonal approximation).
51070 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
51073 M3JC=5*ICLASS+ICOMBI
51077 C...Find if interference with initial state partons.
51079 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
51080 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
51081 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
51086 KCA=PYCOMP(KFLA(I))
51087 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
51089 IF(KCII(I).NE.0) THEN
51091 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
51092 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
51093 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
51095 IIIS(I,NIIS(I))=ICSI
51100 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
51103 C...Boost interfering initial partons to rest frame
51104 C...and reconstruct their polar and azimuthal angles.
51108 K(N+I,J)=K(IPA(I),J)
51109 P(N+I,J)=P(IPA(I),J)
51113 DO 220 I=3,2+NIIS(1)
51115 K(N+I,J)=K(IIIS(1,I-2),J)
51116 P(N+I,J)=P(IIIS(1,I-2),J)
51120 DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
51122 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
51123 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
51127 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
51128 & -PS(2)/PS(4),-PS(3)/PS(4))
51129 PHI=PYANGL(P(N+1,1),P(N+1,2))
51130 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
51131 THE=PYANGL(P(N+1,3),P(N+1,1))
51132 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
51133 DO 250 I=3,2+NIIS(1)
51134 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
51135 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
51137 DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
51138 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
51139 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
51140 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
51144 C...Boost 3 or more partons to their rest frame.
51145 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
51146 &-PS(2)/PS(4),-PS(3)/PS(4))
51148 C...Define imagined single initiator of shower for parton system.
51150 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
51151 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
51152 IF(MSTU(21).GE.1) RETURN
51171 C...Loop over partons that may branch.
51174 IF(NPA.EQ.1) IM=NS-1
51177 IF(IM.GT.N) GOTO 590
51180 IF(KSH(IR).EQ.0) GOTO 280
51181 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 280
51186 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
51187 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
51188 IF(MSTU(21).GE.1) RETURN
51191 C...Position of aunt (sister to branching parton).
51192 C...Origin and flavour of daughters.
51195 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
51196 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
51208 K(N+I,2)=K(IPA(I),2)
51210 ELSEIF(KFLM.NE.21) THEN
51213 IREF(N+1-NS)=IREF(IM-NS)
51214 IREF(N+2-NS)=IABS(K(N+2,2))
51215 ELSEIF(K(IM,5).EQ.21) THEN
51223 IREF(N+1-NS)=IABS(K(N+1,2))
51224 IREF(N+2-NS)=IABS(K(N+2,2))
51227 C...Reset flags on daughters and tries made.
51232 KFLD(IP)=IABS(K(N+IP,2))
51233 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
51237 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
51241 C...Maximum virtuality of daughters.
51244 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
51245 P(N+I,5)=MIN(QMAX,PS(5))
51247 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
51248 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
51251 IF(MSTJ(43).LE.2) PEM=V(IM,2)
51252 IF(MSTJ(43).GE.3) PEM=P(IM,4)
51253 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
51254 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
51255 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
51259 IF(ISI(I).EQ.1) THEN
51261 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
51263 V(N+I,5)=P(N+I,5)**2
51266 C...Choose one of the daughters for evolution.
51268 IF(NEP.EQ.1) INUM=1
51270 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
51273 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
51275 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
51281 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
51282 RPM=P(N+I,5)/PMSD(I)
51284 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
51292 C...Cancel choice of predetermined daughter already treated.
51295 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
51296 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
51297 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
51298 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
51299 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
51302 C...Store information on choice of evolving daughter.
51306 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
51309 KFL(I)=IABS(K(IEP(I),2))
51311 ITRY(INUM)=ITRY(INUM)+1
51312 IF(ITRY(INUM).GT.200) THEN
51313 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
51314 IF(MSTU(21).GE.1) RETURN
51318 IF(KSH(IR).EQ.0) GOTO 440
51319 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 440
51321 C...Check if evolution already predetermined for daughter.
51323 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
51324 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
51325 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
51326 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
51327 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
51330 IF(IPSPD.NE.0) ISSET(INUM)=1
51332 C...Select side for interference with initial state partons.
51333 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
51336 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
51338 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
51339 IF(PYR(0).GT.0.5D0) ISII(III)=1
51340 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
51342 IF(PYR(0).GT.0.5D0) ISII(III)=2
51346 C...Calculate allowed z range.
51349 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
51352 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
51353 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
51355 IF(MOD(MSTJ(43),2).EQ.1) THEN
51357 ZCE=PMTH(2,22)/PMED
51358 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
51360 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
51361 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
51363 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
51364 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
51365 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
51368 ZCE=MIN(ZCE,0.49991D0)
51369 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
51370 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
51371 P(IEP(1),5)=PMTH(1,IR)
51372 V(IEP(1),5)=P(IEP(1),5)**2
51376 C...Integral of Altarelli-Parisi z kernel for QCD.
51377 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
51378 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
51379 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
51380 ELSEIF(MSTJ(49).EQ.0) THEN
51381 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
51382 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
51384 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
51385 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
51386 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
51387 ELSEIF(MSTJ(49).EQ.1) THEN
51388 FBR=(1D0-2D0*ZC)/3D0
51389 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
51391 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
51392 ELSEIF(KFL(1).EQ.21) THEN
51393 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
51395 FBR=2D0*LOG((1D0-ZC)/ZC)
51398 C...Reset QCD probability for colourless.
51399 IF(ISCOL(IR).EQ.0) FBR=0D0
51401 C...Integral of Altarelli-Parisi kernel for photon emission.
51403 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
51404 IF(KFL(1).LE.18) THEN
51405 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
51407 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
51410 C...Inner veto algorithm starts. Find maximum mass for evolution.
51411 400 PMS=V(IEP(1),5)
51416 IRI=IREF(IEP(I)-NS)
51417 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
51420 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
51423 C...Select mass for daughter in QCD evolution.
51425 DO 420 IFF=4,MSTJ(45)
51426 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
51428 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
51429 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
51430 C...Already predetermined choice.
51431 IF(IPSPD.NE.0) THEN
51432 PMSQCD=P(IPSPD,5)**2
51433 ELSEIF(FBR.LT.1D-3) THEN
51435 ELSEIF(MSTJ(44).LE.0) THEN
51436 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
51437 ELSEIF(MSTJ(44).EQ.1) THEN
51438 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
51440 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
51442 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
51443 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
51444 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
51448 C...Select mass for daughter in QED evolution.
51449 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
51450 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
51451 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
51452 IF(FBRE.LT.1D-3) THEN
51455 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
51456 & (PARU(101)*FBRE)))
51458 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
51459 PMSQED=PMSQED+PMTH(1,IR)**2
51460 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
51462 IF(PMSQED.GT.PMSQCD) THEN
51468 C...Check whether daughter mass below cutoff.
51469 P(IEP(1),5)=SQRT(V(IEP(1),5))
51470 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
51471 P(IEP(1),5)=PMTH(1,IR)
51472 V(IEP(1),5)=P(IEP(1),5)**2
51476 C...Already predetermined choice of z, and flavour in g -> qqbar.
51477 IF(IPSPD.NE.0) THEN
51480 PMSGD1=P(IPSGD1,5)**2
51481 PMSGD2=P(IPSGD2,5)**2
51482 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
51483 & 4D0*PMSGD1*PMSGD2))
51484 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
51485 & PMSGD1+PMSGD2)/ALAMPS
51486 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
51487 IF(KFL(1).NE.21) THEN
51490 K(IEP(1),5)=IABS(K(IPSGD1,2))
51493 C...Select z value of branching: q -> qgamma.
51494 ELSEIF(MCE.EQ.2) THEN
51495 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
51496 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 400
51499 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
51500 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
51501 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
51502 C...Only do z weighting when no ME correction afterwards.
51503 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 400
51505 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
51506 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
51507 IF(PYR(0).GT.0.5D0) Z=1D0-Z
51508 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 400
51510 ELSEIF(MSTJ(49).NE.1) THEN
51512 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 400
51513 KFLB=1+INT(MSTJ(45)*PYR(0))
51514 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
51515 IF(PMQ.GE.1D0) GOTO 400
51516 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
51517 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 400
51518 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
51519 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
51520 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 400
51522 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 400
51526 C...Ditto for scalar gluon model.
51527 ELSEIF(KFL(1).NE.21) THEN
51528 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
51530 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
51531 Z=ZC+(1D0-2D0*ZC)*PYR(0)
51534 Z=ZC+(1D0-2D0*ZC)*PYR(0)
51535 KFLB=1+INT(MSTJ(45)*PYR(0))
51536 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
51537 IF(PMQ.GE.1D0) GOTO 400
51541 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
51542 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
51543 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
51544 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51545 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 400
51547 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
51548 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
51549 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
51550 IF(PT2APP.LT.PT2MIN) GOTO 400
51551 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 400
51555 C...Check if z consistent with chosen m.
51556 IF(KFL(1).EQ.21) THEN
51557 IRGD1=IABS(K(IEP(1),5))
51561 IRGD2=IABS(K(IEP(1),5))
51565 ELSEIF(NEP.GE.3) THEN
51567 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
51568 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
51570 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
51571 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
51573 IF(MOD(MSTJ(43),2).EQ.1) THEN
51574 PMQTH3=0.5D0*PARJ(82)
51575 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
51576 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
51577 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
51578 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
51579 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
51583 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
51586 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
51587 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51588 ELSEIF(IPSPD.NE.0) THEN
51592 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 400
51594 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
51596 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
51598 C...Width suppression for q -> q + g.
51599 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
51601 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
51605 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
51606 IF(MSTJ(40).EQ.1) THEN
51607 IF(CHI.LT.PYR(0)) GOTO 400
51608 ELSEIF(MSTJ(40).EQ.2) THEN
51609 IF(1D0-CHI.LT.PYR(0)) GOTO 400
51613 C...Three-jet matrix element correction.
51618 C...QED matrix elements: only for massless case so far.
51619 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
51620 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
51621 X2=1D0-V(IEP(1),5)/V(NS+1,5)
51622 X3=(1D0-X1)+(1D0-X2)
51624 KI2=K(IPA(3-INUM),2)
51625 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
51626 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
51627 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
51628 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
51629 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
51630 ELSEIF(MCE.EQ.2) THEN
51632 C...QCD matrix elements, including mass effects.
51633 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
51637 IF(IR.GE.31.AND.IGM.EQ.0) THEN
51638 C...QCD ME: original parton, first branching.
51639 PM2ME=PMTH(1,63-IR)
51641 ELSEIF(IR.GE.31) THEN
51642 C...QCD ME: original parton, subsequent branchings.
51643 PM2ME=PMTH(1,63-IR)
51644 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
51645 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
51646 ELSEIF(K(IM,2).EQ.21) THEN
51647 C...QCD ME: secondary partons, first branching.
51650 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
51651 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
51652 & 4D0*PS1ME*PM2ME**2))
51653 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
51655 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
51658 C...QCD ME: secondary partons, subsequent branchings.
51660 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
51661 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
51664 C...Construct ME variables.
51667 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
51668 X2=1D0+R2ME**2-PS1ME/ECMME**2
51669 C...Call ME, with right order important for two inequivalent showerers.
51670 IF(IR.EQ.IORD+30) THEN
51671 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
51673 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
51675 C...Split up total ME when two radiating partons.
51677 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
51678 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
51679 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
51680 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
51681 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
51682 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
51683 & MAX(1D-10,2D0-X1-X2)
51684 C...Evaluate shower rate to be compared with.
51685 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
51686 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
51687 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
51688 ELSEIF(MSTJ(49).NE.1) THEN
51690 C...Toy model scalar theory matrix elements; no mass effects.
51692 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
51693 X2=1D0-V(IEP(1),5)/V(NS+1,5)
51694 X3=(1D0-X1)+(1D0-X2)
51695 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
51697 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
51701 IF(WME.LT.PYR(0)*WSHOW) GOTO 400
51704 C...Impose angular ordering by rejection of nonordered emission.
51705 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
51706 PEMAO=V(IM,1)*P(IM,4)
51707 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
51708 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
51710 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
51711 & .OR.MSTJ(42).EQ.7)) THEN
51713 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
51714 & .OR.MSTJ(42).EQ.6)) THEN
51716 PMDAO=PMTH(2,K(IEP(1),5))
51717 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
51720 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
51721 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
51722 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
51726 430 IF(K(IAOM,5).EQ.22) THEN
51728 IF(K(IAOM,3).LE.NS) MAOM=0
51729 IF(MAOM.EQ.1) GOTO 430
51731 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
51732 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
51733 IF(THE2ID.LT.THE2IM) GOTO 400
51737 C...Impose user-defined maximum angle at first branching.
51738 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
51739 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
51740 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
51741 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400
51742 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
51743 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
51744 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400
51745 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
51746 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
51747 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 400
51751 C...Impose angular constraint in first branching from interference
51752 C...with initial state partons.
51753 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
51754 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
51755 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
51756 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 400
51757 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
51758 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 400
51762 C...End of inner veto algorithm. Check if only one leg evolved so far.
51766 IF(NEP.EQ.1) GOTO 480
51767 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 340
51770 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
51771 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 340
51775 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
51779 PMSUM=PMSUM+P(N+I,5)
51781 IF(PMSUM.GE.PS(5)) GOTO 340
51782 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
51785 IF(KSH(IRDA).EQ.0) GOTO 470
51786 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 470
51787 IF(IRDA.EQ.21) THEN
51788 IRGD1=IABS(K(I1,5))
51792 IRGD2=IABS(K(I1,5))
51795 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
51796 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
51798 IF(I1.EQ.N+1) ZM=V(IM,1)
51799 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
51800 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
51801 & 4D0*V(N+1,5)*V(N+2,5))
51802 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
51805 IF(MOD(MSTJ(43),2).EQ.1) THEN
51806 PMQTH3=0.5D0*PARJ(82)
51807 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
51808 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
51809 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
51810 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
51811 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
51815 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
51818 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
51819 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51823 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
51824 & ISSET(1).EQ.0) THEN
51826 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
51827 & ISSET(2).EQ.0) THEN
51831 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
51833 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
51835 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
51838 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
51839 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
51840 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
51841 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
51842 IF(ISL(1).EQ.1) ISL(2)=0
51843 IF(ISL(1).EQ.0) ISLM=1
51844 IF(ISL(2).EQ.0) ISLM=2
51846 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 340
51851 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
51852 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
51853 PMQ1=V(N+1,5)/V(IM,5)
51854 PMQ2=V(N+2,5)/V(IM,5)
51855 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
51860 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 340
51864 C...Accepted branch. Construct four-momentum for initial partons.
51870 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
51872 P(N+1,4)=P(IPA(1),4)
51874 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
51875 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
51878 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
51883 P(N+2,4)=P(IM,5)-PED1
51886 ELSEIF(NEP.GE.3) THEN
51887 C...Rescale all momenta for energy conservation.
51893 P(N+I,J)=P(IPA(I),J)
51896 PQS=PQS+P(N+I,5)**2/P(N+I,4)
51899 FAC=(PS(5)-PQS)/(PES-PQS)
51904 P(N+I,J)=FAC*P(N+I,J)
51906 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)
51909 PQS=PQS+P(N+I,5)**2/P(N+I,4)
51911 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 510
51913 C...Construct transverse momentum for ordinary branching in shower.
51917 540 LOOPPT=LOOPPT+1
51918 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
51919 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
51920 IF(PZM.LE.0D0) THEN
51922 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
51923 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51924 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
51925 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
51926 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
51927 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
51929 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
51931 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
51934 ELSEIF(PTS.LT.0D0) THEN
51937 PT=SQRT(MAX(0D0,PTS))
51939 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
51941 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
51942 & .AND.IAU.NE.0) THEN
51943 IF(K(IGM,3).NE.0) MAZIP=1
51945 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
51946 IF(MAZIP.EQ.0) ZAU=0D0
51947 IF(K(IGM,2).NE.21) THEN
51948 HAZIP=2D0*ZAU/(1D0+ZAU**2)
51950 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
51952 IF(K(N+1,2).NE.21) THEN
51953 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
51955 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
51959 C...Find coefficient of azimuthal asymmetry due to soft gluon
51962 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
51963 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
51964 IF(K(IGM,3).NE.0) MAZIC=N+1
51965 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
51966 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
51967 & ZM.GT.0.5D0) MAZIC=N+2
51968 IF(K(IAU,2).EQ.22) MAZIC=0
51970 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
51972 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
51973 IF(MAZIC.EQ.0) ZGM=1D0
51974 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
51975 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
51976 HAZIC=MIN(0.95D0,HAZIC)
51980 C...Construct energies for ordinary branching in shower.
51981 550 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
51982 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
51983 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51984 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
51985 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
51986 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
51987 P(N+1,4)=PEM*V(IM,1)
51989 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
51990 & SQRT(PMLS)*ZM)/V(IM,5)
51993 C...Already predetermined choice of phi angle or not
51995 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
51997 IF(K(IPSPD,4).GT.0) THEN
51999 IF(IM.EQ.NS+2) THEN
52000 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
52002 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
52005 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
52007 IF(K(IPSPD,4).GT.0) THEN
52009 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
52010 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
52011 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
52012 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
52013 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
52014 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
52018 C...Construct momenta for ordinary branching in shower.
52019 P(N+1,1)=PT*COS(PHI)
52020 P(N+1,2)=PT*SIN(PHI)
52021 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
52022 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
52023 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
52024 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
52025 ELSEIF(PZM.GT.0D0) THEN
52026 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
52027 & 2D0*PEM*P(N+1,4))/PZM
52033 P(N+2,3)=PZM-P(N+1,3)
52034 P(N+2,4)=PEM-P(N+1,4)
52035 IF(MSTJ(43).LE.2) THEN
52036 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
52037 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
52041 C...Rotate and boost daughters.
52043 IF(MSTJ(43).LE.2) THEN
52044 BEX=P(IGM,1)/P(IGM,4)
52045 BEY=P(IGM,2)/P(IGM,4)
52046 BEZ=P(IGM,3)/P(IGM,4)
52047 GA=P(IGM,4)/P(IGM,5)
52048 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
52057 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
52058 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
52059 IF(PTIMB.GT.1D-4) THEN
52060 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
52065 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
52066 & SIN(THE)*COS(PHI)*P(I,3)
52067 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
52068 & SIN(THE)*SIN(PHI)*P(I,3)
52069 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
52071 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
52072 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
52073 P(I,1)=DP(1)+DGABP*BEX
52074 P(I,2)=DP(2)+DGABP*BEY
52075 P(I,3)=DP(3)+DGABP*BEZ
52076 P(I,4)=GA*(DP(4)+DBP)
52080 C...Weight with azimuthal distribution, if required.
52081 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
52087 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
52088 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
52089 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
52091 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
52092 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
52094 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
52095 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
52096 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
52097 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
52098 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
52099 IF(MAZIP.NE.0) THEN
52100 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
52103 IF(MAZIC.NE.0) THEN
52104 IF(MAZIC.EQ.N+2) CAD=-CAD
52105 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
52106 & .LT.PYR(0)) GOTO 550
52111 C...Azimuthal anisotropy due to interference with initial state partons.
52112 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
52113 &K(N+2,2).EQ.21)) THEN
52115 IF(ISII(III).GE.1) THEN
52117 IF(K(N+1,2).NE.21) IAZIID=N+2
52118 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
52119 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
52120 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
52121 IF(III.EQ.2) THEIID=PARU(1)-THEIID
52122 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
52123 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
52124 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
52125 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
52126 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
52127 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
52128 & .LT.PYR(0)) GOTO 550
52132 C...Continue loop over partons that may branch, until none left.
52133 IF(IGM.GE.0) K(IM,1)=14
52136 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
52137 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
52138 IF(MSTU(21).GE.1) N=NS
52139 IF(MSTU(21).GE.1) RETURN
52143 C...Set information on imagined shower initiator.
52144 590 IF(NPA.GE.2) THEN
52148 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
52156 C...Reconstruct string drawing information.
52157 DO 600 I=NS+1+IIM,N
52158 KQ=KCHG(PYCOMP(K(I,2)),2)
52159 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
52161 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
52162 & IABS(K(I,2)).LE.18) THEN
52164 ELSEIF(K(I,1).LE.10) THEN
52165 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
52166 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
52167 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
52168 ID1=MOD(K(I,4),MSTU(5))
52169 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
52170 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
52171 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
52172 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
52173 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
52174 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
52175 K(ID1,4)=K(ID1,4)+MSTU(5)*I
52176 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
52177 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
52178 K(ID2,5)=K(ID2,5)+MSTU(5)*I
52180 ID1=MOD(K(I,4),MSTU(5))
52182 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
52183 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
52184 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
52185 K(ID1,4)=K(ID1,4)+MSTU(5)*I
52186 K(ID1,5)=K(ID1,5)+MSTU(5)*I
52196 C...Transformation from CM frame.
52198 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
52199 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
52201 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
52202 ELSEIF(NPA.EQ.2) THEN
52207 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
52208 & /(1D0+GA)-P(IPA(1),4))
52209 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
52210 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
52211 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
52213 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
52215 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
52218 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
52221 C...Decay vertex of shower.
52228 C...Delete trivial shower, else connect initiators.
52229 IF(N.LE.NS+NPA+IIM) THEN
52234 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
52235 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
52236 K(NS+IIM+IP,3)=IPA(IP)
52237 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
52238 IF(K(NS+IIM+IP,1).NE.1) THEN
52239 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
52240 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
52248 C*********************************************************************
52251 C...Auxiliary to PYSHOW.
52252 C...Matrix elements for gluon (or photon) emission from
52253 C...a two-body state; to be used by the parton shower routine.
52254 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
52255 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
52256 C... = (alpha-strong/2 pi) * CF * PYMAEL,
52257 C...i.e. normalization is such that one recovers the familiar
52258 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
52259 C...Coupling structure:
52260 C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
52261 C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
52262 C... = 16-19 : q -> q V
52263 C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
52264 C... = 26-29 : q -> q S
52265 C... = 31-34 : V -> ~q ~qbar (~q = squark)
52266 C... = 36-39 : ~q -> ~q V
52267 C... = 41-44 : S -> ~q ~qbar
52268 C... = 46-49 : ~q -> ~q S
52269 C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
52270 C... = 56-59 : ~q -> q chi
52271 C... = 61-64 : q -> ~q chi
52272 C... = 66-69 : ~g -> q ~qbar
52273 C... = 71-74 : ~q -> q ~g
52274 C... = 76-79 : q -> ~q ~g
52275 C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
52276 C...Note that the order of the decay products is important.
52277 C...In each set of four, the variants are ordered as:
52278 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
52279 C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
52280 C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
52281 C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
52283 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
52285 C...Double precision and integer declarations.
52286 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52287 IMPLICIT INTEGER(I-N)
52289 C...Check input values. Return zero outside allowed phase space.
52291 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
52292 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
52293 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
52294 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
52295 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
52296 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
52298 C...Initial values and flags.
52306 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
52308 C...Eikonal expression; also acts as default.
52309 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
52311 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
52313 ELSEIF(ICOMBI.EQ.2) THEN
52314 ANUM=(2D0-X1-X2)**2
52315 ELSEIF(ICOMBI.EQ.3) THEN
52316 ANUM=ALPCOR*(2D0-X1-X2)**2
52318 ANUM=0.5D0*(2D0-X1-X2)**2
52320 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
52321 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
52322 & R1**2/(1D0+R2**2-R1**2-X2)**2-
52323 & R2**2/(1D0+R1**2-R2**2-X1)**2)
52326 C...V -> q qbar (V = gamma*/Z0/W+-/...).
52327 ELSEIF(ICLASS.EQ.2) THEN
52328 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52329 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
52330 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
52331 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
52332 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
52333 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
52334 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
52335 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
52336 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
52337 & (-1+R1**2-R2**2+X2)**2
52338 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
52339 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
52340 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
52341 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
52342 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
52343 & -X1-X2)**2+X1*(2-X1-X2)**2)/
52344 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52345 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
52346 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
52347 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
52348 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
52349 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
52353 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52354 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
52355 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
52356 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
52357 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
52358 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
52359 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
52360 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
52361 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
52362 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
52363 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
52364 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
52365 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
52366 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
52367 & -X1-X2)**2+X1*(2-X1-X2)**2)/
52368 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52369 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
52370 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
52371 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
52372 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
52373 & +X2)/(-1-R1**2+R2**2+X1)**2
52377 IF(ICOMBI.EQ.4) THEN
52378 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
52379 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
52380 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
52381 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
52382 & (-1-R1**2+R2**2+X1)**2
52384 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
52385 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
52386 & -R1**2*X2**2+X1*X2**2)/
52387 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52388 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
52389 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
52390 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
52391 & (-1+R1**2-R2**2+X2)**2
52397 ELSEIF(ICLASS.EQ.3) THEN
52398 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52399 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
52400 & +R1**2*R2**2-2D0*R2**4)
52401 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
52402 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
52403 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
52404 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
52405 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
52406 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
52407 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
52408 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
52409 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
52410 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
52411 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
52412 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
52413 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
52414 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
52415 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
52416 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
52417 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
52418 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
52419 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
52422 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52423 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
52424 & +R1**2*R2**2-2D0*R2**4)
52425 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
52426 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
52427 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
52428 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
52429 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
52430 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
52431 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52432 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
52433 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
52434 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
52435 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
52436 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
52437 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
52438 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
52439 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
52440 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
52441 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
52442 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
52443 & +X1*X2**2)/(-2+X1+X2)**2
52446 IF(ICOMBI.EQ.4) THEN
52447 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
52448 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
52449 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
52450 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
52451 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
52452 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52453 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
52454 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
52455 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
52456 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
52457 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
52458 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
52459 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
52460 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
52461 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
52462 & +X1*X2**2)/(2-X1-X2)**2
52466 C...S -> q qbar (S = h0/H0/A0/H+-/...).
52467 ELSEIF(ICLASS.EQ.4) THEN
52468 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52469 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
52470 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52471 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52472 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52473 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
52474 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
52475 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52476 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52477 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
52478 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52481 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52482 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
52483 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52484 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52485 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52486 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52487 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
52488 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52489 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
52490 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
52491 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
52492 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52495 IF(ICOMBI.EQ.4) THEN
52496 RLO4=PS*(1D0-R1**2-R2**2)
52497 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
52498 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52499 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
52500 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
52501 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52502 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
52503 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52508 ELSEIF(ICLASS.EQ.5) THEN
52509 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52510 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
52511 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
52512 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
52513 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
52514 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52515 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
52516 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
52517 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52518 & (-1+R1**2-R2**2+X2)**2
52521 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52522 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
52523 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
52524 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
52525 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
52526 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52527 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
52528 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
52529 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52530 & (-1+R1**2-R2**2+X2)**2
52533 IF(ICOMBI.EQ.4) THEN
52534 RLO4=PS*(1D0+R1**2-R2**2)
52535 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
52536 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
52537 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
52538 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
52539 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
52540 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
52544 C...V -> ~q ~qbar (~q = squark).
52545 ELSEIF(ICLASS.EQ.6) THEN
52546 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
52547 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
52548 & (-1-R1**2+R2**2+X1)**2
52549 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
52550 & (-1-R1**2+R2**2+X1)
52551 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
52552 & /(-1+R1**2-R2**2+X2)**2
52553 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
52554 & (-1+R1**2-R2**2+X2)
52555 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
52556 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
52557 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
52558 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52562 ELSEIF(ICLASS.EQ.7) THEN
52563 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
52564 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
52565 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
52566 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
52567 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
52568 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
52569 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
52570 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
52571 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
52572 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
52573 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
52579 ELSEIF(ICLASS.EQ.8) THEN
52581 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
52582 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
52583 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
52584 & -R1**2*X2**2+X1*X2**2)/
52585 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
52590 ELSEIF(ICLASS.EQ.9) THEN
52592 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
52593 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52594 & -(X1+X2)/(-2+X1+X2)**2
52597 C...chi -> q ~qbar (chi = neutralino/chargino).
52598 ELSEIF(ICLASS.EQ.10) THEN
52599 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52600 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
52601 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
52602 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
52603 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
52604 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52605 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
52606 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52607 & (-1+R1**2-R2**2+X2)**2
52610 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52611 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
52612 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
52613 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
52614 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
52615 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52616 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
52617 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52618 & (-1+R1**2-R2**2+X2)**2
52621 IF(ICOMBI.EQ.4) THEN
52622 RLO4=PS*(1+R1**2-R2**2)
52623 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
52624 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
52625 & +X2+R1**2*X2-X1*X2/2)/
52626 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52627 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
52628 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
52633 ELSEIF(ICLASS.EQ.11) THEN
52634 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52635 RLO1=PS*(1D0-(R1+R2)**2)
52636 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
52637 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52638 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
52639 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52640 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
52641 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
52642 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52645 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52646 RLO2=PS*(1D0-(R1-R2)**2)
52647 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
52649 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52650 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
52651 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52652 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
52653 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
52654 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52657 IF(ICOMBI.EQ.4) THEN
52658 RLO4=PS*(1D0-R1**2-R2**2)
52659 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
52660 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
52661 & +3*R1**2*X2-R2**2*X2-X1*X2)/
52662 & (-1+R1**2-R2**2+X2)**2
52663 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
52664 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
52665 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52670 ELSEIF(ICLASS.EQ.12) THEN
52671 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52672 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
52673 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
52674 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
52675 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
52676 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
52677 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
52678 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52681 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52682 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
52683 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
52684 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
52685 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
52686 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
52687 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
52688 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52691 IF(ICOMBI.EQ.4) THEN
52692 RLO4=PS*(1D0-R1**2+R2**2)
52693 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
52694 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
52695 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
52696 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
52697 & +R1**2*X2-X1*X2/2-X2**2/2)/
52698 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52703 ELSEIF(ICLASS.EQ.13) THEN
52704 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52705 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
52706 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
52707 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
52708 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
52709 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
52710 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
52711 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
52712 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
52713 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
52714 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
52715 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
52716 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
52717 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52718 & (3*(-1+R1**2-R2**2+X2)**2)
52722 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52723 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
52724 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
52725 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
52726 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
52727 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
52728 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
52729 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
52730 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
52731 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
52732 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
52733 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52734 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
52735 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
52736 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52737 & (3*(-1+R1**2-R2**2+X2)**2)
52741 IF(ICOMBI.EQ.4) THEN
52742 RLO4=PS*(1D0+R1**2-R2**2)
52743 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
52744 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
52745 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
52746 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
52747 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
52748 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52749 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
52750 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52751 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
52752 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52753 & (3*(-1+R1**2-R2**2+X2)**2)
52759 ELSEIF(ICLASS.EQ.14) THEN
52760 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52761 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
52762 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
52763 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52764 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52765 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
52766 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
52767 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
52768 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
52769 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52770 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
52771 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
52772 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
52773 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
52774 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
52776 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
52777 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
52778 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52782 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52783 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
52784 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
52785 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52786 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52787 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
52788 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
52789 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
52790 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
52791 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
52792 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
52793 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
52795 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
52796 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
52797 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
52798 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
52799 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
52800 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52804 IF(ICOMBI.EQ.4) THEN
52805 RLO4=PS*(1-R1**2-R2**2)
52806 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
52807 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
52808 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52809 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
52810 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
52811 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
52812 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
52813 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
52814 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
52815 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
52816 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
52817 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
52818 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
52819 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
52820 RFO4=9D0*RFO4/128D0
52825 ELSEIF(ICLASS.EQ.15) THEN
52826 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52827 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
52828 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
52829 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
52830 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
52831 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
52832 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
52833 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
52834 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
52835 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
52836 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
52837 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
52838 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
52839 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
52840 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
52841 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52845 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52846 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
52847 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
52848 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
52849 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
52850 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
52851 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
52852 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
52853 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
52854 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
52855 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
52856 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
52857 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
52858 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
52859 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
52860 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52864 IF(ICOMBI.EQ.4) THEN
52865 RLO4=PS*(1D0-R1**2+R2**2)
52866 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
52867 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
52868 & -R2**2*X2/2-X1*X2/2)/
52869 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
52870 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
52871 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
52872 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
52873 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
52874 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
52875 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
52876 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
52877 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52882 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
52883 ELSEIF(ICLASS.EQ.16) THEN
52885 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
52887 ELSEIF(ICOMBI.EQ.2) THEN
52888 ANUM=(2D0-X1-X2)**2
52889 ELSEIF(ICOMBI.EQ.3) THEN
52890 ANUM=ALPCOR*(2D0-X1-X2)**2
52892 ANUM=0.5D0*(2D0-X1-X2)**2
52894 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
52895 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
52896 & R1**2/(1D0+R2**2-R1**2-X2)**2-
52897 & R2**2/(1D0+R1**2-R2**2-X1)**2)
52902 C...Find relevant LO and FO expression.
52903 IF(ICOMBI.EQ.0) THEN
52904 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
52907 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
52910 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
52911 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
52912 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
52913 ELSEIF(ISSET4.EQ.1) THEN
52916 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
52917 RLO=0.5D0*(RLO1+RLO2)
52918 RFO=0.5D0*(RFO1+RFO2)
52919 ELSEIF(ISSET1.EQ.1) THEN
52923 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
52934 C*********************************************************************
52937 C...Modifies an event so as to approximately take into account
52938 C...Bose-Einstein effects according to a simple phenomenological
52939 C...parametrization.
52941 SUBROUTINE PYBOEI(NSAV)
52943 C...Double precision and integer declarations.
52944 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52945 IMPLICIT INTEGER(I-N)
52946 INTEGER PYK,PYCHGE,PYCOMP
52947 C...Parameter statement to help give large particle numbers.
52948 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52949 &KEXCIT=4000000,KDIMEN=5000000)
52951 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52952 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52953 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52954 COMMON/PYINT1/MINT(400),VINT(400)
52955 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
52956 C...Local arrays and data.
52957 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
52958 &BEIW(100),BEI3W(100)
52959 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
52960 C...Statement function: squared invariant mass.
52961 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
52962 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
52964 C...Boost event to overall CM frame. Calculate CM energy.
52965 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
52971 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
52972 & .AND.K(I,3).GT.0) THEN
52973 KFMA=IABS(K(K(I,3),2))
52974 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
52976 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
52978 DPS(J)=DPS(J)+P(I,J)
52981 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
52985 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
52988 C...Check if we have separated strings
52990 C...Reserve copy of particles by species at end of record.
52996 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
52997 NBE(IBE)=NBE(IBE-1)
52999 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
53000 DO 140 IIBE=1,IBE-1
53001 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
53004 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
53006 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
53007 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
53008 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
53011 NBE(IBE)=NBE(IBE)+1
53018 P(NBE(IBE),1)=0.0D0
53019 P(NBE(IBE),2)=0.0D0
53020 P(NBE(IBE),3)=0.0D0
53021 P(NBE(IBE),4)=0.0D0
53022 P(NBE(IBE),5)=0.0D0
53023 SMMIN=MIN(SMMIN,P(I,5))
53024 C...Check if particles comes from different W's or Z's
53025 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
53027 150 IF(K(IM,3).GT.0) THEN
53029 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
53031 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
53032 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
53033 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
53034 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
53037 C...Check if particles comes from different strings.
53038 IF(PARJ(94).GT.0.0D0) THEN
53040 160 IF(K(IM,3).GT.0) THEN
53042 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
53050 P(NBE(IBE),5)=-1.0D0
53053 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
53055 C...Calculate separation between W+ and W- or between two Z0's.
53056 C...No separation if there has been re-connections.
53058 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
53059 IF(K(IWP,2).EQ.23) THEN
53068 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
53069 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
53070 TAUP=-TAUPD*LOG(PYR(IDUM))
53071 TAUN=-TAUND*LOG(PYR(IDUM))
53072 DXP=TAUP*PYP(IWP,8)/DMP
53073 DXN=TAUN*PYP(IWN,8)/DMN
53075 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
53076 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
53079 C...Add separation between strings.
53080 IF(PARJ(94).GT.0.0D0) THEN
53081 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
53086 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
53087 DO 220 IBE=1,MIN(9,MSTJ(52))
53088 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
53091 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
53092 IF(I2M.EQ.I1M) GOTO 200
53094 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
53095 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
53096 & (P(I1,5)+P(I2,5))**2
53097 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
53106 C...Tabulate integral for subsequent momentum shift.
53107 DO 400 IBE=1,MIN(9,MSTJ(52))
53108 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
53109 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
53111 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
53112 & NBE(7)-NBE(6)).LE.1) GOTO 270
53113 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
53114 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
53115 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
53116 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
53117 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
53118 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
53119 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
53120 QDELW=0.1D0*MIN(PMHQ,SIGW)
53121 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
53122 IF(MSTJ(51).EQ.1) THEN
53123 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
53124 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
53125 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
53126 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
53127 BEEX=EXP(0.5D0*QDEL/PARJ(93))
53128 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
53129 BEEXW=EXP(0.5D0*QDELW/SIGW)
53130 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
53131 BERT=EXP(-QDEL/PARJ(93))
53132 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
53133 BERTW=EXP(-QDELW/SIGW)
53134 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
53136 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
53137 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
53138 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
53139 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
53142 QBIN=QDEL*(IBIN-0.5D0)
53143 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
53144 IF(MSTJ(51).EQ.1) THEN
53146 BEI(IBIN)=BEI(IBIN)*BEEX
53148 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
53150 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
53152 DO 240 IBIN=1,NBIN3
53153 QBIN=QDEL3*(IBIN-0.5D0)
53154 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
53155 IF(MSTJ(51).EQ.1) THEN
53157 BEI3(IBIN)=BEI3(IBIN)*BEEX3
53159 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
53161 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
53163 DO 250 IBIN=1,NBINW
53164 QBIN=QDELW*(IBIN-0.5D0)
53165 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
53166 IF(MSTJ(51).EQ.1) THEN
53168 BEIW(IBIN)=BEIW(IBIN)*BEEXW
53170 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
53172 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
53174 DO 260 IBIN=1,NBIN3W
53175 QBIN=QDEL3W*(IBIN-0.5D0)
53176 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
53177 & SQRT(QBIN**2+PMHQ**2)
53178 IF(MSTJ(51).EQ.1) THEN
53179 BEEX3W=BEEX3W*BERT3W
53180 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
53182 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
53184 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
53187 C...Loop through particle pairs and find old relative momentum.
53188 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
53190 DO 380 I2M=I1M+1,NBE(IBE)
53191 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
53192 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
53194 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
53195 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
53196 IF(Q2OLD.LE.0.0D0) GOTO 380
53199 C...Calculate new relative momentum.
53204 IF(QOLD.LT.1D-3*QDEL) THEN
53206 ELSEIF(QOLD.LE.QDEL) THEN
53208 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
53211 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
53212 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
53213 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
53215 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53217 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
53218 IF(QOLD.LT.1D-3*QDEL3) THEN
53220 ELSEIF(QOLD.LE.QDEL3) THEN
53222 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
53225 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
53226 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
53227 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
53229 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53231 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
53234 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
53235 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
53236 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
53238 IF(QOLD.LT.1D-3*QDELW) THEN
53240 ELSEIF(QOLD.LE.QDELW) THEN
53242 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
53245 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
53246 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
53247 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
53249 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53251 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
53252 IF(QOLD.LT.1D-3*QDEL3W) THEN
53254 ELSEIF(QOLD.LE.QDEL3W) THEN
53256 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
53259 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
53260 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
53261 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53263 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53265 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
53267 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
53269 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
53271 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
53272 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
53274 IF(MSTJ(54).GE.1) THEN
53275 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
53277 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
53278 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
53280 ELSEIF(MSTJ(54).LE.-1) THEN
53281 EDEL=P(I1,4)+P(I2,4)-
53282 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
53283 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
53284 & (P(I1,3)-P(I2,3))**2
53289 SM1=(P(I1,5)+SMMIN)**2
53290 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
53291 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
53292 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
53293 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
53294 & K(I3M,5).NE.K(I1M,5)) GOTO 360
53296 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
53299 SM3=(P(I3,5)+SMMIN)**2
53300 IF(MSTJ(54).EQ.-2) THEN
53301 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
53302 & S23*MIN(SM1,SM3))*SM1)
53304 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
53305 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
53306 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
53307 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
53309 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
53310 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
53313 IF(WMAX*WI.GE.1.0) GOTO 360
53315 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
53316 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
53317 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
53318 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
53319 & K(I4M,5).NE.K(I1M,5)) GOTO 350
53321 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
53323 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
53324 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
53325 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
53327 IF(MSTJ(54).EQ.-2) THEN
53331 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
53332 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
53333 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
53334 W=MIN(W,MIN(S23,S24)*S13*S14)
53337 C...weight=1-cos(theta)/mtot2
53338 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
53339 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
53340 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
53341 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
53343 IF(W.LE.WMAX) GOTO 350
53345 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
53346 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
53347 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
53348 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
53349 IF(W.LE.WMAX) GOTO 350
53355 IF(MI4.EQ.0) GOTO 380
53358 EOLD=P(I3,4)+P(I4,4)
53360 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
53361 & (P(I3,3)+P(I4,3))**2
53362 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
53363 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
53364 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
53366 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
53367 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
53374 C...Shift momenta and recalculate energies.
53378 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
53382 P(I,J)=P(I,J)+P(IM,J)
53384 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53387 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
53392 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
53393 440 ALPHA=(ESUMP-ESUM)/PROD
53394 PARJ(96)=PARJ(96)+ALPHA
53397 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
53400 P(I,J)=P(I,J)+ALPHA*V(IM,J)
53402 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53405 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
53408 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
53412 C...Rescale all momenta for energy conservation.
53416 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
53418 PQS=PQS+P(I,5)**2/P(I,4)
53421 FAC=(PECM-PQS)/(PES-PQS)
53423 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
53427 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53430 C...Boost back to correct reference frame.
53431 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
53433 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
53439 C*********************************************************************
53442 C...Calculates the momentum shift in a system of two particles assuming
53443 C...the relative momentum squared should be shifted to Q2NEW. NI is the
53444 C...last position occupied in /PYJETS/.
53446 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
53448 C...Double precision and integer declarations.
53449 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53450 IMPLICIT INTEGER(I-N)
53451 INTEGER PYK,PYCHGE,PYCOMP
53452 C...Parameter statement to help give large particle numbers.
53453 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53454 &KEXCIT=4000000,KDIMEN=5000000)
53456 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53457 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53458 SAVE /PYJETS/,/PYDAT1/
53459 C...Local arrays and data.
53463 IF(MSTJ(55).EQ.0) THEN
53465 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
53466 & (P(I1,3)-P(I2,3))**2
53467 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
53468 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
53472 DA=SE*DE*DP12-DP2*DQ2SE
53473 DB=DP2*DQ2SE-DP12**2
53474 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
53476 PD=HA*(P(I1,J)-P(I2,J))
53488 DP(J)=P(I1,J)+P(I2,J)
53491 C...Boost to cms and rotate first particle to z-axis
53492 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
53493 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
53494 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
53495 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
53496 S=Q2NEW+(P(I1,5)+P(I2,5))**2
53497 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
53501 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
53505 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
53506 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
53507 CALL PYROBO(NI+1,NI+2,THE,PHI,
53508 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
53511 P(NI+1,J)=P(NI+1,J)-P(I1,J)
53512 P(NI+2,J)=P(NI+2,J)-P(I2,J)
53518 C*********************************************************************
53521 C...Gives the mass of a particle/parton.
53523 FUNCTION PYMASS(KF)
53525 C...Double precision and integer declarations.
53526 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53527 IMPLICIT INTEGER(I-N)
53528 INTEGER PYK,PYCHGE,PYCOMP
53530 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53531 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53532 SAVE /PYDAT1/,/PYDAT2/
53534 C...Reset variables. Compressed code. Special case for popcorn diquarks.
53543 C...Guarantee use of constituent masses for internal checks.
53544 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
53545 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
53547 PYMASS=PARF(100+KFA)
53548 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
53549 ELSEIF(KFA.LE.10) THEN
53551 ELSEIF(MSTJ(93).EQ.1) THEN
53552 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
53554 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
53557 C...Other masses can be read directly off table.
53562 C...Optional mass broadening according to truncated Breit-Wigner
53563 C...(either in m or in m^2).
53564 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
53565 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
53566 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
53567 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
53570 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
53571 & (PM0*PMAS(KC,2)))
53572 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
53573 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
53574 & (PMUPP-PMLOW)*PYR(0))))
53582 C*********************************************************************
53585 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
53586 C...for Higgs couplings. Everything else sent on to PYMASS.
53588 FUNCTION PYMRUN(KF,Q2)
53590 C...Double precision and integer declarations.
53591 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53592 IMPLICIT INTEGER(I-N)
53593 INTEGER PYK,PYCHGE,PYCOMP
53595 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53596 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53597 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53598 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
53600 C...Most masses not handled here.
53602 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
53605 C...Current-algebra masses, but no Q2 dependence.
53606 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
53607 PYMRUN=PARF(90+KFA)
53609 C...Running current-algebra masses.
53612 PYMRUN=PARF(90+KFA)*
53613 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
53614 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
53620 C*********************************************************************
53623 C...Gives the particle/parton name as a character string.
53625 SUBROUTINE PYNAME(KF,CHAU)
53627 C...Double precision and integer declarations.
53628 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53629 IMPLICIT INTEGER(I-N)
53630 INTEGER PYK,PYCHGE,PYCOMP
53632 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53633 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53634 COMMON/PYDAT4/CHAF(500,2)
53636 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
53637 C...Local character variable.
53640 C...Read out code with distinction particle/antiparticle.
53643 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
53649 C*********************************************************************
53652 C...Gives three times the charge for a particle/parton.
53654 FUNCTION PYCHGE(KF)
53656 C...Double precision and integer declarations.
53657 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53658 IMPLICIT INTEGER(I-N)
53659 INTEGER PYK,PYCHGE,PYCOMP
53661 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53664 C...Read out charge and change sign for antiparticle.
53667 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
53672 C*********************************************************************
53675 C...Compress the standard KF codes for use in mass and decay arrays;
53676 C...also checks whether a given code actually is defined.
53678 FUNCTION PYCOMP(KF)
53680 C...Double precision and integer declarations.
53681 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53682 IMPLICIT INTEGER(I-N)
53683 INTEGER PYK,PYCHGE,PYCOMP
53685 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53686 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53687 SAVE /PYDAT1/,/PYDAT2/
53688 C...Local arrays and saved data.
53689 DIMENSION KFORD(100:500),KCORD(101:500)
53690 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
53692 C...Whenever necessary reorder codes for faster search.
53693 IF(MSTU(20).EQ.0) THEN
53698 IF(KFA.LE.100) GOTO 120
53700 DO 100 I1=NFORD-1,0,-1
53701 IF(KFA.GE.KFORD(I1)) GOTO 110
53702 KFORD(I1+1)=KFORD(I1)
53703 KCORD(I1+1)=KCORD(I1)
53705 110 KFORD(I1+1)=KFA
53713 C...Fast action if same code as in latest call.
53714 IF(KF.EQ.KFLAST) THEN
53719 C...Starting values. Remove internal diquark flags.
53722 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
53723 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
53725 C...Simple cases: direct translation.
53726 IF(KFA.GT.KFORD(NFORD)) THEN
53727 ELSEIF(KFA.LE.100) THEN
53730 C...Else binary search.
53734 130 IAVG=(IMIN+IMAX)/2
53735 IF(KFORD(IAVG).GT.KFA) THEN
53737 IF(IMAX.GT.IMIN+1) GOTO 130
53738 ELSEIF(KFORD(IAVG).LT.KFA) THEN
53740 IF(IMAX.GT.IMIN+1) GOTO 130
53746 C...Check if antiparticle allowed.
53747 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
53748 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
53751 C...Save codes for possible future fast action.
53758 C*********************************************************************
53761 C...Informs user of errors in program execution.
53763 SUBROUTINE PYERRM(MERR,CHMESS)
53765 C...Double precision and integer declarations.
53766 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53767 IMPLICIT INTEGER(I-N)
53768 INTEGER PYK,PYCHGE,PYCOMP
53770 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53771 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53772 SAVE /PYJETS/,/PYDAT1/
53773 C...Local character variable.
53774 CHARACTER CHMESS*(*)
53776 C...Write first few warnings, then be silent.
53777 IF(MERR.LE.10) THEN
53778 MSTU(27)=MSTU(27)+1
53780 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
53781 & MERR,MSTU(31),CHMESS
53783 C...Write first few errors, then be silent or stop program.
53784 ELSEIF(MERR.LE.20) THEN
53785 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
53787 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
53788 & MERR-10,MSTU(31),CHMESS
53789 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
53790 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
53791 WRITE(MSTU(11),5200)
53792 IF(MERR.NE.17) CALL PYLIST(2)
53796 C...Stop program in case of irreparable error.
53798 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
53802 C...Formats for output.
53803 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
53804 &' PYEXEC calls:'/5X,A)
53805 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
53806 &' PYEXEC calls:'/5X,A)
53807 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
53809 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
53810 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
53815 C*********************************************************************
53818 C...Calculates the running alpha_electromagnetic.
53820 FUNCTION PYALEM(Q2)
53822 C...Double precision and integer declarations.
53823 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53824 IMPLICIT INTEGER(I-N)
53825 INTEGER PYK,PYCHGE,PYCOMP
53827 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53830 C...Calculate real part of photon vacuum polarization.
53831 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
53832 C...For hadrons use parametrization of H. Burkhardt et al.
53833 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
53834 AEMPI=PARU(101)/(3D0*PARU(1))
53835 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
53837 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
53839 ELSEIF(MSTU(101).EQ.2) THEN
53840 RPIGG=1D0-PARU(101)/PARU(103)
53841 ELSEIF(Q2.LT.0.09D0) THEN
53842 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
53843 ELSEIF(Q2.LT.9D0) THEN
53844 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
53845 & 0.00238D0*LOG(1D0+3.927D0*Q2)
53846 ELSEIF(Q2.LT.1D4) THEN
53847 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
53848 & 0.00299D0*LOG(1D0+Q2)
53850 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
53851 & 0.00293D0*LOG(1D0+Q2)
53854 C...Calculate running alpha_em.
53855 PYALEM=PARU(101)/(1D0-RPIGG)
53861 C*********************************************************************
53864 C...Gives the value of alpha_strong.
53866 FUNCTION PYALPS(Q2)
53868 C...Double precision and integer declarations.
53869 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53870 IMPLICIT INTEGER(I-N)
53871 INTEGER PYK,PYCHGE,PYCOMP
53873 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53874 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53875 SAVE /PYDAT1/,/PYDAT2/
53877 C...Constant alpha_strong trivial. Pick artificial Lambda.
53878 IF(MSTU(111).LE.0) THEN
53880 MSTU(118)=MSTU(112)
53882 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
53883 & ((33D0-2D0*MSTU(112))*PARU(111)))
53884 PARU(118)=PARU(111)
53888 C...Find effective Q2, number of flavours and Lambda.
53890 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
53893 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
53894 Q2THR=PARU(113)*PMAS(NF,1)**2
53895 IF(Q2EFF.LT.Q2THR) THEN
53897 ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF))
53901 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
53902 Q2THR=PARU(113)*PMAS(NF+1,1)**2
53903 IF(Q2EFF.GT.Q2THR) THEN
53905 ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF))
53909 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
53910 PARU(117)=SQRT(ALAM2)
53912 C...Evaluate first or second order alpha_strong.
53913 B0=(33D0-2D0*NF)/6D0
53914 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
53915 IF(MSTU(111).EQ.1) THEN
53916 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
53918 B1=(153D0-19D0*NF)/6D0
53919 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
53928 C*********************************************************************
53931 C...Reconstructs an angle from given x and y coordinates.
53933 FUNCTION PYANGL(X,Y)
53935 C...Double precision and integer declarations.
53936 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53937 IMPLICIT INTEGER(I-N)
53938 INTEGER PYK,PYCHGE,PYCOMP
53940 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53945 IF(R.LT.1D-20) RETURN
53946 IF(ABS(X)/R.LT.0.8D0) THEN
53947 PYANGL=SIGN(ACOS(X/R),Y)
53950 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
53951 PYANGL=PARU(1)-PYANGL
53952 ELSEIF(X.LT.0D0) THEN
53953 PYANGL=-PARU(1)-PYANGL
53960 C*********************************************************************
53963 C...Performs rotations and boosts.
53965 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
53967 C...Double precision and integer declarations.
53968 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53969 IMPLICIT INTEGER(I-N)
53970 INTEGER PYK,PYCHGE,PYCOMP
53972 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53973 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53974 SAVE /PYJETS/,/PYDAT1/
53976 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
53978 C...Find and check range of rotation/boost.
53980 IF(IMIN.LE.0) IMIN=1
53981 IF(MSTU(1).GT.0) IMIN=MSTU(1)
53983 IF(IMAX.LE.0) IMAX=N
53984 IF(MSTU(2).GT.0) IMAX=MSTU(2)
53985 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
53986 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
53990 C...Optional resetting of V (when not set before.)
53991 IF(MSTU(33).NE.0) THEN
53992 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
54000 C...Rotate, typically from z axis to direction (theta,phi).
54001 IF(THE**2+PHI**2.GT.1D-20) THEN
54002 ROT(1,1)=COS(THE)*COS(PHI)
54004 ROT(1,3)=SIN(THE)*COS(PHI)
54005 ROT(2,1)=COS(THE)*SIN(PHI)
54007 ROT(2,3)=SIN(THE)*SIN(PHI)
54012 IF(K(I,1).LE.0) GOTO 140
54018 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
54019 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
54024 C...Boost, typically from rest to momentum/energy=beta.
54025 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
54029 DB=SQRT(DBX**2+DBY**2+DBZ**2)
54031 IF(DB.GT.EPS1) THEN
54032 C...Rescale boost vector if too close to unity.
54033 CALL PYERRM(3,'(PYROBO:) boost vector too large')
54039 DGA=1D0/SQRT(1D0-DB**2)
54041 IF(K(I,1).LE.0) GOTO 160
54046 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
54047 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
54048 P(I,1)=DP(1)+DGABP*DBX
54049 P(I,2)=DP(2)+DGABP*DBY
54050 P(I,3)=DP(3)+DGABP*DBZ
54051 P(I,4)=DGA*(DP(4)+DBP)
54052 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
54053 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
54054 V(I,1)=DV(1)+DGABV*DBX
54055 V(I,2)=DV(2)+DGABV*DBY
54056 V(I,3)=DV(3)+DGABV*DBZ
54057 V(I,4)=DGA*(DV(4)+DBV)
54064 C*********************************************************************
54067 C...Performs global manipulations on the event record, in particular
54068 C...to exclude unstable or undetectable partons/particles.
54070 SUBROUTINE PYEDIT(MEDIT)
54072 C...Double precision and integer declarations.
54073 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54074 IMPLICIT INTEGER(I-N)
54075 INTEGER PYK,PYCHGE,PYCOMP
54077 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54078 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54079 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54080 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
54082 DIMENSION NS(2),PTS(2),PLS(2)
54084 C...Remove unwanted partons/particles.
54085 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
54087 IF(MSTU(2).GT.0) IMAX=MSTU(2)
54088 I1=MAX(1,MSTU(1))-1
54089 DO 110 I=MAX(1,MSTU(1)),IMAX
54090 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
54091 IF(MEDIT.EQ.1) THEN
54092 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
54093 ELSEIF(MEDIT.EQ.2) THEN
54094 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
54096 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
54098 ELSEIF(MEDIT.EQ.3) THEN
54099 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
54101 IF(KC.EQ.0) GOTO 110
54102 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
54103 ELSEIF(MEDIT.EQ.5) THEN
54104 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
54106 IF(KC.EQ.0) GOTO 110
54107 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
54108 & KCHG(KC,2).EQ.0) GOTO 110
54111 C...Pack remaining partons/particles. Origin no longer known.
54120 IF(I1.LT.N) MSTU(3)=0
54121 IF(I1.LT.N) MSTU(70)=0
54124 C...Selective removal of class of entries. New position of retained.
54125 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
54128 K(I,3)=MOD(K(I,3),MSTU(5))
54129 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
54130 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
54131 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
54132 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
54133 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
54134 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
54135 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
54137 K(I,3)=K(I,3)+MSTU(5)*I1
54140 C...Find new event history information and replace old.
54142 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
54143 & K(I,3)/MSTU(5).EQ.0) GOTO 140
54145 130 IM=MOD(K(ID,3),MSTU(5))
54146 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
54147 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
54148 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
54152 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
54153 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
54154 & K(IM,2).EQ.94) THEN
54159 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
54160 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
54161 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
54162 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
54163 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
54164 & K(K(I,4),3)/MSTU(5)
54165 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
54166 & K(K(I,5),3)/MSTU(5)
54168 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
54169 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
54170 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
54171 KCD=MOD(K(I,4),MSTU(5))
54172 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
54173 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
54174 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
54175 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
54176 KCD=MOD(K(I,5),MSTU(5))
54177 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
54178 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
54182 C...Pack remaining entries.
54187 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
54194 K(I1,3)=MOD(K(I1,3),MSTU(5))
54196 IF(I.EQ.MSTU(90+IZ)) THEN
54197 MSTU(90)=MSTU(90)+1
54198 MSTU(90+MSTU(90))=I1
54199 PARU(90+MSTU(90))=PARU(90+IZ)
54203 IF(I1.LT.N) MSTU(3)=0
54204 IF(I1.LT.N) MSTU(70)=0
54207 C...Fill in some missing daughter pointers (lost in colour flow).
54208 ELSEIF(MEDIT.EQ.16) THEN
54210 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
54211 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
54212 C...Find daughters who point to mother.
54214 IF(K(I1,3).NE.I) THEN
54215 ELSEIF(K(I,4).EQ.0) THEN
54221 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
54222 IF(K(I,4).NE.0) GOTO 220
54223 C...Find daughters who point to documentation version of mother.
54225 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
54226 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
54227 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
54229 IF(K(I1,3).NE.IM) THEN
54230 ELSEIF(K(I,4).EQ.0) THEN
54236 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
54237 IF(K(I,4).NE.0) GOTO 220
54238 C...Find daughters who point to documentation daughters who,
54239 C...in their turn, point to documentation mother.
54243 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
54245 IF(ID1.EQ.IM) ID1=I1
54249 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
54250 ELSEIF(K(I,4).EQ.0) THEN
54256 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
54259 C...Save top entries at bottom of PYJETS commonblock.
54260 ELSEIF(MEDIT.EQ.21) THEN
54261 IF(2*N.GE.MSTU(4)) THEN
54262 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
54267 K(MSTU(4)-I,J)=K(I,J)
54268 P(MSTU(4)-I,J)=P(I,J)
54269 V(MSTU(4)-I,J)=V(I,J)
54274 C...Restore bottom entries of commonblock PYJETS to top.
54275 ELSEIF(MEDIT.EQ.22) THEN
54276 DO 260 I=1,MSTU(32)
54278 K(I,J)=K(MSTU(4)-I,J)
54279 P(I,J)=P(MSTU(4)-I,J)
54280 V(I,J)=V(MSTU(4)-I,J)
54285 C...Mark primary entries at top of commonblock PYJETS as untreated.
54286 ELSEIF(MEDIT.EQ.23) THEN
54291 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
54293 IF(KH.NE.0) GOTO 280
54295 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
54296 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
54300 C...Place largest axis along z axis and second largest in xy plane.
54301 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
54302 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
54303 & P(MSTU(61),2)),0D0,0D0,0D0)
54304 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
54305 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
54306 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
54307 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
54308 IF(MEDIT.EQ.31) RETURN
54310 C...Rotate to put slim jet along +z axis.
54317 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
54318 IF(MSTU(41).GE.2) THEN
54320 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
54321 & KC.EQ.18) GOTO 300
54322 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
54325 IS=2D0-SIGN(0.5D0,P(I,3))
54327 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
54329 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
54330 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
54332 C...Rotate to put second largest jet into -z,+x quadrant.
54334 IF(P(I,3).GE.0D0) GOTO 310
54335 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
54336 IF(MSTU(41).GE.2) THEN
54338 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
54339 & KC.EQ.18) GOTO 310
54340 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
54343 IS=2D0-SIGN(0.5D0,P(I,1))
54344 PLS(IS)=PLS(IS)-P(I,3)
54346 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
54353 C*********************************************************************
54356 C...Gives program heading, or lists an event, or particle
54357 C...data, or current parameter values.
54359 SUBROUTINE PYLIST(MLIST)
54361 C...Double precision and integer declarations.
54362 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54363 IMPLICIT INTEGER(I-N)
54364 INTEGER PYK,PYCHGE,PYCOMP
54365 C...Parameter statement to help give large particle numbers.
54366 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54367 &KEXCIT=4000000,KDIMEN=5000000)
54369 C...HEPEVT commonblock.
54370 PARAMETER (NMXHEP=4000)
54371 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
54372 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
54373 DOUBLE PRECISION PHEP,VHEP
54376 C...User process event common block.
54378 PARAMETER (MAXNUP=500)
54379 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
54380 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
54381 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
54382 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
54383 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
54387 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54388 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54389 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54390 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54391 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
54392 C...Local arrays, character variables and data.
54393 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
54395 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
54397 C...Initialization printout: version number and date of last change.
54398 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
54401 IF(MLIST.EQ.0) RETURN
54404 C...List event data, including additional lines after N.
54405 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
54406 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
54407 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
54408 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
54410 IF(MLIST.GE.2) LMX=16
54413 IF(MSTU(2).GT.0) IMAX=MSTU(2)
54414 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
54415 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
54416 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
54417 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
54419 C...Get particle name, pad it and check it is not too long.
54420 CALL PYNAME(K(I,2),CHAP)
54423 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
54427 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
54429 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
54432 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
54434 CHAC=CHDL(MDL)(1:2*LDL)//' '
54436 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
54437 & CHDL(MDL)(LDL+1:2*LDL)//' '
54438 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
54442 C...Add information on string connection.
54443 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
54447 IF(KC.NE.0) KCC=KCHG(KC,2)
54448 IF(IABS(K(I,2)).EQ.39) THEN
54449 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
54450 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
54452 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
54453 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
54454 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
54455 ELSEIF(KCC.NE.0) THEN
54457 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
54460 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
54461 & CHAC(LMX-1:LMX-1)='I'
54463 C...Write data for particle/jet.
54464 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
54465 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
54467 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
54468 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
54470 ELSEIF(MLIST.EQ.1) THEN
54471 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
54473 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
54474 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
54475 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
54476 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
54477 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
54480 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),
54483 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
54485 C...Insert extra separator lines specified by user.
54486 IF(MSTU(70).GE.1) THEN
54488 DO 110 J=1,MIN(10,MSTU(70))
54489 IF(I.EQ.MSTU(70+J)) ISEP=1
54491 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
54492 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
54496 C...Sum of charges and momenta.
54500 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
54501 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
54502 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
54503 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
54504 ELSEIF(MLIST.EQ.1) THEN
54505 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
54507 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
54510 C...Simple listing of HEPEVT entries (mainly for test purposes).
54511 ELSEIF(MLIST.EQ.5) THEN
54512 WRITE(MSTU(11),7500)
54514 IF(ISTHEP(I).EQ.0) GOTO 140
54515 WRITE(MSTU(11),7600) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
54516 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
54520 C...Simple listing of user-process entries (mainly for test purposes).
54521 ELSEIF(MLIST.EQ.7) THEN
54522 WRITE(MSTU(11),7300)
54524 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
54525 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
54528 C...Give simple list of KF codes defined in program.
54529 ELSEIF(MLIST.EQ.11) THEN
54530 WRITE(MSTU(11),6600)
54532 CALL PYNAME(KF,CHAP)
54533 CALL PYNAME(-KF,CHAN)
54534 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
54535 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54539 DO 170 KFLB=1,KFLA-(3-KFLS)/2
54540 KF=1000*KFLA+100*KFLB+KFLS
54541 CALL PYNAME(KF,CHAP)
54542 CALL PYNAME(-KF,CHAN)
54543 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54549 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
54550 IF(KMUL.EQ.5) KFLS=5
54552 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
54553 IF(KMUL.EQ.4) KFLR=2
54555 DO 200 KFLC=1,KFLB-1
54556 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
54557 CALL PYNAME(KF,CHAP)
54558 CALL PYNAME(-KF,CHAN)
54559 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54562 CALL PYNAME(KFK,CHAP)
54563 WRITE(MSTU(11),6700) KFK,CHAP
54565 CALL PYNAME(KFK,CHAP)
54566 WRITE(MSTU(11),6700) KFK,CHAP
54569 KF=10000*KFLR+110*KFLB+KFLS
54570 CALL PYNAME(KF,CHAP)
54571 WRITE(MSTU(11),6700) KF,CHAP
54575 CALL PYNAME(KF,CHAP)
54576 WRITE(MSTU(11),6700) KF,CHAP
54578 CALL PYNAME(KF,CHAP)
54579 WRITE(MSTU(11),6700) KF,CHAP
54585 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
54587 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
54588 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
54589 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
54590 CALL PYNAME(KF,CHAP)
54591 CALL PYNAME(-KF,CHAN)
54592 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54599 IF(KF.LT.1000000) GOTO 270
54600 CALL PYNAME(KF,CHAP)
54601 CALL PYNAME(-KF,CHAN)
54602 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
54603 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54606 C...List parton/particle data table. Check whether to be listed.
54607 ELSEIF(MLIST.EQ.12) THEN
54608 WRITE(MSTU(11),6800)
54609 DO 300 KC=1,MSTU(6)
54611 IF(KF.EQ.0) GOTO 300
54612 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
54615 C...Find particle name and mass. Print information.
54616 CALL PYNAME(KF,CHAP)
54617 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
54618 CALL PYNAME(-KF,CHAN)
54619 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
54620 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
54622 C...Particle decay: channel number, branching ratios, matrix element,
54623 C...decay products.
54624 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
54626 CALL PYNAME(KFDP(IDC,J),CHAD(J))
54628 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
54633 C...List parameter value table.
54634 ELSEIF(MLIST.EQ.13) THEN
54635 WRITE(MSTU(11),7100)
54637 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
54641 C...Format statements for output on unit MSTU(11) (by default 6).
54642 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
54643 &5X,'KF orig p_x p_y p_z E m'/)
54644 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
54645 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
54646 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
54647 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
54648 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
54649 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
54650 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
54651 5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
54652 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
54653 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
54654 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
54655 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
54656 5900 FORMAT(66X,5(1X,F12.3))
54657 6000 FORMAT(1X,78('='))
54658 6100 FORMAT(1X,130('='))
54659 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
54660 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
54661 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
54662 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
54664 6600 FORMAT(///20X,'List of KF codes in program'/)
54665 6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
54666 6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
54667 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
54668 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
54669 &1X,'ME',3X,'Br.rat.',4X,'decay products')
54670 6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
54671 &1X,1P,E13.5,3X,I2)
54672 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
54673 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
54674 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
54675 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
54676 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
54677 &//' I IST ID Mothers Colours p_x p_y p_z',
54679 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
54680 7500 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
54681 &//' I IST ID Mothers Daughters p_x p_y p_z',
54683 7600 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
54688 C*********************************************************************
54691 C...Writes a logo for the program.
54695 C...Double precision and integer declarations.
54696 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54697 IMPLICIT INTEGER(I-N)
54698 INTEGER PYK,PYCHGE,PYCOMP
54699 C...Parameter for length of information block.
54700 PARAMETER (IREFER=24)
54702 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54703 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54704 SAVE /PYDAT1/,/PYPARS/
54705 C...Local arrays and character variables.
54707 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
54708 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
54710 C...Data on months, logo, titles, and references.
54711 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
54712 &'Oct','Nov','Dec'/
54713 DATA (LOGO(J),J=1,19)/
54715 &' *:::!!:::::::::::* ',
54716 &' *::::::!!::::::::::::::* ',
54717 &' *::::::::!!::::::::::::::::* ',
54718 &' *:::::::::!!:::::::::::::::::* ',
54719 &' *:::::::::!!:::::::::::::::::* ',
54720 &' *::::::::!!::::::::::::::::*! ',
54721 &' *::::::!!::::::::::::::* !! ',
54722 &' !! *:::!!:::::::::::* !! ',
54723 &' !! !* -><- * !! ',
54733 DATA (LOGO(J),J=20,38)/
54734 &'Welcome to the Lund Monte Carlo!',
54736 &'PPP Y Y TTTTT H H III A ',
54737 &'P P Y Y T H H I A A ',
54738 &'PPP Y T HHHHH I AAAAA',
54739 &'P Y T H H I A A',
54740 &'P Y T H H III A A',
54742 &'This is PYTHIA version x.xxx ',
54743 &'Last date of change: xx xxx 199x',
54745 &'Now is xx xxx 199x at xx:xx:xx ',
54747 &'Disclaimer: this program comes ',
54748 &'without any guarantees. Beware ',
54749 &'of errors and use common sense ',
54750 &'when interpreting results. ',
54752 &'Copyright T. Sjostrand (2003) '/
54753 DATA (REFER(J),J=1,18)/
54754 &'An archive of program versions and d',
54755 &'ocumentation is found on the web: ',
54756 &'http://www.thep.lu.se/~torbjorn/Pyth',
54760 &'When you cite this program, currentl',
54761 &'y the official reference is ',
54762 &'T. Sjostrand, P. Eden, C. Friberg, L',
54763 &'. Lonnblad, G. Miu, S. Mrenna and ',
54764 &'E. Norrbin, Computer Physics Commun.',
54765 &' 135 (2001) 238. ',
54766 &'The large manual is ',
54768 &'T. Sjostrand, L. Lonnblad and S. Mre',
54769 &'nna, LU TP 01-21 [hep-ph/0108264]. ',
54770 &'Also remember that the program, to a',
54771 &' large extent, represents original '/
54772 DATA (REFER(J),J=19,36)/
54773 &'physics research. Other publications',
54774 &' of special relevance to your ',
54775 &'studies may therefore deserve separa',
54779 &'Main author: Torbjorn Sjostrand; Dep',
54780 &'artment of Theoretical Physics 2, ',
54781 &' Lund University, Solvegatan 14A, S',
54782 &'-223 62 Lund, Sweden; ',
54783 &' phone: + 46 - 46 - 222 48 16; e-ma',
54784 &'il: torbjorn@thep.lu.se ',
54785 &'Author: Leif Lonnblad; Department of',
54786 &' Theoretical Physics 2, ',
54787 &' Lund University, Solvegatan 14A, S',
54788 &'-223 62 Lund, Sweden; ',
54789 &' phone: + 46 - 46 - 222 77 80; e-ma',
54790 &'il: leif@thep.lu.se '/
54791 DATA (REFER(J),J=37,2*IREFER)/
54792 &'Author: Stephen Mrenna; Computing Di',
54793 &'vision, Simulations Group, ',
54794 &' Fermi National Accelerator Laborat',
54795 &'ory, MS 234, Batavia, IL 60510, USA;',
54796 &' phone: + 1 - 630 - 840 - 2556; e-m',
54797 &'ail: mrenna@fnal.gov ',
54798 &'Author: Peter Skands; Department of ',
54799 &'Theoretical Physics 2, ',
54800 &' Lund University, Solvegatan 14A, S',
54801 &'-223 62 Lund, Sweden; ',
54802 &' phone: + 46 - 46 - 222 31 92; e-ma',
54803 &'il: zeiler@thep.lu.se '/
54805 C...Check that PYDATA linked.
54806 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
54808 & 'Error: PYDATA has not been linked.'
54809 WRITE(*,'(1X,A)') 'Execution stopped!'
54812 C...Write current version number and current date+time.
54814 WRITE(VERS,'(I1)') MSTP(181)
54815 LOGO(28)(24:24)=VERS
54816 WRITE(SUBV,'(I3)') MSTP(182)
54817 LOGO(28)(26:28)=SUBV
54818 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
54819 WRITE(DATE,'(I2)') MSTP(185)
54820 LOGO(29)(22:23)=DATE
54821 LOGO(29)(25:27)=MONTH(MSTP(184))
54822 WRITE(YEAR,'(I4)') MSTP(183)
54823 LOGO(29)(29:32)=YEAR
54825 IF(IDATI(1).LE.0) THEN
54828 WRITE(DATE,'(I2)') IDATI(3)
54830 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
54831 WRITE(YEAR,'(I4)') IDATI(1)
54832 LOGO(31)(15:18)=YEAR
54833 WRITE(HOUR,'(I2)') IDATI(4)
54834 LOGO(31)(23:24)=HOUR
54835 WRITE(MINU,'(I2)') IDATI(5)
54836 LOGO(31)(26:27)=MINU
54837 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
54838 WRITE(SECO,'(I2)') IDATI(6)
54839 LOGO(31)(29:30)=SECO
54840 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
54844 C...Loop over lines in header. Define page feed and side borders.
54845 DO 100 ILIN=1,29+IREFER
54854 C...Separator lines and logos.
54855 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
54856 LINE(4:77)='***********************************************'//
54857 & '***************************'
54858 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
54859 LINE(6:37)=LOGO(ILIN-5)
54860 LINE(44:75)=LOGO(ILIN+14)
54861 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
54862 LINE(5:40)=REFER(2*ILIN-51)
54863 LINE(41:76)=REFER(2*ILIN-50)
54866 C...Write lines to appropriate unit.
54867 WRITE(MSTU(11),'(A79)') LINE
54873 C*********************************************************************
54876 C...Facilitates the updating of particle and decay data
54877 C...by allowing it to be done in an external file.
54879 SUBROUTINE PYUPDA(MUPDA,LFN)
54881 C...Double precision and integer declarations.
54882 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54883 IMPLICIT INTEGER(I-N)
54884 INTEGER PYK,PYCHGE,PYCOMP
54886 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54887 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54888 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54889 COMMON/PYDAT4/CHAF(500,2)
54891 COMMON/PYINT4/MWID(500),WIDS(500,5)
54892 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
54893 C...Local arrays, character variables and data.
54894 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
54895 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
54896 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
54897 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
54898 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
54899 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
54900 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
54902 C...Write header if not yet done.
54903 IF(MSTU(12).GE.1) CALL PYLIST(0)
54905 C...Write information on file for editing.
54906 IF(MUPDA.EQ.1) THEN
54908 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
54909 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
54910 & MWID(KC),MDCY(KC,1)
54911 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
54912 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
54913 & (KFDP(IDC,J),J=1,5)
54917 C...Read complete set of information from edited file or
54918 C...read partial set of new or updated information from edited file.
54919 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
54921 C...Reset counters.
54925 IF(MUPDA.EQ.2) THEN
54930 DO 130 KC=1,MSTU(6)
54931 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
54932 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
54936 C...Begin of loop: read new line; unknown whether particle or
54938 140 READ(LFN,5200,END=190) CHINL
54940 C...Identify particle code and whether already defined (for MUPDA=3).
54941 IF(CHINL(2:10).NE.' ') THEN
54944 IF(MUPDA.EQ.2) THEN
54957 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
54960 C...Remove duplicate old decay data.
54961 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
54962 IDCREP=MDCY(KCREP,2)
54963 NDCREP=MDCY(KCREP,3)
54965 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
54967 DO 180 I=IDCREP,NDC-NDCREP
54968 MDME(I,1)=MDME(I+NDCREP,1)
54969 MDME(I,2)=MDME(I+NDCREP,2)
54970 BRAT(I)=BRAT(I+NDCREP)
54972 KFDP(I,J)=KFDP(I+NDCREP,J)
54977 ELSEIF(KCREP.NE.0) THEN
54985 C...Study line with particle data.
54986 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
54987 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
54988 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
54989 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
54990 & MWID(KC),MDCY(KC,1)
54994 C...Study line with decay data.
54997 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
54998 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
54999 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
55000 MDCY(KC,3)=MDCY(KC,3)+1
55001 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
55002 & (KFDP(NDC,J),J=1,5)
55005 C...End of loop; ensure that PYCOMP tables are updated.
55010 C...Perform possible tests that new information is consistent.
55011 DO 220 KC=1,MSTU(6)
55013 IF(KF.EQ.0) GOTO 220
55014 WRITE(CHKF,5300) KF
55015 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
55016 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
55017 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
55019 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
55020 IF(MDME(IDC,2).GT.80) GOTO 210
55022 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
55026 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
55028 ELSEIF(PYCOMP(KP).EQ.0) THEN
55033 PMS=PMS-PMAS(KPC,1)
55034 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
55038 IF(KQ.NE.0) MERR=MAX(2,MERR)
55039 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
55041 IF(MERR.EQ.3) CALL PYERRM(17,
55042 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
55043 IF(MERR.EQ.2) CALL PYERRM(17,
55044 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
55045 IF(MERR.EQ.1) CALL PYERRM(7,
55046 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
55047 BRSUM=BRSUM+BRAT(IDC)
55049 WRITE(CHTMP,5500) BRSUM
55050 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
55051 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
55052 & CHTMP(9:16)//' for KF ='//CHKF)
55055 C...Write DATA statements for inclusion in program.
55056 ELSEIF(MUPDA.EQ.4) THEN
55058 C...Find out how many codes and decay channels are actually used.
55062 IF(KCHG(I,4).NE.0) THEN
55064 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
55068 C...Initialize writing of DATA statements for inclusion in program.
55071 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
55074 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
55078 C...Loop through variables for conversion to characters.
55080 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
55081 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
55082 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
55083 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
55084 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
55085 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
55086 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
55087 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
55088 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
55089 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
55090 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
55091 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
55092 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
55093 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
55094 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
55095 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
55096 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
55097 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
55098 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
55099 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
55100 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
55101 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
55103 C...Replace variables beyond what is properly defined.
55105 IF(IDIM.GT.KCC) CHTMP=' 0'
55106 ELSEIF(IVAR.LE.8) THEN
55107 IF(IDIM.GT.KCC) CHTMP=' 0.0'
55108 ELSEIF(IVAR.LE.11) THEN
55109 IF(IDIM.GT.KCC) CHTMP=' 0'
55110 ELSEIF(IVAR.LE.13) THEN
55111 IF(IDIM.GT.NDC) CHTMP=' 0'
55112 ELSEIF(IVAR.LE.14) THEN
55113 IF(IDIM.GT.NDC) CHTMP=' 0.0'
55114 ELSEIF(IVAR.LE.19) THEN
55115 IF(IDIM.GT.NDC) CHTMP=' 0'
55116 ELSEIF(IVAR.LE.21) THEN
55117 IF(IDIM.GT.KCC) CHTMP=' '
55119 IF(IDIM.GT.KCC) CHTMP=' 0'
55122 C...Length of variable, trailing decimal zeros, quotation marks.
55126 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
55127 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
55129 CHNEW=CHTMP(LLOW:LHIG)//' '
55131 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
55134 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
55135 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
55140 CHNEW(LNEW+1:LNEW+2)='D0'
55143 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
55144 DO 260 LL=LNEW,1,-1
55145 IF(CHNEW(LL:LL).EQ.'''') THEN
55147 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
55153 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
55157 C...Form composite character string, often including repetition counter.
55158 IF(CHNEW.NE.CHOLD) THEN
55165 IF(NRPT.GE.2) LRPT=LNEW+3
55166 IF(NRPT.GE.10) LRPT=LNEW+4
55167 IF(NRPT.GE.100) LRPT=LNEW+5
55168 IF(NRPT.GE.1000) LRPT=LNEW+6
55171 WRITE(CHTMP,5400) NRPT
55173 IF(NRPT.GE.10) LRPT=2
55174 IF(NRPT.GE.100) LRPT=3
55175 IF(NRPT.GE.1000) LRPT=4
55176 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
55180 C...Add characters to end of line, to new line (after storing old line),
55181 C...or to new block of lines (after writing old block).
55182 IF(LLIN+LCOM.LE.70) THEN
55183 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
55185 ELSEIF(NLIN.LE.19) THEN
55186 CHLIN(LLIN+1:72)=' '
55189 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
55192 CHLIN(LLIN:72)='/'//' '
55194 WRITE(CHTMP,5400) IDIM-NRPT
55195 CHBLK(1)(30:33)=CHTMP(13:16)
55197 WRITE(LFN,5700) CHBLK(ILIN)
55201 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
55202 & ',I= , )/'//CHCOM(1:LCOM)//','
55203 WRITE(CHTMP,5400) IDIM-NRPT+1
55204 CHLIN(25:28)=CHTMP(13:16)
55209 C...Write final block of lines.
55210 CHLIN(LLIN:72)='/'//' '
55212 WRITE(CHTMP,5400) NDIM
55213 CHBLK(1)(30:33)=CHTMP(13:16)
55215 WRITE(LFN,5700) CHBLK(ILIN)
55220 C...Formats for reading and writing particle data.
55221 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
55222 5100 FORMAT(10X,2I5,F12.6,5I10)
55233 C*********************************************************************
55236 C...Provides various integer-valued event related data.
55240 C...Double precision and integer declarations.
55241 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55242 IMPLICIT INTEGER(I-N)
55243 INTEGER PYK,PYCHGE,PYCOMP
55245 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55246 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55247 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55248 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55250 C...Default value. For I=0 number of entries, number of stable entries
55251 C...or 3 times total charge.
55253 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
55254 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
55256 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
55258 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
55259 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
55262 ELSEIF(I.EQ.0) THEN
55264 C...For I > 0 direct readout of K matrix or charge.
55265 ELSEIF(J.LE.5) THEN
55267 ELSEIF(J.EQ.6) THEN
55270 C...Status (existing/fragmented/decayed), parton/hadron separation.
55271 ELSEIF(J.LE.8) THEN
55272 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
55273 IF(J.EQ.8) PYK=PYK*K(I,2)
55274 ELSEIF(J.LE.12) THEN
55278 IF(KC.NE.0) KQ=KCHG(KC,2)
55279 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
55280 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
55282 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
55284 C...Heaviest flavour in hadron/diquark.
55285 ELSEIF(J.EQ.13) THEN
55287 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
55288 IF(KFA.LT.10) PYK=KFA
55289 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
55290 PYK=PYK*ISIGN(1,K(I,2))
55292 C...Particle history: generation, ancestor, rank.
55293 ELSEIF(J.LE.15) THEN
55300 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
55303 ELSEIF(J.EQ.16) THEN
55305 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
55306 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
55313 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
55314 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
55316 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
55317 IF(ILP.EQ.1) GOTO 120
55319 IF(K(I1,1).EQ.12) THEN
55321 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
55322 & .AND.K(I3,2).NE.93) PYK=PYK+1
55328 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
55332 C...Particle coming from collapsing jet system or not.
55333 ELSEIF(J.EQ.17) THEN
55340 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
55341 IF(PYK.EQ.1) PYK=-1
55345 IF(KCHG(KC,2).EQ.0) GOTO 150
55346 IF(K(I1,1).NE.12) PYK=0
55347 IF(K(I1,1).NE.12) RETURN
55350 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
55352 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
55354 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
55356 C...Number of decay products. Colour flow.
55357 ELSEIF(J.EQ.18) THEN
55358 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
55359 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
55360 ELSEIF(J.LE.22) THEN
55361 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
55362 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
55363 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
55364 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
55365 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
55372 C*********************************************************************
55375 C...Provides various real-valued event related data.
55379 C...Double precision and integer declarations.
55380 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55381 IMPLICIT INTEGER(I-N)
55382 INTEGER PYK,PYCHGE,PYCOMP
55384 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55385 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55386 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55387 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55391 C...Set default value. For I = 0 sum of momenta or charges,
55392 C...or invariant mass of system.
55394 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
55395 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
55397 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
55399 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
55403 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
55407 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
55408 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
55410 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
55412 ELSEIF(I.EQ.0) THEN
55414 C...Direct readout of P matrix.
55415 ELSEIF(J.LE.5) THEN
55418 C...Charge, total momentum, transverse momentum, transverse mass.
55419 ELSEIF(J.LE.12) THEN
55420 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
55421 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
55422 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
55423 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
55424 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
55426 C...Theta and phi angle in radians or degrees.
55427 ELSEIF(J.LE.16) THEN
55428 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
55429 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
55430 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
55432 C...True rapidity, rapidity with pion mass, pseudorapidity.
55433 ELSEIF(J.LE.19) THEN
55435 IF(J.EQ.17) PMR=P(I,5)
55436 IF(J.EQ.18) PMR=PYMASS(211)
55437 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
55438 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
55441 C...Energy and momentum fractions (only to be used in CM frame).
55442 ELSEIF(J.LE.25) THEN
55443 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
55444 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
55445 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
55446 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
55447 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
55448 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
55454 C*********************************************************************
55457 C...Performs sphericity tensor analysis to give sphericity,
55458 C...aplanarity and the related event axes.
55460 SUBROUTINE PYSPHE(SPH,APL)
55462 C...Double precision and integer declarations.
55463 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55464 IMPLICIT INTEGER(I-N)
55465 INTEGER PYK,PYCHGE,PYCOMP
55467 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55468 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55469 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55470 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55472 DIMENSION SM(3,3),SV(3,3)
55474 C...Calculate matrix to be diagonalized.
55483 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
55484 IF(MSTU(41).GE.2) THEN
55486 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
55487 & KC.EQ.18) GOTO 140
55488 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
55492 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55494 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
55495 & MAX(1D-10,PA)**(PARU(41)-2D0)
55498 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
55504 C...Very low multiplicities (0 or 1) not considered.
55506 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
55513 SM(J1,J2)=SM(J1,J2)/PS
55517 C...Find eigenvalues to matrix (third degree equation).
55518 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
55519 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
55520 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
55521 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
55522 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
55523 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
55524 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
55525 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
55526 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
55527 IF(P(N+2,4).LT.1D-5) THEN
55528 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
55534 C...Find first and last eigenvector by solving equation system.
55537 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
55539 SV(J1,J2)=SM(J1,J2)
55540 SV(J2,J1)=SM(J1,J2)
55546 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
55549 SMAX=ABS(SV(J1,J2))
55553 DO 220 J3=JA+1,JA+2
55555 RL=SV(J1,JB)/SV(JA,JB)
55557 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
55558 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
55560 SMAX=ABS(SV(J1,J2))
55564 JB2=JB+2-3*((JB+1)/3)
55565 P(N+I,JB1)=-SV(JC,JB2)
55566 P(N+I,JB2)=SV(JC,JB1)
55567 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
55569 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
55570 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55572 P(N+I,J)=SGN*P(N+I,J)/PA
55576 C...Middle axis orthogonal to other two. Fill other codes.
55577 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55578 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
55579 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
55580 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
55593 C...Calculate sphericity and aplanarity. Select storing option.
55594 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
55598 IF(MSTU(43).LE.1) MSTU(3)=3
55599 IF(MSTU(43).GE.2) N=N+3
55604 C*********************************************************************
55607 C...Performs thrust analysis to give thrust, oblateness
55608 C...and the related event axes.
55610 SUBROUTINE PYTHRU(THR,OBL)
55612 C...Double precision and integer declarations.
55613 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55614 IMPLICIT INTEGER(I-N)
55615 INTEGER PYK,PYCHGE,PYCOMP
55617 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55618 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55619 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55620 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55622 DIMENSION TDI(3),TPR(3)
55624 C...Take copy of particles that are to be considered in thrust analysis.
55628 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
55629 IF(MSTU(41).GE.2) THEN
55631 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
55632 & KC.EQ.18) GOTO 100
55633 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
55636 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
55637 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
55647 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55649 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
55650 & P(N+NP,4)**(PARU(42)-1D0)
55651 PS=PS+P(N+NP,4)*P(N+NP,5)
55654 C...Very low multiplicities (0 or 1) not considered.
55656 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
55662 C...Loop over thrust and major. T axis along z direction in latter case.
55666 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
55668 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
55669 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
55670 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
55673 C...Find and order particles with highest p (pT for major).
55674 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
55678 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
55679 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
55680 IF(P(I,4).LE.P(ILF,4)) GOTO 140
55682 P(ILF+1,J)=P(ILF,J)
55691 C...Find and order initial axes with highest thrust (major).
55692 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
55695 NC=2**(MIN(MSTU(44),NP)-1)
55700 DO 200 ILF=1,MIN(MSTU(44),NP)
55701 SGN=P(N+NP+ILF+3,5)
55702 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
55704 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
55707 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
55708 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
55709 IF(TDS.LE.P(ILG,4)) GOTO 230
55711 P(ILG+1,J)=P(ILG,J)
55714 ILG=N+NP+MSTU(44)+4
55721 C...Iterate direction of axis until stable maximum.
55728 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
55729 IF(THP.GT.1D-10) TDI(J)=TPR(J)
55733 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
55735 TPR(J)=TPR(J)+SGN*P(I,J)
55738 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
55739 IF(THP.GE.THPS+PARU(48)) GOTO 270
55741 C...Save good axis. Try new initial axis until a number of tries agree.
55742 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
55743 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
55745 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55747 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
55753 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
55756 C...Find minor axis and value by orthogonality.
55757 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55758 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
55759 P(N+NP+3,2)=SGN*P(N+NP+2,1)
55763 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
55768 C...Fill axis information. Rotate back to original coordinate system.
55776 P(N+ILD,J)=P(N+NP+ILD,J)
55780 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
55782 C...Calculate thrust and oblateness. Select storing option.
55784 OBL=P(N+2,4)-P(N+3,4)
55787 IF(MSTU(43).LE.1) MSTU(3)=3
55788 IF(MSTU(43).GE.2) N=N+3
55793 C*********************************************************************
55796 C...Subdivides the particle content of an event into jets/clusters.
55798 SUBROUTINE PYCLUS(NJET)
55800 C...Double precision and integer declarations.
55801 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55802 IMPLICIT INTEGER(I-N)
55803 INTEGER PYK,PYCHGE,PYCOMP
55805 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55806 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55807 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55808 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55809 C...Local arrays and saved variables.
55811 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
55813 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
55814 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
55815 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
55816 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
55817 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
55818 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
55819 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
55821 C...If first time, reset. If reentering, skip preliminaries.
55822 IF(MSTU(48).LE.0) THEN
55828 PIMASS=PMAS(PYCOMP(211),1)
55831 IF(MSTU(43).GE.2) N=N-NJET
55832 DO 110 I=N+1,N+NJET
55833 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55835 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
55838 R2ACC=PARU(45)*PS(5)**2
55844 C...Find which particles are to be considered in cluster search.
55846 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
55847 IF(MSTU(41).GE.2) THEN
55849 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
55850 & KC.EQ.18) GOTO 140
55851 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
55854 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
55855 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
55860 C...Take copy of these particles, with space left for jets later on.
55866 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
55867 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
55868 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
55869 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55871 PS(J)=PS(J)+P(N+NP,J)
55881 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
55883 C...Very low multiplicities not considered.
55884 IF(NP.LT.MSTU(47)) THEN
55885 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
55890 C...Find precluster configuration. If too few jets, make harder cuts.
55892 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
55895 R2ACC=PARU(45)*PS(5)**2
55897 RINIT=1.25D0*PARU(43)
55898 IF(NP.LE.MSTU(47)+2) RINIT=0D0
55899 170 RINIT=0.8D0*RINIT
55902 DO 180 I=N+NP+1,N+2*NP
55906 C...Sum up small momentum region. Jet if enough absolute momentum.
55907 IF(MSTU(46).LE.2) THEN
55911 DO 210 I=N+NP+1,N+2*NP
55912 IF(P(I,5).GT.2D0*RINIT) GOTO 210
55916 P(N+1,J)=P(N+1,J)+P(I,J)
55919 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
55920 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
55921 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
55922 IF(NREM.EQ.0) GOTO 170
55925 C...Find fastest remaining particle.
55928 DO 230 I=N+NP+1,N+2*NP
55929 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
55934 P(N+NPRE,J)=P(IMAX,J)
55939 C...Sum up precluster around it according to pT separation.
55940 IF(MSTU(46).LE.2) THEN
55941 DO 260 I=N+NP+1,N+2*NP
55942 IF(K(I,4).NE.0) GOTO 260
55944 IF(R2.GT.RINIT**2) GOTO 260
55948 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
55951 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
55953 C...Sum up precluster around it according to mass or
55954 C...Durham pT separation.
55958 DO 280 I=N+NP+1,N+2*NP
55959 IF(K(I,4).NE.0) GOTO 280
55960 IF(MSTU(46).LE.4) THEN
55965 IF(R2.GE.R2MIN) GOTO 280
55971 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
55973 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
55980 C...Check if more preclusters to be found. Start over if too few.
55981 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
55982 IF(NREM.GT.0) GOTO 220
55985 C...Reassign all particles to nearest jet. Sum up new jet momenta.
55988 310 IF(MSTU(46).LE.1) THEN
55989 DO 330 I=N+1,N+NJET
55994 DO 360 I=N+NP+1,N+2*NP
55996 DO 340 IJET=N+1,N+NJET
55997 IF(P(IJET,5).LT.RINIT) GOTO 340
55999 IF(R2.GE.R2MIN) GOTO 340
56005 V(IMIN,J)=V(IMIN,J)+P(I,J)
56009 DO 380 I=N+1,N+NJET
56013 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
56018 C...Find two closest jets.
56019 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
56020 DO 400 ITRY1=N+1,N+NJET-1
56021 DO 390 ITRY2=ITRY1+1,N+NJET
56022 IF(MSTU(46).LE.2) THEN
56023 R2=R2T(ITRY1,ITRY2)
56024 ELSEIF(MSTU(46).LE.4) THEN
56025 R2=R2M(ITRY1,ITRY2)
56027 R2=R2D(ITRY1,ITRY2)
56029 IF(R2.GE.R2MIN) GOTO 390
56036 C...If allowed, join two closest jets and start over.
56037 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
56038 IREC=MIN(IMIN1,IMIN2)
56039 IDEL=MAX(IMIN1,IMIN2)
56041 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
56043 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
56044 DO 430 I=IDEL+1,N+NJET
56049 IF(MSTU(46).GE.2) THEN
56050 DO 440 I=N+NP+1,N+2*NP
56052 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
56053 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
56059 C...Divide up broad jet if empty cluster in list of final ones.
56060 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
56061 DO 450 I=N+1,N+NJET
56064 DO 460 I=N+NP+1,N+2*NP
56065 K(N+K(I,4),5)=K(N+K(I,4),5)+1
56068 DO 470 I=N+1,N+NJET
56069 IF(K(I,5).EQ.0) IEMP=I
56075 DO 480 I=N+NP+1,N+2*NP
56076 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
56079 IF(R2.LE.R2MAX) GOTO 480
56086 P(IEMP,J)=P(ISPL,J)
56087 P(IJET,J)=P(IJET,J)-P(ISPL,J)
56089 P(IEMP,5)=P(ISPL,5)
56090 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
56091 IF(NLOOP.LE.2) GOTO 300
56096 C...If generalized thrust has not yet converged, continue iteration.
56097 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
56103 C...Reorder jets according to energy.
56104 DO 510 I=N+1,N+NJET
56109 DO 540 INEW=N+1,N+NJET
56111 DO 520 ITRY=N+1,N+NJET
56112 IF(V(ITRY,4).LE.PEMAX) GOTO 520
56121 P(INEW,J)=V(IMAX,J)
56127 C...Clean up particle-jet assignments and jet information.
56128 DO 550 I=N+NP+1,N+2*NP
56131 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
56132 K(IORI,4)=K(IORI,4)+1
56136 DO 570 I=N+1,N+NJET
56139 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
56143 IF(K(I,4).EQ.0) IEMP=I
56146 C...Select storing option. Output variables. Check for failure.
56152 PARU(63)=SQRT(R2MIN)
56153 IF(NJET.LE.1) PARU(63)=0D0
56155 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
56159 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
56160 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
56166 C*********************************************************************
56169 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
56170 C...as used for calorimeters at hadron colliders.
56172 SUBROUTINE PYCELL(NJET)
56174 C...Double precision and integer declarations.
56175 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56176 IMPLICIT INTEGER(I-N)
56177 INTEGER PYK,PYCHGE,PYCOMP
56179 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56180 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56181 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56182 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56184 C...Loop over all particles. Find cell that was hit by given particle.
56185 PTLRAT=1D0/SINH(PARU(51))**2
56189 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
56190 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
56191 IF(MSTU(41).GE.2) THEN
56193 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56194 & KC.EQ.18) GOTO 110
56195 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
56199 PT=SQRT(P(I,1)**2+P(I,2)**2)
56200 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
56201 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
56202 & (ETA/PARU(51)+1D0))))
56203 PHI=PYANGL(P(I,1),P(I,2))
56204 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
56205 & (PHI/PARU(1)+1D0))))
56206 IETPH=MSTU(52)*IETA+IPHI
56208 C...Add to cell already hit, or book new cell.
56210 IF(IETPH.EQ.K(IC,3)) THEN
56216 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
56217 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
56225 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
56226 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
56230 C...Smear true bin content by calorimeter resolution.
56231 IF(MSTU(53).GE.1) THEN
56234 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
56235 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
56236 & COS(PARU(2)*PYR(0))
56237 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
56239 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
56243 C...Remove cells below threshold.
56244 IF(PARU(58).GT.0D0) THEN
56248 IF(P(IC,5).GT.PARU(58)) THEN
56260 C...Find initiator cell: the one with highest pT of not yet used ones.
56264 IF(K(IC,5).NE.2) GOTO 160
56265 IF(P(IC,5).LE.ETMAX) GOTO 160
56271 IF(ETMAX.LT.PARU(52)) GOTO 220
56272 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
56273 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
56287 C...Sum up unused cells within required distance of initiator.
56289 IF(K(IC,5).EQ.0) GOTO 170
56290 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
56291 DPHIA=ABS(P(IC,2)-PHI)
56292 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
56294 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
56295 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
56297 K(NJ,4)=K(NJ,4)+K(IC,4)
56298 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
56299 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
56300 P(NJ,5)=P(NJ,5)+P(IC,5)
56303 C...Reject cluster below minimum ET, else accept.
56304 IF(P(NJ,5).LT.PARU(53)) THEN
56307 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
56309 ELSEIF(MSTU(54).LE.2) THEN
56310 P(NJ,3)=P(NJ,3)/P(NJ,5)
56311 P(NJ,4)=P(NJ,4)/P(NJ,5)
56312 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
56315 IF(K(IC,5).LT.0) K(IC,5)=0
56322 IF(K(IC,5).GE.0) GOTO 210
56323 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
56324 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
56325 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
56326 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
56332 C...Arrange clusters in falling ET sequence.
56333 220 DO 250 I=1,NJ-NC
56336 IF(K(IJ,5).EQ.0) GOTO 230
56337 IF(P(IJ,5).LT.ETMAX) GOTO 230
56345 K(N+I,4)=K(IJMAX,4)
56348 P(N+I,J)=P(IJMAX,J)
56354 C...Convert to massless or massive four-vectors.
56355 IF(MSTU(54).EQ.2) THEN
56356 DO 260 I=N+1,N+NJET
56358 P(I,1)=P(I,5)*COS(P(I,4))
56359 P(I,2)=P(I,5)*SIN(P(I,4))
56360 P(I,3)=P(I,5)*SINH(ETA)
56361 P(I,4)=P(I,5)*COSH(ETA)
56364 ELSEIF(MSTU(54).GE.3) THEN
56365 DO 270 I=N+1,N+NJET
56366 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
56370 C...Information about storage.
56374 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
56375 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
56380 C*********************************************************************
56383 C...Determines, approximately, the two jet masses that minimize
56384 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
56386 SUBROUTINE PYJMAS(PMH,PML)
56388 C...Double precision and integer declarations.
56389 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56390 IMPLICIT INTEGER(I-N)
56391 INTEGER PYK,PYCHGE,PYCOMP
56393 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56394 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56395 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56396 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56398 DIMENSION SM(3,3),SAX(3),PS(3,5)
56411 PIMASS=PMAS(PYCOMP(211),1)
56413 C...Take copy of particles that are to be considered in mass analysis.
56415 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
56416 IF(MSTU(41).GE.2) THEN
56418 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56419 & KC.EQ.18) GOTO 170
56420 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
56423 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
56424 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
56433 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
56434 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
56435 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
56437 C...Fill information in sphericity tensor and total momentum vector.
56440 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
56443 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
56445 PS(3,J)=PS(3,J)+P(N+NP,J)
56449 C...Very low multiplicities (0 or 1) not considered.
56451 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
56456 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
56459 C...Find largest eigenvalue to matrix (third degree equation).
56462 SM(J1,J2)=SM(J1,J2)/PSS
56465 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
56466 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
56467 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
56468 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
56469 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
56470 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
56471 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
56473 C...Find largest eigenvector by solving equation system.
56475 SM(J1,J1)=SM(J1,J1)-SMA
56477 SM(J2,J1)=SM(J1,J2)
56483 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
56486 SMAX=ABS(SM(J1,J2))
56490 DO 250 J3=JA+1,JA+2
56492 RL=SM(J1,JB)/SM(JA,JB)
56494 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
56495 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
56497 SMAX=ABS(SM(J1,J2))
56501 JB2=JB+2-3*((JB+1)/3)
56502 SAX(JB1)=-SM(JC,JB2)
56503 SAX(JB2)=SM(JC,JB1)
56504 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
56506 C...Divide particles into two initial clusters by hemisphere.
56508 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
56510 IF(PSAX.LT.0D0) IS=2
56513 PS(IS,J)=PS(IS,J)+P(I,J)
56516 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
56517 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
56519 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
56523 PS(3,J)=PS(1,J)-PS(2,J)
56526 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)
56527 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
56528 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
56529 IF(PMDI.LT.PMD) THEN
56535 C...Loop back if significant reduction in sum of m^2.
56536 IF(PMD.LT.-PARU(48)*PMS) THEN
56540 PS(IS,J)=PS(IS,J)-P(IM,J)
56541 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
56547 C...Final masses and output.
56550 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
56551 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
56552 PMH=MAX(PS(1,5),PS(2,5))
56553 PML=MIN(PS(1,5),PS(2,5))
56558 C*********************************************************************
56561 C...Calculates the first few Fox-Wolfram moments.
56563 SUBROUTINE PYFOWO(H10,H20,H30,H40)
56565 C...Double precision and integer declarations.
56566 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56567 IMPLICIT INTEGER(I-N)
56568 INTEGER PYK,PYCHGE,PYCOMP
56570 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56571 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56572 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56573 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56575 C...Copy momenta for particles and calculate H0.
56580 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
56581 IF(MSTU(41).GE.2) THEN
56583 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56584 & KC.EQ.18) GOTO 110
56585 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
56588 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
56589 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
56600 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
56606 C...Very low multiplicities (0 or 1) not considered.
56608 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
56616 C...Calculate H1 - H4.
56622 DO 120 I2=I1+1,N+NP
56623 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
56624 & (P(I1,4)*P(I2,4))
56625 H10=H10+P(I1,4)*P(I2,4)*CTHE
56626 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
56627 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
56628 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
56633 C...Calculate H1/H0 - H4/H0. Output.
56636 H10=(HD+2D0*H10)/H0
56637 H20=(HD+2D0*H20)/H0
56638 H30=(HD+2D0*H30)/H0
56639 H40=(HD+2D0*H40)/H0
56644 C*********************************************************************
56647 C...Evaluates various properties of an event, with statistics
56648 C...accumulated during the course of the run and
56649 C...printed at the end.
56651 SUBROUTINE PYTABU(MTABU)
56653 C...Double precision and integer declarations.
56654 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56655 IMPLICIT INTEGER(I-N)
56656 INTEGER PYK,PYCHGE,PYCOMP
56658 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56659 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56660 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56661 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
56662 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
56663 C...Local arrays, character variables, saved variables and data.
56664 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
56665 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
56666 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
56667 &KFDM(8),KFDC(200,0:8),NPDC(200)
56668 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
56669 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
56670 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
56671 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
56672 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
56673 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
56674 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
56675 &NEVDC/0/,NKFDC/0/,NREDC/0/
56677 C...Reset statistics on initial parton state.
56678 IF(MTABU.EQ.10) THEN
56682 C...Identify and order flavour content of initial state.
56683 ELSEIF(MTABU.EQ.11) THEN
56685 KFM1=2*IABS(MSTU(161))
56686 IF(MSTU(161).GT.0) KFM1=KFM1-1
56687 KFM2=2*IABS(MSTU(162))
56688 IF(MSTU(162).GT.0) KFM2=KFM2-1
56689 KFMN=MIN(KFM1,KFM2)
56690 KFMX=MAX(KFM1,KFM2)
56692 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
56695 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
56696 & KFMX.LT.KFIS(I,2))) THEN
56702 110 IF(IKFIS.LT.0) THEN
56705 IF(NKFIS.GE.100) RETURN
56706 DO 130 I=NKFIS,IKFIS,-1
56707 KFIS(I+1,1)=KFIS(I,1)
56708 KFIS(I+1,2)=KFIS(I,2)
56710 NPIS(I+1,J)=NPIS(I,J)
56720 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
56722 C...Count number of partons in initial state.
56725 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
56726 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
56727 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
56732 IF(IM.LE.0.OR.IM.GT.N) THEN
56734 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
56736 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
56737 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
56747 IF(NP.GE.11) NPCO=8
56748 IF(NP.GE.16) NPCO=9
56749 IF(NP.GE.26) NPCO=10
56750 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
56753 C...Write statistics on initial parton state.
56754 ELSEIF(MTABU.EQ.12) THEN
56755 FAC=1D0/MAX(1,NEVIS)
56756 WRITE(MSTU(11),5000) NEVIS
56759 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
56761 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
56762 CALL PYNAME(KFM1,CHAU)
56764 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
56766 IF(KFIS(I,1).EQ.0) KFMX=0
56768 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
56769 CALL PYNAME(KFM2,CHAU)
56771 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
56772 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
56773 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
56776 C...Copy statistics on initial parton state into /PYJETS/.
56777 ELSEIF(MTABU.EQ.13) THEN
56778 FAC=1D0/MAX(1,NEVIS)
56781 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
56783 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
56785 IF(KFIS(I,1).EQ.0) KFMX=0
56787 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
56794 P(I,J)=FAC*NPIS(I,J)
56795 V(I,J)=FAC*NPIS(I,J+5)
56809 C...Reset statistics on number of particles/partons.
56810 ELSEIF(MTABU.EQ.20) THEN
56817 C...Identify whether particle/parton is primary or not.
56818 ELSEIF(MTABU.EQ.21) THEN
56822 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
56823 MSTU(62)=MSTU(62)+1
56826 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
56828 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
56830 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
56832 ELSEIF(KC.EQ.0) THEN
56833 ELSEIF(K(K(I,3),1).EQ.13) THEN
56835 IF(IM.LE.0.OR.IM.GT.N) THEN
56837 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
56840 ELSEIF(KCHG(KC,2).EQ.0) THEN
56841 KCM=PYCOMP(K(K(I,3),2))
56843 IF(KCHG(KCM,2).NE.0) MPRI=1
56846 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
56847 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
56849 IF(K(I,1).LE.10) THEN
56851 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
56854 C...Fill statistics on number of particles/partons in event.
56856 KFS=3-ISIGN(1,K(I,2))-MPRI
56858 IF(KFA.EQ.KFFS(IP)) THEN
56861 ELSEIF(KFA.LT.KFFS(IP)) THEN
56867 220 IF(IKFFS.LT.0) THEN
56870 IF(NKFFS.GE.400) RETURN
56871 DO 240 IP=NKFFS,IKFFS,-1
56872 KFFS(IP+1)=KFFS(IP)
56874 NPFS(IP+1,J)=NPFS(IP,J)
56883 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
56886 C...Write statistics on particle/parton composition of events.
56887 ELSEIF(MTABU.EQ.22) THEN
56888 FAC=1D0/MAX(1,NEVFS)
56889 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
56891 CALL PYNAME(KFFS(I),CHAU)
56894 IF(KC.NE.0) MDCYF=MDCY(KC,1)
56895 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
56896 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
56899 C...Copy particle/parton composition information into /PYJETS/.
56900 ELSEIF(MTABU.EQ.23) THEN
56901 FAC=1D0/MAX(1,NEVFS)
56907 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
56909 P(I,J)=FAC*NPFS(I,J)
56929 C...Reset factorial moments statistics.
56930 ELSEIF(MTABU.EQ.30) THEN
56936 FM1FM(IM,IB,IP)=0D0
56937 FM2FM(IM,IB,IP)=0D0
56942 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
56943 ELSEIF(MTABU.EQ.31) THEN
56948 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
56949 IF(MSTU(41).GE.2) THEN
56951 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56952 & KC.EQ.18) GOTO 410
56953 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
56954 & PYCHGE(K(I,2)).EQ.0) GOTO 410
56957 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
56958 IF(MSTU(42).GE.2) PMR=P(I,5)
56959 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
56960 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
56962 IF(ABS(YETA).GT.PARU(57)) GOTO 410
56963 PHI=PYANGL(P(I,1),P(I,2))
56964 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
56965 IYETA=MAX(0,MIN(511,IYETA))
56966 IPHI=512D0*(PHI+PARU(1))/PARU(2)
56967 IPHI=MAX(0,MIN(511,IPHI))
56970 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
56973 C...Order particles in (pseudo)rapidity and/or azimuth.
56974 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
56975 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
56979 IF(NUPP.EQ.NLOW+1) THEN
56984 DO 350 I1=NUPP-1,NLOW+1,-1
56985 IF(IYETA.GE.K(I1,1)) GOTO 360
56988 360 K(I1+1,1)=IYETA
56989 DO 370 I1=NUPP-1,NLOW+1,-1
56990 IF(IPHI.GE.K(I1,2)) GOTO 380
56994 DO 390 I1=NUPP-1,NLOW+1,-1
56995 IF(IYEP.GE.K(I1,3)) GOTO 400
57005 C...Calculate sum of factorial moments in event.
57013 IF(IM.LE.2) IBIN=2**(10-IB)
57014 IF(IM.EQ.3) IBIN=4**(10-IB)
57015 IAGR=K(NLOW+1,IM)/IBIN
57017 DO 440 I=NLOW+2,NUPP+1
57019 IF(ICUT.EQ.IAGR) THEN
57023 ELSEIF(NAGR.EQ.2) THEN
57024 FEVFM(IB,1)=FEVFM(IB,1)+2D0
57025 ELSEIF(NAGR.EQ.3) THEN
57026 FEVFM(IB,1)=FEVFM(IB,1)+6D0
57027 FEVFM(IB,2)=FEVFM(IB,2)+6D0
57028 ELSEIF(NAGR.EQ.4) THEN
57029 FEVFM(IB,1)=FEVFM(IB,1)+12D0
57030 FEVFM(IB,2)=FEVFM(IB,2)+24D0
57031 FEVFM(IB,3)=FEVFM(IB,3)+24D0
57033 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
57034 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
57035 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
57037 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
57038 & (NAGR-3D0)*(NAGR-4D0)
57046 C...Add results to total statistics.
57049 IF(FEVFM(1,IP).LT.0.5D0) THEN
57051 ELSEIF(IM.LE.2) THEN
57052 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
57054 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
57056 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
57057 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
57061 NMUFM=NMUFM+(NUPP-NLOW)
57064 C...Write accumulated statistics on factorial moments.
57065 ELSEIF(MTABU.EQ.32) THEN
57066 FAC=1D0/MAX(1,NEVFM)
57067 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
57068 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
57069 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
57071 WRITE(MSTU(11),5500)
57074 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
57076 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
57077 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
57078 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
57080 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
57081 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
57084 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
57089 C...Copy statistics on factorial moments into /PYJETS/.
57090 ELSEIF(MTABU.EQ.33) THEN
57091 FAC=1D0/MAX(1,NEVFM)
57098 IF(IM.NE.2) K(I,3)=2**(IB-1)
57100 IF(IM.NE.1) K(I,4)=2**(IB-1)
57102 P(I,1)=2D0*PARU(57)/K(I,3)
57103 V(I,1)=PARU(2)/K(I,4)
57105 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
57106 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
57122 C...Reset statistics on Energy-Energy Correlation.
57123 ELSEIF(MTABU.EQ.40) THEN
57134 C...Find particles to include, with proper assumed mass.
57135 ELSEIF(MTABU.EQ.41) THEN
57141 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
57142 IF(MSTU(41).GE.2) THEN
57144 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
57145 & KC.EQ.18) GOTO 570
57146 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
57147 & PYCHGE(K(I,2)).EQ.0) GOTO 570
57150 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
57151 IF(MSTU(42).GE.2) PMR=P(I,5)
57152 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
57153 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
57160 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
57161 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
57164 IF(NUPP.EQ.NLOW) RETURN
57166 C...Analyze Energy-Energy Correlation in event.
57167 FAC=(2D0/ECM**2)*50D0/PARU(1)
57171 DO 600 I1=NLOW+2,NUPP
57172 DO 590 I2=NLOW+1,I1-1
57173 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
57174 & (P(I1,5)*P(I2,5))
57175 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
57176 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
57177 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
57181 FE1EC(J)=FE1EC(J)+FEVEE(J)
57182 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
57183 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
57184 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
57185 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
57186 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
57190 C...Write statistics on Energy-Energy Correlation.
57191 ELSEIF(MTABU.EQ.42) THEN
57192 FAC=1D0/MAX(1,NEVEE)
57193 WRITE(MSTU(11),5700) NEVEE
57196 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
57197 FEEC2=FAC*FE1EC(51-J)
57198 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
57200 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
57201 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
57202 & FEEC2,FEES2,FEECA,FEESA
57205 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
57206 ELSEIF(MTABU.EQ.43) THEN
57207 FAC=1D0/MAX(1,NEVEE)
57214 P(I,1)=FAC*FE1EC(I)
57215 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
57216 P(I,2)=FAC*FE1EC(51-I)
57217 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
57218 P(I,3)=FAC*FE1EA(I)
57219 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
57220 P(I,4)=PARU(1)*(I-1)/50D0
57221 P(I,5)=PARU(1)*I/50D0
57236 C...Reset statistics on decay channels.
57237 ELSEIF(MTABU.EQ.50) THEN
57242 C...Identify and order flavour content of final state.
57243 ELSEIF(MTABU.EQ.51) THEN
57247 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
57254 IF(K(I,2).LT.0) KFM=KFM-1
57255 DO 650 IDS=NDS-1,1,-1
57257 IF(KFM.LT.KFDM(IDS)) GOTO 660
57258 KFDM(IDS+1)=KFDM(IDS)
57264 C...Find whether old or new final state.
57266 IF(NDS.LT.KFDC(IDC,0)) THEN
57269 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
57271 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
57274 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
57283 700 IF(IKFDC.LT.0) THEN
57285 ELSEIF(NKFDC.GE.200) THEN
57289 DO 720 IDC=NKFDC,IKFDC,-1
57290 NPDC(IDC+1)=NPDC(IDC)
57292 KFDC(IDC+1,I)=KFDC(IDC,I)
57298 KFDC(IKFDC,I)=KFDM(I)
57302 NPDC(IKFDC)=NPDC(IKFDC)+1
57304 C...Write statistics on decay channels.
57305 ELSEIF(MTABU.EQ.52) THEN
57306 FAC=1D0/MAX(1,NEVDC)
57307 WRITE(MSTU(11),5900) NEVDC
57309 DO 740 I=1,KFDC(IDC,0)
57312 IF(2*KF.NE.KFM) KF=-KF
57313 CALL PYNAME(KF,CHAU)
57315 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
57317 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
57319 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
57321 C...Copy statistics on decay channels into /PYJETS/.
57322 ELSEIF(MTABU.EQ.53) THEN
57323 FAC=1D0/MAX(1,NEVDC)
57329 K(IDC,5)=KFDC(IDC,0)
57334 DO 770 I=1,KFDC(IDC,0)
57337 IF(2*KF.NE.KFM) KF=-KF
57338 IF(I.LE.5) P(IDC,I)=KF
57339 IF(I.GE.6) V(IDC,I-5)=KF
57341 V(IDC,5)=FAC*NPDC(IDC)
57356 C...Format statements for output on unit MSTU(11) (default 6).
57357 5000 FORMAT(///20X,'Event statistics - initial state'/
57358 &20X,'based on an analysis of ',I6,' events'//
57359 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
57360 &'according to fragmenting system multiplicity'/
57361 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
57362 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
57363 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
57364 5200 FORMAT(///20X,'Event statistics - final state'/
57365 &20X,'based on an analysis of ',I7,' events'//
57366 &5X,'Mean primary multiplicity =',F10.4/
57367 &5X,'Mean final multiplicity =',F10.4/
57368 &5X,'Mean charged multiplicity =',F10.4//
57369 &5X,'Number of particles produced per event (directly and via ',
57370 &'decays/branchings)'/
57371 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
57372 &8X,'Total'/35X,'prim seco prim seco'/)
57373 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
57374 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
57375 &20X,'based on an analysis of ',I6,' events'//
57376 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
57377 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
57379 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
57380 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
57381 &20X,'based on an analysis of ',I6,' events'//
57382 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
57383 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
57384 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
57385 5900 FORMAT(///20X,'Decay channel analysis - final state'/
57386 &20X,'based on an analysis of ',I6,' events'//
57387 &2X,'Probability',10X,'Complete final state'/)
57388 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
57389 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
57390 &'or table overflow)')
57395 C*********************************************************************
57398 C...Handles the generation of an e+e- annihilation jet event.
57400 SUBROUTINE PYEEVT(KFL,ECM)
57402 C...Double precision and integer declarations.
57403 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57404 IMPLICIT INTEGER(I-N)
57405 INTEGER PYK,PYCHGE,PYCOMP
57407 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57408 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57409 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57410 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
57412 C...Check input parameters.
57413 IF(MSTU(12).GE.1) CALL PYLIST(0)
57414 IF(KFL.LT.0.OR.KFL.GT.8) THEN
57415 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
57416 IF(MSTU(21).GE.1) RETURN
57418 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
57419 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
57420 IF(ECM.LT.ECMMIN) THEN
57421 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
57422 IF(MSTU(21).GE.1) RETURN
57425 C...Check consistency of MSTJ options set.
57426 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
57428 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
57431 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
57433 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
57437 C...Initialize alpha_strong and total cross-section.
57438 MSTU(111)=MSTJ(108)
57439 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
57441 PARU(112)=PARJ(121)
57442 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
57443 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
57444 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
57446 IF(MSTJ(116).GE.3) MSTJ(116)=1
57449 C...Add initial e+e- to event record (documentation only).
57452 IF(NTRY.GT.100) THEN
57453 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
57458 IF(MSTJ(115).GE.2) THEN
57460 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
57462 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
57466 C...Radiative photon (in initial state).
57469 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
57471 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
57472 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
57474 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
57475 K(NC,3)=MIN(MSTJ(115)/2,1)
57478 C...Virtual exchange boson (gamma or Z0).
57479 IF(MSTJ(115).GE.3) THEN
57482 IF(MSTJ(102).EQ.2) KF=23
57486 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
57492 C...Choice of flavour and jet configuration.
57493 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
57494 IF(KFLC.EQ.0) GOTO 100
57495 CALL PYXJET(ECMC,NJET,CUT)
57497 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
57499 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
57500 IF(NJET.EQ.2) MSTJ(120)=1
57502 C...Fill jet configuration and origin.
57503 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
57504 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
57506 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
57507 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
57508 &-KFLC,ECMC,X1,X2,X4,X12,X14)
57509 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
57510 &-KFLC,ECMC,X1,X2,X4,X12,X14)
57511 IF(MSTU(24).NE.0) GOTO 100
57513 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
57516 C...Angular orientation according to matrix element.
57517 IF(MSTJ(106).EQ.1) THEN
57518 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
57519 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
57520 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
57523 C...Rotation and boost from radiative photon.
57525 DBEK=-PAK/(ECM-PAK)
57526 NMIN=NC+1-MSTJ(115)/3
57527 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
57528 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
57529 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
57532 C...Generate parton shower. Rearrange along strings and check.
57533 IF(MSTJ(101).EQ.5) THEN
57534 CALL PYSHOW(N-1,N,ECMC)
57536 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
57537 IF(MSTJ(105).GE.0) MSTU(28)=0
57540 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
57543 C...Fragmentation/decay generation. Information for PYTABU.
57544 IF(MSTJ(105).EQ.1) CALL PYEXEC
57551 C*********************************************************************
57554 C...Calculates total cross-section, including initial state
57555 C...radiation effects.
57557 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
57559 C...Double precision and integer declarations.
57560 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57561 IMPLICIT INTEGER(I-N)
57562 INTEGER PYK,PYCHGE,PYCOMP
57564 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57565 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57566 SAVE /PYDAT1/,/PYDAT2/
57568 C...Status, (optimized) Q^2 scale, alpha_strong.
57570 MSTJ(119)=10*MSTJ(102)+KFL
57571 IF(MSTJ(111).EQ.0) THEN
57573 ELSEIF(MSTU(111).EQ.0) THEN
57574 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
57575 & ((33D0-2D0*MSTU(112))*PARU(111)))))
57576 Q2R=PARJ(168)*ECM**2
57578 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
57579 & (2D0*PARU(112)/ECM)**2))
57580 Q2R=PARJ(168)*ECM**2
57582 ALSPI=PYALPS(Q2R)/PARU(1)
57584 C...QCD corrections factor in R.
57585 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
57587 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
57589 ELSEIF(MSTJ(109).EQ.0) THEN
57590 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
57591 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
57592 & LOG(PARJ(168))*ALSPI**2)
57593 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
57594 RQCD=1D0+(3D0/4D0)*ALSPI
57596 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
57599 C...Calculate Z0 width if default value not acceptable.
57600 IF(MSTJ(102).GE.3) THEN
57601 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
57602 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
57605 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
57606 & (2D0*PYMASS(KFLC)/ ECM)**2))
57607 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
57608 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
57609 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
57611 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
57615 C...Calculate propagator and related constants for QFD case.
57616 POLL=1D0-PARJ(131)*PARJ(132)
57617 IF(MSTJ(102).GE.2) THEN
57618 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
57619 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
57620 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
57621 VE=4D0*PARU(102)-1D0
57622 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
57623 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
57628 C...Loop over different flavours: charge, velocity.
57633 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
57634 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
57637 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
57638 QF=KCHG(KFLC,1)/3D0
57640 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
57642 C...Calculate R and sum of charges for QED or QFD case.
57643 RQQ=RQQ+3D0*QF**2*POLL
57644 IF(MSTJ(102).LE.1) THEN
57645 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
57647 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
57648 RQV=RQV-6D0*QF*VF*SF1I
57649 RVA=RVA+3D0*(VF**2+1D0)*SF1W
57650 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
57651 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
57655 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
57657 C...Calculate cross-section, including QCD corrections.
57660 PARJ(143)=RTOT*RQCD
57661 PARJ(144)=PARJ(143)
57662 PARJ(145)=PARJ(141)*86.8D0/ECM**2
57663 PARJ(146)=PARJ(142)*86.8D0/ECM**2
57664 PARJ(147)=PARJ(143)*86.8D0/ECM**2
57665 PARJ(148)=PARJ(147)
57666 PARJ(157)=RSUM*RQCD
57670 IF(MSTJ(107).LE.0) RETURN
57672 C...Virtual cross-section.
57674 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
57675 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
57676 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
57677 &1.526D0*LOG(ECM**2/0.932D0)
57679 C...Soft and hard radiative cross-section in QED case.
57680 IF(MSTJ(102).LE.1) THEN
57681 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
57682 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
57683 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
57685 C...Soft and hard radiative cross-section in QFD case.
57687 SZM=1D0-(PARJ(123)/ECM)**2
57688 SZW=PARJ(123)*PARJ(124)/ECM**2
57689 PARJ(161)=-RQQ/RSUM
57690 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
57691 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
57692 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
57693 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
57694 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
57695 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
57696 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
57697 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
57698 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
57699 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
57700 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
57701 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
57702 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
57705 C...Total cross-section and fraction of hard photon events.
57706 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
57707 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
57708 PARJ(144)=PARJ(157)
57709 PARJ(148)=PARJ(144)*86.8D0/ECM**2
57715 C*********************************************************************
57718 C...Generates initial state photon radiation.
57720 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
57722 C...Double precision and integer declarations.
57723 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57724 IMPLICIT INTEGER(I-N)
57725 INTEGER PYK,PYCHGE,PYCOMP
57727 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57730 C...Function: cumulative hard photon spectrum in QFD case.
57731 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
57732 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
57734 C...Determine whether radiative photon or not.
57737 IF(PARJ(160).LT.PYR(0)) RETURN
57740 C...Photon energy range. Find photon momentum in QED case.
57742 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
57743 IF(MSTJ(102).LE.1) THEN
57744 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
57745 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
57747 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
57749 SZM=1D0-(PARJ(123)/ECM)**2
57750 SZW=PARJ(123)*PARJ(124)/ECM**2
57753 FXKD=1D-4*(FXKU-FXKL)
57754 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
57759 IF(FXKV.GT.FXKR) THEN
57766 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
57767 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
57771 C...Photon polar and azimuthal angle.
57772 PME=2D0*(PYMASS(11)/ECM)**2
57773 120 CTHM=PME*(2D0/PME)**PYR(0)
57774 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
57775 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
57777 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
57778 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
57779 THEK=PYANGL(CTHE,STHE)
57780 PHIK=PARU(2)*PYR(0)
57782 C...Rotation angle for hadronic system.
57784 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
57786 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
57787 &(2D0-XK*(1D0-SGN*CTHE)))
57792 C*********************************************************************
57795 C...Selects flavour for produced qqbar pair.
57797 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
57799 C...Double precision and integer declarations.
57800 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57801 IMPLICIT INTEGER(I-N)
57802 INTEGER PYK,PYCHGE,PYCOMP
57804 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57805 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57806 SAVE /PYDAT1/,/PYDAT2/
57808 C...Calculate maximum weight in QED or QFD case.
57809 IF(MSTJ(102).LE.1) THEN
57812 POLL=1D0-PARJ(131)*PARJ(132)
57813 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
57814 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
57815 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
57816 VE=4D0*PARU(102)-1D0
57817 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
57818 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
57819 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
57820 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
57821 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
57825 C...Choose flavour. Gives charge and velocity.
57828 IF(NTRY.GT.100) THEN
57829 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
57834 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
57837 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
57838 QF=KCHG(KFLC,1)/3D0
57840 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
57842 C...Calculate weight in QED or QFD case.
57843 IF(MSTJ(102).LE.1) THEN
57845 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
57847 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
57848 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
57849 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
57851 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
57854 C...Weighting or new event (radiative photon). Cross-section update.
57855 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
57856 PARJ(158)=PARJ(158)+1D0
57857 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
57858 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
57859 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
57860 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
57861 PARJ(148)=PARJ(144)*86.8D0/ECM**2
57866 C*********************************************************************
57869 C...Selects number of jets in matrix element approach.
57871 SUBROUTINE PYXJET(ECM,NJET,CUT)
57873 C...Double precision and integer declarations.
57874 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57875 IMPLICIT INTEGER(I-N)
57876 INTEGER PYK,PYCHGE,PYCOMP
57878 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57880 C...Local array and data.
57882 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
57884 C...Trivial result for two-jets only, including parton shower.
57885 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
57888 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
57889 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
57891 IF(MSTJ(109).EQ.2) CF=1D0
57892 IF(MSTJ(111).EQ.0) THEN
57895 ELSEIF(MSTU(111).EQ.0) THEN
57896 PARJ(169)=MIN(1D0,PARJ(129))
57897 Q2=PARJ(169)*ECM**2
57898 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
57899 & ((33D0-2D0*MSTU(112))*PARU(111)))))
57900 Q2R=PARJ(168)*ECM**2
57902 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
57903 Q2=PARJ(169)*ECM**2
57904 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
57905 & (2D0*PARU(112)/ECM)**2))
57906 Q2R=PARJ(168)*ECM**2
57909 C...alpha_strong for R and R itself.
57910 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
57911 IF(IABS(MSTJ(101)).EQ.1) THEN
57913 ELSEIF(MSTJ(109).EQ.0) THEN
57914 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
57915 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
57916 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
57918 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
57921 C...alpha_strong for jet rate. Initial value for y cut.
57922 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
57923 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
57924 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
57925 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
57926 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
57928 C...Parametrization of first order three-jet cross-section.
57929 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
57932 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
57933 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
57934 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
57935 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
57936 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
57940 C...Parametrization of second order three-jet cross-section.
57941 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
57942 & CUT.GE.0.25D0) THEN
57944 ELSEIF(MSTJ(110).LE.1) THEN
57945 CT=LOG(1D0/CUT-2D0)
57946 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
57947 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
57949 C...Interpolation in second/first order ratio for Zhu parametrization.
57950 ELSEIF(MSTJ(110).EQ.2) THEN
57953 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
57959 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
57961 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
57964 C...Shift in second order three-jet cross-section with optimized Q^2.
57965 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
57966 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
57967 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
57969 C...Parametrization of second order four-jet cross-section.
57970 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
57973 CT=LOG(1D0/CUT-5D0)
57974 IF(CUT.LE.0.018D0) THEN
57975 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
57976 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
57978 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
57979 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
57981 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
57982 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
57983 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
57984 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
57985 & 0.002093D0*CT**3)
57986 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
57988 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
57989 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
57992 C...If negative three-jet rate, change y' optimization parameter.
57993 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
57994 & PARJ(169).LT.0.99D0) THEN
57995 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
57996 Q2=PARJ(169)*ECM**2
57997 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
58001 C...If too high cross-section, use harder cuts, or fail.
58002 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
58003 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
58004 & PARJ(169).LT.0.99D0) THEN
58005 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
58006 Q2=PARJ(169)*ECM**2
58007 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
58009 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
58011 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
58013 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
58014 & PARJ(154))**(-1D0/3D0)
58015 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
58019 C...Scalar gluon (first order only).
58021 ALSPI=PYALPS(ECM**2)/PARU(1)
58022 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
58024 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
58025 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
58030 C...Select number of jets.
58032 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
58034 ELSEIF(MSTJ(101).LE.0) THEN
58035 NJET=MIN(4,2-MSTJ(101))
58039 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
58040 IF(PARJ(154).GT.RNJ) NJET=4
58046 C*********************************************************************
58049 C...Selects the kinematical variables of three-jet events.
58051 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
58053 C...Double precision and integer declarations.
58054 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58055 IMPLICIT INTEGER(I-N)
58056 INTEGER PYK,PYCHGE,PYCOMP
58058 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58061 DIMENSION ZHUP(5,12)
58063 C...Coefficients of Zhu second order parametrization.
58064 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
58065 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
58066 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
58067 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
58068 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
58069 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
58070 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
58071 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
58072 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
58073 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
58074 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
58076 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
58077 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
58080 C...Event type. Mass effect factors and other common constants.
58084 QME=(2D0*PMQ/ECM)**2
58085 IF(MSTJ(109).NE.1) THEN
58087 CUTD=LOG(1D0/CUT-2D0)
58088 IF(MSTJ(109).EQ.0) THEN
58092 WTMX=MIN(20D0,37D0-6D0*CUTD)
58093 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
58101 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
58102 ALS2PI=PARU(118)/PARU(2)
58104 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
58105 & LOG(PARJ(169))*ALS2PI
58106 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
58108 C...Choose three-jet events in allowed region.
58110 110 Y13L=CUTL+CUTD*PYR(0)
58111 Y23L=CUTL+CUTD*PYR(0)
58115 IF(Y12.LE.CUT) GOTO 110
58116 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
58118 C...Second order corrections.
58119 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
58124 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
58125 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
58126 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
58127 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
58128 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
58129 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
58130 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
58131 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
58132 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
58133 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
58134 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
58135 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
58136 & TR*(2D0*CUTL/3D0-10D0/9D0)+
58137 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
58138 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
58139 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
58140 & Y13*Y23)/(Y12+Y13)**2)/WT1+
58141 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
58142 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
58143 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
58144 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
58145 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
58146 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
58147 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
58148 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
58149 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
58150 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
58152 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
58153 C...Second order corrections; Zhu parametrization of ERT.
58158 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
58162 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
58163 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
58164 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
58165 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
58168 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
58169 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
58170 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
58171 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
58173 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
58174 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
58175 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
58176 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
58177 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
58179 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
58180 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
58181 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
58184 C...Impose mass cuts (gives two jets). For fixed jet number new try.
58188 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
58189 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
58190 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
58191 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
58192 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
58194 C...Scalar gluon model (first order only, no mass effects).
58197 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
58198 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
58199 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
58200 X1=1D0-0.5D0*(X3+YD)
58201 X2=1D0-0.5D0*(X3-YD)
58202 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
58203 IF(MSTJ(102).GE.2) THEN
58204 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
58205 & X3**2*PYR(0)) NJET=2
58207 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
58213 C*********************************************************************
58216 C...Selects the kinematical variables of four-jet events.
58218 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
58220 C...Double precision and integer declarations.
58221 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58222 IMPLICIT INTEGER(I-N)
58223 INTEGER PYK,PYCHGE,PYCOMP
58225 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58228 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
58230 C...Common constants. Colour factors for QCD and Abelian gluon theory.
58232 QME=(2D0*PMQ/ECM)**2
58233 CT=LOG(1D0/CUT-5D0)
58234 IF(MSTJ(109).EQ.0) THEN
58244 C...Choice of process (qqbargg or qqbarqqbar).
58247 IF(PARJ(155).GT.PYR(0)) IT=2
58248 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
58249 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
58250 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
58251 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
58254 C...Sample the five kinematical variables (for qqgg preweighted in y34).
58255 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
58256 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
58257 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
58258 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
58259 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
58261 CP=COS(PARU(1)*PYR(0))
58264 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
58265 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
58266 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
58268 Y12=1D0-Y134-Y23-Y24
58269 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
58273 C...Calculate matrix elements for qqgg or qqqq process.
58278 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
58279 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
58280 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
58281 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
58282 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
58283 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
58284 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
58285 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
58286 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
58287 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
58288 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
58289 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
58290 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
58291 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
58292 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
58293 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
58294 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
58295 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
58296 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
58297 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
58298 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
58299 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
58300 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
58301 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
58302 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
58303 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
58304 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
58305 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
58306 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
58307 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
58308 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
58309 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
58310 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
58311 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
58312 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
58313 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
58314 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
58315 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
58316 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
58317 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
58318 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
58321 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
58322 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
58323 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
58324 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
58325 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
58326 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
58327 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
58328 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
58329 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
58330 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
58331 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
58332 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
58333 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
58334 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
58335 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
58336 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
58337 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
58338 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
58341 C...Permutations of momenta in matrix element. Weighting.
58342 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
58353 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
58364 IF(IC.LE.3) GOTO 120
58365 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
58368 C...qqgg events: string configuration and event type.
58370 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
58371 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
58372 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
58373 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
58374 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
58375 IF(ID.EQ.2) GOTO 130
58376 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
58377 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
58378 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
58379 IF(ID.EQ.2) GOTO 130
58382 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
58383 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
58386 C...Mass cuts. Kinematical variables out.
58387 IF(Y12.LE.CUT+QME) NJET=2
58388 IF(NJET.EQ.2) GOTO 150
58389 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
58390 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
58391 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
58393 X12=(1D0-Q12)*Y13+Q12*Y23
58395 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
58397 C...qqbarqqbar events: string configuration, choose new flavour.
58400 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
58401 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
58402 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
58403 IF(WTR.LT.WTD(4)) ID=4
58404 IF(ID.GE.2) GOTO 130
58407 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
58408 140 KFLN=1+INT(5D0*PYR(0))
58409 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
58410 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
58411 IF(KFLN.GT.MSTJ(104)) NJET=2
58413 QMEN=(2D0*PMQN/ECM)**2
58415 C...Mass cuts. Kinematical variables out.
58416 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
58417 IF(NJET.EQ.2) GOTO 150
58418 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
58419 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
58420 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
58421 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
58422 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
58423 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
58426 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
58428 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
58429 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
58430 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
58432 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
58437 C*********************************************************************
58440 C...Gives the angular orientation of events.
58442 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
58444 C...Double precision and integer declarations.
58445 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58446 IMPLICIT INTEGER(I-N)
58447 INTEGER PYK,PYCHGE,PYCOMP
58449 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58450 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58451 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58452 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58454 C...Charge. Factors depending on polarization for QED case.
58456 POLL=1D0-PARJ(131)*PARJ(132)
58457 POLD=PARJ(132)-PARJ(131)
58458 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
58464 C...Factors depending on flavour, energy and polarization for QFD case.
58466 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
58467 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
58468 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
58470 VE=4D0*PARU(102)-1D0
58472 VF=AF-4D0*QF*PARU(102)
58473 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
58474 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
58475 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
58476 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
58477 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
58478 & SFW*SFF**2*(VE**2-AE**2))
58479 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
58483 C...Mass factor. Differential cross-sections for two-jet events.
58486 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
58487 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
58489 SIGU=4D0*SQRT(1D0-QME)
58490 SIGL=2D0*QME*SQRT(1D0-QME)
58496 C...Kinematical variables. Reduce four-jet event to three-jet one.
58499 X1=2D0*P(NC+1,4)/ECM
58500 X2=2D0*P(NC+3,4)/ECM
58502 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
58503 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
58504 X1=2D0*P(NC+1,4)/ECMR
58505 X2=2D0*P(NC+4,4)/ECMR
58508 C...Differential cross-sections for three-jet (or reduced four-jet).
58509 XQ=(1D0-X1)/(1D0-X2)
58510 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
58511 ST12=SQRT(1D0-CT12**2)
58512 IF(MSTJ(109).NE.1) THEN
58513 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
58514 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
58515 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
58516 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
58518 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
58519 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
58520 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
58521 SIGA=X2**2*ST12/SQ2
58522 SIGP=2D0*(X1**2-X2**2*CT12)
58524 C...Differential cross-sect for scalar gluons (no mass effects).
58528 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
58529 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
58530 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
58531 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
58532 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
58533 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
58534 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
58535 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
58536 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
58537 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
58538 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
58542 C...Upper bounds for differential cross-section.
58547 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
58548 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
58549 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
58550 &2D0*HF2A*ABS(SIGP)
58552 C...Generate angular orientation according to differential cross-sect.
58553 100 CHI=PARU(2)*PYR(0)
58554 CTHE=2D0*PYR(0)-1D0
58562 C2PHI=COS(2D0*(PHI-PARJ(134)))
58563 S2PHI=SIN(2D0*(PHI-PARJ(134)))
58564 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
58565 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
58566 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
58567 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
58568 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
58569 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
58570 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
58571 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
58576 C*********************************************************************
58579 C...Generates Upsilon and toponium decays into three gluons
58580 C...or two gluons and a photon.
58582 SUBROUTINE PYONIA(KFL,ECM)
58584 C...Double precision and integer declarations.
58585 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58586 IMPLICIT INTEGER(I-N)
58587 INTEGER PYK,PYCHGE,PYCOMP
58589 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58590 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58591 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58592 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58594 C...Printout. Check input parameters.
58595 IF(MSTU(12).GE.1) CALL PYLIST(0)
58596 IF(KFL.LT.0.OR.KFL.GT.8) THEN
58597 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
58598 IF(MSTU(21).GE.1) RETURN
58600 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
58601 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
58602 IF(MSTU(21).GE.1) RETURN
58605 C...Initial e+e- and onium state (optional).
58607 IF(MSTJ(115).GE.2) THEN
58609 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
58611 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
58615 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
58621 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
58627 C...Choose x1 and x2 according to matrix element.
58632 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
58633 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
58636 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
58637 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
58639 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
58640 MSTU(111)=MSTJ(108)
58641 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
58643 PARU(112)=PARJ(121)
58644 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
58646 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
58647 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
58650 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
58651 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
58653 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
58654 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
58657 ECMC=SQRT(1D0-X1)*ECM
58658 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
58663 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
58664 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
58665 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
58666 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
58668 IF(ECMC.LT.4D0*PARJ(127)) THEN
58672 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
58678 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
58681 C...Differential cross-sections. Upper limit for cross-section.
58682 IF(MSTJ(106).EQ.1) THEN
58684 HF1=1D0-PARJ(131)*PARJ(132)
58686 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
58687 ST13=SQRT(1D0-CT13**2)
58688 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
58689 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
58691 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
58692 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
58693 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
58695 C...Angular orientation of event.
58696 120 CHI=PARU(2)*PYR(0)
58697 CTHE=2D0*PYR(0)-1D0
58705 C2PHI=COS(2D0*(PHI-PARJ(134)))
58706 S2PHI=SIN(2D0*(PHI-PARJ(134)))
58707 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
58708 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
58709 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
58710 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
58711 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
58712 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
58713 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
58714 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
58717 C...Generate parton shower. Rearrange along strings and check.
58718 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
58719 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
58721 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
58722 IF(MSTJ(105).GE.0) MSTU(28)=0
58725 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
58728 C...Generate fragmentation. Information for PYTABU:
58729 IF(MSTJ(105).EQ.1) CALL PYEXEC
58730 MSTU(161)=110*KFLC+3
58736 C*********************************************************************
58739 C...Books a histogram.
58741 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
58743 C...Double precision declaration.
58744 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58745 IMPLICIT INTEGER(I-N)
58747 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58749 C...Local character variables.
58750 CHARACTER TITLE*(*), TITFX*60
58752 C...Check that input is sensible. Find initial address in memory.
58753 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
58754 &'(PYBOOK:) not allowed histogram number')
58755 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
58756 &'(PYBOOK:) not allowed number of bins')
58757 IF(XL.GE.XU) CALL PYERRM(28,
58758 &'(PYBOOK:) x limits in wrong order')
58760 IHIST(4)=IHIST(4)+28+NX
58761 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
58762 &'(PYBOOK:) out of histogram space')
58765 C...Store histogram size and reset contents.
58769 BIN(IS+4)=(XU-XL)/NX
58772 C...Store title by conversion to integer to double precision.
58775 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
58776 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
58782 C*********************************************************************
58785 C...Fills entry in histogram.
58787 SUBROUTINE PYFILL(ID,X,W)
58789 C...Double precision declaration.
58790 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58791 IMPLICIT INTEGER(I-N)
58793 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58796 C...Find initial address in memory. Increase number of entries.
58797 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
58798 &'(PYFILL:) not allowed histogram number')
58800 IF(IS.EQ.0) CALL PYERRM(28,
58801 &'(PYFILL:) filling unbooked histogram')
58802 BIN(IS+5)=BIN(IS+5)+1D0
58804 C...Find bin in x, including under/overflow, and fill.
58805 IF(X.LT.BIN(IS+2)) THEN
58806 BIN(IS+6)=BIN(IS+6)+W
58807 ELSEIF(X.GE.BIN(IS+3)) THEN
58808 BIN(IS+8)=BIN(IS+8)+W
58810 BIN(IS+7)=BIN(IS+7)+W
58811 IX=(X-BIN(IS+2))/BIN(IS+4)
58812 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
58813 BIN(IS+9+IX)=BIN(IS+9+IX)+W
58819 C*********************************************************************
58822 C...Multiplies histogram contents by factor.
58824 SUBROUTINE PYFACT(ID,F)
58826 C...Double precision declaration.
58827 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58828 IMPLICIT INTEGER(I-N)
58830 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58833 C...Find initial address in memory. Multiply all contents bins.
58834 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
58835 &'(PYFACT:) not allowed histogram number')
58837 IF(IS.EQ.0) CALL PYERRM(28,
58838 &'(PYFACT:) scaling unbooked histogram')
58839 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
58846 C*********************************************************************
58849 C...Performs operations between histograms.
58851 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
58853 C...Double precision declaration.
58854 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58855 IMPLICIT INTEGER(I-N)
58857 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58859 C...Character variable.
58862 C...Find initial addresses in memory, and histogram size.
58863 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
58864 &'(PYFACT:) not allowed histogram number')
58866 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
58867 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
58868 NX=NINT(BIN(IS3+1))
58869 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
58871 C...Update info on number of histogram entries.
58872 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
58873 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
58874 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
58875 BIN(IS3+5)=BIN(IS1+5)
58878 C...Operations on pair of histograms: addition, subtraction,
58879 C...multiplication, division.
58880 IF(OPER.EQ.'+') THEN
58882 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
58884 ELSEIF(OPER.EQ.'-') THEN
58886 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
58888 ELSEIF(OPER.EQ.'*') THEN
58890 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
58892 ELSEIF(OPER.EQ.'/') THEN
58895 IF(ABS(FA2).LE.1D-20) THEN
58898 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
58902 C...Operations on single histogram: multiplication+addition,
58903 C...square root+addition, logarithm+addition.
58904 ELSEIF(OPER.EQ.'A') THEN
58906 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
58908 ELSEIF(OPER.EQ.'S') THEN
58910 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
58912 ELSEIF(OPER.EQ.'L') THEN
58915 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
58916 & ZMIN=0.8D0*BIN(IS1+IX)
58919 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
58922 C...Operation on two or three histograms: average and
58923 C...standard deviation.
58924 ELSEIF(OPER.EQ.'M') THEN
58926 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
58929 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
58932 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
58935 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
58939 BIN(IS1+IX)=F1*BIN(IS1+IX)
58946 C*********************************************************************
58949 C...Prints and resets all histograms.
58953 C...Double precision declaration.
58954 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58955 IMPLICIT INTEGER(I-N)
58957 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58960 C...Loop over histograms, print and reset used ones.
58961 DO 100 ID=1,IHIST(1)
58963 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
58972 C*********************************************************************
58975 C...Prints a histogram (but does not reset it).
58977 SUBROUTINE PYPLOT(ID)
58979 C...Double precision declaration.
58980 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58981 IMPLICIT INTEGER(I-N)
58983 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58984 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58985 SAVE /PYDAT1/,/PYBINS/
58986 C...Local arrays and character variables.
58987 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
58988 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
58990 C...Steps in histogram scale. Character sequence.
58991 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
58992 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
58994 C...Find initial address in memory; skip if empty histogram.
58995 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
58998 IF(NINT(BIN(IS+5)).LE.0) THEN
58999 WRITE(MSTU(11),5000) ID
59003 C...Number of histogram lines and x bins.
59007 C...Extract title by conversion from double precision via integer.
59009 IEQ=NINT(BIN(IS+8+NX+IT))
59010 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
59011 & //CHAR(MOD(IEQ,256))
59014 C...Find time; print title.
59016 IF(IDATI(1).GT.0) THEN
59017 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
59019 WRITE(MSTU(11),5200) ID, TITLE
59022 C...Find minimum and maximum bin content.
59025 DO 110 IX=IS+10,IS+8+NX
59026 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
59027 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
59030 C...Determine scale and step size for y axis.
59031 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
59032 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
59033 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
59034 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
59035 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
59036 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
59039 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
59043 C...Convert bin contents to integer form; fractional fill in top row.
59045 CTA=ABS(BIN(IS+8+IX))/DY
59046 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
59047 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
59049 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
59050 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
59052 C...Print histogram row by row.
59053 DO 150 IR=IRMA,IRMI,-1
59054 IF(IR.EQ.0) GOTO 150
59057 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
59058 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
59060 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
59063 C...Print sign and value of bin contents.
59064 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
59067 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
59068 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
59070 WRITE(MSTU(11),5400) OUT
59073 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
59075 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
59078 C...Print sign and value of lower bin edge.
59079 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
59083 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
59084 & OUT(IX:IX)=CHA(11)
59085 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
59087 WRITE(MSTU(11),5600) OUT
59090 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
59092 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
59096 C...Calculate and print statistics.
59101 CTA=ABS(BIN(IS+8+IX))
59102 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
59105 CXXSUM=CXXSUM+CTA*X**2
59107 XMEAN=CXSUM/MAX(CSUM,1D-20)
59108 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
59109 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
59110 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
59112 C...Formats for output.
59113 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
59114 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
59116 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
59117 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
59118 5400 FORMAT(/8X,'Contents',3X,A100)
59119 5500 FORMAT(9X,'*10**',I2,3X,A100)
59120 5600 FORMAT(/8X,'Low edge',3X,A100)
59121 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
59122 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
59123 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
59128 C*********************************************************************
59131 C...Resets bin contents of a histogram.
59133 SUBROUTINE PYNULL(ID)
59135 C...Double precision declaration.
59136 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59137 IMPLICIT INTEGER(I-N)
59139 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
59142 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
59145 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
59152 C*********************************************************************
59155 C...Dumps histogram contents on file for reading by other program.
59156 C...Can also read back own dump.
59158 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
59160 C...Double precision declaration.
59161 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59162 IMPLICIT INTEGER(I-N)
59164 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
59166 C...Local arrays and character variables.
59167 DIMENSION IHI(*),ISS(100),VAL(5)
59168 CHARACTER TITLE*60,FORMAT*13
59170 C...Dump all histograms that have been booked,
59171 C...including titles and ranges, one after the other.
59172 IF(MDUMP.EQ.1) THEN
59174 C...Loop over histograms and find which are wanted and booked.
59189 C...Write title, histogram size, filling statistics.
59192 IEQ=NINT(BIN(IS+8+NX+IT))
59193 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
59194 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
59196 WRITE(LFN,5100) ID,TITLE
59197 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
59198 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
59202 C...Write histogram contents, in groups of five.
59203 DO 120 IXG=1,(NX+4)/5
59207 VAL(IXV)=BIN(IS+8+IX)
59212 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
59215 C...Go to next histogram; finish.
59216 ELSEIF(NHI.GT.0) THEN
59217 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
59221 C...Read back in histograms dumped MDUMP=1.
59222 ELSEIF(MDUMP.EQ.2) THEN
59224 C...Read histogram number, title and range, and book.
59225 140 READ(LFN,5100,END=170) ID,TITLE
59226 READ(LFN,5200) NX,XL,XU
59227 CALL PYBOOK(ID,TITLE,NX,XL,XU)
59230 C...Read filling statistics.
59231 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
59232 BIN(IS+5)=DBLE(NENTRY)
59234 C...Read histogram contents, in groups of five.
59235 DO 160 IXG=1,(NX+4)/5
59236 READ(LFN,5400) (VAL(IXV),IXV=1,5)
59239 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
59243 C...Go to next histogram; finish.
59247 C...Write histogram contents in column format,
59248 C...convenient e.g. for GNUPLOT input.
59249 ELSEIF(MDUMP.EQ.3) THEN
59251 C...Find addresses to wanted histograms.
59265 IF(IS.NE.0.AND.NSS.LT.100) THEN
59268 ELSEIF(NSS.GE.100) THEN
59269 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
59270 ELSEIF(NHI.GT.0) THEN
59271 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
59275 C...Check that they have common number of x bins. Fix format.
59276 NX=NINT(BIN(ISS(1)+1))
59278 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
59279 CALL PYERRM(8,'(PYDUMP:) different number of bins')
59283 FORMAT='(1P,000E12.4)'
59284 WRITE(FORMAT(5:7),'(I3)') NSS+1
59286 C...Write histogram contents; first column x values.
59288 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
59289 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
59294 C...Formats for output.
59295 5100 FORMAT(I5,5X,A60)
59296 5200 FORMAT(I5,1P,2D12.4)
59297 5300 FORMAT(I12,1P,3D12.4)
59298 5400 FORMAT(1P,5D12.4)
59303 C*********************************************************************
59306 C...Dummy routine, which the user can replace in order to make cuts on
59307 C...the kinematics on the parton level before the matrix elements are
59308 C...evaluated and the event is generated. The cross-section estimates
59309 C...will automatically take these cuts into account, so the given
59310 C...values are for the allowed phase space region only. MCUT=0 means
59311 C...that the event has passed the cuts, MCUT=1 that it has failed.
59313 SUBROUTINE PYKCUT(MCUT)
59315 C...Double precision and integer declarations.
59316 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59317 IMPLICIT INTEGER(I-N)
59318 INTEGER PYK,PYCHGE,PYCOMP
59320 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59321 COMMON/PYINT1/MINT(400),VINT(400)
59322 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
59323 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
59325 C...Set default value (accepting event) for MCUT.
59328 C...Read out subprocess number.
59332 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
59336 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
59338 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
59340 C...Calculate x_1, x_2, x_F.
59341 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
59342 X1=SQRT(TAU)*EXP(YST)
59343 X2=SQRT(TAU)*EXP(-YST)
59345 X1=SQRT(TAUP)*EXP(YST)
59346 X2=SQRT(TAUP)*EXP(-YST)
59350 C...Calculate shat, that, uhat, p_T^2.
59356 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
59357 RPTS=4D0*VINT(71)**2/SHAT
59358 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
59361 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
59362 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
59363 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
59364 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
59366 C...Decisions by user to be put here.
59368 C...Stop program if this routine is ever called.
59369 C...You should not copy these lines to your own routine.
59370 WRITE(MSTU(11),5000)
59371 IF(PYR(0).LT.10D0) STOP
59373 C...Format for error printout.
59374 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
59375 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
59376 &1X,'Execution stopped!')
59381 C*********************************************************************
59384 C...Dummy routine, which the user can replace in order to multiply the
59385 C...standard PYTHIA differential cross-section by a process- and
59386 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
59387 C...to generation of weighted events, with weight 1/WTXS, while for
59388 C...MSTP(142)=2 it corresponds to a modification of the underlying
59391 SUBROUTINE PYEVWT(WTXS)
59393 C...Double precision and integer declarations.
59394 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59395 IMPLICIT INTEGER(I-N)
59396 INTEGER PYK,PYCHGE,PYCOMP
59398 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59399 COMMON/PYINT1/MINT(400),VINT(400)
59400 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
59401 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
59403 C...Set default weight for WTXS.
59406 C...Read out subprocess number.
59410 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
59414 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
59416 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
59418 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
59427 C...Modifications by user to be put here.
59429 C...Stop program if this routine is ever called.
59430 C...You should not copy these lines to your own routine.
59431 WRITE(MSTU(11),5000)
59432 IF(PYR(0).LT.10D0) STOP
59434 C...Format for error printout.
59435 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
59436 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
59437 &1X,'Execution stopped!')
59442 C*********************************************************************
59445 C...Dummy routine, to be replaced by a user implementing external
59446 C...processes. Is supposed to fill the HEPRUP commonblock with info
59447 C...on incoming beams and allowed processes.
59451 C...Double precision and integer declarations.
59452 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59453 IMPLICIT INTEGER(I-N)
59455 C...User process initialization commonblock.
59457 PARAMETER (MAXPUP=100)
59458 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
59459 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
59460 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
59461 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
59468 C*********************************************************************
59471 C...Dummy routine, to be replaced by a user implementing external
59472 C...processes. Depending on cross section model chosen, it either has
59473 C...to generate a process of the type IDPRUP requested, or pick a type
59474 C...itself and generate this event. The event is to be stored in the
59475 C...HEPEUP commonblock, including (often) an event weight.
59479 C...Double precision and integer declarations.
59480 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59481 IMPLICIT INTEGER(I-N)
59483 C...User process event common block.
59485 PARAMETER (MAXNUP=500)
59486 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
59487 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
59488 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
59489 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
59490 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
59496 C*********************************************************************
59498 C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
59500 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
59501 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59502 IMPLICIT INTEGER(I-N)
59503 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
59506 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59509 C...Stop program if this routine is ever called.
59510 WRITE(MSTU(11),5000)
59511 IF(PYR(0).LT.10D0) STOP
59513 C...Format for error printout.
59514 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
59515 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
59516 &1X,'Execution stopped!')
59521 C*********************************************************************
59524 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
59527 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59528 IMPLICIT INTEGER(I-N)
59529 CHARACTER*40 VISAJE
59532 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59535 C...Assign default value.
59538 C...Stop program if this routine is ever called.
59539 WRITE(MSTU(11),5000)
59540 IF(PYR(0).LT.10D0) STOP
59542 C...Format for error printout.
59543 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
59544 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
59545 &1X,'Execution stopped!')
59550 C*********************************************************************
59553 C...Dummy routine, to be replaced by user, to handle the decay of a
59554 C...polarized tau lepton.
59556 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
59557 C...IORIG is the position where the mother of the tau is stored;
59558 C... is 0 when the mother is not stored.
59559 C...KFORIG is the flavour of the mother of the tau;
59560 C... is 0 when the mother is not known.
59561 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
59562 C... e.g. in B hadron semileptonic decays the W propagator
59563 C... is not explicitly stored but the W code is still unambiguous.
59565 C...NDECAY is the number of decay products in the current tau decay.
59566 C...These decay products should be added to the /PYJETS/ common block,
59567 C...in positions N+1 through N+NDECAY. For each product I you must
59568 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
59569 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
59571 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
59573 C...Double precision and integer declarations.
59574 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59575 IMPLICIT INTEGER(I-N)
59576 INTEGER PYK,PYCHGE,PYCOMP
59578 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59579 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59580 SAVE /PYJETS/,/PYDAT1/
59582 C...Stop program if this routine is ever called.
59583 C...You should not copy these lines to your own routine.
59584 NDECAY=ITAU+IORIG+KFORIG
59585 WRITE(MSTU(11),5000)
59586 IF(PYR(0).LT.10D0) STOP
59588 C...Format for error printout.
59589 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
59590 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
59591 &1X,'Execution stopped!')
59596 C*********************************************************************
59599 C...Finds current date and time.
59600 C...Since this task is not standardized in Fortran 77, the routine
59601 C...is dummy, to be replaced by the user. Examples are given for
59602 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
59603 C...you do not have access to suitable routines.
59605 SUBROUTINE PYTIME(IDATI)
59607 C...Double precision and integer declarations.
59608 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59609 IMPLICIT INTEGER(I-N)
59610 INTEGER PYK,PYCHGE,PYCOMP
59613 INTEGER IDATI(6),IDTEMP(3)
59615 C...Example 0: if you do not have suitable routines.
59620 C...Example 1: Fortran 90 routine.
59622 C CALL DATE_AND_TIME(VALUES=IVAL)
59630 C...Example 2: DEC Fortran 77. AIX.
59631 C CALL IDATE(IMON,IDAY,IYEAR)
59635 C CALL ITIME(IHOUR,IMIN,ISEC)
59640 C...Example 3: DEC Fortran, IRIX, IRIX64.
59641 C CALL IDATE(IMON,IDAY,IYEAR)
59649 C READ(ATIME(1:2),'(I2)') IHOUR
59650 C READ(ATIME(4:5),'(I2)') IMIN
59651 C READ(ATIME(7:8),'(I2)') ISEC
59656 C...Example 4: GNU LINUX libU77, SunOS.
59666 C...Common code to ensure right century.
59667 IDATI(1)=2000+MOD(IDATI(1),100)
git://git.uio.no / u / mrichter / AliRoot.git / blob