1 C*********************************************************************
2 C*********************************************************************
6 C* The Lund Monte Carlo **
8 C* PYTHIA version 6.2 **
10 C* Torbjorn Sjostrand **
11 C* Department of Theoretical Physics **
13 C* Solvegatan 14A, S-223 62 Lund, Sweden **
14 C* phone +46 - 46 - 222 48 16 **
15 C* E-mail torbjorn@thep.lu.se **
17 C* SUSY and Technicolor parts by **
19 C* Computing Division, Simulations Group **
20 C* Fermi National Accelerator Laboratory **
21 C* MS 234, Batavia, IL 60510, USA **
22 C* phone + 1 - 630 - 840 - 2556 **
23 C* E-mail mrenna@fnal.gov **
25 C* Baryon and lepton number violation parts by **
27 C* Department of Theoretical Physics **
29 C* Solvegatan 14A, S-223 62 Lund, Sweden **
30 C* phone +46 - 46 - 222 31 92 **
31 C* E-mail zeiler@thep.lu.se **
33 C* PYTHIA 7 efforts coordinated by **
35 C* Department of Theoretical Physics **
37 C* Solvegatan 14A, S-223 62 Lund, Sweden **
38 C* phone +46 - 46 - 222 77 80 **
39 C* E-mail leif@thep.lu.se **
41 C* Several parts are written by Hans-Uno Bengtsson **
42 C* PYSHOW is written together with Mats Bengtsson **
43 C* PYMAEL is written by Emanuel Norrbin **
44 C* advanced popcorn baryon production written by Patrik Eden **
45 C* code for virtual photons mainly written by Christer Friberg **
46 C* code for low-mass strings mainly written by Emanuel Norrbin **
47 C* Bose-Einstein code mainly written by Leif Lonnblad **
48 C* CTEQ parton distributions are by the CTEQ collaboration **
49 C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
50 C* SaS photon parton distributions together with Gerhard Schuler **
51 C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
52 C* MSSM Higgs mass calculation code by M. Carena, **
53 C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
54 C* PYGAUS adapted from CERN library (K.S. Kolbig) **
56 C* The latest program version and documentation is found on WWW **
57 C* http://www.thep.lu.se/~torbjorn/Pythia.html **
59 C* Copyright Torbjorn Sjostrand, Lund 2003 **
61 C*********************************************************************
62 C*********************************************************************
64 C List of subprograms in order of appearance, with main purpose *
65 C (S = subroutine, F = function, B = block data) *
67 C B PYDATA to contain all default values *
68 C S PYTEST to test the proper functioning of the package *
69 C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
71 C S PYINIT to administer the initialization procedure *
72 C S PYEVNT to administer the generation of an event *
73 C S PYSTAT to print cross-section and other information *
74 C S PYINRE to initialize treatment of resonances *
75 C S PYINBM to read in beam, target and frame choices *
76 C S PYINKI to initialize kinematics of incoming particles *
77 C S PYINPR to set up the selection of included processes *
78 C S PYXTOT to give total, elastic and diffractive cross-sect. *
79 C S PYMAXI to find differential cross-section maxima *
80 C S PYPILE to select multiplicity of pileup events *
81 C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
82 C S PYGAGA to handle lepton -> lepton + gamma branchings *
83 C S PYRAND to select subprocess and kinematics for event *
84 C S PYSCAT to set up kinematics and colour flow of event *
85 C S PYSSPA to simulate initial state spacelike showers *
86 C S PYMEMX auxiliary to PYSSPA for ME correction maximum *
87 C S PYMEWT auxiliary to PYSSPA for matrix element correction *
88 C S PYADSH to administrate sequential final-state showers *
89 C S PYRESD to perform resonance decays *
90 C S PYMULT to generate multiple interactions *
91 C S PYREMN to add on target remnants *
92 C S PYDIFF to set up kinematics for diffractive events *
93 C S PYDISG to set up kinematics, remnant and showers for DIS *
94 C S PYDOCU to compute cross-sections and handle documentation *
95 C S PYFRAM to perform boosts between different frames *
96 C S PYWIDT to calculate full and partial widths of resonances *
97 C S PYOFSH to calculate partial width into off-shell channels *
98 C S PYRECO to handle colour reconnection in W+W- events *
99 C S PYKLIM to calculate borders of allowed kinematical region *
100 C S PYKMAP to construct value of kinematical variable *
101 C S PYSIGH to calculate differential cross-sections *
102 C S PYPDFU to evaluate parton distributions *
103 C S PYPDFL to evaluate parton distributions at low x and Q^2 *
104 C S PYPDEL to evaluate electron parton distributions *
105 C S PYPDGA to evaluate photon parton distributions (generic) *
106 C S PYGGAM to evaluate photon parton distributions (SaS sets) *
107 C S PYGVMD to evaluate VMD part of photon parton distributions *
108 C S PYGANO to evaluate anomalous part of photon pdf's *
109 C S PYGBEH to evaluate Bethe-Heitler part of photon pdf's *
110 C S PYGDIR to evaluate direct contribution to photon pdf's *
111 C S PYPDPI to evaluate pion parton distributions *
112 C S PYPDPR to evaluate proton parton distributions *
113 C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
114 C S PYGRVL to evaluate the GRV 94L proton parton distributions *
115 C S PYGRVM to evaluate the GRV 94M proton parton distributions *
116 C S PYGRVD to evaluate the GRV 94D proton parton distributions *
117 C F PYGRVV auxiliary to the PYGRV* routines *
118 C F PYGRVW auxiliary to the PYGRV* routines *
119 C F PYGRVS auxiliary to the PYGRV* routines *
120 C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
121 C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
122 C S PYPDPO to evaluate old proton parton distributions *
123 C F PYHFTH to evaluate threshold factor for heavy flavour *
124 C S PYSPLI to find flavours left in hadron when one removed *
125 C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
126 C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
127 C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
128 C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
129 C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
131 C S PYMSIN to initialize the supersymmetry simulation *
132 C S PYAPPS to determine MSSM parameters from SUGRA input *
133 C S PYSUGI to determine MSSM parameters using ISASUSY *
134 C F PYRNMQ to determine running squark masses *
135 C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
136 C S PYINOM to calculate neutralino/chargino mass eigenstates *
137 C F PYRNM3 to determine running M3, gluino mass *
138 C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
139 C S PYHGGM to determine Higgs mass spectrum *
140 C S PYSUBH to determine Higgs masses in the MSSM *
141 C S PYPOLE to determine Higgs masses in the MSSM *
142 C S PYRGHM auxiliary to PYPOLE *
143 C S PYGFXX auxiliary to PYRGHM *
144 C F PYFINT auxiliary to PYPOLE *
145 C F PYFISB auxiliary to PYFINT *
146 C S PYSFDC to calculate sfermion decay partial widths *
147 C S PYGLUI to calculate gluino decay partial widths *
148 C S PYTBBN to calculate 3-body decay of gluino to neutralino *
149 C S PYTBBC to calculate 3-body decay of gluino to chargino *
150 C S PYNJDC to calculate neutralino decay partial widths *
151 C S PYCJDC to calculate chargino decay partial widths *
152 C F PYXXZ6 auxiliary for ino 3-body decays *
153 C F PYXXGA auxiliary for ino -> ino + gamma decay *
154 C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
155 C F PYX2XH auxiliary for ino -> ino + Higgs decay *
156 C S PYHEXT to calculate non-SM Higgs decay partial widths *
157 C F PYH2XX auxiliary for H -> ino + ino decay *
158 C F PYGAUS to perform Gaussian integration *
159 C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
160 C F PYSIMP to perform Simpson integration *
161 C F PYLAMF to evaluate the lambda kinematics function *
162 C S PYTBDY to perform 3-body decay of gauginos *
163 C S PYTECM to calculate techni_rho/omega masses *
164 C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
165 C S PYCMQR auxiliary to PYEICG *
166 C S PYCMQ2 auxiliary to PYEICG *
167 C S PYCDIV auxiliary to PYCMQR *
168 C S PYCSRT auxiliary to PYCMQR *
169 C S PYTHAG auxiliary to PYCMQR *
170 C S PYCBAL auxiliary to PYEICG *
171 C S PYCBA2 auxiliary to PYEICG *
172 C S PYCRTH auxiliary to PYEICG *
173 C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
174 C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
175 C S PYWIDX to calculate decay widths from within PYWIDT *
176 C S PYRVSF to calculate R-violating sfermion decay widths *
177 C S PYRVNE to calculate R-violating neutralino decay widths *
178 C S PYRVCH to calculate R-violating chargino decay widths *
179 C S PYRVGL to calculate R-violating gluino decay widths *
180 C F PYRVSB auxiliary to PYRVSF *
181 C S PYRVGW to calculate R-Violating 3-body widths *
182 C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
183 C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
184 C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
185 C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
186 C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
187 C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
188 C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
189 C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
190 C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
192 C S PY1ENT to fill one entry (= parton or particle) *
193 C S PY2ENT to fill two entries *
194 C S PY3ENT to fill three entries *
195 C S PY4ENT to fill four entries *
196 C S PY2FRM to interface to generic two-fermion generator *
197 C S PY4FRM to interface to generic four-fermion generator *
198 C S PY6FRM to interface to generic six-fermion generator *
199 C S PY4JET to generate a shower from a given 4-parton config *
200 C S PY4JTW to evaluate the weight od a shower history for above *
201 C S PY4JTS to set up the parton configuration for above *
202 C S PYJOIN to connect entries with colour flow information *
203 C S PYGIVE to fill (or query) commonblock variables *
204 C S PYEXEC to administrate fragmentation and decay chain *
205 C S PYPREP to rearrange showered partons along strings *
206 C S PYSTRF to do string fragmentation of jet system *
207 C S PYJURF to find boost to string junction rest frame *
208 C S PYINDF to do independent fragmentation of one or many jets *
209 C S PYDECY to do the decay of a particle *
210 C S PYDCYK to select parton and hadron flavours in decays *
211 C S PYKFDI to select parton and hadron flavours in fragm *
212 C S PYNMES to select number of popcorn mesons *
213 C S PYKFIN to calculate falvour prod. ratios from input params. *
214 C S PYPTDI to select transverse momenta in fragm *
215 C S PYZDIS to select longitudinal scaling variable in fragm *
216 C S PYSHOW to do timelike parton shower evolution *
217 C F PYMAEL auxiliary to PYSHOW, with gluon emission ME's *
218 C S PYBOEI to include Bose-Einstein effects (crudely) *
219 C S PYBESQ auxiliary to PYBOEI *
220 C F PYMASS to give the mass of a particle or parton *
221 C F PYMRUN to give the running MSbar mass of a quark *
222 C S PYNAME to give the name of a particle or parton *
223 C F PYCHGE to give three times the electric charge *
224 C F PYCOMP to compress standard KF flavour code to internal KC *
225 C S PYERRM to write error messages and abort faulty run *
226 C F PYALEM to give the alpha_electromagnetic value *
227 C F PYALPS to give the alpha_strong value *
228 C F PYANGL to give the angle from known x and y components *
229 C F PYR to provide a random number generator *
230 C S PYRGET to save the state of the random number generator *
231 C S PYRSET to set the state of the random number generator *
232 C S PYROBO to rotate and/or boost an event *
233 C S PYEDIT to remove unwanted entries from record *
234 C S PYLIST to list event record or particle data *
235 C S PYLOGO to write a logo *
236 C S PYUPDA to update particle data *
237 C F PYK to provide integer-valued event information *
238 C F PYP to provide real-valued event information *
239 C S PYSPHE to perform sphericity analysis *
240 C S PYTHRU to perform thrust analysis *
241 C S PYCLUS to perform three-dimensional cluster analysis *
242 C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
243 C S PYJMAS to give high and low jet mass of event *
244 C S PYFOWO to give Fox-Wolfram moments *
245 C S PYTABU to analyze events, with tabular output *
247 C S PYEEVT to administrate the generation of an e+e- event *
248 C S PYXTEE to give the total cross-section at given CM energy *
249 C S PYRADK to generate initial state photon radiation *
250 C S PYXKFL to select flavour of primary qqbar pair *
251 C S PYXJET to select (matrix element) jet multiplicity *
252 C S PYX3JT to select kinematics of three-jet event *
253 C S PYX4JT to select kinematics of four-jet event *
254 C S PYXDIF to select angular orientation of event *
255 C S PYONIA to perform generation of onium decay to gluons *
257 C S PYBOOK to book a histogram *
258 C S PYFILL to fill an entry in a histogram *
259 C S PYFACT to multiply histogram contents by a factor *
260 C S PYOPER to perform operations between histograms *
261 C S PYHIST to print and reset all histograms *
262 C S PYPLOT to print a single histogram *
263 C S PYNULL to reset contents of a single histogram *
264 C S PYDUMP to dump histogram contents onto a file *
266 C S PYKCUT dummy routine for user kinematical cuts *
267 C S PYEVWT dummy routine for weighting events *
268 C S UPINIT dummy routine to initialize user processes *
269 C S UPEVNT dummy routine to generate a user process event *
270 C S PDFSET dummy routine to be removed when using PDFLIB *
271 C S STRUCTM dummy routine to be removed when using PDFLIB *
272 C S STRUCTP dummy routine to be removed when using PDFLIB *
273 C S SUGRA dummy routine to be removed when linking with ISAJET *
274 C F VISAJE dummy functn. to be removed when linking with ISAJET *
275 C S PYTAUD dummy routine for interface to tau decay libraries *
276 C S PYTIME dummy routine for giving date and time *
278 C*********************************************************************
281 C...Default values for switches and parameters,
282 C...and particle, decay and process data.
286 C...Double precision and integer declarations.
287 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
288 IMPLICIT INTEGER(I-N)
289 C INTEGER PYK,PYCHGE,PYCOMP
291 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
292 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
293 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
294 COMMON/PYDAT4/CHAF(500,2)
296 COMMON/PYDATR/MRPY(6),RRPY(100)
297 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
298 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
299 COMMON/PYINT1/MINT(400),VINT(400)
300 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
301 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
302 COMMON/PYINT4/MWID(500),WIDS(500,5)
303 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
304 COMMON/PYINT6/PROC(0:500)
306 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
307 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
308 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
309 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
310 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
311 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
312 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
313 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
314 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
315 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYBINS/
317 C...PYDAT1, containing status codes and most parameters.
319 & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
320 1 6, 1, 1, 0, 0, 1, 0, 0, 0, 0,
321 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
322 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
323 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
324 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
325 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
327 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
328 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
330 DATA (PARU(I),I=1,100)/
331 & 3.141592653589793D0, 6.283185307179586D0,
332 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
333 1 0.001D0, 0.09D0, 0.01D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
334 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
335 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
336 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
337 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
338 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
340 DATA (PARU(I),I=101,200)/
341 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
342 & 0D0, 0D0, 0D0, 0D0, 0D0,
343 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
344 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
345 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
346 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
347 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
348 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
349 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
350 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
351 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
352 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
354 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
355 1 4, 2, 0, 1, 0, 2, 2, 10, 0, 0,
356 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
357 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
358 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
359 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
361 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
362 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
365 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
366 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
367 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
368 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
369 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
370 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
371 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
372 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
373 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
374 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
375 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
376 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
377 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
378 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
379 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
380 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
381 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
385 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
386 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
387 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
388 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
391 C...PYDAT2, with particle data and flavour treatment parameters.
392 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
393 &-3,0,-3,6*0,3,9*0,3,2*0,3,4*0,-1,41*0,2,-1,20*0,3*3,7*0,3*3,3*0,
394 &3*3,3*0,3*3,6*0,3*3,3*0,3*3,4*0,-2,-3,2*1,2*0,4,2*3,6,2*-2,2*-3,
395 &0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,3,2*1,2*0,
396 &2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,3,2*-2,
397 &2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,-3,2*0,
398 &2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,3,0,3,
399 &2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,2,-1,
400 &2,-1,2,-3,0,-3,0,-3,2*0,3,3*0,3,8*0,-1,2,-3,6*0,3,2*6,0,3,4*0,3,
402 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
403 &2*0,-1,3*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0,
404 &-1,7*0,2*-1,5*0,2*-1,6*0,2*-1,7*0,2*-1,8*0,-1,56*0,6*1,6*0,2,7*0,
405 &6*1,9*0,2,3*0,2,0,5*2,2*1,156*0/
406 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
407 &2*1,39*0,1,0,2*1,20*0,3*1,4*0,6*1,3*0,9*1,3*0,12*1,4*0,100*1,2*0,
408 &2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,0,4*1,3*0,12*1,3*0,
409 &1,2*0,1,0,12*1,0,1,3*0,1,8*0,4*1,5*0,3*1,0,1,3*0,2*1,139*0/
410 DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
411 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
412 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
413 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
414 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
415 &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
416 &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
417 &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
418 &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
419 &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
420 &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
421 &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
422 &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
423 &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
424 &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
425 &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
426 &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
427 &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
428 &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
429 &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
430 DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
431 &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
432 &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
433 &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
434 &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
435 &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
436 &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
437 &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
438 &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
439 &9902110,9902210,139*0/
440 DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
441 &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
442 &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
443 &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
444 &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
445 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
446 &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
447 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
448 &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
449 &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
450 &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
451 &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
452 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
453 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
454 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
455 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
456 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
457 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
458 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
459 &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
460 DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
461 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
462 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
463 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
464 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
465 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
466 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
467 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
468 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
469 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
470 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
471 &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
472 &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,139*0D0/
473 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
474 &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
475 &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
476 &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
477 &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
478 &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
479 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
480 &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
481 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
482 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
483 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
484 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
485 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
486 &0.02911D0,0.01741D0,0.04536D0,0.09511D0,0.8686D0,0.62395D0,
487 &0.19192D0,123.27638D0,0.02296D0,0.18886D0,23.26819D0,2.86306D0,
488 &0D0,3.45903D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
489 &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
491 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
492 &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
493 &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
494 &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
495 &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
496 &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
497 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
498 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
499 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
500 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
501 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
502 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
503 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
504 &0.29108D0,0.17412D0,0.45362D0,0.95114D0,8.68604D0,6.23946D0,
505 &1.91923D0,450D0,0.22959D0,1.88863D0,232.68185D0,28.63059D0,0D0,
506 &34.59032D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
507 &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
508 &8.80013D0,7*0D0,139*0D0/
509 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
510 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
511 &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
512 &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
513 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
514 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
515 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
516 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,112*0D0,139*0D0/
518 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
519 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
520 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
521 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
522 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
523 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
524 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
525 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
526 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
527 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0,
528 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
529 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
530 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
532 4 0.2D0, 0.5D0, 8*0D0,
534 DATA ((VCKM(I,J),J=1,4),I=1,4)/
535 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
536 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
537 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
538 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
540 C...PYDAT3, with particle decay parameters and data.
541 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
542 &4*1,3*0,2*1,40*0,3*1,16*0,3*1,2*0,9*1,0,32*1,2*0,1,3*0,1,2*0,2*1,
543 &2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,2*0,6*1,0,7*1,2*0,5*1,2*0,
544 &6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,1,0,26*1,146*0/
545 DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
546 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
547 &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
548 &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
549 &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
550 &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
551 &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
552 &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
553 &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
554 &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
555 &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
556 &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
557 &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
558 &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
559 &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
560 &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
561 &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
562 &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
563 &3924,0,3960,0,3996,4004,4012,4020,4023,4047,4073,4097,4103,4110,
564 &4117,4124,4130,4136,4145,4149,4153,4156,4158,4178,4200,4222,4244/
565 DATA (MDCY(I,2),I= 352, 500)/4259,4271,4278,146*0/
566 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
567 &2*0,9,12,16,20,79,6*0,22,0,23,86,83,27,3*0,9,1,40*0,1,4,9,16*0,2,
568 &5,2*9,2*2,7,8,6,9,2*2,3,10,6,3,11,6,11,6,63,3,8,61,2,8,33,2,4,1,
569 &3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,2*0,1,3*0,3,2*0,3,1,2*0,2,
570 &3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,4*1,4,2*0,1,2,1,2,4,1,
571 &0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,1,9,2*0,8*9,0,9*9,4*1,
572 &5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,9*2,11,14,45,24,45,24,
573 &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
574 &28,49,28,36,0,36,0,36,0,3*8,3,24,26,24,6,3*7,2*6,9,2*4,3,2,20,
575 &3*22,15,12,2*7,146*0/
576 DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
577 &7*1,-1,1,7*-1,8*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,5*1,0,2*-1,6*1,0,
578 &2*-1,3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,85*1,
579 &2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,200*1,2*-1,2*1,-1,
580 &1249*1,2*-1,377*1,2*-1,1868*1,2*-1,6*1,2*-1,9*1,-1,3*1,-1,3*1,
581 &5*-1,3*1,-1,14*1,2*-1,6*1,2*-1,67*1,2*-1,6*1,2*-1,111*1,3716*0/
582 DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
583 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
584 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
585 &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
586 &18*53,6*32,4*0,12,2*42,2*11,9*42,0,2,3,15*0,4*42,5*0,3,12*0,2,
587 &3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,3*0,1,11*0,22*42,41*0,
588 &2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,6*0,12,2*0,12,0,12,
589 &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
590 &19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,4*32,2*4,0,32,45*0,
591 &14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,2*42,2*11,0,2*42,
592 &2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,
593 &2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,9*42,0,162*42,50*0,2*12,
594 &17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,5*0,2404*53,4*32,
595 &3*0,6*32,3*0,4*32,3*0,4*32,8*0,8*32,14*0,16*32,12*0,8*32,8*0,
596 &46*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0,9*32,3733*0/
597 DATA (BRAT(I) ,I= 1, 346)/43*0D0,0.00003D0,0.001765D0,
598 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
599 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
600 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
601 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
602 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
603 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
604 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
605 &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
606 &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
607 &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
608 &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
609 &0.108087D0,0D0,0.000001D0,0D0,0.000349D0,0.048707D0,0.768308D0,
610 &4*0D0,0.000227D0,0.064048D0,0D0,0.040621D0,0.002043D0,0.000615D0,
611 &0.006981D0,0.068099D0,62*0D0,0.145835D0,0.113276D0,0.145835D0,
612 &0.113271D0,0.145781D0,0.049002D0,2*0D0,0.032025D0,0.063642D0,
613 &0.032025D0,0.063642D0,0.032022D0,0.063642D0,8*0D0,0.251225D0,
614 &0.0129D0,0.000006D0,0D0,0.0129D0,0.250764D0,0.00038D0,0D0,
615 &0.000008D0,0.000465D0,0.215418D0,5*0D0,2*0.085312D0,0.08531D0,
616 &7*0D0,0.000049D0,0.000774D0,5*0D0,0.000074D0,0D0,0.000417D0/
617 DATA (BRAT(I) ,I= 347, 651)/0.000015D0,0.000061D0,0.30671D0,
618 &0.689011D0,0D0,0.002889D0,69*0D0,0.000001D0,0.000121D0,
619 &0.001924D0,4*0D0,0.000001D0,0.000184D0,0D0,0.003106D0,0.000015D0,
620 &0.000003D0,2*0D0,0.994646D0,66*0D0,0.000021D0,0.090135D0,2*0D0,
621 &0.000013D0,0.003714D0,0D0,0.906117D0,18*0D0,3*0.215119D0,
622 &0.214724D0,2*0D0,0.06996D0,0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,
623 &0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
624 &0.005D0,0.988D0,0.012D0,0.998739D0,0.00079D0,0.00038D0,
625 &0.000046D0,0.000045D0,2*0.34725D0,0.144D0,0.104D0,0.0245D0,
626 &2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0,2*0.1939D0,
627 &2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0,0.000123D0,
628 &0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0,0.049D0,0.0028D0,
629 &0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0,0.0049D0,0.0013D0,
630 &0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0,0.00083D0,
631 &2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0,2*0.0115D0,
632 &0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0,0.333D0,
633 &0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0,0.059D0,
634 &2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0,0.0482D0,
635 &0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0,0.168D0,0.084D0,
636 &0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0,0.437D0,0.208D0/
637 DATA (BRAT(I) ,I= 652, 823)/0.302D0,0.0302D0,0.0212D0,0.0016D0,
638 &0.48947D0,0.34D0,3*0.043D0,0.027D0,0.0126D0,0.0013D0,0.0003D0,
639 &0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,2*0.004D0,0.07D0,
640 &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,0.065D0,2*0.005D0,
641 &2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0,0.041D0,0.045D0,
642 &0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0,0.0006D0,0.0066D0,
643 &0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0,0.005D0,0.012D0,
644 &0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0,0.004D0,0.019D0,
645 &0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0,0.087D0,0.001D0,
646 &0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0,0.011D0,0.3D0,0.15D0,
647 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.034D0,0.027D0,
648 &2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0,2*0.002D0,
649 &2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0,3*0.021D0,
650 &0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0,0.0041D0,
651 &0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0,0.0018D0,
652 &0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0,0.0036D0,
653 &0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0,0.0077D0,
654 &0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0,0.017D0,
655 &0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0,0.08D0,
656 &0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,2*0.005D0/
657 DATA (BRAT(I) ,I= 824, 991)/2*0.02D0,0.03D0,2*0.005D0,0.015D0,
658 &0.037D0,0.028D0,0.079D0,0.095D0,0.052D0,0.0078D0,4*0.001D0,
659 &0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,0.0952D0,
660 &0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,0.8797D0,
661 &0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,
662 &0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
663 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
664 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
665 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
666 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
667 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
668 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
669 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,
670 &0.0008D0,0.0014D0,0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,
671 &0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,
672 &0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,
673 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,
674 &0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,
675 &0.0135D0,0.025D0,2*0.0002D0,0.0007D0,2*0.0004D0,0.0014D0,0.001D0,
676 &0.0009D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0/
677 DATA (BRAT(I) ,I= 992,1183)/1D0,2*0.3D0,2*0.2D0,0.047D0,0.122D0,
678 &0.006D0,0.012D0,0.035D0,0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,
679 &0.037D0,0.008D0,0.002D0,0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,
680 &0.042D0,0.014D0,0.042D0,0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,
681 &0.002D0,0.001D0,0.002D0,0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,
682 &0.0252D0,0.0248D0,0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,
683 &0.7743D0,0.029D0,0.22D0,0.78D0,1D0,0.331D0,0.663D0,0.006D0,
684 &0.663D0,0.331D0,0.006D0,1D0,0.999D0,0.001D0,0.88D0,2*0.06D0,
685 &0.639D0,0.358D0,0.002D0,0.001D0,1D0,0.88D0,2*0.06D0,0.516D0,
686 &0.483D0,0.001D0,0.88D0,2*0.06D0,0.9988D0,0.0001D0,0.0006D0,
687 &0.0004D0,0.0001D0,0.667D0,0.333D0,0.9954D0,0.0011D0,0.0035D0,
688 &0.333D0,0.667D0,0.676D0,0.234D0,0.085D0,0.005D0,2*1D0,0.018D0,
689 &2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.018D0,2*0.005D0,0.003D0,
690 &0.002D0,2*0.006D0,0.0066D0,0.025D0,0.016D0,0.0088D0,2*0.005D0,
691 &0.0058D0,0.005D0,0.0055D0,4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,
692 &0.002D0,2*0.003D0,3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,
693 &2*0.002D0,0.0013D0,0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,
694 &2*0.002D0,2*0.001D0,2*0.002D0,2*0.001D0,0.2432D0,0.057D0,
695 &2*0.035D0,0.15D0,2*0.075D0,0.03D0,2*0.015D0,2*0.08D0,0.76D0,
696 &0.08D0,4*1D0,2*0.08D0,0.76D0,0.08D0,1D0,2*0.5D0,1D0,2*0.5D0/
697 DATA (BRAT(I) ,I=1184,1377)/2*0.08D0,0.76D0,0.08D0,1D0,2*0.08D0,
698 &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,
699 &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,
700 &0.04D0,0.0077D0,0.02D0,0.0235D0,0.0285D0,0.0435D0,0.0011D0,
701 &0.0022D0,0.0044D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
702 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
703 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
704 &4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
705 &0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
706 &0.005D0,4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
707 &0.015D0,0.005D0,1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
708 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
709 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
710 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
711 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
712 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
713 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
714 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
715 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
716 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0/
717 DATA (BRAT(I) ,I=1378,1580)/0.015D0,0.005D0,2*0.105D0,0.04D0,
718 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
719 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
720 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
721 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
722 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
723 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
724 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
725 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,
726 &0.11D0,2*0.055D0,0.333D0,0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,
727 &0.14D0,0.313D0,0.157D0,0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,
728 &0.313D0,0.157D0,0.11D0,0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,
729 &4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,
730 &0.333D0,4*0.5D0,0.007D0,0.993D0,1D0,0.667D0,0.333D0,0.667D0,
731 &0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,
732 &1D0,4*0.5D0,3*0.146D0,3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,
733 &0.667D0,0.333D0,0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,
734 &0.333D0,2*0.5D0,0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,
735 &4*0.5D0,0.35D0,0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,
736 &0.027D0,0.001D0,0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0/
737 DATA (BRAT(I) ,I=1581,4149)/0.008D0,0.024D0,0.008D0,0.024D0,
738 &0.425D0,0.02D0,0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,
739 &0.017431D0,0.054048D0,0.857694D0,2*0D0,0.00025D0,0.070578D0,0D0,
740 &0.022748D0,0.026576D0,0.359486D0,0.561581D0,2*0D0,0.000104D0,
741 &0.029504D0,0.011185D0,0.034681D0,0.550354D0,2*0D0,0.00016D0,
742 &0.045287D0,0.358333D0,0.445781D0,0D0,0.554219D0,0.144051D0,
743 &2*0.351902D0,0D0,0.082107D0,0.029566D0,0.001511D0,0.000726D0,
744 &0.004518D0,0.006522D0,0.004518D0,0.006522D0,0.004513D0,3*0D0,
745 &0.002908D0,0.000973D0,0.002908D0,0.000973D0,0.002908D0,
746 &0.000973D0,2*0D0,0.143982D0,0.489888D0,0.1951D0,0D0,0.114302D0,
747 &0.008426D0,0.014868D0,0.000763D0,2*0D0,0.000763D0,0.01484D0,
748 &0.000003D0,2*0D0,0.000027D0,0.001945D0,5*0D0,3*0.00503D0,0D0,
749 &0.133776D0,0.003284D0,0.37169D0,0.006838D0,2*0.030954D0,
750 &0.00163D0,0D0,0.047224D0,0.073737D0,0.047224D0,0.073732D0,
751 &0.047179D0,3*0D0,0.034761D0,0.009166D0,0.034761D0,0.009166D0,
752 &0.034759D0,0.009166D0,2*0D0,4*0.009069D0,0.510147D0,0.453576D0,
753 &6*0D0,1D0,6*0D0,1D0,4*0.001128D0,0.571047D0,0.382288D0,
754 &0.042153D0,4*0.016597D0,0.93361D0,0D0,4*0.016597D0,0.93361D0,0D0,
755 &4*0.05515D0,0.34469D0,0D0,0.228998D0,0.164208D0,0.041503D0,
756 &0.850973D0,0.005411D0,0.045025D0,0.098591D0,0.849898D0/
757 DATA (BRAT(I) ,I=4150,4280)/0.021617D0,0.030018D0,0.098466D0,
758 &0.294448D0,0.10945D0,0.596102D0,0.389906D0,0.610094D0,3*0.0633D0,
759 &0.063299D0,0.063295D0,0.056281D0,2*0D0,6*0.020495D0,2*0D0,
760 &0.327919D0,0.04099D0,0.045236D0,0.090112D0,0.19874D0,0.010204D0,
761 &0.000003D0,0.010205D0,0.198356D0,0.000151D0,0.000006D0,
762 &0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,0.010205D0,
763 &0.198356D0,0.000151D0,0.000006D0,0.000367D0,0.081967D0,4*0D0,
764 &0.198776D0,0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,
765 &0.000006D0,0.000367D0,0.081893D0,0.198776D0,0.010206D0,
766 &0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,0.000367D0,
767 &0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0,0.010236D0,
768 &0.198928D0,0.000149D0,0.000006D0,0.000368D0,0.080733D0,
769 &0.199344D0,0.010234D0,0.000003D0,0.010236D0,0.198928D0,
770 &0.000149D0,0.000006D0,0.000368D0,0.080733D0,4*0D0,0.184738D0,
771 &0.104588D0,0.184738D0,0.104587D0,0.184731D0,0.09582D0,0.022902D0,
772 &0.008429D0,0.015602D0,0.022902D0,0.008429D0,0.015602D0,
773 &0.022902D0,0.008429D0,0.015602D0,0.28959D0,0.01487D0,0.000008D0,
774 &0.01487D0,0.289061D0,0.000492D0,0.000009D0,0.000536D0,0.27911D0,
775 &2*0.037151D0,0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,
776 &0.001805D0,0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0/
777 DATA (BRAT(I) ,I=4281,8000)/0.090428D0,0.001808D0,0.81372D0,0D0,
779 DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
780 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
781 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
782 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
783 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
784 &-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,
785 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
786 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
787 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
788 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
789 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
790 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
791 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
792 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
793 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
794 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
795 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
796 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
797 &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
798 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
799 DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
800 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
801 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
802 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
803 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
804 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
805 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
806 &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
807 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
808 &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
809 &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
810 &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
811 &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
812 &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
813 &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
814 &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
815 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
816 &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
817 &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
818 &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
819 DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
820 &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
821 &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
822 &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
823 &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
824 &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
825 &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
826 &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
827 &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
828 &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
829 &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
830 &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
831 &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
832 &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
833 &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
834 &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
835 &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
836 &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
837 &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
838 &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
839 DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
840 &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
841 &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
842 &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
843 &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
844 &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
845 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
846 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
847 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
848 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
849 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
850 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
851 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
852 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
853 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
854 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
855 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
856 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
857 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
858 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
859 DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
860 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
861 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
862 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
863 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
864 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
865 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
866 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
867 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
868 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
869 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
870 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
871 &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
872 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
873 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
874 &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
875 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
876 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
877 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
878 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
879 DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,
880 &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
881 &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
882 &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
883 &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
884 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
885 &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
886 &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
887 &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
888 &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
889 &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
890 &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
891 &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
892 &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
893 &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
894 &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
895 &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
896 &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
897 &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
898 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
899 DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,
900 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
901 &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
902 &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
903 &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
904 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
905 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
906 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
907 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
908 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
909 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
910 &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
911 &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
912 &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
913 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
914 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
915 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
916 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
917 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
918 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
919 DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
920 &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
921 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
922 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
923 &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
924 &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
925 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
926 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
927 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
928 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
929 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
930 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
931 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
932 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
933 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
934 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
935 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
936 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
937 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
938 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
939 DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
940 &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
941 &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
942 &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
943 &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
944 &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
945 &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
946 &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
947 &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
948 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
949 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
950 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
951 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
952 &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
953 &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
954 &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
955 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
956 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
957 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
958 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
959 DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,
960 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
961 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
962 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
963 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
964 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
965 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
966 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
967 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
968 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
969 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
970 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
971 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
972 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
973 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
974 &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
975 &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
976 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
977 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
978 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
979 DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,
980 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
981 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
982 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
983 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
984 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
985 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
986 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
987 &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
988 &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
989 &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
990 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
991 &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
992 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
993 &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
994 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
995 &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
996 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
997 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
998 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
999 DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,
1000 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
1001 &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1002 &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
1003 &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
1004 &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1005 &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1006 &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
1007 &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
1008 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
1009 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
1010 &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
1011 &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
1012 &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
1013 &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
1014 &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
1015 &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
1016 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
1017 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
1018 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
1019 DATA (KFDP(I,1),I=3783,4127)/1000039,1000024,1000037,1000022,
1020 &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
1021 &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1022 &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
1023 &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
1024 &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
1025 &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
1026 &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
1027 &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1028 &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1029 &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1030 &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1031 &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1032 &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
1033 &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
1034 &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
1035 &2*24,2*3000211,2*22,2*23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1036 &2*24,3*3000211,24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,22,
1037 &23,24,3000211,24,3000211,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1038 &1,2,3,4,5,6,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4/
1039 DATA (KFDP(I,1),I=4128,8000)/5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,
1040 &3100111,3200111,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1,2,3,4,
1041 &5,6,7,8,11,12,13,14,15,16,17,18,21,22,23,24,9*11,9*-11,2*11,
1042 &2*-11,9*13,9*-13,2*13,2*-13,9*15,9*-15,2*15,2*-15,1,2,3,4,5,6,11,
1043 &12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,
1044 &-15,3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3716*0/
1045 DATA (KFDP(I,2),I= 1, 339)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
1046 &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,6*1000006,3*7,
1047 &2,4,6,8,7,4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14,
1048 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1049 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1050 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1051 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1052 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1053 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1054 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1055 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1056 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1057 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1058 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1059 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1060 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1061 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1062 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1063 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1064 &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,25,-1,-2,-3,-4,-5,-6/
1065 DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1066 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1067 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1068 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1069 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1070 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1071 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1072 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1073 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1074 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1075 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1076 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1077 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1078 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1079 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1080 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1081 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1082 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1083 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1084 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1085 DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1086 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1087 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1088 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1089 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1090 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1091 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1092 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1093 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1094 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1095 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1096 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1097 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1098 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1099 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1100 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1101 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1102 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1103 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1104 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1105 DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1106 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1107 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1108 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1109 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1110 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1111 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1112 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1113 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1114 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1115 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1116 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1117 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1118 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1119 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1120 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1121 &4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,11,13,15,1,4,3,4,1,3,11,
1122 &13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,4,
1123 &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,
1124 &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3/
1125 DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1126 &4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,
1127 &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,
1128 &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
1129 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1130 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1131 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1132 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1133 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1134 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1135 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1136 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1137 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1138 &1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,
1139 &-5,2,2*1,4*2,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,
1140 &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,
1141 &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,2*24,2*37,4,1,3,5,1,3,5,1,3,5,-3,
1142 &2*-5,5,2*6,4*5,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,
1143 &4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,2*5,4*6,2*24,2*37,6,4,-15,
1144 &16,1,3,5,1,3,5,1,3,5,-3,2*-5,11,2*12,4*11,2*-24,-37,13,15,11,15/
1145 DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1146 &1,3,5,12,2*11,4*12,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,
1147 &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1148 &5,1,3,5,1,3,5,14,2*13,4*14,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,
1149 &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1150 &13,15,1,3,5,1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15,
1151 &1,3,5,1,3,5,1,3,5,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,
1152 &5,-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,
1153 &1,-1,3,-3,5,-5,1,-1,3,-3,5,-5,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,
1154 &-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,
1155 &-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,
1156 &-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,
1157 &-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,
1158 &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1159 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1160 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1161 &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,
1162 &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,
1163 &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,
1164 &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3/
1165 DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1166 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1167 &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1168 &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1169 &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1170 &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1171 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1172 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1173 &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,
1174 &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,
1175 &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,
1176 &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,
1177 &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1178 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1179 &2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,
1180 &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1181 &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1182 &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1183 &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1184 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1185 DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1186 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1187 &2*4,-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,22,23,25,35,36,22,23,11,13,
1188 &15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,
1189 &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1190 &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1191 &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1192 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1193 &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1194 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1195 &-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,
1196 &-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,
1197 &-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,
1198 &-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,
1199 &-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,
1200 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1201 &16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,
1202 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1203 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1204 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1205 DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1206 &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1207 &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1208 &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1209 &3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,
1210 &2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,
1211 &5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,
1212 &4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,
1213 &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1214 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1215 &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1216 &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1217 &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1218 &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1219 &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1220 &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1221 &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1222 &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1223 &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1224 &-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,1,2*2,4*1,23,25,35,36,2*-24/
1225 DATA (KFDP(I,2),I=3670,4136)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1226 &6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,-5,2,2*1,4*2,23,25,35,
1227 &36,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,23,25,35,36,
1228 &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,
1229 &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,23,25,35,36,2*24,2*37,4,1,3,5,1,
1230 &3,5,1,3,5,-3,2*-5,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,1,3,5,1,3,
1231 &5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,
1232 &2*5,4*6,23,25,35,36,2*24,2*37,6,1,3,5,1,3,5,1,3,5,-3,2*-5,11,
1233 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1234 &13,15,1,3,5,1,3,5,1,3,5,13,2*14,4*13,23,25,35,36,2*-24,2*-37,13,
1235 &15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15,2*16,4*15,
1236 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1237 &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1238 &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-24,-3000211,-24,-3000211,
1239 &3000111,3000221,3000111,3000221,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,
1240 &-13,-14,-15,-16,-17,-18,23,3000111,23,3000111,22,3000221,2,4,6,8,
1241 &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,
1242 &2*-24,-3000211,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1243 &-17,-18,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,
1244 &21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,-1/
1245 DATA (KFDP(I,2),I=4137,8000)/-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1246 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1247 &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3,
1248 &3*-5,3*1,3*3,3*5,2*-11,2*15,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-11,
1249 &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16,
1250 &9900016,2,4,6,2,4,6,2,4,6,9900012,9900014,9900016,-11,-13,-15,
1251 &-13,2*-15,24,-11,-13,-15,-13,2*-15,9900024,3716*0/
1252 DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1253 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1254 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1255 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1256 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1257 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1258 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1259 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1260 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1261 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1262 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1263 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1264 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1265 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1266 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1267 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1268 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1269 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1270 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1271 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1272 DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1273 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1274 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1275 &4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,2*2,4*4,1,4,3,
1276 &2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,
1277 &2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
1278 &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
1279 &3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
1280 &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
1281 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1282 &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1283 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1284 &6,-2,2,-4,4,-6,6,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,
1285 &-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1286 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1287 &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1288 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,
1289 &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1290 &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1291 &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1292 DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1293 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1294 &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1295 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,
1296 &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1297 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1298 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1299 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1300 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1301 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1302 &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1303 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
1304 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
1305 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,3*0,12,14,16,2,4,0,12,14,16,2,
1306 &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1307 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1308 &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1309 &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1310 &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1311 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1/
1312 DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1313 &2*6,5,-5,3,-3,5,-5,1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,7*0,
1314 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1315 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1316 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1317 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1318 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1319 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1320 &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1321 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
1322 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
1323 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1324 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1325 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1326 &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1327 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1328 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1329 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
1330 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,
1331 &-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1332 DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1333 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,
1334 &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1335 &4*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,
1336 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1337 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1338 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1339 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,
1340 &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1341 &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1342 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,3,-3,5,-5,
1343 &1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,351*0,-5,169*0,2,4,6,2,
1344 &4,6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,
1345 &4,6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,
1346 &4,6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3757*0/
1347 DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1348 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1349 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1350 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1351 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1352 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1353 &-311,20*0,-3,43*0,6*1,39*0,6*2,42*0,6*3,14*0,8*4,4*0,4*-5,4*0,
1354 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1355 &4*0,4*81,6*0,4*81,0,28*81,13*0,6*2101,18*81,4*0,18*81,4*0,9*81,0,
1356 &162*81,31*0,-211,111,6516*0/
1357 DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1358 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1359 &3*111,-211,111,7193*0/
1361 C...PYDAT4, with particle names (character strings).
1362 DATA (CHAF(I,1),I= 1, 100)/'d','u','s','c','b','t','b''','t''',
1363 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1364 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1365 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1366 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1367 &'junction',' ','system','cluster','string','indep.','CMshower',
1368 &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' '/
1369 DATA (CHAF(I,1),I= 101, 202)/'reggeon','pi0',
1370 &'rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega','f_2',
1371 &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1372 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1373 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1374 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1375 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1376 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1377 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1378 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1379 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1380 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1381 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1382 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1383 DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1384 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1385 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1386 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1387 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1388 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1389 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1390 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1391 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1392 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1393 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1394 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1395 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1396 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1397 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1398 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1399 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1400 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1401 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1402 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1403 DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1404 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1405 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1406 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1407 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1408 &'n_diffr0','p_diffr+',139*' '/
1409 DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1410 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1411 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1412 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1413 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1414 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1415 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1416 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1417 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1418 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1419 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1420 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1421 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1422 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1423 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1424 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1425 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1426 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1427 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1428 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1429 DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1430 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1431 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1432 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1433 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1434 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1435 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1436 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1437 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1438 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1439 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1440 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1441 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1442 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1443 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1444 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1445 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1446 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1447 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1448 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1449 DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1450 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1451 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1452 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',139*' '/
1454 C...PYDATR, with initial values for the random number generator.
1455 DATA MRPY/19780503,0,0,97,33,0/
1457 C...Default values for allowed processes and kinematics constraints.
1460 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1461 &5*1,5*0,6*1,4*0,4*1,16*0,16*0,4*1,4*0,6*1,5*0,5*1,0,5*1,5*0,
1464 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1465 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1466 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1467 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1468 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1469 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1470 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1471 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1472 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1473 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1474 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1475 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1476 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1477 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1478 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1479 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1482 C...Default values for main switches and parameters. Reset information.
1483 DATA (MSTP(I),I=1,100)/
1484 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1485 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1486 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1487 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1488 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1489 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1490 6 2, 3, 2, 2, 1, 5, 2, 1, 0, 0,
1491 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1492 8 1, 1, 100, 0, 0, 2, 0, 0, 0, 0,
1493 9 1, 3, 1, 3, 0, 0, 0, 0, 0, 0/
1494 DATA (MSTP(I),I=101,200)/
1495 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1496 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1497 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1498 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1499 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1500 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1501 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1502 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1503 8 6, 214, 2003, 01, 22, 0, 0, 0, 0, 0,
1504 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1505 DATA (PARP(I),I=1,100)/
1506 & 0.25D0, 10D0, 8*0D0,
1507 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1509 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
1510 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1512 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 1.0D0,1D-3,2*0D0,
1513 7 4.0D0, 0.25D0, 8*0D0,
1514 8 1.90D0, 1.90D0, 0.5D0, 0.2D0, 0.33D0,
1515 8 0.66D0, 0.7D0, 0.5D0, 1000D0, 0.16D0,
1516 9 1.0D0,0.40D0,5.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1517 DATA (PARP(I),I=101,200)/
1518 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1519 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1520 2 1.0D0, 0.4D0, 8*0D0,
1523 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1524 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1525 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1526 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1528 9 0.64D0, 5.0D0, 8*0D0/
1534 C...Constants for the generation of the various processes.
1535 DATA (ISET(I),I=1,100)/
1536 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1537 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1538 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1539 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1540 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1541 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1542 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1543 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1544 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1545 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1546 DATA (ISET(I),I=101,200)/
1547 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1548 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1549 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1550 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1551 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1552 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1553 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1554 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1555 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1556 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1557 DATA (ISET(I),I=201,300)/
1558 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1559 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1560 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1561 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1562 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1563 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1564 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1565 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1566 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1567 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1568 DATA (ISET(I),I=301,500)/
1570 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1571 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1572 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1573 7 2, 2, 2, 2, 2, 2, 2, -1, -1, -1,
1574 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1575 9 1, 1, 2, 2, 2, 5*-2,
1577 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1578 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1579 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1580 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1581 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1582 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1583 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1584 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1585 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1586 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1587 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1588 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1589 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1590 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1591 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1592 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1593 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1594 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1595 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1596 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1597 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1598 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1599 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1600 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1601 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1602 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1603 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1604 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1605 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1606 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1607 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1608 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1609 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1610 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1611 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1612 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1613 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1614 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1615 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1616 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1617 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1618 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1619 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1620 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1621 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1622 & 1000011, 1000011, 2000011, 2000011, 1000011,
1623 & 2000011, 1000013, 1000013, 2000013, 2000013,
1624 & 1000013, 2000013, 1000015, 1000015, 2000015,
1625 & 2000015, 1000015, 2000015, 1000011, 1000012,
1626 1 1000015, 1000016, 2000015, 1000016, 1000012,
1627 1 1000012, 1000016, 1000016, 0, 0,
1628 1 1000022, 1000022, 1000023, 1000023, 1000025,
1629 1 1000025, 1000035, 1000035, 1000022, 1000023,
1630 2 1000022, 1000025, 1000022, 1000035, 1000023,
1631 2 1000025, 1000023, 1000035, 1000025, 1000035,
1632 2 1000024, 1000024, 1000037, 1000037, 1000024,
1633 2 1000037, 1000022, 1000024, 1000023, 1000024,
1634 3 1000025, 1000024, 1000035, 1000024, 1000022,
1635 3 1000037, 1000023, 1000037, 1000025, 1000037,
1636 3 1000035, 1000037, 1000021, 1000022, 1000021,
1637 3 1000023, 1000021, 1000025, 1000021, 1000035/
1638 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1639 4 1000021, 1000024, 1000021, 1000037, 1000021,
1640 4 1000021, 1000021, 1000021, 0, 0,
1641 4 1000002, 1000022, 2000002, 1000022, 1000002,
1642 4 1000023, 2000002, 1000023, 1000002, 1000025,
1643 5 2000002, 1000025, 1000002, 1000035, 2000002,
1644 5 1000035, 1000001, 1000024, 2000005, 1000024,
1645 5 1000001, 1000037, 2000005, 1000037, 1000002,
1646 5 1000021, 2000002, 1000021, 0, 0,
1647 6 1000006, 1000006, 2000006, 2000006, 1000006,
1648 6 2000006, 1000006, 1000006, 2000006, 2000006,
1651 7 1000002, 1000002, 2000002, 2000002, 1000002,
1652 7 2000002, 1000002, 1000002, 2000002, 2000002,
1653 7 1000002, 2000002, 1000002, 1000002, 2000002,
1654 7 2000002, 1000002, 1000002, 2000002, 2000002/
1655 DATA ((KFPR(I,J),J=1,2),I=281,350)/
1656 8 1000005, 1000002, 2000005, 2000002, 1000005,
1657 8 2000002, 1000005, 1000002, 2000005, 2000002,
1658 8 1000005, 2000002, 1000005, 1000005, 2000005,
1659 8 2000005, 1000005, 1000005, 2000005, 2000005,
1660 9 1000005, 1000005, 2000005, 2000005, 1000005,
1661 9 2000005, 1000005, 1000021, 2000005, 1000021,
1662 9 1000005, 2000005, 37, 25, 37,
1663 9 35, 36, 25, 36, 35,
1665 4 9900041, 0, 9900042, 0, 9900041,
1666 4 11, 9900042, 11, 9900041, 13,
1667 4 9900042, 13, 9900041, 15, 9900042,
1668 4 15, 9900041, 9900041, 9900042, 9900042/
1669 DATA ((KFPR(I,J),J=1,2),I=351,500)/
1670 5 9900041, 0, 9900042, 0, 9900023,
1671 5 0, 9900024, 0, 0, 0,
1674 6 24, 24, 24, 3000211, 3000211,
1675 6 3000211, 22, 3000111, 22, 3000221,
1676 6 23, 3000111, 23, 3000221, 24,
1677 6 3000211, 0, 0, 24, 23,
1678 7 24, 3000111, 3000211, 23, 3000211,
1679 7 3000111, 22, 3000211, 23, 3000211,
1680 7 24, 3000111, 24, 3000221, 0,
1682 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1683 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1684 9 5000039, 0, 5000039, 0, 21,
1685 9 5000039, 0, 5000039, 21, 5000039,
1688 DATA COEF/10000*0D0/
1689 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1690 &4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2,
1691 &3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2,
1692 &3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1,
1693 &3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0,
1694 &4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3,
1695 &2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2,
1696 &4,0,0,0,4,0,1,3,0,0,3,0,2,4,3,0,3,4,0,0,1,0,0,1,0,0,3,4,2,0,0,2,
1697 &3,0,0,0,1,0,0,0,0,0,3,0,2,0,0,0,2,0,3,1,2,0,0,0,3,2,1,0,1,0,0,0,
1698 &4,4,3,3,2,2,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1699 &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
1701 C...Treatment of resonances.
1702 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1703 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,146*0/
1705 C...Character constants: name of processes.
1706 DATA PROC(0)/ 'All included subprocesses '/
1707 DATA (PROC(I),I=1,20)/
1708 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1709 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1710 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1711 &' ', 'W+ + W- -> h0 ',
1712 &' ', 'f + f'' -> f + f'' (QFD) ',
1713 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1714 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1715 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1716 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1717 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1718 DATA (PROC(I),I=21,40)/
1719 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1720 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1721 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1722 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1723 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1724 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1725 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1726 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1727 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1728 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1729 DATA (PROC(I),I=41,60)/
1730 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1731 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1732 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1733 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1734 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1735 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1736 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1737 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1738 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1739 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1740 DATA (PROC(I),I=61,80)/
1741 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1742 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1743 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1744 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1745 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1746 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1747 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1748 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1749 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1750 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1751 DATA (PROC(I),I=81,100)/
1752 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1753 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1754 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1755 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1756 8'g + g -> chi_2c + g ', ' ',
1757 9'Elastic scattering ', 'Single diffractive (XB) ',
1758 9'Single diffractive (AX) ', 'Double diffractive ',
1759 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1761 9'q + gamma* -> q ', ' '/
1762 DATA (PROC(I),I=101,120)/
1763 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1764 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1765 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1766 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1767 &' ', 'f + fbar -> gamma + h0 ',
1768 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1769 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1770 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1771 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1773 DATA (PROC(I),I=121,140)/
1774 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1775 2'f + f'' -> f + f'' + h0 ',
1776 2'f + f'' -> f" + f"'' + h0 ',
1780 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1781 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1782 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1783 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1784 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1785 DATA (PROC(I),I=141,160)/
1786 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1787 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1788 4'q + l -> LQ ', 'e + gamma -> e* ',
1789 4'd + g -> d* ', 'u + g -> u* ',
1790 4'g + g -> eta_tc ', ' ',
1791 5'f + fbar -> H0 ', 'g + g -> H0 ',
1792 5'gamma + gamma -> H0 ', ' ',
1793 5' ', 'f + fbar -> A0 ',
1794 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1796 DATA (PROC(I),I=161,180)/
1797 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1798 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1799 6'f + fbar -> f'' + fbar'' (g/Z)',
1800 6'f +fbar'' -> f" + fbar"'' (W) ',
1801 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1802 6'q + qbar -> e + e* ', ' ',
1803 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1804 7'f + f'' -> f + f'' + H0 ',
1805 7'f + f'' -> f" + f"'' + H0 ',
1806 7' ', 'f + fbar -> Z0 + A0 ',
1807 7'f + fbar'' -> W+/- + A0 ',
1808 7'f + f'' -> f + f'' + A0 ',
1809 7'f + f'' -> f" + f"'' + A0 ',
1811 DATA (PROC(I),I=181,200)/
1812 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1813 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
1814 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
1815 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
1816 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
1817 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
1818 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
1819 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
1822 DATA (PROC(I),I=201,220)/
1823 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1824 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1825 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1826 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1827 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1828 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1829 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1830 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1831 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1832 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1833 DATA (PROC(I),I=221,240)/
1834 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1835 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1836 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1837 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1838 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1839 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1840 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1841 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1842 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1843 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1844 DATA (PROC(I),I=241,260)/
1845 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1846 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1847 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1848 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1849 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1850 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1851 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1852 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1853 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1854 5'qj + g -> ~qj_R + ~g ', ' '/
1855 DATA (PROC(I),I=261,300)/
1856 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1857 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1858 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1861 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1862 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1863 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1864 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1865 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
1866 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
1867 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
1868 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
1869 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
1870 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
1871 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
1872 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
1873 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
1874 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
1875 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
1876 DATA (PROC(I),I=301,340)/
1877 &'f + fbar -> H+ + H- ', 39*' '/
1878 DATA (PROC(I),I=341,380)/
1879 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
1880 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
1881 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
1882 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
1883 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
1884 5'f + f -> f'' + f'' + H_L++/-- ',
1885 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
1886 5'f + fbar'' -> W_R+/- ',5*' ',
1887 6' ', 'f + fbar -> W_L+ W_L- ',
1888 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
1889 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
1890 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
1891 6'f + fbar -> W+/- pi_T-/+ ', ' ',
1892 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
1893 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
1894 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
1895 7'f + fbar'' -> W+/- pi_T0 ',
1896 7'f + fbar'' -> W+/- pi_T0'' ',
1899 DATA (PROC(I),I=381,500)/
1900 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
1901 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
1902 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
1903 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
1905 9'f + fbar -> G* ', 'g + g -> G* ',
1906 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
1907 9'g + g -> g + G* ',' ',
1910 C...Cross sections and slope offsets.
1913 C...Supersymmetry switches and parameters.
1915 & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
1918 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
1919 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
1920 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
1922 C...Initial values for R-violating SUSY couplings.
1923 C...Should not be changed here. See PYMSIN.
1928 C...Technicolor switches and parameters
1930 & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1933 & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
1934 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
1935 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
1936 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
1937 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 4*0D0,
1940 C...Data for histogramming routines.
1941 DATA IHIST/1000,20000,55,1/
1946 C*********************************************************************
1949 C...A simple program (disguised as subroutine) to run at installation
1950 C...as a check that the program works as intended.
1952 SUBROUTINE PYTEST(MTEST)
1954 C...Double precision and integer declarations.
1955 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1956 IMPLICIT INTEGER(I-N)
1957 INTEGER PYK,PYCHGE,PYCOMP
1959 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1960 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1961 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1962 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
1963 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
1964 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
1965 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
1967 DIMENSION PSUM(5),PINI(6),PFIN(6)
1969 C...Save defaults for values that are changed.
1986 C...First part: loop over simple events to be generated.
1987 IF(MTEST.GE.1) CALL PYTABU(20)
1991 C...Reset parameter values. Switch on some nonstandard features.
2006 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
2008 C...Ten events each for some single jets configurations.
2012 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
2013 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
2014 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
2015 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
2016 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
2017 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
2019 C...Ten events each for some simple jet systems; string fragmentation.
2020 ELSEIF(IEV.LE.130) THEN
2022 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
2023 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
2024 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
2025 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
2026 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
2027 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
2028 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
2029 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
2030 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2032 C...Seventy events with independent fragmentation and momentum cons.
2033 ELSEIF(IEV.LE.200) THEN
2035 MSTJ(2)=1+MOD(IEV-131,4)
2036 MSTJ(3)=1+MOD((IEV-131)/4,4)
2037 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
2038 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
2039 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
2040 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2041 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
2042 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2044 C...A hundred events with random jets (check invariant mass).
2045 ELSEIF(IEV.LE.300) THEN
2052 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
2053 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
2054 EJET=5D0+20D0*PYR(0)
2055 THETA=ACOS(2D0*PYR(0)-1D0)
2057 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
2058 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
2059 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
2060 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
2062 PSUM(J)=PSUM(J)+P(I,J)
2065 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2066 & (PSUM(5)+PARJ(32))**2) GOTO 100
2068 C...Fifty e+e- continuum events with matrix elements.
2069 ELSEIF(IEV.LE.350) THEN
2073 C...Fifty e+e- continuum event with varying shower options.
2074 ELSEIF(IEV.LE.400) THEN
2075 MSTJ(42)=1+MOD(IEV,2)
2076 MSTJ(43)=1+MOD(IEV/2,4)
2077 MSTJ(44)=MOD(IEV/8,3)
2080 C...Fifty e+e- continuum events with coherent shower.
2081 ELSEIF(IEV.LE.450) THEN
2082 CALL PYEEVT(0,500D0)
2084 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2086 CALL PYONIA(5,9.46D0)
2089 C...Generate event. Find total momentum, energy and charge.
2100 C...Check conservation of energy, momentum and charge;
2101 C...usually exact, but only approximate for single jets.
2104 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2106 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2107 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2108 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2111 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2113 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2115 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2116 & (PFIN(J),J=1,4),PFIN(6)
2118 C...Check that all KF codes are known ones, and that partons/particles
2119 C...satisfy energy-momentum-mass relation. Store particle statistics.
2121 IF(K(I,1).GT.20) GOTO 170
2122 IF(PYCOMP(K(I,2)).EQ.0) THEN
2123 WRITE(MSTU(11),5100) I
2126 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2127 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2129 WRITE(MSTU(11),5200) I
2133 IF(MTEST.GE.1) CALL PYTABU(21)
2135 C...List all erroneous events and some normal ones.
2136 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2137 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2139 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2143 C...Stop execution if too many errors.
2144 IF(MERR.NE.0) NERR=NERR+1
2146 WRITE(MSTU(11),6300)
2152 C...Summarize result of run.
2153 IF(MTEST.GE.1) CALL PYTABU(22)
2155 C...Reset commonblock variables changed during run.
2172 C...Second part: complete events of various kinds.
2173 C...Common initial values. Loop over initiating conditions.
2174 MSTP(122)=MAX(0,MIN(2,MTEST))
2175 MDCY(PYCOMP(111),1)=0
2178 C...Reset process type, kinematics cuts, and the flags used.
2195 C...Prompt photon production at fixed target.
2198 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2202 CALL PYINIT('FIXT','pi+','p',PZSUM)
2204 C...QCD processes at ISR energies.
2205 ELSEIF(IPROC.EQ.2) THEN
2211 CALL PYINIT('CMS','p','p',PESUM)
2213 C...W production + multiple interactions at CERN Collider.
2214 ELSEIF(IPROC.EQ.3) THEN
2223 CALL PYINIT('CMS','p','pbar',PESUM)
2225 C...W/Z gauge boson pairs + pileup events at the Tevatron.
2226 ELSEIF(IPROC.EQ.4) THEN
2238 CALL PYINIT('CMS','p','pbar',PESUM)
2240 C...Higgs production at LHC.
2241 ELSEIF(IPROC.EQ.5) THEN
2253 CALL PYINIT('CMS','p','p',PESUM)
2255 C...Z' production at SSC.
2256 ELSEIF(IPROC.EQ.6) THEN
2265 CALL PYINIT('CMS','p','p',PESUM)
2267 C...W pair production at 1 TeV e+e- collider.
2268 ELSEIF(IPROC.EQ.7) THEN
2275 CALL PYINIT('CMS','e+','e-',PESUM)
2277 C...Deep inelastic scattering at a LEP+LHC ep collider.
2278 ELSEIF(IPROC.EQ.8) THEN
2291 CALL PYINIT('3MOM','p','e-',PESUM)
2294 C...Generate 20 events of each required type.
2298 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2300 C...Check conservation of energy/momentum/flavour.
2311 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2312 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2313 DEVQ=ABS(PFIN(6)-PINI(6))
2314 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2315 & DEVQ.GT.0.1D0) MERR=1
2316 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2317 & (PFIN(J),J=1,4),PFIN(6)
2319 C...Check that all KF codes are known ones, and that partons/particles
2320 C...satisfy energy-momentum-mass relation.
2322 IF(K(I,1).GT.20) GOTO 210
2323 IF(PYCOMP(K(I,2)).EQ.0) THEN
2324 WRITE(MSTU(11),5100) I
2327 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2329 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2330 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2331 WRITE(MSTU(11),5200) I
2336 C...Listing of erroneous events, and first event of each type.
2337 IF(MERR.GE.1) NERR=NERR+1
2339 WRITE(MSTU(11),6300)
2343 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2344 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2349 C...List statistics for each process type.
2350 IF(MTEST.GE.1) CALL PYSTAT(1)
2353 C...Summarize result of run.
2354 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2355 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2357 C...Format statements for output.
2358 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2359 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2360 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2361 &4(1X,F12.5),1X,F8.2)
2362 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2363 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2365 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2366 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2367 6400 FORMAT(5X,'Faulty event follows:')
2368 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2369 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2370 &5X,'This should not have happened!')
2375 C*********************************************************************
2378 C...Converts PYTHIA event record contents to or from
2379 C...the standard event record commonblock.
2381 SUBROUTINE PYHEPC(MCONV)
2383 C...Double precision and integer declarations.
2384 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2385 IMPLICIT INTEGER(I-N)
2386 INTEGER PYK,PYCHGE,PYCOMP
2388 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2389 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2390 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2391 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2392 C...HEPEVT commonblock.
2393 PARAMETER (NMXHEP=4000)
2394 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2395 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2396 DOUBLE PRECISION PHEP,VHEP
2399 C...Conversion from PYTHIA to standard, the easy part.
2402 IF(N.GT.NMXHEP) CALL PYERRM(8,
2403 & '(PYHEPC:) no more space in /HEPEVT/')
2407 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2408 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2409 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2410 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2414 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2428 C...Check if new event (from pileup).
2432 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2435 C...Fill in missing mother information.
2436 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2438 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0)
2445 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2448 IF(I1.GE.I) CALL PYERRM(8,
2449 & '(PYHEPC:) translation of inconsistent event history')
2450 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130
2452 IF(I1.LT.I.AND.KC.EQ.0) GOTO 130
2453 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130
2455 ELSEIF(K(I,2).EQ.94) THEN
2457 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2458 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2459 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2460 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2461 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2464 C...Fill in missing daughter information.
2465 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2466 DO 140 I1=JDAHEP(1,I),JDAHEP(2,I)
2467 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2471 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150
2473 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150
2474 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150
2475 IF(JDAHEP(1,I1).EQ.0) THEN
2482 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160
2483 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2486 C...Conversion from standard to PYTHIA, the easy part.
2488 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2489 & '(PYHEPC:) no more space in /PYJETS/')
2495 IF(ISTHEP(I).EQ.1) K(I,1)=1
2496 IF(ISTHEP(I).EQ.2) K(I,1)=11
2497 IF(ISTHEP(I).EQ.3) K(I,1)=21
2509 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2511 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2512 & PHEP(5,I)/PHEP(4,I)
2515 C...Fill in missing information on colour connection in jet systems.
2516 IF(ISTHEP(I).EQ.1) THEN
2519 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2520 IF(KQ.NE.0) NKQ=NKQ+1
2521 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2522 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2524 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2525 IF(K(I+1,2).EQ.21) K(I,1)=2
2529 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2530 & '(PYHEPC:) input parton configuration not colour singlet')
2535 C*********************************************************************
2538 C...Initializes the generation procedure; finds maxima of the
2539 C...differential cross-sections to be used for weighting.
2541 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2543 C...Double precision and integer declarations.
2544 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2545 IMPLICIT INTEGER(I-N)
2546 INTEGER PYK,PYCHGE,PYCOMP
2548 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2549 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2550 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2551 COMMON/PYDAT4/CHAF(500,2)
2553 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2554 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2555 COMMON/PYINT1/MINT(400),VINT(400)
2556 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2557 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2558 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2559 &/PYINT1/,/PYINT2/,/PYINT5/
2560 C...Local arrays and character variables.
2561 DIMENSION ALAMIN(20),NFIN(20)
2562 CHARACTER*(*) FRAME,BEAM,TARGET
2563 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2565 C...Interface to PDFLIB.
2566 COMMON/LW50512/QCDL4,QCDL5
2568 DOUBLE PRECISION VALUE(20),QCDL4,QCDL5
2569 CHARACTER*20 PARM(20)
2570 DATA VALUE/20*0D0/,PARM/20*' '/
2572 C...Data:Lambda and n_f values for parton distributions..
2573 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2574 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2576 DATA CHLH/'lepton','hadron'/
2578 C...Reset MINT and VINT arrays. Write headers.
2584 IF(MSTU(12).GE.1) CALL PYLIST(0)
2585 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2587 C...Call user process initialization routine.
2588 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2594 C...Maximum 4 generations; set maximum number of allowed flavours.
2595 MSTP(1)=MIN(4,MSTP(1))
2596 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2597 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2599 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2603 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2606 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2607 IPM=(5-ISIGN(1,I))/2
2609 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2610 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2612 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2617 C...Initialize parton distributions: PDFLIB.
2618 IF(MSTP(52).EQ.2) THEN
2622 VALUE(2)=MSTP(51)/1000
2624 VALUE(3)=MOD(MSTP(51),1000)
2627 CALL PDFSET_ALICE(PARM,VALUE)
2628 MINT(93)=1000000+MSTP(51)
2631 C...Choose Lambda value to use in alpha-strong.
2633 IF(MSTP(3).GE.2) THEN
2636 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2637 ALAM=ALAMIN(MSTP(51))
2639 ELSEIF(MSTP(52).EQ.2) THEN
2648 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2651 C...Initialize the SUSY generation: couplings, masses,
2652 C...decay modes, branching ratios, and so on.
2654 C...Initialize widths and partial widths for resonances.
2656 C...Set Z0 mass and width for e+e- routines.
2657 PARJ(123)=PMAS(23,1)
2658 PARJ(124)=PMAS(23,2)
2660 C...Identify beam and target particles and frame of process.
2664 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2665 IF(MINT(65).EQ.1) GOTO 170
2667 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2668 C...For e-gamma allow 2 alternatives.
2670 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2671 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2672 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2673 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2674 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2675 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2676 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2677 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2678 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2679 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
2680 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2681 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2682 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
2683 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
2684 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2685 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2686 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
2687 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
2690 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
2691 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
2692 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
2693 IF(MSTP(14).EQ.11) MINT(123)=0
2694 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
2695 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
2696 IF(MSTP(14).EQ.15) MINT(123)=2
2697 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
2698 IF(MSTP(14).EQ.19) MINT(123)=3
2699 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
2700 IF(MSTP(14).EQ.21) MINT(123)=0
2701 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
2702 IF(MSTP(14).EQ.24) MINT(123)=1
2703 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
2704 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
2705 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
2708 C...Set up kinematics of process.
2711 C...Set up kinematics for photons inside leptons.
2712 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
2714 C...Precalculate flavour selection weights.
2717 C...Loop over gamma-p or gamma-gamma alternatives.
2720 DO 160 IGA=1,MINT(121)
2724 C...Select partonic subprocesses to be included in the simulation.
2731 C...Count number of subprocesses on.
2734 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2735 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
2737 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2738 & MSUB(ISUB).EQ.1) THEN
2739 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2741 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2742 WRITE(MSTU(11),5300) ISUB
2744 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2745 WRITE(MSTU(11),5400) ISUB
2747 ELSEIF(MSUB(ISUB).EQ.1) THEN
2752 C...Stop or raise warning flag if no subprocesses on.
2753 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
2754 IF(MSTP(127).NE.1) THEN
2755 WRITE(MSTU(11),5500)
2758 WRITE(MSTU(11),5700)
2762 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2763 MSAV48=MSAV48+MINT(48)
2765 C...Reset variables for cross-section calculation.
2773 C...Find parametrized total cross-sections.
2777 C...Maxima of differential cross-sections.
2778 IF(MSTP(121).LE.1) CALL PYMAXI
2780 C...Initialize possibility of pileup events.
2781 IF(MINT(121).GT.1) MSTP(131)=0
2782 IF(MSTP(131).NE.0) CALL PYPILE(1)
2784 C...Initialize multiple interactions with variable impact parameter.
2785 IF(MINT(50).EQ.1) THEN
2786 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
2787 IF(MSTP(81).EQ.0.AND.CKIN(3).GT.PTMN) MSTP(82)=MIN(1,MSTP(82))
2788 IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2)
2792 C...Save results for gamma-p and gamma-gamma alternatives.
2793 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2796 C...Initialization finished.
2797 IF(MSAV48.EQ.0) THEN
2798 IF(MSTP(127).NE.1) THEN
2799 WRITE(MSTU(11),5500)
2802 WRITE(MSTU(11),5700)
2806 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2808 C...Formats for initialization information.
2809 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
2810 &'routines',1X,17('*'))
2811 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
2812 &'-',A6,' interactions.'/1X,'Execution stopped!')
2813 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
2814 &1X,'Execution stopped!')
2815 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
2816 &1X,'Execution stopped!')
2817 5500 FORMAT(1X,'Error: no subprocess switched on.'/
2818 &1X,'Execution stopped.')
2819 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
2821 5700 FORMAT(1X,'Error: no subprocess switched on.'/
2822 &1X,'Execution will stop if you try to generate events.')
2827 C*********************************************************************
2830 C...Administers the generation of a high-pT event via calls to
2831 C...a number of subroutines.
2835 C...Double precision and integer declarations.
2836 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2837 IMPLICIT INTEGER(I-N)
2838 INTEGER PYK,PYCHGE,PYCOMP
2840 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2842 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2843 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2844 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2845 COMMON/PYINT1/MINT(400),VINT(400)
2846 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2847 COMMON/PYINT4/MWID(500),WIDS(500,5)
2848 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2849 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,
2850 &/PYINT2/,/PYINT4/,/PYINT5/
2854 C...Stop if no subprocesses on.
2855 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
2856 WRITE(MSTU(11),5100)
2859 C...Initial values for some counters.
2870 C...If variable energies: redo incoming kinematics and cross-section.
2872 IF(MSTP(171).EQ.1) THEN
2874 IF(MSTI(61).EQ.1) THEN
2878 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
2882 C...Loop over number of pileup events; check space left.
2883 IF(MSTP(131).LE.0) THEN
2889 DO 250 IPILE=1,NPILE
2890 IF(MINT(84)+100.GE.MSTU(4)) THEN
2892 & '(PYEVNT:) no more space in PYJETS for pileup events')
2893 IF(MSTU(21).GE.1) GOTO 260
2897 C...Generate variables of hard scattering.
2901 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
2906 IF(MSTI(61).EQ.1) THEN
2910 IF(MINT(51).EQ.2) RETURN
2912 IF(MSTP(111).EQ.-1) GOTO 240
2914 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
2915 C...Hard scattering (including low-pT):
2916 C...reconstruct kinematics and colour flow of hard scattering.
2921 IF(MINT(51).EQ.1) GOTO 100
2924 IF(ISUB.EQ.95) GOTO 120
2926 C...Showering of initial state partons (optional).
2930 IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2)
2932 IF(MINT(51).EQ.1) GOTO 100
2934 C...Showering of final state partons (optional).
2937 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
2941 IF(ISET(ISUB).EQ.5) IPU4=-3
2943 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
2944 CALL PYSHOW(IPU3,IPU4,QMAX)
2945 ELSEIF(ISET(ISUB).EQ.11) THEN
2950 C...Decay of final state resonances.
2952 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
2953 IF(MINT(51).EQ.1) GOTO 100
2956 C...Multiple interactions.
2957 IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6)
2960 C...Hadron remnants and primordial kT.
2961 120 CALL PYREMN(IPU1,IPU2)
2962 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO 110
2963 IF(MINT(51).EQ.1) GOTO 100
2965 ELSEIF(ISUB.NE.99) THEN
2966 C...Diffractive and elastic scattering.
2970 C...DIS scattering (photon flux external).
2972 IF(MINT(51).EQ.1) GOTO 100
2975 C...Check that no odd resonance left undecayed.
2976 IF(MSTP(111).GE.1) THEN
2978 DO 130 I=MINT(84)+1,NFIX
2979 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
2980 & K(I,2).NE.22) THEN
2982 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
2984 IF(MINT(51).EQ.1) GOTO 100
2990 C...Boost hadronic subsystem to overall rest frame.
2991 C..(Only relevant when photon inside lepton beam.)
2992 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
2994 C...Recalculate energies from momenta and masses (if desired).
2995 IF(MSTP(113).GE.1) THEN
2996 DO 140 I=MINT(83)+1,N
2997 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
2998 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3003 C...Rearrange partons along strings, check invariant mass cuts.
3005 IF(MSTP(111).LE.0) MSTJ(14)=-1
3006 CALL PYPREP(MINT(84)+1)
3008 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3009 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3010 DO 170 I=MINT(84)+1,N
3011 IF(K(I,2).EQ.94) THEN
3012 DO 160 I1=I+1,MIN(N,I+10)
3013 IF(K(I1,3).EQ.I) THEN
3014 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3015 IF(K(I1,3).EQ.0) THEN
3016 DO 150 II=MINT(84)+1,I-1
3017 IF(K(II,2).EQ.K(I1,2)) THEN
3018 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3019 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3022 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3030 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3031 IF(MSTP(125).EQ.0) MINT(4)=0
3032 DO 190 I=MINT(83)+1,N
3033 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3035 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3036 IF(K(I1,3).EQ.I) K(I,5)=I1
3042 C...Introduce separators between sections in PYLIST event listing.
3043 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3046 ELSEIF(IPILE.EQ.1) THEN
3053 C...Go back to lab frame (needed for vertices, also in fragmentation).
3056 C...Set nonvanishing production vertex (optional).
3057 IF(MSTP(151).EQ.1) THEN
3059 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3060 & SIN(PARU(2)*PYR(0))
3062 DO 220 I=MINT(83)+1,N
3064 V(I,J)=V(I,J)+VTX(J)
3069 C...Perform hadronization (if desired).
3070 IF(MSTP(111).GE.1) THEN
3072 IF(MSTU(24).NE.0) GOTO 100
3074 IF(MSTP(113).GE.1) THEN
3076 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3077 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3080 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3082 C...Store event information and calculate Monte Carlo estimates of
3083 C...subprocess cross-sections.
3084 240 IF(IPILE.EQ.1) CALL PYDOCU
3086 C...Set counters for current pileup event and loop to next one.
3088 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3089 IF(MSTU70.LT.10) THEN
3094 MINT(84)=N+MSTP(126)
3095 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3098 C...Generic information on pileup events. Reconstruct missing history.
3099 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3103 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3107 C...Transform to the desired coordinate frame.
3108 260 CALL PYFRAM(MSTP(124))
3113 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3114 &1X,'Execution stopped.')
3119 C***********************************************************************
3122 C...Prints out information about cross-sections, decay widths, branching
3123 C...ratios, kinematical limits, status codes and parameter values.
3125 SUBROUTINE PYSTAT(MSTAT)
3127 C...Double precision and integer declarations.
3128 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3129 IMPLICIT INTEGER(I-N)
3130 INTEGER PYK,PYCHGE,PYCOMP
3131 C...Parameter statement to help give large particle numbers.
3132 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3133 &KEXCIT=4000000,KDIMEN=5000000)
3134 PARAMETER (EPS=1D-3)
3136 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3137 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3138 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3139 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3140 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3141 COMMON/PYINT1/MINT(400),VINT(400)
3142 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3143 COMMON/PYINT4/MWID(500),WIDS(500,5)
3144 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3145 COMMON/PYINT6/PROC(0:500)
3146 CHARACTER PROC*28, CHTMP*16
3147 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3148 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
3149 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
3150 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
3151 C...Local arrays, character variables and data.
3152 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
3153 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
3154 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
3155 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
3156 CHARACTER*24 CHD0, CHDC(10)
3157 CHARACTER*6 DNAME(3)
3159 &'VMD/hadron * VMD ','VMD/hadron * direct ',
3160 &'VMD/hadron * anomalous ','direct * direct ',
3161 &'direct * anomalous ','anomalous * anomalous '/
3162 DATA DISGA/'e * VMD','e * anomalous'/
3164 &'direct * direct ','direct * VMD ',
3165 &'direct * anomalous ','VMD * direct ',
3166 &'VMD * VMD ','VMD * anomalous ',
3167 &'anomalous * direct ','anomalous * VMD ',
3168 &'anomalous * anomalous ','DIS * VMD ',
3169 &'DIS * anomalous ','VMD * DIS ',
3170 &'anomalous * DIS '/
3172 &'direct * direct ','direct * resolved ',
3173 &'resolved * direct ','resolved * resolved '/
3175 &'direct * hadron ','resolved * hadron '/
3177 &'VMD * hadron ','direct * hadron ',
3178 &'anomalous * hadron ','DIS * hadron '/
3179 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
3180 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
3181 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
3182 &' y*_small ',' eta*_large ',' eta*_small ',
3183 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
3184 &' x_2 ',' x_F ',' cos(theta_hard) ',
3185 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
3186 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
3188 DATA DNAME /'q ','lepton','nu '/
3192 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
3193 WRITE(MSTU(11),5000)
3194 WRITE(MSTU(11),5100)
3195 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
3197 IF(MSUB(I).NE.1) GOTO 100
3198 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
3200 IF(MINT(121).GT.1) THEN
3201 WRITE(MSTU(11),5300)
3202 DO 110 IGA=1,MINT(121)
3204 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3205 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
3207 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3208 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
3210 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
3211 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
3213 ELSEIF(MINT(121).EQ.4) THEN
3214 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
3216 ELSEIF(MINT(121).EQ.2) THEN
3217 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
3220 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
3226 WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
3227 & MAX(1D0,DBLE(NGEN(0,2)))
3229 C...Decay widths and branching ratios.
3230 ELSEIF(MSTAT.EQ.2) THEN
3231 WRITE(MSTU(11),5500)
3232 WRITE(MSTU(11),5600)
3235 CALL PYNAME(KF,CHKF)
3238 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
3239 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
3240 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
3241 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
3242 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
3244 IF(MWID(KC).LE.0) GOTO 140
3245 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
3246 & KF/KSUSY1.EQ.2)) GOTO 140
3248 C...Off-shell branchings.
3251 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
3252 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
3253 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
3254 DO 120 J=1,MDCY(KC,3)
3257 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3258 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3260 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3261 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3262 CALL PYNAME(KFDP(IDC,1),CHD1)
3263 CALL PYNAME(KFDP(IDC,2),CHD2)
3264 IF(KFDP(IDC,3).EQ.0) THEN
3265 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3266 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3267 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3269 CALL PYNAME(KFDP(IDC,3),CHD3)
3270 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3271 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3272 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3275 C...On-shell decays.
3277 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
3279 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
3280 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
3281 & STATE(MDCY(KC,1)),BRFIN
3282 DO 130 J=1,MDCY(KC,3)
3285 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3286 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3288 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3289 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3291 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
3292 CALL PYNAME(KFDP(IDC,1),CHD1)
3293 CALL PYNAME(KFDP(IDC,2),CHD2)
3294 IF(KFDP(IDC,3).EQ.0) THEN
3295 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3296 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3297 & CHD2(1:10),WDTP(J),WDTP(J)/WDTP(0),
3298 & STATE(MDME(IDC,1)),BRFIN
3300 CALL PYNAME(KFDP(IDC,3),CHD3)
3301 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3302 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3303 & CHD2(1:10),CHD3(1:10),WDTP(J),WDTP(J)/WDTP(0),
3304 & STATE(MDME(IDC,1)),BRFIN
3309 WRITE(MSTU(11),6000)
3311 C...Allowed incoming partons/particles at hard interaction.
3312 ELSEIF(MSTAT.EQ.3) THEN
3313 WRITE(MSTU(11),6100)
3314 CALL PYNAME(MINT(11),CHAU)
3316 CALL PYNAME(MINT(12),CHAU)
3318 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
3322 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
3323 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
3325 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
3328 WRITE(MSTU(11),6400)
3330 C...User-defined limits on kinematical variables.
3331 ELSEIF(MSTAT.EQ.4) THEN
3332 WRITE(MSTU(11),6500)
3333 WRITE(MSTU(11),6600)
3335 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
3336 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
3337 PTHMIN=MAX(CKIN(3),CKIN(5))
3339 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
3340 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
3341 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
3343 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
3346 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
3347 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
3348 WRITE(MSTU(11),7000)
3350 C...Status codes and parameter values.
3351 ELSEIF(MSTAT.EQ.5) THEN
3352 WRITE(MSTU(11),7100)
3353 WRITE(MSTU(11),7200)
3355 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
3359 C...List of all processes implemented in the program.
3360 ELSEIF(MSTAT.EQ.6) THEN
3361 WRITE(MSTU(11),7400)
3362 WRITE(MSTU(11),7500)
3364 IF(ISET(I).LT.0) GOTO 180
3365 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
3367 WRITE(MSTU(11),7700)
3369 ELSEIF(MSTAT.EQ.7) THEN
3370 WRITE (MSTU(11),8000)
3376 KFSUSY=ILR*KSUSY1+KFSM
3379 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
3385 CALL PYNAME(KFSUSY,CHTMP)
3387 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
3388 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
3389 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
3391 DO 200 J=1,MDCY(KC,3)
3393 ID1=IABS(KFDP(IDC,1))
3394 ID2=IABS(KFDP(IDC,2))
3395 IF (KFDP(IDC,3).EQ.0) THEN
3396 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3397 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3398 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3399 NMODES(1)=NMODES(1)+1
3400 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3401 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3402 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3403 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
3404 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3405 NMODES(2)=NMODES(2)+1
3406 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3407 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3408 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3409 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3410 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3411 NMODES(3)=NMODES(3)+1
3412 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3413 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3419 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
3425 CALL PYNAME(KFSUSY,CHTMP)
3427 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
3428 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3430 DO 220 J=1,MDCY(KC,3)
3432 ID1=IABS(KFDP(IDC,1))
3433 ID2=IABS(KFDP(IDC,2))
3434 IF (KFDP(IDC,3).EQ.0) THEN
3435 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
3436 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3437 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3438 NMODES(1)=NMODES(1)+1
3439 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3440 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3441 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
3442 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3443 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3444 NMODES(2)=NMODES(2)+1
3445 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3446 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3452 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
3458 CALL PYNAME(KFSUSY,CHTMP)
3460 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
3461 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3463 DO 240 J=1,MDCY(KC,3)
3465 ID1=IABS(KFDP(IDC,1))
3466 ID2=IABS(KFDP(IDC,2))
3467 IF (KFDP(IDC,3).EQ.0) THEN
3468 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3469 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
3470 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3471 NMODES(1)=NMODES(1)+1
3472 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3473 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3475 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
3476 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3477 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3478 NMODES(2)=NMODES(2)+1
3479 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3480 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3485 C...SNEUTRINO DECAYS
3486 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
3493 CALL PYNAME(KFSUSY,CHTMP)
3495 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
3496 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
3498 DO 260 J=1,MDCY(KC,3)
3500 ID1=IABS(KFDP(IDC,1))
3501 ID2=IABS(KFDP(IDC,2))
3502 IF (KFDP(IDC,3).EQ.0) THEN
3503 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
3504 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
3505 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3506 NMODES(1)=NMODES(1)+1
3507 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3508 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3510 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
3511 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
3512 NMODES(2)=NMODES(2)+1
3513 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3514 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3515 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3520 IF (NRVDC.NE.0) THEN
3522 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
3523 NMODES(0)=NMODES(0)+NMODES(I)
3531 C...NEUTRALINO DECAYS
3532 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
3538 CALL PYNAME(KFSUSY,CHTMP)
3540 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
3541 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3542 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3543 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3545 DO 310 J=1,MDCY(KC,3)
3547 ID1=IABS(KFDP(IDC,1))
3548 ID2=IABS(KFDP(IDC,2))
3549 ID3=IABS(KFDP(IDC,3))
3550 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3551 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
3552 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
3553 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3554 NMODES(1)=NMODES(1)+1
3555 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3556 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3557 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3558 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
3559 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3560 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3561 NMODES(2)=NMODES(2)+1
3562 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3563 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3564 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3565 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
3566 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3567 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3568 NMODES(3)=NMODES(3)+1
3569 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3570 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3571 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3572 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
3573 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3574 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3575 NMODES(4)=NMODES(4)+1
3576 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3577 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3582 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
3588 CALL PYNAME(KFSUSY,CHTMP)
3590 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
3591 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
3592 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3593 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3594 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3596 DO 330 J=1,MDCY(KC,3)
3598 ID1=IABS(KFDP(IDC,1))
3599 ID2=IABS(KFDP(IDC,2))
3600 ID3=IABS(KFDP(IDC,3))
3601 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3602 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
3603 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
3604 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3605 NMODES(1)=NMODES(1)+1
3606 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3607 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3608 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3609 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
3610 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
3611 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3612 NMODES(1)=NMODES(1)+1
3613 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3614 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3615 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3616 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
3617 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
3618 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3619 NMODES(2)=NMODES(2)+1
3620 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3621 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3622 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3623 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3624 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
3625 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3626 NMODES(3)=NMODES(3)+1
3627 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3628 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3629 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
3630 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3631 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3632 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3633 NMODES(3)=NMODES(3)+1
3634 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3635 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3636 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3637 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3638 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
3639 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3640 NMODES(4)=NMODES(4)+1
3641 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3642 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3643 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3644 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3645 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3646 PBRAT(4)=PBRAT(4)+BRAT(IDC)
3647 NMODES(4)=NMODES(4)+1
3648 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3649 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3650 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3651 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
3652 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3653 PBRAT(5)=PBRAT(5)+BRAT(IDC)
3654 NMODES(5)=NMODES(5)+1
3655 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3656 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3657 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
3658 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
3659 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3660 PBRAT(5)=PBRAT(5)+BRAT(IDC)
3661 NMODES(5)=NMODES(5)+1
3662 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3663 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3668 IF (KFSM.EQ.21) THEN
3674 CALL PYNAME(KFSUSY,CHTMP)
3676 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3677 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3678 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
3680 DO 350 J=1,MDCY(KC,3)
3682 ID1=IABS(KFDP(IDC,1))
3683 ID2=IABS(KFDP(IDC,2))
3684 ID3=IABS(KFDP(IDC,3))
3685 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
3686 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
3687 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
3688 PBRAT(1)=PBRAT(1)+BRAT(IDC)
3689 NMODES(1)=NMODES(1)+1
3690 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3691 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3692 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
3693 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
3694 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3695 PBRAT(2)=PBRAT(2)+BRAT(IDC)
3696 NMODES(2)=NMODES(2)+1
3697 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3698 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3699 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
3700 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
3701 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
3702 PBRAT(3)=PBRAT(3)+BRAT(IDC)
3703 NMODES(3)=NMODES(3)+1
3704 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
3705 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
3710 IF (NRVDC.NE.0) THEN
3712 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
3713 NMODES(0)=NMODES(0)+NMODES(I)
3717 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
3719 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
3720 WRITE (MSTU(11),8500)
3724 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
3725 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
3729 WRITE (MSTU(11),8600)
3733 C...Formats for printouts.
3734 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
3735 &'Events and Cross-sections',1X,9('*'))
3736 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
3737 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
3738 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
3739 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
3740 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
3741 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
3743 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
3745 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
3746 &1X,'I',34X,'I',28X,'I',12X,'I')
3747 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
3748 &1X,'********* Fraction of events that fail fragmentation ',
3749 &'cuts =',1X,F8.5,' *********'/)
3750 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
3751 &'Ratios',1X,27('*'))
3752 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3753 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
3754 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
3755 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
3757 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
3758 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
3759 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
3760 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
3761 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3762 &1P,D10.3,0P,1X,'I')
3763 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
3764 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
3765 &1P,D10.3,0P,1X,'I')
3766 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
3767 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
3768 &'Particles at Hard Interaction',1X,7('*'))
3769 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
3770 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
3771 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
3772 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
3773 &78('=')/1X,'I',38X,'I',37X,'I')
3774 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
3775 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
3776 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
3777 &'Kinematical Variables',1X,12('*'))
3778 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
3779 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
3781 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
3782 &1X,'<',1X,1P,D10.3,0P,16X,'I')
3783 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
3784 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
3785 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
3786 &'Parameter Values',1X,12('*'))
3787 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
3789 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
3790 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
3792 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
3793 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
3794 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
3795 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
3796 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
3798 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
3799 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
3800 & ,'Mother --> Sum over final state flavours',4X,'I',2X
3801 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
3802 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
3803 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
3804 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
3805 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
3806 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
3808 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
3809 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
3810 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
3812 & 1X,'R-Violating couplings',1X/ 1X /
3814 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
3815 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
3816 & ,'I',15X,'I',15X,'I',15X,'I')
3817 8600 FORMAT(1X,55('='))
3818 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
3819 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
3824 C*********************************************************************
3827 C...Calculates full and effective widths of gauge bosons, stores
3828 C...masses and widths, rescales coefficients to be used for
3829 C...resonance production generation.
3833 C...Double precision and integer declarations.
3834 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3835 IMPLICIT INTEGER(I-N)
3836 INTEGER PYK,PYCHGE,PYCOMP
3837 C...Parameter statement to help give large particle numbers.
3838 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3839 &KEXCIT=4000000,KDIMEN=5000000)
3841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3842 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3843 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3844 COMMON/PYDAT4/CHAF(500,2)
3846 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3847 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3848 COMMON/PYINT1/MINT(400),VINT(400)
3849 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3850 COMMON/PYINT4/MWID(500),WIDS(500,5)
3851 COMMON/PYINT6/PROC(0:500)
3853 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3854 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
3855 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
3856 C...Local arrays and data.
3857 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
3858 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
3860 C...Born level couplings in MSSM Higgs doublet sector.
3863 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
3865 IF(MSTP(4).EQ.2) THEN
3867 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
3871 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
3872 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
3874 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
3875 WRITE(MSTU(11),5000)
3878 PMAS(35,1)=SQRT(SQMHP)
3879 PMAS(36,1)=SQRT(SQMA)
3880 PMAS(37,1)=SQRT(SQMHC)
3881 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
3886 PARU(161)=-SIN(ALSU)/COS(BESU)
3887 PARU(162)=COS(ALSU)/SIN(BESU)
3889 PARU(164)=SIN(BESU-ALSU)
3891 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
3892 PARU(171)=COS(ALSU)/COS(BESU)
3893 PARU(172)=SIN(ALSU)/SIN(BESU)
3895 PARU(174)=COS(BESU-ALSU)
3897 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
3899 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
3900 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
3906 PARU(186)=COS(BESU-ALSU)
3907 PARU(187)=SIN(BESU-ALSU)
3911 PARU(195)=COS(BESU-ALSU)
3914 C...Reset effective widths of gauge bosons.
3921 C...Order resonances by increasing mass (except Z0 and W+/-).
3925 IF(KF.EQ.0) GOTO 140
3926 IF(MWID(KC).EQ.0) GOTO 140
3927 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
3928 IF(MSTP(1).LE.3) GOTO 140
3930 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
3931 IF(IMSS(1).LE.0) GOTO 140
3935 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
3936 DO 120 I1=NRES-1,1,-1
3937 IF(PMRES.GE.PMORD(I1)) GOTO 130
3938 KCORD(I1+1)=KCORD(I1)
3939 PMORD(I1+1)=PMORD(I1)
3945 C...Loop over possible resonances.
3950 C...Check that no fourth generation channels on by mistake.
3951 IF(MSTP(1).LE.3) THEN
3952 DO 150 J=1,MDCY(KC,3)
3954 KFA1=IABS(KFDP(IDC,1))
3955 KFA2=IABS(KFDP(IDC,2))
3956 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
3957 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
3962 C...Check that no supersymmetric channels on by mistake.
3963 IF(IMSS(1).LE.0) THEN
3964 DO 160 J=1,MDCY(KC,3)
3966 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
3967 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
3968 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
3973 C...Find mass and evaluate width.
3975 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
3976 IF(MWID(KC).EQ.3) MINT(63)=1
3977 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
3980 C...Evaluate suppression factors due to non-simulated channels.
3982 C...Protection against division by 0 since rho_21_tc is causing problem here
3983 IF (WDTP(0) .GT. 0.) THEN
3985 IF(KCHG(KC,3).EQ.0) THEN
3986 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
3987 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3988 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3989 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3994 IF(MWID(KC).EQ.3) MINT(63)=1
3995 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
3997 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
3998 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
3999 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
4000 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
4001 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
4002 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
4003 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
4004 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
4005 & 2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
4006 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
4007 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
4008 & 2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
4012 C...Set resonance widths and branching ratios;
4013 C...also on/off switch for decays.
4014 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
4016 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
4017 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
4018 DO 170 J=1,MDCY(KC,3)
4021 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
4026 C...Flavours of leptoquark: redefine charge and name.
4027 KFLQQ=KFDP(MDCY(42,2),1)
4028 KFLQL=KFDP(MDCY(42,2),2)
4029 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
4030 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
4032 IF(IABS(KFLQL).EQ.13) LL=2
4033 IF(IABS(KFLQL).EQ.15) LL=3
4034 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
4035 &CHAF(IABS(KFLQL),1)(1:LL)//' '
4036 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
4038 C...Special cases in treatment of gamma*/Z0: redefine process name.
4039 IF(MSTP(43).EQ.1) THEN
4040 PROC(1)='f + fbar -> gamma*'
4041 PROC(15)='f + fbar -> g + gamma*'
4042 PROC(19)='f + fbar -> gamma + gamma*'
4043 PROC(30)='f + g -> f + gamma*'
4044 PROC(35)='f + gamma -> f + gamma*'
4045 ELSEIF(MSTP(43).EQ.2) THEN
4046 PROC(1)='f + fbar -> Z0'
4047 PROC(15)='f + fbar -> g + Z0'
4048 PROC(19)='f + fbar -> gamma + Z0'
4049 PROC(30)='f + g -> f + Z0'
4050 PROC(35)='f + gamma -> f + Z0'
4051 ELSEIF(MSTP(43).EQ.3) THEN
4052 PROC(1)='f + fbar -> gamma*/Z0'
4053 PROC(15)='f + fbar -> g + gamma*/Z0'
4054 PROC(19)='f + fbar -> gamma + gamma*/Z0'
4055 PROC(30)='f + g -> f + gamma*/Z0'
4056 PROC(35)='f + gamma -> f + gamma*/Z0'
4059 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
4060 IF(MSTP(44).EQ.1) THEN
4061 PROC(141)='f + fbar -> gamma*'
4062 ELSEIF(MSTP(44).EQ.2) THEN
4063 PROC(141)='f + fbar -> Z0'
4064 ELSEIF(MSTP(44).EQ.3) THEN
4065 PROC(141)='f + fbar -> Z''0'
4066 ELSEIF(MSTP(44).EQ.4) THEN
4067 PROC(141)='f + fbar -> gamma*/Z0'
4068 ELSEIF(MSTP(44).EQ.5) THEN
4069 PROC(141)='f + fbar -> gamma*/Z''0'
4070 ELSEIF(MSTP(44).EQ.6) THEN
4071 PROC(141)='f + fbar -> Z0/Z''0'
4072 ELSEIF(MSTP(44).EQ.7) THEN
4073 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
4076 C...Special cases in treatment of WW -> WW: redefine process name.
4077 IF(MSTP(45).EQ.1) THEN
4078 PROC(77)='W+ + W+ -> W+ + W+'
4079 ELSEIF(MSTP(45).EQ.2) THEN
4080 PROC(77)='W+ + W- -> W+ + W-'
4081 ELSEIF(MSTP(45).EQ.3) THEN
4082 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
4085 C...Format for error information.
4086 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
4087 &'combination'/1X,'Execution stopped!')
4092 C*********************************************************************
4095 C...Identifies the two incoming particles and the choice of frame.
4097 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
4099 C...Double precision and integer declarations.
4100 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4101 IMPLICIT INTEGER(I-N)
4102 INTEGER PYK,PYCHGE,PYCOMP
4104 C...User process initialization commonblock.
4106 PARAMETER (MAXPUP=100)
4107 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4108 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4109 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4110 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4115 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4116 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4117 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4118 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4119 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4120 COMMON/PYINT1/MINT(400),VINT(400)
4121 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
4123 C...Local arrays, character variables and data.
4124 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
4125 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
4126 DIMENSION LEN(3),KCDE(39),PM(2)
4127 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
4128 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
4129 DATA CHCDE/ 'e- ','e+ ','nu_e ',
4130 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
4131 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
4132 &'nu_taubar ','pi+ ','pi- ','n0 ',
4133 &'nbar0 ','p+ ','pbar- ','gamma ',
4134 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
4135 &'xi- ','xi0 ','omega- ','pi0 ',
4136 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
4137 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
4138 &'k+ ','k- ','ks0 ','kl0 '/
4139 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
4140 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
4141 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
4143 C...Store initial energy. Default frame.
4147 C...Special user process initialization; convert to normal input.
4148 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
4150 CALL PYNAME(IDBMUP(1),CHNAME)
4152 CALL PYNAME(IDBMUP(2),CHNAME)
4156 C...Convert character variables to lowercase and find their length.
4163 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
4165 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
4171 C...Fix up bar, underscore and charge in particle name (if needed).
4173 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
4175 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
4178 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
4180 CHIDNT(I)='nu_'//CHTEMP(3:7)
4181 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
4182 CHIDNT(I)(1:3)='n0 '
4183 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
4184 CHIDNT(I)(1:5)='nbar0'
4185 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
4186 CHIDNT(I)(1:3)='p+ '
4187 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
4188 & CHIDNT(I)(1:2).EQ.'p-') THEN
4189 CHIDNT(I)(1:5)='pbar-'
4190 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
4192 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
4193 CHIDNT(I)(1:7)='reggeon'
4194 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
4195 CHIDNT(I)(1:7)='pomeron'
4199 C...Identify free initialization.
4200 IF(CHCOM(1)(1:2).EQ.'no') THEN
4205 C...Identify incoming beam and target particles.
4208 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
4210 PM(I)=PYMASS(MINT(10+I))
4213 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
4214 CHTEMP=CHIDNT(I+1)(7:12)//' '
4216 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
4218 PM(I)=PYMASS(MINT(140+I))
4222 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
4223 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
4224 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
4226 C...Identify choice of frame and input energies.
4229 C...Events defined in the CM frame.
4230 IF(CHCOM(1)(1:2).EQ.'cm') THEN
4233 IF(MSTP(122).GE.1) THEN
4234 IF(CHCOM(2)(1:1).NE.'e') THEN
4235 LOFFS=(31-(LEN(2)+LEN(3)))/2
4236 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
4237 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4240 LOFFS=(30-(LEN(2)+LEN(3)))/2
4241 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
4242 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4245 WRITE(MSTU(11),5200) CHINIT
4246 WRITE(MSTU(11),5300) WIN
4249 C...Events defined in fixed target frame.
4250 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
4252 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
4253 IF(MSTP(122).GE.1) THEN
4254 LOFFS=(29-(LEN(2)+LEN(3)))/2
4255 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4256 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4257 & ' fixed target'//' '
4258 WRITE(MSTU(11),5200) CHINIT
4259 WRITE(MSTU(11),5400) WIN
4260 WRITE(MSTU(11),5500) SQRT(S)
4263 C...Frame defined by user three-vectors.
4264 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
4268 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4269 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4270 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4271 & (P(1,3)+P(2,3))**2
4272 IF(MSTP(122).GE.1) THEN
4273 LOFFS=(22-(LEN(2)+LEN(3)))/2
4274 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4275 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4276 & ' user configuration'//' '
4277 WRITE(MSTU(11),5200) CHINIT
4278 WRITE(MSTU(11),5600)
4279 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4280 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4281 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4284 C...Frame defined by user four-vectors.
4285 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
4287 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4288 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4289 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4290 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4291 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4292 & (P(1,3)+P(2,3))**2
4293 IF(MSTP(122).GE.1) THEN
4294 LOFFS=(22-(LEN(2)+LEN(3)))/2
4295 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4296 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4297 & ' user configuration'//' '
4298 WRITE(MSTU(11),5200) CHINIT
4299 WRITE(MSTU(11),5600)
4300 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4301 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4302 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4305 C...Frame defined by user five-vectors.
4306 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
4308 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
4309 & (P(1,3)+P(2,3))**2
4310 IF(MSTP(122).GE.1) THEN
4311 LOFFS=(22-(LEN(2)+LEN(3)))/2
4312 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4313 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4314 & ' user configuration'//' '
4315 WRITE(MSTU(11),5200) CHINIT
4316 WRITE(MSTU(11),5600)
4317 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
4318 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
4319 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4322 C...Frame defined by HEPRUP common block.
4323 ELSEIF(MINT(111).EQ.11) THEN
4324 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
4325 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
4326 IF(MSTP(122).GE.1) THEN
4327 LOFFS=(22-(LEN(2)+LEN(3)))/2
4328 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
4329 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
4330 & ' user configuration'//' '
4331 WRITE(MSTU(11),5200) CHINIT
4332 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
4333 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
4336 C...Unknown frame. Error for too low CM energy.
4338 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
4341 IF(S.LT.PARP(2)**2) THEN
4342 WRITE(MSTU(11),5900) SQRT(S)
4346 C...Formats for initialization and error information.
4347 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
4348 &1X,'Execution stopped!')
4349 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
4350 &1X,'Execution stopped!')
4351 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
4352 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
4353 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
4354 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
4355 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
4356 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
4357 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
4358 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
4359 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
4360 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
4361 &1X,'Execution stopped!')
4362 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
4363 &'generation.'/1X,'Execution stopped!')
4364 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
4365 &'GeV beam energies',13X,'I')
4370 C*********************************************************************
4373 C...Sets up kinematics, including rotations and boosts to/from CM frame.
4375 SUBROUTINE PYINKI(MODKI)
4377 C...Double precision and integer declarations.
4378 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4379 IMPLICIT INTEGER(I-N)
4380 INTEGER PYK,PYCHGE,PYCOMP
4382 C...User process initialization commonblock.
4384 PARAMETER (MAXPUP=100)
4385 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4386 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4387 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4388 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4393 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4394 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4395 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4396 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4397 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4398 COMMON/PYINT1/MINT(400),VINT(400)
4399 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
4401 C...Set initial flavour state.
4406 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
4409 C...Reset boost. Do kinematics for various cases.
4414 C...Set up kinematics for events defined in CM frame.
4415 IF(MINT(111).EQ.1) THEN
4417 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4421 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4422 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4427 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
4430 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4431 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
4433 C...Set up kinematics for fixed target events.
4434 ELSEIF(MINT(111).EQ.2) THEN
4436 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
4439 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4440 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4446 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
4449 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
4450 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
4451 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4453 C...Set up kinematics for events in user-defined frame.
4454 ELSEIF(MINT(111).EQ.3) THEN
4457 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4458 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4459 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
4460 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
4462 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4464 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4465 VINT(7)=PYANGL(P(1,1),P(1,2))
4466 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4467 VINT(6)=PYANGL(P(1,3),P(1,1))
4468 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4469 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
4471 C...Set up kinematics for events with user-defined four-vectors.
4472 ELSEIF(MINT(111).EQ.4) THEN
4473 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
4474 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
4475 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
4476 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
4478 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4480 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4481 VINT(7)=PYANGL(P(1,1),P(1,2))
4482 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4483 VINT(6)=PYANGL(P(1,3),P(1,1))
4484 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4485 S=(P(1,4)+P(2,4))**2
4487 C...Set up kinematics for events with user-defined five-vectors.
4488 ELSEIF(MINT(111).EQ.5) THEN
4490 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
4492 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
4493 VINT(7)=PYANGL(P(1,1),P(1,2))
4494 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
4495 VINT(6)=PYANGL(P(1,3),P(1,1))
4496 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
4497 S=(P(1,4)+P(2,4))**2
4499 C...Set up kinematics for events with external user processes.
4500 ELSEIF(MINT(111).EQ.11) THEN
4503 IF(MINT(141).NE.0) P(1,5)=VINT(303)
4504 IF(MINT(142).NE.0) P(2,5)=VINT(304)
4509 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
4510 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
4513 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
4514 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
4515 S=(P(1,4)+P(2,4))**2
4518 C...Return or error for too low CM energy.
4519 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
4520 IF(MSTP(172).LE.1) THEN
4522 & '(PYINKI:) too low invariant mass in this event')
4529 C...Save information on incoming particles.
4532 IF(MINT(111).GE.4) THEN
4533 IF(MINT(141).EQ.0) THEN
4535 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
4539 IF(MINT(142).EQ.0) THEN
4541 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
4547 IF(MODKI.EQ.0) VINT(289)=S
4555 C...Store pT cut-off and related constants to be used in generation.
4556 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
4557 IF(MSTP(82).LE.1) THEN
4558 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4560 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4562 VINT(149)=4D0*PTMN**2/S
4568 C*********************************************************************
4571 C...Selects partonic subprocesses to be included in the simulation.
4575 C...Double precision and integer declarations.
4576 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4577 IMPLICIT INTEGER(I-N)
4578 INTEGER PYK,PYCHGE,PYCOMP
4580 C...User process initialization commonblock.
4582 PARAMETER (MAXPUP=100)
4583 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4584 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4585 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4586 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4590 C...Commonblocks and character variables.
4591 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4592 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4593 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4594 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4595 COMMON/PYINT1/MINT(400),VINT(400)
4596 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4597 COMMON/PYINT6/PROC(0:500)
4599 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
4603 C...Reset processes to be included.
4610 C...Set running pTmin scale.
4611 IF(MSTP(82).LE.1) THEN
4612 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
4614 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
4617 C...Begin by assuming incoming photon to enter subprocess.
4618 IF(MINT(11).EQ.22) MINT(15)=22
4619 IF(MINT(12).EQ.22) MINT(16)=22
4621 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
4622 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4624 MINT(123)=MINT(122)+1
4626 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
4628 C...Here also set a few parameters otherwise normally not touched.
4629 ELSEIF(MINT(121).GT.1) THEN
4631 C...Parton distributions dampened at small Q2; go to low energies,
4632 C...alpha_s <1; no minimum pT cut-off a priori.
4633 IF(MSTP(18).EQ.2) THEN
4641 C...Define pT cut-off parameters and whether run involves low-pT.
4645 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
4647 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
4648 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
4650 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
4651 IF(MSEL.EQ.2) IPTL=1
4653 C...Set up for p/gamma * gamma; real or virtual photons.
4654 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
4655 & MSTP(14).EQ.30)) THEN
4657 C...Set up for p/VMD * VMD.
4658 IF(MINT(122).EQ.1) THEN
4666 IF(IPTL.EQ.1) MSUB(95)=1
4673 IF(IPTL.EQ.1) CKIN(3)=0D0
4675 C...Set up for p/VMD * direct gamma.
4676 ELSEIF(MINT(122).EQ.2) THEN
4678 IF(MINT(121).EQ.6) MINT(123)=5
4683 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4685 C...Set up for p/VMD * anomalous gamma.
4686 ELSEIF(MINT(122).EQ.3) THEN
4688 IF(MINT(121).EQ.6) MINT(123)=7
4695 IF(IPTL.EQ.1) MSUB(95)=1
4702 IF(IPTL.EQ.1) CKIN(3)=0D0
4704 C...Set up for DIS * p.
4705 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
4706 & IABS(MINT(12)).GT.100)) THEN
4708 IF(IPTL.EQ.1) MSUB(99)=1
4710 C...Set up for direct * direct gamma (switch off leptons).
4711 ELSEIF(MINT(122).EQ.4) THEN
4717 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4718 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4720 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4722 C...Set up for direct * anomalous gamma.
4723 ELSEIF(MINT(122).EQ.5) THEN
4729 IF(IPTL.EQ.1) CKIN(3)=PTMANO
4731 C...Set up for anomalous * anomalous gamma.
4732 ELSEIF(MINT(122).EQ.6) THEN
4740 IF(IPTL.EQ.1) MSUB(95)=1
4747 IF(IPTL.EQ.1) CKIN(3)=0D0
4750 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
4751 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4753 C...Set up for direct * direct gamma (switch off leptons).
4754 IF(MINT(122).EQ.1) THEN
4760 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4761 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4763 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4765 C...Set up for direct * VMD and VMD * direct gamma.
4766 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
4772 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4774 C...Set up for direct * anomalous and anomalous * direct gamma.
4775 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
4781 IF(IPTL.EQ.1) CKIN(3)=PTMANO
4783 C...Set up for VMD*VMD.
4784 ELSEIF(MINT(122).EQ.5) THEN
4792 IF(IPTL.EQ.1) MSUB(95)=1
4799 IF(IPTL.EQ.1) CKIN(3)=0D0
4801 C...Set up for VMD * anomalous and anomalous * VMD gamma.
4802 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
4810 IF(IPTL.EQ.1) MSUB(95)=1
4817 IF(IPTL.EQ.1) CKIN(3)=0D0
4819 C...Set up for anomalous * anomalous gamma.
4820 ELSEIF(MINT(122).EQ.9) THEN
4828 IF(IPTL.EQ.1) MSUB(95)=1
4835 IF(IPTL.EQ.1) CKIN(3)=0D0
4837 C...Set up for DIS * VMD and VMD * DIS gamma.
4838 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
4840 IF(IPTL.EQ.1) MSUB(99)=1
4842 C...Set up for DIS * anomalous and anomalous * DIS gamma.
4843 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
4845 IF(IPTL.EQ.1) MSUB(99)=1
4848 C...Set up for gamma* * p; virtual photons = dir, res.
4849 ELSEIF(MINT(121).EQ.2) THEN
4851 C...Set up for direct * p.
4852 IF(MINT(122).EQ.1) THEN
4858 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4860 C...Set up for resolved * p.
4861 ELSEIF(MINT(122).EQ.2) THEN
4869 IF(IPTL.EQ.1) MSUB(95)=1
4876 IF(IPTL.EQ.1) CKIN(3)=0D0
4879 C...Set up for gamma* * gamma*; virtual photons = dir, res.
4880 ELSEIF(MINT(121).EQ.4) THEN
4882 C...Set up for direct * direct gamma (switch off leptons).
4883 IF(MINT(122).EQ.1) THEN
4889 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
4890 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
4892 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4894 C...Set up for direct * resolved and resolved * direct gamma.
4895 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
4901 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
4903 C...Set up for resolved * resolved gamma.
4904 ELSEIF(MINT(122).EQ.4) THEN
4912 IF(IPTL.EQ.1) MSUB(95)=1
4919 IF(IPTL.EQ.1) CKIN(3)=0D0
4922 C...End of special set up for gamma-p and gamma-gamma.
4927 C...Flavour information for individual beams.
4930 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
4931 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
4932 MINT(44+I)=MINT(40+I)
4933 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
4934 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
4937 C...If two real gammas, whereof one direct, pick the first.
4938 C...For two virtual photons, keep requested order.
4939 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4940 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
4943 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
4944 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
4947 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
4948 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
4951 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
4952 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
4955 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
4956 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
4959 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
4962 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
4966 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
4967 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
4968 IF(MINT(11).EQ.22) THEN
4976 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
4977 & '(PYINPR:) unallowed MSTP(14) code for single photon')
4980 C...Flavour information on combination of incoming particles.
4981 MINT(43)=2*MINT(41)+MINT(42)-2
4983 IF(MINT(123).LE.0) THEN
4984 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
4985 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
4986 ELSEIF(MINT(123).LE.3) THEN
4987 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
4988 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
4989 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
4993 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
4994 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
4995 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
4996 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
4998 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
5001 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
5002 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
5004 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
5006 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
5007 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
5008 & MINT(122).EQ.10) MINT(108)=2
5009 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
5010 & MINT(122).EQ.11) MINT(108)=3
5011 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
5012 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
5013 IF(MINT(122).GE.3) MINT(107)=1
5014 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
5015 ELSEIF(MINT(121).EQ.2) THEN
5016 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
5017 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
5019 IF(MINT(11).EQ.22) THEN
5021 IF(MINT(123).GE.4) MINT(107)=0
5022 IF(MINT(123).EQ.7) MINT(107)=2
5023 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
5024 IF(MSTP(14).EQ.28) MINT(107)=2
5025 IF(MSTP(14).EQ.29) MINT(107)=3
5026 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
5029 IF(MINT(12).EQ.22) THEN
5031 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
5032 IF(MINT(123).EQ.7) MINT(108)=3
5033 IF(MSTP(14).EQ.26) MINT(108)=2
5034 IF(MSTP(14).EQ.27) MINT(108)=3
5035 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
5036 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
5039 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
5040 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
5046 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
5047 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
5049 C...Select default processes according to incoming beams
5050 C...(already done for gamma-p and gamma-gamma with
5051 C...MSTP(14) = 10, 20, 25 or 30).
5052 IF(MINT(121).GT.1) THEN
5053 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
5055 IF(MINT(43).EQ.1) THEN
5056 C...Lepton + lepton -> gamma/Z0 or W.
5057 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
5058 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
5060 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
5061 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
5062 C...Unresolved photon + lepton: Compton scattering.
5066 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
5067 & .OR.MINT(12).EQ.22)) THEN
5068 C...DIS as pure gamma* + f -> f process.
5071 ELSEIF(MINT(43).LE.3) THEN
5072 C...Lepton + hadron: deep inelastic scattering.
5075 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
5076 & MINT(12).EQ.22) THEN
5077 C...Two unresolved photons: fermion pair production,
5078 C...exclude lepton pairs.
5082 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5083 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5086 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
5087 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
5088 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
5090 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
5091 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
5092 & MINT(12).EQ.22)) THEN
5093 C...Unresolved photon + hadron: photon-parton scattering.
5098 ELSEIF(MSEL.EQ.1) THEN
5099 C...High-pT QCD processes:
5108 IF(CKIN(3).LT.PTMN) MSUB(95)=1
5109 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
5112 C...All QCD processes:
5126 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
5127 C...Heavy quark production.
5131 DO 180 J=1,MIN(8,MDCY(21,3))
5132 MDME(MDCY(21,2)+J-1,1)=0
5134 MDME(MDCY(21,2)+MSEL-1,1)=1
5136 DO 190 J=1,MIN(12,MDCY(22,3))
5137 MDME(MDCY(22,2)+J-1,1)=0
5139 MDME(MDCY(22,2)+MSEL-1,1)=1
5141 ELSEIF(MSEL.EQ.10) THEN
5142 C...Prompt photon production:
5147 ELSEIF(MSEL.EQ.11) THEN
5148 C...Z0/gamma* production:
5151 ELSEIF(MSEL.EQ.12) THEN
5152 C...W+/- production:
5155 ELSEIF(MSEL.EQ.13) THEN
5160 ELSEIF(MSEL.EQ.14) THEN
5165 ELSEIF(MSEL.EQ.15) THEN
5166 C...Z0 & W+/- pair production:
5173 ELSEIF(MSEL.EQ.16) THEN
5181 ELSEIF(MSEL.EQ.17) THEN
5182 C...h0 & Z0 or W+/- pair production:
5186 ELSEIF(MSEL.EQ.18) THEN
5187 C...h0 production; interesting processes in e+e-.
5193 ELSEIF(MSEL.EQ.19) THEN
5194 C...h0, H0 and A0 production; interesting processes in e+e-.
5208 ELSEIF(MSEL.EQ.21) THEN
5212 ELSEIF(MSEL.EQ.22) THEN
5213 C...W'+/- production:
5216 ELSEIF(MSEL.EQ.23) THEN
5217 C...H+/- production:
5220 ELSEIF(MSEL.EQ.24) THEN
5224 ELSEIF(MSEL.EQ.25) THEN
5225 C...LQ (leptoquark) production.
5231 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
5232 C...Production of one heavy quark (W exchange):
5234 DO 200 J=1,MIN(8,MDCY(21,3))
5235 MDME(MDCY(21,2)+J-1,1)=0
5237 MDME(MDCY(21,2)+MSEL-31,1)=1
5239 CMRENNA++Define SUSY alternatives.
5240 ELSEIF(MSEL.EQ.39) THEN
5241 C...Turn on all SUSY processes.
5242 IF(MINT(43).EQ.4) THEN
5243 C...Hadron-hadron processes.
5245 IF(ISET(I).GE.0) MSUB(I)=1
5247 ELSEIF(MINT(43).EQ.1) THEN
5248 C...Lepton-lepton processes: QED production of squarks.
5265 ELSEIF(MSEL.EQ.40) THEN
5266 C...Gluinos and squarks.
5267 IF(MINT(43).EQ.4) THEN
5279 ELSEIF(MINT(43).EQ.1) THEN
5284 ELSEIF(MSEL.EQ.41) THEN
5285 C...Stop production.
5289 IF(MINT(43).EQ.4) THEN
5294 ELSEIF(MSEL.EQ.42) THEN
5295 C...Slepton production.
5299 IF(MINT(43).NE.4) THEN
5305 ELSEIF(MSEL.EQ.43) THEN
5306 C...Neutralino/Chargino + Gluino/Squark.
5307 IF(MINT(43).EQ.4) THEN
5316 ELSEIF(MSEL.EQ.44) THEN
5317 C...Neutralino/Chargino pair production.
5318 IF(MINT(43).EQ.4) THEN
5322 ELSEIF(MINT(43).EQ.1) THEN
5328 ELSEIF(MSEL.EQ.45) THEN
5329 C...Sbottom production.
5332 IF(MINT(43).EQ.4) THEN
5338 ELSEIF(MSEL.EQ.50) THEN
5339 C...Pair production of technipions and gauge bosons.
5343 IF(MINT(43).EQ.4) THEN
5349 ELSEIF(MSEL.EQ.51) THEN
5350 C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
5356 C...Find heaviest new quark flavour allowed in processes 81-84.
5358 DO 350 I=1,MIN(8,MDCY(21,3))
5360 IF(MDME(IDC,1).LE.0) GOTO 350
5363 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
5374 C...Find heaviest new fermion flavour allowed in process 85.
5376 DO 360 I=1,MIN(12,MDCY(22,3))
5378 IF(MDME(IDC,1).LE.0) GOTO 360
5381 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
5382 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
5387 C...Import relevant information on external user processes.
5388 IF(MINT(111).EQ.11) THEN
5391 C...Find next empty PYTHIA process number slot and enable it.
5393 IF(IPYPR.GT.500) CALL PYERRM(26,
5394 & '(PYINPR.) no more empty slots for user processes')
5395 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
5396 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
5398 C...Overwrite KFPR with references back to process number and ID.
5400 KFPR(IPYPR,2)=LPRUP(IUP)
5402 WRITE(CHIPR,'(I10)') LPRUP(IUP)
5405 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
5407 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
5408 C...Switch on process.
5416 C*********************************************************************
5419 C...Parametrizes total, elastic and diffractive cross-sections
5420 C...for different energies and beams. Donnachie-Landshoff for
5421 C...total and Schuler-Sjostrand for elastic and diffractive.
5422 C...Process code IPROC:
5429 C...= 7 : J/psi + p;
5430 C...= 11 : rho + rho;
5431 C...= 12 : rho + phi;
5432 C...= 13 : rho + J/psi;
5433 C...= 14 : phi + phi;
5434 C...= 15 : phi + J/psi;
5435 C...= 16 : J/psi + J/psi;
5436 C...= 21 : gamma + p (DL);
5437 C...= 22 : gamma + p (VDM).
5438 C...= 23 : gamma + pi (DL);
5439 C...= 24 : gamma + pi (VDM);
5440 C...= 25 : gamma + gamma (DL);
5441 C...= 26 : gamma + gamma (VDM).
5445 C...Double precision and integer declarations.
5446 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5447 IMPLICIT INTEGER(I-N)
5448 INTEGER PYK,PYCHGE,PYCOMP
5450 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5451 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5452 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5453 COMMON/PYINT1/MINT(400),VINT(400)
5454 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5455 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5456 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
5458 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
5459 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
5460 &CEFFD(10,9),SIGTMP(6,0:5)
5462 C...Common constants.
5463 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
5464 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
5467 C...Number of multiple processes to be evaluated (= 0 : undefined).
5468 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
5469 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
5470 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
5471 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
5472 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
5474 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
5475 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
5476 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
5478 C...Beam and target hadron class:
5479 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
5480 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
5481 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
5482 C...Characteristic class masses, slope parameters, beta = sqrt(X).
5483 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
5484 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
5485 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
5487 C...Fitting constants used in parametrizations of diffractive results.
5488 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5489 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
5490 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
5491 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
5492 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
5493 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
5494 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
5495 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
5496 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
5497 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
5498 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
5499 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
5500 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
5501 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
5502 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
5503 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
5504 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
5505 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
5506 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
5507 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
5508 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
5509 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
5510 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
5511 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
5512 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
5513 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
5514 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
5515 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
5516 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
5518 C...Parameters. Combinations of the energy.
5527 C...Ratio of gamma/pi (for rescaling in parton distributions).
5528 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
5529 &(XPAR(5)*SEPS+YPAR(5)*SETA)
5531 IF(MINT(50).NE.1) RETURN
5533 C...Order flavours of incoming particles: KF1 < KF2.
5534 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
5543 ISGN12=ISIGN(1,MINT(11)*MINT(12))
5545 C...Find process number (for lookup tables).
5546 IF(KF1.GT.1000) THEN
5548 IF(ISGN12.LT.0) IPROC=2
5549 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
5551 IF(ISGN12.LT.0) IPROC=4
5552 IF(KF1.EQ.111) IPROC=5
5553 ELSEIF(KF1.GT.100) THEN
5555 ELSEIF(KF2.GT.1000) THEN
5557 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
5558 ELSEIF(KF2.GT.100) THEN
5560 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
5563 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
5566 C... Number of multiple processes to be stored; beam/target side.
5572 ELSEIF(NPR.EQ.6) THEN
5577 IF(MINT(101).EQ.4) N1=4
5579 IF(MINT(102).EQ.4) N2=4
5581 C...Do not do any more for user-set or undefined cross-sections.
5582 IF(MSTP(31).LE.0) RETURN
5583 IF(NPR.EQ.0) CALL PYERRM(26,
5584 &'(PYXTOT:) cross section for this process not yet implemented')
5586 C...Parameters. Combinations of the energy.
5595 C...Loop over multiple processes (for VDM).
5599 ELSEIF(NPR.EQ.3) THEN
5601 IF(KF2.LT.1000) IPR=I+10
5602 ELSEIF(NPR.EQ.6) THEN
5606 C...Evaluate hadron species, mass, slope contribution and fit number.
5616 C...Skip if energy too low relative to masses.
5620 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
5622 C...Total cross-section. Elastic slope parameter and cross-section.
5623 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
5624 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
5625 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
5627 C...Diffractive scattering A + B -> X + B.
5630 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
5631 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5632 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5633 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
5634 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
5635 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
5636 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
5638 C...Diffractive scattering A + B -> A + X.
5641 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
5642 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
5643 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
5644 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
5645 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
5646 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
5647 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
5649 C...Order single diffractive correctly.
5652 SIGTMP(I,2)=SIGTMP(I,3)
5656 C...Double diffractive scattering A + B -> X1 + X2.
5657 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
5658 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
5659 SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
5660 IF(YEFF.LE.0) SUM1=0D0
5661 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
5662 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
5663 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
5664 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
5666 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
5667 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
5668 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
5670 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
5671 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
5672 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
5673 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
5674 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
5676 C...Non-diffractive by unitarity.
5677 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
5681 C...Put temporary results in output array: only one process.
5682 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
5684 SIGT(0,0,J)=SIGTMP(1,J)
5687 C...Beam multiple processes.
5688 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
5689 IF(MINT(107).EQ.2) THEN
5690 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5692 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5693 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5695 IF(MSTP(20).GT.0) THEN
5696 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
5699 IF(MINT(107).EQ.2) THEN
5700 CONV=(AEM/PARP(160+I))*VINT(317)
5701 ELSEIF(VINT(154).GT.PARP(15)) THEN
5702 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5703 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5709 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
5713 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5716 C...Target multiple processes.
5717 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
5718 IF(MINT(108).EQ.2) THEN
5719 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5721 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5722 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5724 IF(MSTP(20).GT.0) THEN
5725 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
5728 IF(MINT(108).EQ.2) THEN
5729 CONV=(AEM/PARP(160+I))*VINT(317)
5730 ELSEIF(VINT(154).GT.PARP(15)) THEN
5731 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
5732 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5738 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
5742 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
5745 C...Both beam and target multiple processes.
5747 IF(MINT(107).EQ.2) THEN
5748 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
5750 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
5751 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
5753 IF(MINT(108).EQ.2) THEN
5754 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
5756 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
5757 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
5759 IF(MSTP(20).GT.0) THEN
5760 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
5761 & VINT(308)))**MSTP(20)
5765 IF(MINT(107).EQ.2) THEN
5766 CONV=(AEM/PARP(160+I1))*VINT(317)
5767 ELSEIF(VINT(154).GT.PARP(15)) THEN
5768 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
5769 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
5773 IF(MINT(108).EQ.2) THEN
5774 CONV=CONV*(AEM/PARP(160+I2))
5775 ELSEIF(VINT(154).GT.PARP(15)) THEN
5776 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
5777 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
5783 ELSEIF(I2.LE.2) THEN
5785 ELSEIF(I1.EQ.I2) THEN
5792 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
5793 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
5799 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
5800 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
5802 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
5806 C...Scale up uniformly for Donnachie-Landshoff parametrization.
5807 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
5808 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
5812 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
5821 C*********************************************************************
5824 C...Finds optimal set of coefficients for kinematical variable selection
5825 C...and the maximum of the part of the differential cross-section used
5826 C...in the event weighting.
5830 C...Double precision and integer declarations.
5831 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5832 IMPLICIT INTEGER(I-N)
5833 INTEGER PYK,PYCHGE,PYCOMP
5834 C...Parameter statement to help give large particle numbers.
5835 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5836 &KEXCIT=4000000,KDIMEN=5000000)
5838 C...User process initialization commonblock.
5840 PARAMETER (MAXPUP=100)
5841 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5842 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5843 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5844 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5849 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5850 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5851 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5852 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5853 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5854 COMMON/PYINT1/MINT(400),VINT(400)
5855 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5856 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
5857 COMMON/PYINT4/MWID(500),WIDS(500,5)
5858 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5859 COMMON/PYINT6/PROC(0:500)
5861 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5862 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
5863 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
5864 C...Local arrays, character variables and data.
5866 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
5867 &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
5868 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
5869 DATA CVAR/'tau ','tau''','y* ','cth '/
5872 C...Initial values and loop over subprocesses.
5881 C...Find maximum weight factors for photon flux.
5882 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
5883 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
5886 C...Select subprocess to study: skip cases not applicable.
5887 IF(ISET(ISUB).EQ.11) THEN
5888 IF(MSUB(ISUB).NE.1) GOTO 460
5889 C...User process intialization: cross section model dependent.
5890 IF(IABS(IDWTUP).EQ.1) THEN
5891 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5892 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5893 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
5895 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
5896 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
5897 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
5898 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
5899 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
5900 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
5902 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5903 & WTGAGA*XSEC(ISUB,1)
5906 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
5907 CALL PYSIGH(NCHN,SIGS)
5909 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5910 & WTGAGA*XSEC(ISUB,1)
5911 IF(MSUB(ISUB).NE.1) GOTO 460
5914 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
5915 CALL PYSIGH(NCHN,SIGS)
5917 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
5918 & WTGAGA*XSEC(ISUB,1)
5919 IF(XSEC(ISUB,1).EQ.0D0) THEN
5925 ELSEIF(ISUB.EQ.96) THEN
5926 IF(MINT(50).EQ.0) GOTO 460
5927 IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
5929 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
5930 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
5931 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
5932 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
5933 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
5934 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
5936 IF(MSUB(ISUB).NE.1) GOTO 460
5939 IF(ISUB.EQ.96) ISTSB=2
5940 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
5942 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
5943 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
5945 C...Find resonances (explicit or implicit in cross-section).
5948 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
5950 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
5951 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
5953 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
5954 & .OR.ISUB.EQ.177) THEN
5956 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
5958 IF(MSTP(46).EQ.5) THEN
5961 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
5963 ELSEIF(ISUB.EQ.194) THEN
5965 ELSEIF(ISUB.EQ.195) THEN
5967 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
5969 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
5973 IF(CKMX.LE.0D0) CKMX=VINT(1)
5976 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
5977 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
5980 TAUR1=PMAS(KCR1,1)**2/VINT(2)
5981 IF(KFR1.EQ.KTECHN+113) THEN
5985 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
5992 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
5995 IF(ISUB.EQ.194) THEN
5997 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
6001 TAUR2=PMAS(KCR2,1)**2/VINT(2)
6002 IF(KFR2.EQ.KTECHN+223) THEN
6006 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
6007 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
6008 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
6009 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
6014 ELSEIF(KFR2.NE.0) THEN
6026 C...Find product masses and minimum pT of process.
6032 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
6036 IF(KFPR(ISUB,I).EQ.0) THEN
6037 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
6039 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
6040 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
6043 C...This prevents SUSY/t particles from becoming too light.
6045 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
6048 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
6049 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
6050 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
6051 & PMAS(PYCOMP(KFDP(IDC,2)),1)
6052 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
6053 & PMAS(PYCOMP(KFDP(IDC,3)),1)
6054 PMMN(I)=MIN(PMMN(I),PMSUM)
6057 ELSEIF(KFLW.EQ.6) THEN
6058 PMMN(I)=PMAS(24,1)+PMAS(5,1)
6065 CKIN(41)=MAX(PMMN(1),CKIN(41))
6066 CKIN(43)=MAX(PMMN(2),CKIN(43))
6067 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
6070 IF(MINT(51).EQ.1) THEN
6071 WRITE(MSTU(11),5100) ISUB
6078 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
6079 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
6080 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
6081 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6082 ELSEIF(ISUB.EQ.96) THEN
6083 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6089 C...Prepare for additional variable choices in 2 -> 3.
6092 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
6094 VINT(204)=PMAS(23,1)
6095 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
6096 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
6097 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
6098 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
6102 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
6103 NPTS(1)=2+2*MINT(72)
6104 IF(MINT(47).EQ.1) THEN
6105 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
6106 ELSEIF(MINT(47).GE.5) THEN
6107 IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
6110 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
6111 IF(MINT(47).GE.2) NPTS(2)=2
6112 IF(MINT(47).GE.5) NPTS(2)=3
6115 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
6117 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
6118 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
6121 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
6122 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
6124 C...Reset coefficients of cross-section weighting.
6140 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
6141 C...in grid of phase space points.
6147 IF(METAU.EQ.1) GOTO 150
6148 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
6149 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
6150 IF(MTAU.GT.2+2*MINT(72)) MTAU=7
6152 C...Special case when both resonances have same mass,
6153 C...as is often the case in process 194.
6154 IF(MINT(72).EQ.2) THEN
6155 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
6156 & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
6157 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
6159 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
6164 CALL PYKMAP(1,MTAU,RTAU)
6165 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
6168 IF(METAUP.EQ.1) GOTO 150
6169 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
6171 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
6172 CALL PYKMAP(4,MTAUP,0.5D0)
6174 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
6178 IF(MEYST.EQ.1) GOTO 150
6179 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
6180 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
6181 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
6182 CALL PYKMAP(2,MYST,0.5D0)
6186 IF(MECTH.EQ.1) GOTO 150
6187 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
6188 MCTH=1+MOD(ITRY-1,NPTS(4))
6189 CALL PYKMAP(3,MCTH,0.5D0)
6191 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
6193 C...Store position and limits.
6196 IF(MINT(51).EQ.1) GOTO 150
6199 MVARPT(NACC,2)=MTAUP
6203 VINTPT(NACC,J)=VINT(10+J)
6206 C...Normal case: calculate cross-section.
6208 CALL PYSIGH(NCHN,SIGS)
6214 C..2 -> 3: find highest value out of a number of tries.
6217 DO 140 IKIN3=1,MSTP(129)
6218 CALL PYKMAP(5,0,0D0)
6219 IF(MINT(51).EQ.1) GOTO 140
6220 CALL PYSIGH(NCHN,SIGTMP)
6225 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6229 C...Store cross-section.
6231 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6232 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
6233 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6236 WRITE(MSTU(11),5100) ISUB
6239 ELSEIF(SIGSAM.EQ.0D0) THEN
6240 WRITE(MSTU(11),5300) ISUB
6244 IF(ISUB.NE.96) NPOSI=NPOSI+1
6246 C...Calculate integrals in tau over maximal phase space limits.
6249 ATAU1=LOG(TAUMAX/TAUMIN)
6250 IF(NPTS(1).GE.2) THEN
6251 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
6253 IF(NPTS(1).GE.4) THEN
6254 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
6255 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
6258 IF(NPTS(1).GE.6) THEN
6259 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
6260 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
6263 IF(NPTS(1).GT.2+2*MINT(72)) THEN
6264 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
6267 C...Reset. Sum up cross-sections in points calculated.
6269 IF(NPTS(IVAR).EQ.1) GOTO 320
6270 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
6281 IBIN=MVARPT(IACC,IVAR)
6282 IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
6283 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
6284 NAREL(IBIN)=NAREL(IBIN)+1
6285 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
6287 C...Sum up tau cross-section pieces in points used.
6290 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6291 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
6293 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
6294 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
6295 & ((TAU-TAUR1)**2+GAMR1**2)
6298 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
6299 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
6300 & ((TAU-TAUR2)**2+GAMR2**2)
6302 IF(NBIN.GT.2+2*MINT(72)) THEN
6303 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
6304 & TAU/MAX(2D-10,1D0-TAU)
6307 C...Sum up tau' cross-section pieces in points used.
6308 ELSEIF(IVAR.EQ.2) THEN
6310 TAUP=VINTPT(IACC,16)
6311 TAUPMN=VINTPT(IACC,6)
6312 TAUPMX=VINTPT(IACC,26)
6313 ATAUP1=LOG(TAUPMX/TAUPMN)
6314 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
6315 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6316 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
6317 & (1D0-TAU/TAUP)**3/TAUP
6319 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
6320 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
6321 & TAUP/MAX(2D-10,1D0-TAUP)
6324 C...Sum up y* cross-section pieces in points used.
6325 ELSEIF(IVAR.EQ.3) THEN
6327 YSTMIN=VINTPT(IACC,2)
6328 YSTMAX=VINTPT(IACC,22)
6330 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
6332 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
6333 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
6334 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
6335 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
6336 IF(MINT(45).EQ.3) THEN
6337 TAUE=VINTPT(IACC,11)
6338 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6339 YST0=-0.5D0*LOG(TAUE)
6340 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
6341 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
6342 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
6343 & MAX(1D-10,1D0-EXP(YST-YST0))
6345 IF(MINT(46).EQ.3) THEN
6346 TAUE=VINTPT(IACC,11)
6347 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
6348 YST0=-0.5D0*LOG(TAUE)
6349 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
6350 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
6351 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
6352 & MAX(1D-10,1D0-EXP(-YST-YST0))
6355 C...Sum up cos(theta-hat) cross-section pieces in points used.
6357 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
6359 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
6361 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
6364 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
6365 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
6366 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
6367 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
6369 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
6370 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
6371 & MAX(RM34,RSQM-CTH)
6372 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
6373 & MAX(RM34,RSQM+CTH)
6374 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
6375 & MAX(RM34,RSQM-CTH)**2
6376 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
6377 & MAX(RM34,RSQM+CTH)**2
6381 C...Check that equation system solvable.
6382 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
6386 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
6387 & IRED=1,NBIN),WTREL(IBIN)
6388 IF(NAREL(IBIN).EQ.0) MSOLV=0
6389 WTRELS=WTRELS+WTREL(IBIN)
6391 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
6393 C...Solve to find relative importance of cross-section pieces.
6396 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
6398 DO 230 IRED=1,NBIN-1
6399 DO 220 IBIN=IRED+1,NBIN
6400 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
6404 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
6405 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
6406 DO 210 ICOE=IRED,NBIN
6407 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
6411 DO 250 IRED=NBIN,1,-1
6412 DO 240 ICOE=IRED+1,NBIN
6413 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
6415 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
6419 C...Share evenly if failure.
6420 260 IF(MSOLV.EQ.0) THEN
6424 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
6425 & WTREL(IBIN)/WTRELS)
6429 C...Normalize coefficients, with piece shared democratically.
6433 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
6434 COEFSU=COEFSU+COEFU(IBIN)
6435 WTRELS=WTRELS+WTRELN(IBIN)
6437 IF(COEFSU.GT.0D0) THEN
6439 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
6440 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
6444 COEFO(IBIN)=1D0/NBIN
6447 IF(IVAR.EQ.1) IOFF=0
6448 IF(IVAR.EQ.2) IOFF=17
6449 IF(IVAR.EQ.3) IOFF=7
6450 IF(IVAR.EQ.4) IOFF=12
6453 IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
6454 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
6455 COEF(ISUB,ICOF)=COEFO(IBIN)
6457 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
6458 & (COEFO(IBIN),IBIN=1,NBIN)
6461 C...Find two most promising maxima among points previously determined.
6469 VINT(10+J)=VINTPT(IACC,J)
6472 CALL PYSIGH(NCHN,SIGS)
6479 DO 350 IKIN3=1,MSTP(129)
6480 CALL PYKMAP(5,0,0D0)
6481 IF(MINT(51).EQ.1) GOTO 350
6482 CALL PYSIGH(NCHN,SIGTMP)
6487 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6492 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
6495 DO 370 IMV=NMAX,1,-1
6497 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
6498 IACCMX(IMV+1)=IACCMX(IMV)
6499 SIGSMX(IMV+1)=SIGSMX(IMV)
6502 380 IACCMX(IIN)=IACC
6504 IF(NMAX.LE.1) NMAX=NMAX+1
6508 C...Read out starting position for search.
6509 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
6514 MTAUP=MVARPT(IACC,2)
6522 C...Starting point and step size in parameter space.
6525 IF(NPTS(IVAR).EQ.1) GOTO 420
6526 IF(IVAR.EQ.1) VVAR=VTAU
6527 IF(IVAR.EQ.2) VVAR=VTAUP
6528 IF(IVAR.EQ.3) VVAR=VYST
6529 IF(IVAR.EQ.4) VVAR=VCTH
6530 IF(IVAR.EQ.1) MVAR=MTAU
6531 IF(IVAR.EQ.2) MVAR=MTAUP
6532 IF(IVAR.EQ.3) MVAR=MYST
6533 IF(IVAR.EQ.4) MVAR=MCTH
6534 IF(IRPT.EQ.1) VDEL=0.1D0
6535 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
6537 IF(IRPT.EQ.1) VMAR=0.02D0
6538 IF(IRPT.EQ.2) VMAR=0.002D0
6540 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
6543 C...Define new point in parameter space.
6547 ELSEIF(IMOV.EQ.1) THEN
6550 ELSEIF(IMOV.EQ.2) THEN
6553 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
6554 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
6560 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
6561 & VVAR-2D0*VDEL.GT.VMAR) THEN
6567 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
6581 C...Convert to relevant variables and find derived new limits.
6585 CALL PYKMAP(1,MTAU,VTAU)
6586 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
6588 IF(MINT(51).EQ.1) ILERR=1
6591 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
6593 IF(IVAR.EQ.2) VTAUP=VNEW
6594 CALL PYKMAP(4,MTAUP,VTAUP)
6596 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
6598 IF(MINT(51).EQ.1) ILERR=1
6600 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
6601 IF(IVAR.EQ.3) VYST=VNEW
6602 CALL PYKMAP(2,MYST,VYST)
6604 IF(MINT(51).EQ.1) ILERR=1
6606 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
6608 IF(IVAR.EQ.4) VCTH=VNEW
6609 CALL PYKMAP(3,MCTH,VCTH)
6611 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
6613 C...Evaluate cross-section. Save new maximum. Final maximum.
6616 ELSEIF(ISTSB.NE.5) THEN
6617 CALL PYSIGH(NCHN,SIGS)
6624 DO 400 IKIN3=1,MSTP(129)
6625 CALL PYKMAP(5,0,0D0)
6626 IF(MINT(51).EQ.1) GOTO 400
6627 CALL PYSIGH(NCHN,SIGTMP)
6632 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
6636 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
6637 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
6638 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
6643 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
6644 XSEC(ISUB,1)=1.05D0*SIGSAM
6645 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
6646 & WTGAGA*XSEC(ISUB,1)
6648 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
6649 & PARP(174)*XSEC(ISUB,1)
6650 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
6654 C...Print summary table.
6655 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
6656 IF(MSTP(127).NE.1) THEN
6657 WRITE(MSTU(11),5900)
6660 WRITE(MSTU(11),6400)
6664 IF(MSTP(122).GE.1) THEN
6665 WRITE(MSTU(11),6000)
6666 WRITE(MSTU(11),6100)
6668 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
6669 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
6670 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
6671 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
6672 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
6673 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
6674 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
6675 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
6677 WRITE(MSTU(11),6300)
6680 C...Format statements for maximization results.
6681 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
6682 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
6683 &'cth',9X,'tau''',7X,'sigma')
6684 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
6685 &'phase space.'/1X,'Process switched off!')
6686 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
6687 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
6688 &'cross-section.'/1X,'Process switched off!')
6689 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
6690 5500 FORMAT(1X,1P,8D11.3)
6691 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
6692 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
6693 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
6694 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
6695 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
6696 &'cross-section.'/1X,'Execution stopped!')
6697 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
6698 &'cross-section maximum search',1X,8('*'))
6699 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
6700 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
6701 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
6702 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
6703 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
6704 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
6706 &1X,'Execution will stop if you try to generate events.')
6711 C*********************************************************************
6714 C...Initializes multiplicity distribution and selects mutliplicity
6715 C...of pileup events, i.e. several events occuring at the same
6718 SUBROUTINE PYPILE(MPILE)
6720 C...Double precision and integer declarations.
6721 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6722 IMPLICIT INTEGER(I-N)
6723 INTEGER PYK,PYCHGE,PYCOMP
6725 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6726 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6727 COMMON/PYINT1/MINT(400),VINT(400)
6728 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6729 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
6730 C...Local arrays and saved variables.
6731 DIMENSION WTI(0:200)
6732 SAVE IMIN,IMAX,WTI,WTS
6734 C...Sum of allowed cross-sections for pileup events.
6736 VINT(131)=SIGT(0,0,5)
6737 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
6738 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
6739 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
6740 IF(MSTP(133).LE.0) RETURN
6742 C...Initialize multiplicity distribution at maximum.
6743 XNAVE=VINT(131)*PARP(131)
6744 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
6745 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
6748 WTN=WTI(INAVE)*INAVE
6750 C...Find shape of multiplicity distribution below maximum.
6752 DO 100 I=INAVE-1,1,-1
6753 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
6754 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
6755 IF(WTI(I).LT.1D-6) GOTO 110
6761 C...Find shape of multiplicity distribution above maximum.
6763 DO 120 I=INAVE+1,200
6764 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
6765 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
6766 IF(WTI(I).LT.1D-6) GOTO 130
6773 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
6774 & WTS/(WTS+WTI(1)/XNAVE)
6775 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
6776 IF(MSTP(133).GE.2) VINT(134)=XNAVE
6778 C...Pick multiplicity of pileup events.
6780 IF(MSTP(133).LE.0) THEN
6781 MINT(81)=MAX(1,MSTP(134))
6787 IF(WTR.LE.0D0) GOTO 150
6793 C...Format statement for error message.
6794 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
6795 &'crossing too large, ',1P,D12.4)
6800 C*********************************************************************
6803 C...Saves and restores parameter and cross section values for the
6804 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
6805 C...Also makes random choice between alternatives.
6807 SUBROUTINE PYSAVE(ISAVE,IGA)
6809 C...Double precision and integer declarations.
6810 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6811 IMPLICIT INTEGER(I-N)
6812 INTEGER PYK,PYCHGE,PYCOMP
6814 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6815 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6816 COMMON/PYINT1/MINT(400),VINT(400)
6817 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6818 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6819 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6820 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
6821 C...Local arrays and saved variables.
6822 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
6823 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
6824 &INTCP(15,20),RECP(15,20)
6825 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
6827 C...Save list of subprocesses and cross-section information.
6831 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
6834 MSUBCP(IGA,ICP)=MSUB(I)
6836 COEFCP(IGA,ICP,J)=COEF(I,J)
6839 NGENCP(IGA,ICP,J)=NGEN(I,J)
6840 XSECCP(IGA,ICP,J)=XSEC(I,J)
6845 NGENCP(IGA,0,J)=NGEN(0,J)
6846 XSECCP(IGA,0,J)=XSEC(0,J)
6851 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
6856 C...Save various common process variables.
6858 INTCP(IGA,J)=MINT(40+J)
6860 INTCP(IGA,11)=MINT(101)
6861 INTCP(IGA,12)=MINT(102)
6862 INTCP(IGA,13)=MINT(107)
6863 INTCP(IGA,14)=MINT(108)
6864 INTCP(IGA,15)=MINT(123)
6866 RECP(IGA,2)=VINT(318)
6868 C...Save cross-section information only.
6869 ELSEIF(ISAVE.EQ.2) THEN
6870 DO 190 ICP=1,NCP(IGA)
6873 NGENCP(IGA,ICP,J)=NGEN(I,J)
6874 XSECCP(IGA,ICP,J)=XSEC(I,J)
6878 NGENCP(IGA,0,J)=NGEN(0,J)
6879 XSECCP(IGA,0,J)=XSEC(0,J)
6882 C...Choose between allowed alternatives.
6883 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
6886 DO 210 IG=1,MINT(121)
6887 XSUMCP=XSUMCP+XSECCP(IG,0,1)
6889 XSUMCP=XSUMCP*PYR(0)
6890 DO 220 IG=1,MINT(121)
6892 XSUMCP=XSUMCP-XSECCP(IG,0,1)
6893 IF(XSUMCP.LE.0D0) GOTO 230
6898 C...Restore cross-section information.
6902 DO 270 ICP=1,NCP(IGA)
6904 MSUB(I)=MSUBCP(IGA,ICP)
6906 COEF(I,J)=COEFCP(IGA,ICP,J)
6909 NGEN(I,J)=NGENCP(IGA,ICP,J)
6910 XSEC(I,J)=XSECCP(IGA,ICP,J)
6914 NGEN(0,J)=NGENCP(IGA,0,J)
6915 XSEC(0,J)=XSECCP(IGA,0,J)
6920 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
6925 C...Restore various common process variables.
6927 MINT(40+J)=INTCP(IGA,J)
6929 MINT(101)=INTCP(IGA,11)
6930 MINT(102)=INTCP(IGA,12)
6931 MINT(107)=INTCP(IGA,13)
6932 MINT(108)=INTCP(IGA,14)
6933 MINT(123)=INTCP(IGA,15)
6936 VINT(318)=RECP(IGA,2)
6938 C...Sum up cross-section info (for PYSTAT).
6939 ELSEIF(ISAVE.EQ.5) THEN
6950 DO 350 IG=1,MINT(121)
6951 DO 340 ICP=1,NCP(IG)
6953 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
6954 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
6955 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
6956 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
6958 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
6959 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
6960 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
6961 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
6968 C*********************************************************************
6971 C...For lepton beams it gives photon-hadron or photon-photon systems
6972 C...to be treated with the ordinary machinery and combines this with a
6973 C...description of the lepton -> lepton + photon branching.
6975 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
6977 C...Double precision and integer declarations.
6978 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6979 IMPLICIT INTEGER(I-N)
6980 INTEGER PYK,PYCHGE,PYCOMP
6982 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
6983 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6984 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6985 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6986 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6987 COMMON/PYINT1/MINT(400),VINT(400)
6988 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6989 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
6991 C...Local variables and data statement.
6992 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
6993 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
6994 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
6997 C...Initialize generation of photons inside leptons.
7000 C...Save quantities on incoming lepton system.
7004 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
7006 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
7007 PMC(3)=VINT(302)-PMS(1)-PMS(2)
7008 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
7010 C...Calculate range of x and Q2 values allowed in generation.
7012 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
7013 IF(MINT(140+I).NE.0) THEN
7014 XMIN(I)=MAX(CKIN(59+2*I),EPS)
7015 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
7017 YMIN=MAX(CKIN(71+2*I),EPS)
7018 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
7019 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
7020 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
7021 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
7022 THEMIN=MAX(CKIN(67+2*I),0D0)
7023 THEMAX=MIN(CKIN(68+2*I),PARU(1))
7024 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
7025 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
7026 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
7027 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
7028 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
7029 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
7030 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
7031 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
7032 C...W limits when lepton on one side only.
7033 IF(MINT(143-I).EQ.0) THEN
7034 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
7035 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
7036 & (CKIN(78)**2-PMS(3-I))/PMC(I))
7041 C...W limits when lepton on both sides.
7042 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7043 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
7044 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
7045 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
7046 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
7047 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
7048 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
7049 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
7050 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
7051 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
7053 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
7054 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
7058 C...Q2 and W values and photon flux weight factors for initialization.
7059 ELSEIF(IGAGA.EQ.2) THEN
7064 C...W value for photon on one or both sides, and for processes
7065 C...with gamma-gamma cross section peaked at small shat.
7066 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
7067 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
7068 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
7069 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
7070 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
7071 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
7072 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
7074 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
7075 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
7077 VINT(1)=SQRT(MAX(0D0,VINT(2)))
7079 C...Upper estimate of photon flux weight factor.
7080 C...Initialization Q2 scale. Flag incoming unresolved photon.
7083 IF(MINT(140+I).NE.0) THEN
7084 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
7085 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
7086 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
7088 Q2INIT=5D0+Q2MIN(3-I)
7089 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
7090 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
7091 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
7092 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
7093 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
7094 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
7096 ELSEIF(ISUB.EQ.140) THEN
7101 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
7102 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
7104 VINT(306+I)=VINT(2+I)**2
7109 C...Update pTmin and cross section information.
7110 IF(MSTP(82).LE.1) THEN
7111 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7113 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7115 VINT(149)=4D0*PTMN**2/VINT(2)
7120 C...Generate photons inside leptons and
7121 C...calculate photon flux weight factors.
7122 ELSEIF(IGAGA.EQ.3) THEN
7127 C...Generate phase space point and check against cuts.
7131 IF(MINT(140+I).NE.0) THEN
7133 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
7134 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
7135 C...Cuts on internal consistency in x and Q2.
7136 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
7137 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
7138 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
7139 C...Cuts on y and theta.
7140 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
7141 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
7142 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
7143 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
7144 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
7145 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
7146 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
7149 C...Phi angle isotropic. Reconstruct pT.
7150 PHI(I)=PARU(2)*PYR(0)
7151 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
7152 & PMS(I))*SIN(THETA(I))
7154 C...Store info on variables selected, for documentation purposes.
7155 VINT(2+I)=-SQRT(Q2(I))
7159 VINT(310+I)=THETA(I)
7170 C...Cut on W combines info from two sides.
7171 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7172 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
7173 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
7174 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
7175 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
7176 IF(W2.LT.W2MIN) GOTO 120
7177 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
7180 ELSEIF(MINT(141).NE.0) THEN
7181 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
7184 ELSEIF(MINT(142).NE.0) THEN
7185 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
7190 C...Store kinematics info for photon(s) in subsystem cm frame.
7195 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
7196 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
7197 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
7200 VINT(298)=-VINT(293)
7201 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
7202 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
7204 C...Assign weight for photon flux; different for transverse and
7205 C...longitudinal photons. Flag incoming unresolved photon.
7208 IF(MINT(140+I).NE.0) THEN
7209 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
7210 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
7211 IF(MSTP(16).EQ.0) THEN
7214 WTGAGA=WTGAGA*X(I)/Y(I)
7217 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
7218 WTGAGA=WTGAGA*(1D0-XY)
7219 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
7220 WTGAGA=WTGAGA*(1D0-XY)
7221 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
7222 WTGAGA=WTGAGA*(1D0-XY)
7224 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
7225 & PMS(I)*XY**2/Q2(I))
7227 IF(MINT(106+I).EQ.0) MINT(14+I)=22
7233 C...Update pTmin and cross section information.
7234 IF(MSTP(82).LE.1) THEN
7235 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7237 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7239 VINT(149)=4D0*PTMN**2/VINT(2)
7243 C...Reconstruct kinematics of photons inside leptons.
7244 ELSEIF(IGAGA.EQ.4) THEN
7246 C...Make place for incoming particles and scattered leptons.
7248 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
7249 MINT(4)=MINT(4)+MOVE
7250 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
7251 IF(K(I,1).EQ.21) THEN
7257 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7258 & K(I+MOVE,3)=K(I,3)+MOVE
7259 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
7260 & K(I+MOVE,4)=K(I,4)+MOVE
7261 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
7262 & K(I+MOVE,5)=K(I,5)+MOVE
7265 DO 170 I=MINT(84)+1,N
7266 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
7267 & K(I,3)=K(I,3)+MOVE
7270 C...Fill in incoming particles.
7271 DO 190 I=MINT(83)+1,MINT(83)+MOVE
7280 IF(MINT(140+I).NE.0) THEN
7281 K(MINT(83)+I,2)=MINT(140+I)
7282 P(MINT(83)+I,5)=VINT(302+I)
7284 K(MINT(83)+I,2)=MINT(10+I)
7285 P(MINT(83)+I,5)=VINT(2+I)
7287 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
7288 & VINT(302))*(-1D0)**(I+1)
7289 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
7292 C...New mother-daughter relations in documentation section.
7293 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
7294 K(MINT(83)+1,4)=MINT(83)+3
7295 K(MINT(83)+1,5)=MINT(83)+5
7296 K(MINT(83)+2,4)=MINT(83)+4
7297 K(MINT(83)+2,5)=MINT(83)+6
7298 K(MINT(83)+3,3)=MINT(83)+1
7299 K(MINT(83)+5,3)=MINT(83)+1
7300 K(MINT(83)+4,3)=MINT(83)+2
7301 K(MINT(83)+6,3)=MINT(83)+2
7302 ELSEIF(MINT(141).NE.0) THEN
7303 K(MINT(83)+1,4)=MINT(83)+3
7304 K(MINT(83)+1,5)=MINT(83)+4
7305 K(MINT(83)+2,4)=MINT(83)+5
7306 K(MINT(83)+3,3)=MINT(83)+1
7307 K(MINT(83)+4,3)=MINT(83)+1
7308 K(MINT(83)+5,3)=MINT(83)+2
7309 ELSEIF(MINT(142).NE.0) THEN
7310 K(MINT(83)+1,4)=MINT(83)+4
7311 K(MINT(83)+2,4)=MINT(83)+3
7312 K(MINT(83)+2,5)=MINT(83)+5
7313 K(MINT(83)+3,3)=MINT(83)+2
7314 K(MINT(83)+4,3)=MINT(83)+1
7315 K(MINT(83)+5,3)=MINT(83)+2
7318 C...Fill scattered lepton(s).
7320 IF(MINT(140+I).NE.0) THEN
7321 LSC=MINT(83)+MIN(I+2,MOVE)
7323 K(LSC,2)=MINT(140+I)
7324 P(LSC,1)=PT(I)*COS(PHI(I))
7325 P(LSC,2)=PT(I)*SIN(PHI(I))
7326 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
7327 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
7329 P(LSC,5)=VINT(302+I)
7333 C...Find incoming four-vectors to subprocess.
7335 IF(MINT(141).NE.0) THEN
7337 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
7341 P(N+1,J)=P(MINT(83)+1,J)
7345 IF(MINT(142).NE.0) THEN
7347 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
7351 P(N+2,J)=P(MINT(83)+2,J)
7355 C...Define boost and rotation between hadronic subsystem and
7356 C...collision rest frame; boost hadronic subsystem to this frame.
7358 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
7360 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
7361 BPHI=PYANGL(P(N+1,1),P(N+1,2))
7362 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
7363 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
7364 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
7367 C...Add on scattered leptons to final state.
7369 IF(MINT(140+I).NE.0) THEN
7370 LSC=MINT(83)+MIN(I+2,MOVE)
7386 C*********************************************************************
7389 C...Generates quantities characterizing the high-pT scattering at the
7390 C...parton level according to the matrix elements. Chooses incoming,
7391 C...reacting partons, their momentum fractions and one of the possible
7396 C...Double precision and integer declarations.
7397 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7398 IMPLICIT INTEGER(I-N)
7399 INTEGER PYK,PYCHGE,PYCOMP
7400 C...Parameter statement to help give large particle numbers.
7401 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7402 &KEXCIT=4000000,KDIMEN=5000000)
7404 C...User process initialization and event commonblocks.
7406 PARAMETER (MAXPUP=100)
7407 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7408 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7409 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7410 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7413 PARAMETER (MAXNUP=500)
7414 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
7415 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
7416 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
7417 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
7418 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
7419 SAVE /HEPRUP/,/HEPEUP/
7422 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7423 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7424 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7425 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7426 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7427 COMMON/PYINT1/MINT(400),VINT(400)
7428 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7429 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7430 COMMON/PYINT4/MWID(500),WIDS(500,5)
7431 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7432 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7433 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
7434 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7435 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/
7437 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
7439 C...Parameters and data used in elastic/diffractive treatment.
7440 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
7441 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
7443 C...Initial values, specifically for (first) semihard interaction.
7453 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
7461 C...Start by assuming incoming photon is entering subprocess.
7462 IF(MINT(11).EQ.22) THEN
7464 VINT(307)=VINT(3)**2
7466 IF(MINT(12).EQ.22) THEN
7468 VINT(308)=VINT(4)**2
7473 C...Choice of process type - first event of pileup.
7475 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
7476 ELSEIF(MINT(82).EQ.1) THEN
7478 C...For gamma-p or gamma-gamma first pick between alternatives.
7480 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
7483 C...For real gamma + gamma with different nature, flip at random.
7484 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
7485 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
7495 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
7498 C...Pick process type, possibly by user process machinery.
7499 C...(If the latter, also event will be picked here.)
7500 IF(MINT(111).EQ.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
7502 ELSEIF(MINT(111).EQ.11.AND.IABS(IDWTUP).GE.3) THEN
7506 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
7507 & ISUB.LT.500) GOTO 110
7509 RSUB=XSEC(0,1)*PYR(0)
7511 IF(MSUB(I).NE.1) GOTO 120
7514 IF(RSUB.LE.0D0) GOTO 130
7516 130 IF(ISUB.EQ.95) ISUB=96
7517 IF(ISUB.EQ.96) INMULT=1
7518 IF(ISET(ISUB).EQ.11) THEN
7524 C...Choice of inclusive process type - pileup events.
7525 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
7526 RSUB=VINT(131)*PYR(0)
7528 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
7529 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
7530 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
7531 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
7533 IF(ISUB.EQ.96) INMULT=1
7536 C...Choice of photon energy and flux factor inside lepton.
7537 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
7538 CALL PYGAGA(3,WTGAGA)
7539 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
7540 CKIN(3)=MAX(VINT(285),VINT(154))
7543 C...When necessary set direct/resolved photon by hand.
7544 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
7545 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
7546 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
7549 C...Restrict direct*resolved processes to pTmin >= Q,
7550 C...to avoid doublecounting with DIS.
7551 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
7552 IF(MINT(15).EQ.22) THEN
7553 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
7555 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
7560 C...Set up for multiple interactions.
7561 IF(INMULT.EQ.1) CALL PYMULT(2)
7563 C...Loopback point for minimum bias in photon physics.
7566 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
7567 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
7568 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
7569 &NGEN(97,1)=NGEN(97,1)+MINT(143)
7573 C...Random choice of flavour for some SUSY processes.
7574 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
7575 C...~e_L ~nu_e or ~mu_L ~nu_mu.
7576 IF(ISUB.EQ.210) THEN
7577 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
7578 KFPR(ISUB,2)=KFPR(ISUB,1)+1
7579 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
7580 ELSEIF(ISUB.EQ.213) THEN
7581 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
7582 KFPR(ISUB,2)=KFPR(ISUB,1)
7583 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
7584 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
7585 IF(ISUB.GE.258) THEN
7590 IF(MOD(ISUB,2).EQ.0) THEN
7591 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
7593 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
7595 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7596 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
7597 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
7600 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
7603 ELSEIF(PYR(0).LT.0.5D0) THEN
7610 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
7611 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
7612 C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
7613 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
7614 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
7615 KFPR(ISUB,2)=KFPR(ISUB,1)
7616 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
7617 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
7618 KFPR(ISUB,2)=KFPR(ISUB,1)
7619 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
7620 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
7621 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
7624 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
7627 ELSEIF(PYR(0).LT.0.5D0) THEN
7634 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
7639 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
7643 C...Find resonances (explicit or implicit in cross-section).
7646 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7648 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
7649 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7651 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
7654 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7656 IF(MSTP(46).EQ.5) THEN
7659 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7661 ELSEIF(ISUB.EQ.194) THEN
7663 ELSEIF(ISUB.EQ.195) THEN
7665 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
7667 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
7671 IF(CKMX.LE.0D0) CKMX=VINT(1)
7674 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7675 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7678 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7679 IF(KFR1.EQ.KTECHN+113) THEN
7683 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7689 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
7692 IF(ISUB.EQ.194) THEN
7694 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
7698 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7699 IF(KFR2.EQ.KTECHN+223) THEN
7703 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7704 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7705 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
7706 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7711 ELSEIF(KFR2.NE.0) THEN
7722 C...Find product masses and minimum pT of process,
7723 C...optionally with broadening according to a truncated Breit-Wigner.
7728 IF(MINT(82).GE.2) VINT(71)=0D0
7730 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7734 IF(KFPR(ISUB,I).EQ.0) THEN
7735 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7737 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7740 C...This prevents SUSY/t particles from becoming too light.
7742 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7745 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7746 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7747 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7748 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7749 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7750 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7751 PMMN(I)=MIN(PMMN(I),PMSUM)
7754 ELSEIF(KFLW.EQ.6) THEN
7755 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7762 CKIN(41)=MAX(PMMN(1),CKIN(41))
7763 CKIN(43)=MAX(PMMN(2),CKIN(43))
7764 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7767 IF(MINT(51).EQ.1) THEN
7768 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
7778 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
7779 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7782 C...Prepare for additional variable choices in 2 -> 3.
7785 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7787 VINT(204)=PMAS(23,1)
7788 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7789 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7790 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
7791 & ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
7795 C...Select incoming VDM particle (rho/omega/phi/J/psi).
7796 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
7797 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
7798 VRN=PYR(0)*SIGT(0,0,5)
7799 IF(MINT(101).LE.1) THEN
7806 IF(MINT(102).LE.1) THEN
7817 VRN=VRN-SIGT(I1,I2,5)
7818 IF(VRN.LE.0D0) GOTO 190
7821 190 IF(MINT(101).GE.2) MINT(103)=KFV1
7822 IF(MINT(102).GE.2) MINT(104)=KFV2
7826 C...Elastic scattering or single or double diffractive scattering.
7828 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
7833 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
7835 VRN=PYR(0)*SIGT(0,0,JJ)
7836 IF(MINT(101).LE.1) THEN
7843 IF(MINT(102).LE.1) THEN
7854 VRN=VRN-SIGT(I1,I2,JJ)
7855 IF(VRN.LE.0D0) GOTO 220
7858 220 IF(MINT(101).GE.2) THEN
7862 IF(MINT(102).GE.2) THEN
7870 C...Select mass for GVMD states (rejecting previous assignment).
7872 Q1S=4D0*VINT(154)**2
7876 IF(MINT(106+JT).EQ.3) THEN
7878 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
7879 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
7880 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
7881 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
7884 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
7885 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
7890 C...Side/sides of diffractive system.
7893 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
7894 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
7896 C...Find masses of particles and minimal masses of diffractive states.
7899 VINT(68+JT)=PDIF(JT)
7900 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
7907 SMRES1=(PMM(1)+PMRC)**2
7908 SMRES2=(PMM(2)+PMRC)**2
7910 C...Find elastic slope and lower limit diffractive slope.
7911 IHA=MAX(2,IABS(MINT(103))/110)
7913 IHB=MAX(2,IABS(MINT(104))/110)
7916 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
7917 ELSEIF(ISUB.EQ.92) THEN
7918 BMN=MAX(2D0,2D0*BHAD(IHB))
7919 ELSEIF(ISUB.EQ.93) THEN
7920 BMN=MAX(2D0,2D0*BHAD(IHA))
7921 ELSEIF(ISUB.EQ.94) THEN
7925 C...Determine maximum possible t range and coefficient of generation.
7926 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
7927 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7928 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7929 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7930 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7931 & (SQM1*SQM4-SQM2*SQM3)/SH
7932 THL=-0.5D0*(THA+THB)
7934 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
7936 C...Select diffractive mass/masses according to dm^2/m^2.
7940 IF(MINT(16+JT).EQ.0) THEN
7944 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
7945 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
7951 C..Additional mass factors, including resonance enhancement.
7952 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
7953 IF(LOOP3.LT.100) GOTO 260
7957 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
7958 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7959 ELSEIF(ISUB.EQ.93) THEN
7960 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
7961 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
7962 ELSEIF(ISUB.EQ.94) THEN
7963 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
7964 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
7965 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
7966 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
7969 C...Select t according to exp(Bmn*t) and correct to right slope.
7970 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
7973 BADD=2D0*ALP*LOG(SH/SQM3)
7974 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
7975 ELSEIF(ISUB.EQ.93) THEN
7976 BADD=2D0*ALP*LOG(SH/SQM4)
7977 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
7978 ELSEIF(ISUB.EQ.94) THEN
7979 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
7981 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
7984 C...Check whether m^2 and t choices are consistent.
7985 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
7986 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
7987 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
7988 IF(THB.LE.1D-8) GOTO 260
7989 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
7990 & (SQM1*SQM4-SQM2*SQM3)/SH
7991 THLM=-0.5D0*(THA+THB)
7993 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
7995 C...Information to output.
7998 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
8000 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
8003 VINT(283)=PMM(1)**2/4D0
8004 VINT(284)=PMM(2)**2/4D0
8006 C...Note: in the following, by In is meant the integral over the
8007 C...quantity multiplying coefficient cn.
8008 C...Choose tau according to h1(tau)/tau, where
8009 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
8010 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
8011 C...I1/I5*c5*1/(tau+tau_R') +
8012 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
8013 C...I1/I7*c7*tau/(1.-tau), and
8014 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
8015 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
8017 IF(MINT(51).NE.0) THEN
8018 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8027 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
8028 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
8029 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
8030 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
8032 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
8033 & COEF(ISUB,5)) MTAU=6
8034 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
8035 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
8036 CALL PYKMAP(1,MTAU,PYR(0))
8038 C...2 -> 3, 4 processes:
8039 C...Choose tau' according to h4(tau,tau')/tau', where
8040 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
8041 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
8042 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8044 IF(MINT(51).NE.0) THEN
8045 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8054 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
8055 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
8056 CALL PYKMAP(4,MTAUP,PYR(0))
8059 C...Choose y* according to h2(y*), where
8060 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
8061 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
8062 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
8063 C...and c1 + c2 + c3 + c4 + c5 = 1.
8065 IF(MINT(51).NE.0) THEN
8066 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8075 IF(RYST.GT.COEF(ISUB,8)) MYST=2
8076 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
8077 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
8078 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
8079 & COEF(ISUB,11)) MYST=5
8080 CALL PYKMAP(2,MYST,PYR(0))
8082 C...2 -> 2 processes:
8083 C...Choose cos(theta-hat) (cth) according to h3(cth), where
8084 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
8085 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
8086 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
8087 C...and c0 + c1 + c2 + c3 + c4 = 1.
8089 IF(MINT(51).NE.0) THEN
8090 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8097 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
8100 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
8101 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
8102 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
8103 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
8104 & COEF(ISUB,16)) MCTH=5
8105 CALL PYKMAP(3,MCTH,PYR(0))
8108 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
8110 CALL PYKMAP(5,0,0D0)
8111 IF(MINT(51).NE.0) THEN
8112 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8121 C...DIS as f + gamma* -> f process: set dummy values.
8122 ELSEIF(ISTSB.EQ.8) THEN
8129 C...Low-pT or multiple interactions (first semihard interaction).
8130 ELSEIF(ISTSB.EQ.9) THEN
8134 C...Study user-defined process: kinematics plus weight.
8135 ELSEIF(ISTSB.EQ.11) THEN
8136 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
8137 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
8142 IF(MINT(82).EQ.1) THEN
8143 NGEN(0,1)=NGEN(0,1)-1
8144 NGEN(ISUB,1)=NGEN(ISUB,1)-1
8146 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8150 C...Extract cross section event weight.
8151 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
8154 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
8156 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
8157 VINT(97)=SIGN(1D0,XWGTUP)
8159 VINT(97)=1D-9*XWGTUP
8162 C...Construct 'trivial' kinematical variables needed.
8165 VINT(41)=PUP(4,1)/EBMUP(1)
8166 VINT(42)=PUP(4,2)/EBMUP(2)
8167 VINT(21)=VINT(41)*VINT(42)
8168 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
8169 VINT(44)=VINT(21)*VINT(2)
8170 VINT(43)=SQRT(MAX(0D0,VINT(44)))
8172 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
8173 VINT(56)=VINT(55)**2
8177 C...Construct other kinematical variables needed (approximately).
8180 VINT(45)=-0.5D0*VINT(44)
8181 VINT(46)=-0.5D0*VINT(44)
8190 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
8191 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
8193 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
8194 & '(PYRAND:) unacceptable ISTUP code for particles')
8195 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
8196 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
8197 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
8200 VINT(47)=SQRT(VINT(48))
8203 C...Choose azimuthal angle.
8205 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
8207 C...Check against user cuts on kinematics at parton level.
8209 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
8210 IF(MINT(51).NE.0) THEN
8211 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8218 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
8220 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
8223 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8232 C...Calculate differential cross-section for different subprocesses.
8233 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
8235 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
8237 C...Multiply cross section by lepton -> photon flux factor.
8238 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
8241 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
8243 SIGLPT=WTGAGA*SIGLPT
8246 C...Multiply cross-section by user-defined weights.
8247 IF(MSTP(173).EQ.1) THEN
8250 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
8252 SIGLPT=PARP(173)*SIGLPT
8258 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
8259 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
8260 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
8263 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
8266 C...Calculations for Monte Carlo estimate of all cross-sections.
8267 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
8268 IF(MSTP(142).LE.1) THEN
8269 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8271 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
8273 ELSEIF(MINT(82).EQ.1) THEN
8274 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
8276 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
8277 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
8279 C...Multiple interactions: store results of cross-section calculation.
8280 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
8285 C...Ratio of actual to maximum cross section.
8286 IF(ISTSB.NE.11) THEN
8287 VIOL=SIGSWT/XSEC(ISUB,1)
8288 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
8289 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
8290 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
8291 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
8292 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
8297 C...Check that weight not negative.
8298 IF(MSTP(123).LE.0) THEN
8299 IF(VIOL.LT.-1D-3) THEN
8300 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
8301 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8302 & VINT(22),VINT(23),VINT(26)
8306 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
8308 WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
8309 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
8310 & VINT(22),VINT(23),VINT(26)
8314 C...Weighting using estimate of maximum of differential cross-section.
8315 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
8316 IF(VIOL.LT.PYR(0)) THEN
8317 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8318 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
8321 ELSEIF(MFAIL.EQ.0) THEN
8322 RATND=SIGLPT/XSEC(95,1)
8324 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
8325 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
8326 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
8327 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8331 IF(VIOL.LT.PYR(0)) THEN
8334 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
8335 IF(VIOL.LT.PYR(0)) THEN
8337 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8341 RATND=SIGLPT/XSEC(95,1)
8342 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
8344 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8348 IF(VIOL.LT.PYR(0)) THEN
8349 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8354 C...Check for possible violation of estimated maximum of differential
8355 C...cross-section used in weighting.
8356 IF(MSTP(123).LE.0) THEN
8357 IF(VIOL.GT.1D0) THEN
8358 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
8359 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8360 & VINT(22),VINT(23),VINT(26)
8363 ELSEIF(MSTP(123).EQ.1) THEN
8364 IF(VIOL.GT.VINT(108)) THEN
8366 IF(VIOL.GT.1.0001D0) THEN
8368 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8369 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8370 & VINT(22),VINT(23),VINT(26)
8373 ELSEIF(VIOL.GT.VINT(108)) THEN
8375 IF(VIOL.GT.1D0) THEN
8377 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
8378 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
8380 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
8381 IF(KFPR(ISUB,1).LE.9) THEN
8382 WRITE(MSTU(11),5800) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8383 ELSEIF(KFPR(ISUB,1).LE.99) THEN
8384 WRITE(MSTU(11),5900) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8386 WRITE(MSTU(11),6000) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1))
8389 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
8390 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
8391 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
8392 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
8393 & XSEC(0,1)=XSEC(0,1)+XDIF
8394 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
8395 & VINT(22),VINT(23),VINT(26)
8397 WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
8398 ELSEIF(ISUB.LE.99) THEN
8399 WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
8401 WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
8408 C...Multiple interactions: choose impact parameter.
8410 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
8411 &MSTP(82).GE.3) THEN
8413 IF(VINT(150).LT.PYR(0)) THEN
8414 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8422 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
8423 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
8424 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
8425 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
8427 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
8429 C...Choose flavour of reacting partons (and subprocess).
8430 IF(ISTSB.GE.11) GOTO 320
8433 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
8434 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
8435 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
8436 &PYR(0).GT.RQQBAR)) THEN
8440 MINT(2)=ISIG(ICHN,3)
8441 RSIGS=RSIGS-SIGH(ICHN)
8442 IF(RSIGS.LE.0D0) GOTO 320
8445 C...Multiple interactions: choose qqbar preferentially at small pT.
8446 ELSEIF(ISUB.EQ.96) THEN
8449 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
8452 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
8455 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
8457 C...Low-pT: choose string drawing configuration.
8463 IF(RSIGS.GT.1D0) MINT(2)=2
8464 IF(RSIGS.GT.2D0) MINT(2)=3
8467 C...Reassign QCD process. Partons before initial state radiation.
8468 320 IF(MINT(2).GT.10) THEN
8470 MINT(2)=MOD(MINT(2),10)
8472 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
8483 C...Calculate x value of photon for parton inside photon inside e.
8488 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
8489 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
8490 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
8495 MINT(105)=MINT(102+JT)
8496 MINT(109)=MINT(106+JT)
8497 VINT(120)=VINT(2+JT)
8498 IF(MSTP(57).LE.1) THEN
8499 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
8501 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
8504 IF(MSTP(13).EQ.2) THEN
8505 Q2PMS=Q2HRD/PMAS(11,1)**2
8506 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
8509 XG=MIN(1D0-1D-10,XHRD/XE)
8510 IF(MSTP(57).LE.1) THEN
8511 CALL PYPDFU(22,XG,Q2HRD,XPQ)
8513 CALL PYPDFL(22,XG,Q2HRD,XPQ)
8515 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
8516 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
8517 IF(WT.LT.PYR(0)*WTMX) GOTO 330
8521 XSFX(JT,KFLS)=XPQ(KFLS)
8526 C...Pick scale where photon is resolved.
8530 IF(MINT(107).EQ.3) THEN
8531 IF(MSTP(66).EQ.1) THEN
8532 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
8533 ELSEIF(MSTP(66).EQ.2) THEN
8535 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8536 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8537 Q2INT=SQRT(Q0S*Q2EFF)
8538 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8539 ELSEIF(MSTP(66).EQ.3) THEN
8540 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
8541 ELSEIF(MSTP(66).GE.4) THEN
8542 PS=0.25D0*VINT(3)**2
8543 VINT(283)=(Q0S+PS)*(Q1S+PS)/
8544 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8548 IF(MINT(108).EQ.3) THEN
8549 IF(MSTP(66).EQ.1) THEN
8550 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
8551 ELSEIF(MSTP(66).EQ.2) THEN
8553 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
8554 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
8555 Q2INT=SQRT(Q0S*Q2EFF)
8556 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
8557 ELSEIF(MSTP(66).EQ.3) THEN
8558 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
8559 ELSEIF(MSTP(66).GE.4) THEN
8560 PS=0.25D0*VINT(4)**2
8561 VINT(284)=(Q0S+PS)*(Q1S+PS)/
8562 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
8565 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8567 C...Format statements for differential cross-section maximum violations.
8568 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
8569 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8570 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
8571 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
8572 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
8574 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
8575 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
8576 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
8578 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
8579 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
8580 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
8581 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
8582 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
8583 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
8588 C*********************************************************************
8591 C...Finds outgoing flavours and event type; sets up the kinematics
8592 C...and colour flow of the hard scattering
8596 C...Double precision and integer declarations
8597 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8598 IMPLICIT INTEGER(I-N)
8599 INTEGER PYK,PYCHGE,PYCOMP
8600 C...Parameter statement to help give large particle numbers.
8601 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
8602 &KEXCIT=4000000,KDIMEN=5000000)
8604 C...User process event common block.
8606 PARAMETER (MAXNUP=500)
8607 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
8608 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
8609 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
8610 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
8611 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
8615 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8616 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8617 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8618 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
8619 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8620 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8621 COMMON/PYINT1/MINT(400),VINT(400)
8622 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8623 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8624 COMMON/PYINT4/MWID(500),WIDS(500,5)
8625 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8626 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
8627 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
8628 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
8629 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
8630 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,/PYTCSM/
8631 C...Local arrays and saved variables
8632 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
8633 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
8636 C...Read out process
8640 C...Restore information for low-pT processes
8641 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
8643 100 VINT(J)=VINTSV(J)
8646 C...Convert H' or A process into equivalent H one
8649 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
8652 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
8654 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
8655 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
8656 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
8657 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
8658 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
8659 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
8660 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
8661 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
8662 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
8663 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
8664 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
8665 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
8668 C...Choice of subprocess, number of documentation lines
8670 IF(ISUB.EQ.95) IDOC=8
8671 IF(ISET(ISUB).EQ.5) IDOC=9
8672 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
8674 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
8683 C...Reset K, P and V vectors. Store incoming particles
8684 DO 120 JT=1,MSTP(126)+100
8686 IF(I.GT.MSTU(4)) GOTO 120
8698 P(I,J)=VINT(285+5*JT+J)
8704 C...Store incoming partons in their CM-frame
8707 SHP=VINT(26)*VINT(2)
8710 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
8715 K(I,3)=MINT(83)+2+JT
8716 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
8720 C...Copy incoming partons to documentation lines
8732 C...Choose new quark/lepton flavour for relevant annihilation graphs
8733 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
8734 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
8736 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
8737 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
8738 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
8739 DO 190 I=1,MDCY(IGLGA,3)
8740 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
8741 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
8742 IF(RKFL.LE.0D0) GOTO 200
8745 IF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.2) THEN
8746 IF(KFLF.GE.4) GOTO 180
8747 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.4) THEN
8750 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385) THEN
8753 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
8754 & .AND.IABS(KFLF).GE.3) THEN
8755 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
8757 FACCIB=VINT(46)**2/RTCM(41)**4
8758 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
8759 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
8762 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
8763 IF(KFLF.EQ.5) GOTO 180
8764 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
8765 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
8766 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
8767 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
8771 C...Final state flavours and colour flow: default values
8778 KCS=ISIGN(1,MINT(15))
8780 IF(ISET(ISUB).EQ.11) THEN
8781 C...User-defined processes: find products
8784 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
8785 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
8786 MINT(21+IUP)=IDUP(IUP)
8787 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
8788 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
8789 ELSEIF(IDUP(IUP).EQ.0) THEN
8792 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
8796 ELSEIF(ISUB.LE.10) THEN
8798 C...f + fbar -> gamma*/Z0
8801 ELSEIF(ISUB.EQ.2) THEN
8802 C...f + fbar' -> W+/-
8803 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8804 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8805 KFRES=ISIGN(24,KCH1+KCH2)
8807 ELSEIF(ISUB.EQ.3) THEN
8808 C...f + fbar -> h0 (or H0, or A0)
8811 ELSEIF(ISUB.EQ.4) THEN
8812 C...gamma + W+/- -> W+/-
8814 ELSEIF(ISUB.EQ.5) THEN
8819 PMQ(1)=PYMASS(MINT(21))
8820 PMQ(2)=PYMASS(MINT(22))
8821 220 JT=INT(1.5D0+PYR(0))
8822 ZMIN=2D0*PMQ(JT)/SHPR
8823 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8824 & (SHPR*(SHPR-PMQ(3-JT)))
8825 ZMAX=MIN(1D0-XH,ZMAX)
8826 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8827 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8828 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
8829 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8830 IF(SQC1.LT.1D-8) GOTO 220
8832 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8833 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8834 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8835 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8836 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8837 IF(SQC1.LT.1D-8) GOTO 220
8839 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8840 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8841 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8844 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8845 & SQRT(1D0-CTHE(2)**2)*CPHI
8847 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8848 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8849 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8850 & PMQ(3-JT)**2/SHP))
8851 ZMIN=2D0*PMQ(3-JT)/SHPR
8852 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8853 ZMAX=MIN(1D0-XH,ZMAX)
8854 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
8858 ELSEIF(ISUB.EQ.6) THEN
8859 C...Z0 + W+/- -> W+/-
8861 ELSEIF(ISUB.EQ.7) THEN
8864 ELSEIF(ISUB.EQ.8) THEN
8871 RVCKM=VINT(180+I)*PYR(0)
8874 IPM=(5-ISIGN(1,I))/2
8876 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
8877 MINT(20+JT)=ISIGN(IB,I)
8878 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8879 IF(RVCKM.LE.0D0) GOTO 250
8882 IB=2*((IA+1)/2)-1+MOD(IA,2)
8883 MINT(20+JT)=ISIGN(IB,I)
8885 250 PMQ(JT)=PYMASS(MINT(20+JT))
8887 JT=INT(1.5D0+PYR(0))
8888 ZMIN=2D0*PMQ(JT)/SHPR
8889 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
8890 & (SHPR*(SHPR-PMQ(3-JT)))
8891 ZMAX=MIN(1D0-XH,ZMAX)
8892 IF(ZMIN.GE.ZMAX) GOTO 230
8893 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
8894 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
8895 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
8896 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
8897 IF(SQC1.LT.1D-8) GOTO 230
8899 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8900 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8901 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
8902 Z(3-JT)=1D0-XH/(1D0-Z(JT))
8903 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8904 IF(SQC1.LT.1D-8) GOTO 230
8906 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8907 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
8908 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
8911 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
8912 & SQRT(1D0-CTHE(2)**2)*CPHI
8914 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
8915 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8916 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8917 & PMQ(3-JT)**2/SHP))
8918 ZMIN=2D0*PMQ(3-JT)/SHPR
8919 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8920 ZMAX=MIN(1D0-XH,ZMAX)
8921 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
8925 ELSEIF(ISUB.EQ.10) THEN
8926 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
8927 IF(MINT(2).EQ.1) THEN
8930 C...W exchange: need to mix flavours according to CKM matrix
8935 RVCKM=VINT(180+I)*PYR(0)
8938 IPM=(5-ISIGN(1,I))/2
8940 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
8941 MINT(20+JT)=ISIGN(IB,I)
8942 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8943 IF(RVCKM.LE.0D0) GOTO 280
8946 IB=2*((IA+1)/2)-1+MOD(IA,2)
8947 MINT(20+JT)=ISIGN(IB,I)
8954 ELSEIF(ISUB.LE.20) THEN
8956 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
8958 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8960 ELSEIF(ISUB.EQ.12) THEN
8961 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
8962 MINT(21)=ISIGN(KFLF,MINT(15))
8966 ELSEIF(ISUB.EQ.13) THEN
8967 C...f + fbar -> g + g; th arbitrary
8972 ELSEIF(ISUB.EQ.14) THEN
8973 C...f + fbar -> g + gamma; th arbitrary
8974 IF(PYR(0).GT.0.5D0) JS=2
8979 ELSEIF(ISUB.EQ.15) THEN
8980 C...f + fbar -> g + Z0; th arbitrary
8981 IF(PYR(0).GT.0.5D0) JS=2
8986 ELSEIF(ISUB.EQ.16) THEN
8987 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
8988 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8989 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8990 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8992 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8995 ELSEIF(ISUB.EQ.17) THEN
8996 C...f + fbar -> g + h0; th arbitrary
8997 IF(PYR(0).GT.0.5D0) JS=2
9002 ELSEIF(ISUB.EQ.18) THEN
9003 C...f + fbar -> gamma + gamma; th arbitrary
9007 ELSEIF(ISUB.EQ.19) THEN
9008 C...f + fbar -> gamma + Z0; th arbitrary
9009 IF(PYR(0).GT.0.5D0) JS=2
9013 ELSEIF(ISUB.EQ.20) THEN
9014 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
9015 C...(p(fbar')-p(W+))**2
9016 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9017 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9018 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
9020 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
9023 ELSEIF(ISUB.LE.30) THEN
9025 C...f + fbar -> gamma + h0; th arbitrary
9026 IF(PYR(0).GT.0.5D0) JS=2
9030 ELSEIF(ISUB.EQ.22) THEN
9031 C...f + fbar -> Z0 + Z0; th arbitrary
9035 ELSEIF(ISUB.EQ.23) THEN
9036 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
9037 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9038 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9039 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
9041 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
9043 ELSEIF(ISUB.EQ.24) THEN
9044 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
9045 IF(PYR(0).GT.0.5D0) JS=2
9049 ELSEIF(ISUB.EQ.25) THEN
9050 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
9051 MINT(21)=-ISIGN(24,MINT(15))
9054 ELSEIF(ISUB.EQ.26) THEN
9055 C...f + fbar' -> W+/- + h0 (or H0, or A0);
9056 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
9057 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9058 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9059 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
9060 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
9063 ELSEIF(ISUB.EQ.27) THEN
9064 C...f + fbar -> h0 + h0
9066 ELSEIF(ISUB.EQ.28) THEN
9067 C...f + g -> f + g; th = (p(f)-p(f))**2
9068 IF(MINT(15).EQ.21) JS=2
9070 IF(MINT(15).EQ.21) KCC=KCC+2
9071 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
9072 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
9074 ELSEIF(ISUB.EQ.29) THEN
9075 C...f + g -> f + gamma; th = (p(f)-p(f))**2
9076 IF(MINT(15).EQ.21) JS=2
9079 KCS=ISIGN(1,MINT(14+JS))
9081 ELSEIF(ISUB.EQ.30) THEN
9082 C...f + g -> f + Z0; th = (p(f)-p(f))**2
9083 IF(MINT(15).EQ.21) JS=2
9086 KCS=ISIGN(1,MINT(14+JS))
9089 ELSEIF(ISUB.LE.40) THEN
9091 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
9092 IF(MINT(15).EQ.21) JS=2
9095 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
9096 RVCKM=VINT(180+I)*PYR(0)
9099 IPM=(5-ISIGN(1,I))/2
9101 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
9102 MINT(20+JS)=ISIGN(IB,I)
9103 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9104 IF(RVCKM.LE.0D0) GOTO 300
9107 KCS=ISIGN(1,MINT(14+JS))
9109 ELSEIF(ISUB.EQ.32) THEN
9110 C...f + g -> f + h0; th = (p(f)-p(f))**2
9111 IF(MINT(15).EQ.21) JS=2
9114 KCS=ISIGN(1,MINT(14+JS))
9116 ELSEIF(ISUB.EQ.33) THEN
9117 C...f + gamma -> f + g; th=(p(f)-p(f))**2
9118 IF(MINT(15).EQ.22) JS=2
9121 KCS=ISIGN(1,MINT(14+JS))
9123 ELSEIF(ISUB.EQ.34) THEN
9124 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
9125 IF(MINT(15).EQ.22) JS=2
9127 KCS=ISIGN(1,MINT(14+JS))
9129 ELSEIF(ISUB.EQ.35) THEN
9130 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
9131 IF(MINT(15).EQ.22) JS=2
9135 ELSEIF(ISUB.EQ.36) THEN
9136 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
9137 IF(MINT(15).EQ.22) JS=2
9140 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
9142 RVCKM=VINT(180+I)*PYR(0)
9145 IPM=(5-ISIGN(1,I))/2
9147 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
9148 MINT(20+JS)=ISIGN(IB,I)
9149 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9150 IF(RVCKM.LE.0D0) GOTO 320
9153 IB=2*((IA+1)/2)-1+MOD(IA,2)
9154 MINT(20+JS)=ISIGN(IB,I)
9158 ELSEIF(ISUB.EQ.37) THEN
9159 C...f + gamma -> f + h0
9161 ELSEIF(ISUB.EQ.38) THEN
9164 ELSEIF(ISUB.EQ.39) THEN
9165 C...f + Z0 -> f + gamma
9167 ELSEIF(ISUB.EQ.40) THEN
9168 C...f + Z0 -> f + Z0
9171 ELSEIF(ISUB.LE.50) THEN
9173 C...f + Z0 -> f' + W+/-
9175 ELSEIF(ISUB.EQ.42) THEN
9176 C...f + Z0 -> f + h0
9178 ELSEIF(ISUB.EQ.43) THEN
9179 C...f + W+/- -> f' + g
9181 ELSEIF(ISUB.EQ.44) THEN
9182 C...f + W+/- -> f' + gamma
9184 ELSEIF(ISUB.EQ.45) THEN
9185 C...f + W+/- -> f' + Z0
9187 ELSEIF(ISUB.EQ.46) THEN
9188 C...f + W+/- -> f' + W+/-
9190 ELSEIF(ISUB.EQ.47) THEN
9191 C...f + W+/- -> f' + h0
9193 ELSEIF(ISUB.EQ.48) THEN
9196 ELSEIF(ISUB.EQ.49) THEN
9197 C...f + h0 -> f + gamma
9199 ELSEIF(ISUB.EQ.50) THEN
9200 C...f + h0 -> f + Z0
9203 ELSEIF(ISUB.LE.60) THEN
9205 C...f + h0 -> f' + W+/-
9207 ELSEIF(ISUB.EQ.52) THEN
9208 C...f + h0 -> f + h0
9210 ELSEIF(ISUB.EQ.53) THEN
9211 C...g + g -> f + fbar; th arbitrary
9212 KCS=(-1)**INT(1.5D0+PYR(0))
9213 MINT(21)=ISIGN(KFLF,KCS)
9217 ELSEIF(ISUB.EQ.54) THEN
9218 C...g + gamma -> f + fbar; th arbitrary
9219 KCS=(-1)**INT(1.5D0+PYR(0))
9220 MINT(21)=ISIGN(KFLF,KCS)
9223 IF(MINT(16).EQ.21) KCC=28
9225 ELSEIF(ISUB.EQ.55) THEN
9226 C...g + Z0 -> f + fbar
9228 ELSEIF(ISUB.EQ.56) THEN
9229 C...g + W+/- -> f + fbar'
9231 ELSEIF(ISUB.EQ.57) THEN
9232 C...g + h0 -> f + fbar
9234 ELSEIF(ISUB.EQ.58) THEN
9235 C...gamma + gamma -> f + fbar; th arbitrary
9236 KCS=(-1)**INT(1.5D0+PYR(0))
9237 MINT(21)=ISIGN(KFLF,KCS)
9241 ELSEIF(ISUB.EQ.59) THEN
9242 C...gamma + Z0 -> f + fbar
9244 ELSEIF(ISUB.EQ.60) THEN
9245 C...gamma + W+/- -> f + fbar'
9248 ELSEIF(ISUB.LE.70) THEN
9250 C...gamma + h0 -> f + fbar
9252 ELSEIF(ISUB.EQ.62) THEN
9253 C...Z0 + Z0 -> f + fbar
9255 ELSEIF(ISUB.EQ.63) THEN
9256 C...Z0 + W+/- -> f + fbar'
9258 ELSEIF(ISUB.EQ.64) THEN
9259 C...Z0 + h0 -> f + fbar
9261 ELSEIF(ISUB.EQ.65) THEN
9262 C...W+ + W- -> f + fbar
9264 ELSEIF(ISUB.EQ.66) THEN
9265 C...W+/- + h0 -> f + fbar'
9267 ELSEIF(ISUB.EQ.67) THEN
9268 C...h0 + h0 -> f + fbar
9270 ELSEIF(ISUB.EQ.68) THEN
9271 C...g + g -> g + g; th arbitrary
9273 KCS=(-1)**INT(1.5D0+PYR(0))
9275 ELSEIF(ISUB.EQ.69) THEN
9276 C...gamma + gamma -> W+ + W-; th arbitrary
9281 ELSEIF(ISUB.EQ.70) THEN
9282 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
9283 IF(MINT(15).EQ.22) MINT(21)=23
9284 IF(MINT(16).EQ.22) MINT(22)=23
9288 ELSEIF(ISUB.LE.80) THEN
9289 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
9290 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
9294 PMQ(1)=PYMASS(MINT(21))
9295 PMQ(2)=PYMASS(MINT(22))
9296 330 JT=INT(1.5D0+PYR(0))
9297 ZMIN=2D0*PMQ(JT)/SHPR
9298 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9299 & (SHPR*(SHPR-PMQ(3-JT)))
9300 ZMAX=MIN(1D0-XH,ZMAX)
9301 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9302 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9303 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
9304 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9305 IF(SQC1.LT.1D-8) GOTO 330
9307 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9308 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9309 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9310 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9311 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9312 IF(SQC1.LT.1D-8) GOTO 330
9314 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9315 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9316 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9319 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9320 & SQRT(1D0-CTHE(2)**2)*CPHI
9322 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9323 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9324 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9325 & PMQ(3-JT)**2/SHP))
9326 ZMIN=2D0*PMQ(3-JT)/SHPR
9327 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9328 ZMAX=MIN(1D0-XH,ZMAX)
9329 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
9332 ELSEIF(ISUB.EQ.73) THEN
9333 C...Z0 + W+/- -> Z0 + W+/-
9340 RVCKM=VINT(180+I)*PYR(0)
9343 IPM=(5-ISIGN(1,I))/2
9345 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
9346 MINT(20+JT)=ISIGN(IB,I)
9347 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9348 IF(RVCKM.LE.0D0) GOTO 360
9351 IB=2*((IA+1)/2)-1+MOD(IA,2)
9352 MINT(20+JT)=ISIGN(IB,I)
9354 360 PMQ(JT)=PYMASS(MINT(20+JT))
9355 MINT(23-JT)=MINT(17-JT)
9356 PMQ(3-JT)=PYMASS(MINT(23-JT))
9357 JT=INT(1.5D0+PYR(0))
9358 ZMIN=2D0*PMQ(JT)/SHPR
9359 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9360 & (SHPR*(SHPR-PMQ(3-JT)))
9361 ZMAX=MIN(1D0-XH,ZMAX)
9362 IF(ZMIN.GE.ZMAX) GOTO 340
9363 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9364 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9365 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
9366 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9367 IF(SQC1.LT.1D-8) GOTO 340
9369 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9370 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9371 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9372 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9373 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9374 IF(SQC1.LT.1D-8) GOTO 340
9376 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9377 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9378 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9381 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9382 & SQRT(1D0-CTHE(2)**2)*CPHI
9384 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9385 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9386 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9387 & PMQ(3-JT)**2/SHP))
9388 ZMIN=2D0*PMQ(3-JT)/SHPR
9389 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9390 ZMAX=MIN(1D0-XH,ZMAX)
9391 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
9394 ELSEIF(ISUB.EQ.74) THEN
9395 C...Z0 + h0 -> Z0 + h0
9397 ELSEIF(ISUB.EQ.75) THEN
9398 C...W+ + W- -> gamma + gamma
9400 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
9401 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
9407 RVCKM=VINT(180+I)*PYR(0)
9410 IPM=(5-ISIGN(1,I))/2
9412 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
9413 MINT(20+JT)=ISIGN(IB,I)
9414 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9415 IF(RVCKM.LE.0D0) GOTO 390
9418 IB=2*((IA+1)/2)-1+MOD(IA,2)
9419 MINT(20+JT)=ISIGN(IB,I)
9421 390 PMQ(JT)=PYMASS(MINT(20+JT))
9423 JT=INT(1.5D0+PYR(0))
9424 ZMIN=2D0*PMQ(JT)/SHPR
9425 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9426 & (SHPR*(SHPR-PMQ(3-JT)))
9427 ZMAX=MIN(1D0-XH,ZMAX)
9428 IF(ZMIN.GE.ZMAX) GOTO 370
9429 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9430 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9431 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
9432 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9433 IF(SQC1.LT.1D-8) GOTO 370
9435 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9436 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9437 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
9438 Z(3-JT)=1D0-XH/(1D0-Z(JT))
9439 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
9440 IF(SQC1.LT.1D-8) GOTO 370
9442 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
9443 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9444 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
9447 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
9448 & SQRT(1D0-CTHE(2)**2)*CPHI
9450 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
9451 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
9452 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
9453 & PMQ(3-JT)**2/SHP))
9454 ZMIN=2D0*PMQ(3-JT)/SHPR
9455 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
9456 ZMAX=MIN(1D0-XH,ZMAX)
9457 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
9460 ELSEIF(ISUB.EQ.78) THEN
9461 C...W+/- + h0 -> W+/- + h0
9463 ELSEIF(ISUB.EQ.79) THEN
9464 C...h0 + h0 -> h0 + h0
9466 ELSEIF(ISUB.EQ.80) THEN
9467 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
9468 IF(MINT(15).EQ.22) JS=2
9471 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
9473 MINT(20+JS)=ISIGN(IB,I)
9477 ELSEIF(ISUB.LE.90) THEN
9479 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
9480 MINT(21)=ISIGN(MINT(55),MINT(15))
9484 ELSEIF(ISUB.EQ.82) THEN
9485 C...g + g -> Q + Qbar; th arbitrary
9486 KCS=(-1)**INT(1.5D0+PYR(0))
9487 MINT(21)=ISIGN(MINT(55),KCS)
9491 ELSEIF(ISUB.EQ.83) THEN
9492 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
9494 IF(MINT(2).EQ.2) KFOLD=MINT(15)
9496 IF(KFAOLD.GT.10) THEN
9497 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
9499 RCKM=VINT(180+KFOLD)*PYR(0)
9500 IPM=(5-ISIGN(1,KFOLD))/2
9501 KFANEW=-MOD(KFAOLD+1,2)
9503 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
9504 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
9505 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
9506 & VCKM(KFAOLD/2,(KFANEW+1)/2)
9507 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
9508 & VCKM(KFANEW/2,(KFAOLD+1)/2)
9510 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
9512 IF(MINT(2).EQ.1) THEN
9513 MINT(21)=ISIGN(MINT(55),MINT(15))
9514 MINT(22)=ISIGN(KFANEW,MINT(16))
9516 MINT(21)=ISIGN(KFANEW,MINT(15))
9517 MINT(22)=ISIGN(MINT(55),MINT(16))
9522 ELSEIF(ISUB.EQ.84) THEN
9523 C...g + gamma -> Q + Qbar; th arbitary
9524 KCS=(-1)**INT(1.5D0+PYR(0))
9525 MINT(21)=ISIGN(MINT(55),KCS)
9528 IF(MINT(16).EQ.21) KCC=28
9530 ELSEIF(ISUB.EQ.85) THEN
9531 C...gamma + gamma -> F + Fbar; th arbitary
9532 KCS=(-1)**INT(1.5D0+PYR(0))
9533 MINT(21)=ISIGN(MINT(56),KCS)
9537 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
9538 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
9539 MINT(21)=KFPR(ISUB,1)
9540 MINT(22)=KFPR(ISUB,2)
9542 KCS=(-1)**INT(1.5D0+PYR(0))
9545 ELSEIF(ISUB.LE.100) THEN
9547 C...Low-pT ( = energyless g + g -> g + g)
9549 KCS=(-1)**INT(1.5D0+PYR(0))
9551 ELSEIF(ISUB.EQ.96) THEN
9552 C...Multiple interactions (should be reassigned to QCD process)
9555 ELSEIF(ISUB.LE.110) THEN
9556 IF(ISUB.EQ.101) THEN
9557 C...g + g -> gamma*/Z0
9561 ELSEIF(ISUB.EQ.102) THEN
9562 C...g + g -> h0 (or H0, or A0)
9566 ELSEIF(ISUB.EQ.103) THEN
9567 C...gamma + gamma -> h0 (or H0, or A0)
9571 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
9572 C...g + g -> chi_0c or chi_2c.
9576 ELSEIF(ISUB.EQ.106) THEN
9577 C...g + g -> J/Psi + gamma
9578 MINT(21)=KFPR(ISUB,1)
9579 MINT(22)=KFPR(ISUB,2)
9582 ELSEIF(ISUB.EQ.107) THEN
9583 C...g + gamma -> J/Psi + g
9584 MINT(21)=KFPR(ISUB,1)
9585 MINT(22)=KFPR(ISUB,2)
9587 IF(MINT(16).EQ.22) KCC=33
9589 ELSEIF(ISUB.EQ.108) THEN
9590 C...gamma + gamma -> J/Psi + gamma
9591 MINT(21)=KFPR(ISUB,1)
9592 MINT(22)=KFPR(ISUB,2)
9594 ELSEIF(ISUB.EQ.110) THEN
9595 C...f + fbar -> gamma + h0; th arbitrary
9596 IF(PYR(0).GT.0.5D0) JS=2
9601 ELSEIF(ISUB.LE.120) THEN
9602 IF(ISUB.EQ.111) THEN
9603 C...f + fbar -> g + h0; th arbitrary
9604 IF(PYR(0).GT.0.5D0) JS=2
9609 ELSEIF(ISUB.EQ.112) THEN
9610 C...f + g -> f + h0; th = (p(f) - p(f))**2
9611 IF(MINT(15).EQ.21) JS=2
9614 KCS=ISIGN(1,MINT(14+JS))
9616 ELSEIF(ISUB.EQ.113) THEN
9617 C...g + g -> g + h0; th arbitrary
9618 IF(PYR(0).GT.0.5D0) JS=2
9621 KCS=(-1)**INT(1.5D0+PYR(0))
9623 ELSEIF(ISUB.EQ.114) THEN
9624 C...g + g -> gamma + gamma; th arbitrary
9625 IF(PYR(0).GT.0.5D0) JS=2
9630 ELSEIF(ISUB.EQ.115) THEN
9631 C...g + g -> g + gamma; th arbitrary
9632 IF(PYR(0).GT.0.5D0) JS=2
9635 KCS=(-1)**INT(1.5D0+PYR(0))
9637 ELSEIF(ISUB.EQ.116) THEN
9638 C...g + g -> gamma + Z0
9640 ELSEIF(ISUB.EQ.117) THEN
9641 C...g + g -> Z0 + Z0
9643 ELSEIF(ISUB.EQ.118) THEN
9644 C...g + g -> W+ + W-
9647 ELSEIF(ISUB.LE.140) THEN
9648 IF(ISUB.EQ.121) THEN
9649 C...g + g -> Q + Qbar + h0
9650 KCS=(-1)**INT(1.5D0+PYR(0))
9651 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
9653 KCC=11+INT(0.5D0+PYR(0))
9656 ELSEIF(ISUB.EQ.122) THEN
9657 C...q + qbar -> Q + Qbar + h0
9658 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
9663 ELSEIF(ISUB.EQ.123) THEN
9664 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
9669 ELSEIF(ISUB.EQ.124) THEN
9670 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
9676 RVCKM=VINT(180+I)*PYR(0)
9679 IPM=(5-ISIGN(1,I))/2
9681 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
9682 MINT(20+JT)=ISIGN(IB,I)
9683 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
9684 IF(RVCKM.LE.0D0) GOTO 430
9687 IB=2*((IA+1)/2)-1+MOD(IA,2)
9688 MINT(20+JT)=ISIGN(IB,I)
9694 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
9695 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
9696 IF(MINT(15).EQ.22) JS=2
9699 KCS=ISIGN(1,MINT(14+JS))
9701 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
9702 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
9703 IF(MINT(15).EQ.22) JS=2
9705 KCS=ISIGN(1,MINT(14+JS))
9707 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
9708 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
9709 KCS=(-1)**INT(1.5D0+PYR(0))
9710 MINT(21)=ISIGN(KFLF,KCS)
9713 IF(MINT(16).EQ.21) KCC=28
9715 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
9716 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
9717 KCS=(-1)**INT(1.5D0+PYR(0))
9718 MINT(21)=ISIGN(KFLF,KCS)
9724 ELSEIF(ISUB.LE.160) THEN
9725 IF(ISUB.EQ.141) THEN
9726 C...f + fbar -> gamma*/Z0/Z'0
9729 ELSEIF(ISUB.EQ.142) THEN
9730 C...f + fbar' -> W'+/-
9731 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9732 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9733 KFRES=ISIGN(34,KCH1+KCH2)
9735 ELSEIF(ISUB.EQ.143) THEN
9736 C...f + fbar' -> H+/-
9737 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9738 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9739 KFRES=ISIGN(37,KCH1+KCH2)
9741 ELSEIF(ISUB.EQ.144) THEN
9743 KFRES=ISIGN(41,MINT(15)+MINT(16))
9745 ELSEIF(ISUB.EQ.145) THEN
9746 C...q + l -> LQ (leptoquark)
9747 IF(IABS(MINT(16)).LE.8) JS=2
9748 KFRES=ISIGN(42,MINT(14+JS))
9750 KCS=ISIGN(1,MINT(14+JS))
9752 ELSEIF(ISUB.EQ.146) THEN
9753 C...e + gamma -> e* (excited lepton)
9754 IF(MINT(15).EQ.22) JS=2
9755 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9758 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
9759 C...q + g -> q* (excited quark)
9760 IF(MINT(15).EQ.21) JS=2
9761 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
9763 KCS=ISIGN(1,MINT(14+JS))
9765 ELSEIF(ISUB.EQ.149) THEN
9769 KCS=(-1)**INT(1.5D0+PYR(0))
9772 ELSEIF(ISUB.LE.200) THEN
9773 IF(ISUB.EQ.161) THEN
9774 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
9775 IF(MINT(15).EQ.21) JS=2
9778 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
9779 IB=IA+MOD(IA,2)-MOD(IA+1,2)
9780 MINT(20+JS)=ISIGN(IB,I)
9782 KCS=ISIGN(1,MINT(14+JS))
9784 ELSEIF(ISUB.EQ.162) THEN
9785 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
9786 IF(MINT(15).EQ.21) JS=2
9787 MINT(20+JS)=ISIGN(42,MINT(14+JS))
9788 KFLQL=KFDP(MDCY(42,2),2)
9789 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
9791 KCS=ISIGN(1,MINT(14+JS))
9793 ELSEIF(ISUB.EQ.163) THEN
9794 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
9795 KCS=(-1)**INT(1.5D0+PYR(0))
9796 MINT(21)=ISIGN(42,KCS)
9800 ELSEIF(ISUB.EQ.164) THEN
9801 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
9802 MINT(21)=ISIGN(42,MINT(15))
9806 ELSEIF(ISUB.EQ.165) THEN
9807 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
9808 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9811 ELSEIF(ISUB.EQ.166) THEN
9812 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9813 IF(MOD(MINT(15),2).EQ.0) THEN
9814 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9815 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9817 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9818 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9821 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
9822 C...q + q' -> q" + q* (excited quark)
9824 KFQEXC=MOD(KFQSTR,KEXCIT)
9826 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9827 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
9828 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9832 ELSEIF(ISUB.EQ.169) THEN
9833 C...q + qbar -> e + e* (excited lepton)
9835 KFQEXC=MOD(KFQSTR,KEXCIT)
9837 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
9838 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
9841 ELSEIF(ISUB.EQ.191) THEN
9842 C...f + fbar -> rho_tc0.
9845 ELSEIF(ISUB.EQ.192) THEN
9846 C...f + fbar' -> rho_tc+/-
9847 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9848 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9849 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
9851 ELSEIF(ISUB.EQ.193) THEN
9852 C...f + fbar -> omega_tc0.
9855 ELSEIF(ISUB.EQ.194) THEN
9856 C...f + fbar -> f' + fbar' via mixture of s-channel
9857 C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
9858 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9861 ELSEIF(ISUB.EQ.195) THEN
9862 C...f + fbar' -> f'' + fbar''' via s-channel
9863 C...rho_tc+ th=(p(f)-p(f'))**2
9864 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
9865 IF(MOD(MINT(15),2).EQ.0) THEN
9866 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
9867 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
9869 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
9870 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
9875 ELSEIF(ISUB.LE.215) THEN
9876 IF(ISUB.EQ.201) THEN
9877 C...f + fbar -> ~e_L + ~e_Lbar
9878 MINT(21)=ISIGN(KSUSY1+11,KCS)
9881 ELSEIF(ISUB.EQ.202) THEN
9882 C...f + fbar -> ~e_R + ~e_Rbar
9883 MINT(21)=ISIGN(KSUSY2+11,KCS)
9886 ELSEIF(ISUB.EQ.203) THEN
9887 C...f + fbar -> ~e_L + ~e_Rbar
9888 IF(MINT(15).LT.0) JS=2
9889 IF(MINT(2).EQ.1) THEN
9890 MINT(20+JS)=KFPR(ISUB,1)
9891 MINT(23-JS)=-KFPR(ISUB,2)
9893 MINT(20+JS)=-KFPR(ISUB,1)
9894 MINT(23-JS)=KFPR(ISUB,2)
9897 ELSEIF(ISUB.EQ.204) THEN
9898 C...f + fbar -> ~mu_L + ~mu_Lbar
9899 MINT(21)=ISIGN(KSUSY1+13,KCS)
9902 ELSEIF(ISUB.EQ.205) THEN
9903 C...f + fbar -> ~mu_R + ~mu_Rbar
9904 MINT(21)=ISIGN(KSUSY2+13,KCS)
9907 ELSEIF(ISUB.EQ.206) THEN
9908 C...f + fbar -> ~mu_L + ~mu_Rbar
9909 IF(MINT(15).LT.0) JS=2
9910 IF(MINT(2).EQ.1) THEN
9911 MINT(20+JS)=KFPR(ISUB,1)
9912 MINT(23-JS)=-KFPR(ISUB,2)
9914 MINT(20+JS)=-KFPR(ISUB,1)
9915 MINT(23-JS)=KFPR(ISUB,2)
9918 ELSEIF(ISUB.EQ.207) THEN
9919 C...f + fbar -> ~tau_1 + ~tau_1bar
9920 MINT(21)=ISIGN(KSUSY1+15,KCS)
9923 ELSEIF(ISUB.EQ.208) THEN
9924 C...f + fbar -> ~tau_2 + ~tau_2bar
9925 MINT(21)=ISIGN(KSUSY2+15,KCS)
9928 ELSEIF(ISUB.EQ.209) THEN
9929 C...f + fbar -> ~tau_1 + ~tau_2bar
9930 IF(MINT(15).LT.0) JS=2
9931 IF(MINT(2).EQ.1) THEN
9932 MINT(20+JS)=KFPR(ISUB,1)
9933 MINT(23-JS)=-KFPR(ISUB,2)
9935 MINT(20+JS)=-KFPR(ISUB,1)
9936 MINT(23-JS)=KFPR(ISUB,2)
9939 ELSEIF(ISUB.EQ.210) THEN
9940 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
9941 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9942 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9943 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
9944 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
9946 ELSEIF(ISUB.EQ.211) THEN
9947 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
9948 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9949 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9950 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
9951 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9953 ELSEIF(ISUB.EQ.212) THEN
9954 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
9955 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9956 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9957 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
9958 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
9960 ELSEIF(ISUB.EQ.213) THEN
9961 C...f + fbar -> ~nul + ~nulbar
9962 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
9965 ELSEIF(ISUB.EQ.214) THEN
9966 C...f + fbar -> ~nutau + ~nutaubar
9967 MINT(21)=ISIGN(KSUSY1+16,KCS)
9971 ELSEIF(ISUB.LE.225) THEN
9972 IF(ISUB.EQ.216) THEN
9973 C...f + fbar -> ~chi01 + ~chi01
9977 ELSEIF(ISUB.EQ.217) THEN
9978 C...f + fbar -> ~chi02 + ~chi02
9982 ELSEIF(ISUB.EQ.218 ) THEN
9983 C...f + fbar -> ~chi03 + ~chi03
9987 ELSEIF(ISUB.EQ.219 ) THEN
9988 C...f + fbar -> ~chi04 + ~chi04
9992 ELSEIF(ISUB.EQ.220 ) THEN
9993 C...f + fbar -> ~chi01 + ~chi02
9994 IF(MINT(15).LT.0) JS=2
9995 C IF(PYR(0).GT.0.5D0) JS=2
9996 MINT(20+JS)=KSUSY1+22
9997 MINT(23-JS)=KSUSY1+23
9999 ELSEIF(ISUB.EQ.221 ) THEN
10000 C...f + fbar -> ~chi01 + ~chi03
10001 IF(MINT(15).LT.0) JS=2
10002 C IF(PYR(0).GT.0.5D0) JS=2
10003 MINT(20+JS)=KSUSY1+22
10004 MINT(23-JS)=KSUSY1+25
10006 ELSEIF(ISUB.EQ.222) THEN
10007 C...f + fbar -> ~chi01 + ~chi04
10008 IF(MINT(15).LT.0) JS=2
10009 C IF(PYR(0).GT.0.5D0) JS=2
10010 MINT(20+JS)=KSUSY1+22
10011 MINT(23-JS)=KSUSY1+35
10013 ELSEIF(ISUB.EQ.223) THEN
10014 C...f + fbar -> ~chi02 + ~chi03
10015 IF(MINT(15).LT.0) JS=2
10016 C IF(PYR(0).GT.0.5D0) JS=2
10017 MINT(20+JS)=KSUSY1+23
10018 MINT(23-JS)=KSUSY1+25
10020 ELSEIF(ISUB.EQ.224) THEN
10021 C...f + fbar -> ~chi02 + ~chi04
10022 IF(MINT(15).LT.0) JS=2
10023 C IF(PYR(0).GT.0.5D0) JS=2
10024 MINT(20+JS)=KSUSY1+23
10025 MINT(23-JS)=KSUSY1+35
10027 ELSEIF(ISUB.EQ.225) THEN
10028 C...f + fbar -> ~chi03 + ~chi04
10029 IF(MINT(15).LT.0) JS=2
10030 C IF(PYR(0).GT.0.5D0) JS=2
10031 MINT(20+JS)=KSUSY1+25
10032 MINT(23-JS)=KSUSY1+35
10035 ELSEIF(ISUB.LE.236) THEN
10036 IF(ISUB.EQ.226) THEN
10037 C...f + fbar -> ~chi+-1 + ~chi-+1
10038 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
10039 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10040 MINT(21)=ISIGN(KSUSY1+24,KCH1)
10043 ELSEIF(ISUB.EQ.227) THEN
10044 C...f + fbar -> ~chi+-2 + ~chi-+2
10045 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10046 MINT(21)=ISIGN(KSUSY1+37,KCH1)
10049 ELSEIF(ISUB.EQ.228) THEN
10050 C...f + fbar -> ~chi+-1 + ~chi-+2
10051 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
10052 C...js=1 if pyr<.5, js=2 if pyr>.5
10053 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
10054 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
10055 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
10056 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
10057 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10059 IF(MINT(2).EQ.1) THEN
10060 MINT(21)= ISIGN(KSUSY1+24,KCH1)
10061 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
10062 c IF(KCH2.EQ.0) JS=2
10064 MINT(21)= ISIGN(KSUSY1+37,KCH1)
10065 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
10067 c IF(KCH2.EQ.1) JS=2
10070 ELSEIF(ISUB.EQ.229) THEN
10071 C...q + qbar' -> ~chi01 + ~chi+-1
10072 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
10073 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10074 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10076 IF(MOD(MINT(15),2).EQ.0) JS=2
10077 MINT(20+JS)=KSUSY1+22
10078 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10080 ELSEIF(ISUB.EQ.230) THEN
10081 C...q + qbar' -> ~chi02 + ~chi+-1
10082 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10083 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10084 IF(MOD(MINT(15),2).EQ.0) JS=2
10085 MINT(20+JS)=KSUSY1+23
10086 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10088 ELSEIF(ISUB.EQ.231) THEN
10089 C...q + qbar' -> ~chi03 + ~chi+-1
10090 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10091 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10092 IF(MOD(MINT(15),2).EQ.0) JS=2
10093 MINT(20+JS)=KSUSY1+25
10094 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10096 ELSEIF(ISUB.EQ.232) THEN
10097 C...q + qbar' -> ~chi04 + ~chi+-1
10098 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10099 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10100 IF(MOD(MINT(15),2).EQ.0) JS=2
10101 MINT(20+JS)=KSUSY1+35
10102 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10104 ELSEIF(ISUB.EQ.233) THEN
10105 C...q + qbar' -> ~chi01 + ~chi+-2
10106 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10107 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10108 IF(MOD(MINT(15),2).EQ.0) JS=2
10109 MINT(20+JS)=KSUSY1+22
10110 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10112 ELSEIF(ISUB.EQ.234) THEN
10113 C...q + qbar' -> ~chi02 + ~chi+-2
10114 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10115 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10116 IF(MOD(MINT(15),2).EQ.0) JS=2
10117 MINT(20+JS)=KSUSY1+23
10118 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10120 ELSEIF(ISUB.EQ.235) THEN
10121 C...q + qbar' -> ~chi03 + ~chi+-2
10122 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10123 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10124 IF(MOD(MINT(15),2).EQ.0) JS=2
10125 MINT(20+JS)=KSUSY1+25
10126 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10128 ELSEIF(ISUB.EQ.236) THEN
10129 C...q + qbar' -> ~chi04 + ~chi+-2
10130 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10131 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10132 IF(MOD(MINT(15),2).EQ.0) JS=2
10133 MINT(20+JS)=KSUSY1+35
10134 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10137 ELSEIF(ISUB.LE.245) THEN
10138 IF(ISUB.EQ.237) THEN
10139 C...q + qbar -> ~chi01 + ~g
10141 IF(PYR(0).GT.0.5D0) JS=2
10142 MINT(20+JS)=KSUSY1+21
10143 MINT(23-JS)=KSUSY1+22
10146 ELSEIF(ISUB.EQ.238) THEN
10147 C...q + qbar -> ~chi02 + ~g
10149 IF(PYR(0).GT.0.5D0) JS=2
10150 MINT(20+JS)=KSUSY1+21
10151 MINT(23-JS)=KSUSY1+23
10154 ELSEIF(ISUB.EQ.239) THEN
10155 C...q + qbar -> ~chi03 + ~g
10157 IF(PYR(0).GT.0.5D0) JS=2
10158 MINT(20+JS)=KSUSY1+21
10159 MINT(23-JS)=KSUSY1+25
10162 ELSEIF(ISUB.EQ.240) THEN
10163 C...q + qbar -> ~chi04 + ~g
10165 IF(PYR(0).GT.0.5D0) JS=2
10166 MINT(20+JS)=KSUSY1+21
10167 MINT(23-JS)=KSUSY1+35
10170 ELSEIF(ISUB.EQ.241) THEN
10171 C...q + qbar' -> ~chi+-1 + ~g
10172 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10173 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10174 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10175 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10176 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10177 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10178 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10180 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10181 MINT(20+JS)=KSUSY1+21
10182 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
10185 ELSEIF(ISUB.EQ.242) THEN
10186 C...q + qbar' -> ~chi+-2 + ~g
10187 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
10188 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
10189 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
10190 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
10191 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
10192 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10193 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10195 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10196 MINT(20+JS)=KSUSY1+21
10197 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
10200 ELSEIF(ISUB.EQ.243) THEN
10201 C...q + qbar -> ~g + ~g ; th arbitrary
10206 ELSEIF(ISUB.EQ.244) THEN
10207 C...g + g -> ~g + ~g ; th arbitrary
10209 KCS=(-1)**INT(1.5D0+PYR(0))
10214 ELSEIF(ISUB.LE.260) THEN
10215 IF(ISUB.EQ.246) THEN
10216 C...qj + g -> ~qj_L + ~chi01
10217 IF(MINT(15).EQ.21) JS=2
10220 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10221 MINT(23-JS)=KSUSY1+22
10223 KCS=ISIGN(1,MINT(14+JS))
10225 ELSEIF(ISUB.EQ.247) THEN
10226 C...qj + g -> ~qj_R + ~chi01
10227 IF(MINT(15).EQ.21) JS=2
10230 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10231 MINT(23-JS)=KSUSY1+22
10233 KCS=ISIGN(1,MINT(14+JS))
10235 ELSEIF(ISUB.EQ.248) THEN
10236 C...qj + g -> ~qj_L + ~chi02
10237 IF(MINT(15).EQ.21) JS=2
10240 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10241 MINT(23-JS)=KSUSY1+23
10243 KCS=ISIGN(1,MINT(14+JS))
10245 ELSEIF(ISUB.EQ.249) THEN
10246 C...qj + g -> ~qj_R + ~chi02
10247 IF(MINT(15).EQ.21) JS=2
10250 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10251 MINT(23-JS)=KSUSY1+23
10253 KCS=ISIGN(1,MINT(14+JS))
10255 ELSEIF(ISUB.EQ.250) THEN
10256 C...qj + g -> ~qj_L + ~chi03
10257 IF(MINT(15).EQ.21) JS=2
10260 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10261 MINT(23-JS)=KSUSY1+25
10263 KCS=ISIGN(1,MINT(14+JS))
10265 ELSEIF(ISUB.EQ.251) THEN
10266 C...qj + g -> ~qj_R + ~chi03
10267 IF(MINT(15).EQ.21) JS=2
10270 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10271 MINT(23-JS)=KSUSY1+25
10273 KCS=ISIGN(1,MINT(14+JS))
10275 ELSEIF(ISUB.EQ.252) THEN
10276 C...qj + g -> ~qj_L + ~chi04
10277 IF(MINT(15).EQ.21) JS=2
10280 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10281 MINT(23-JS)=KSUSY1+35
10283 KCS=ISIGN(1,MINT(14+JS))
10285 ELSEIF(ISUB.EQ.253) THEN
10286 C...qj + g -> ~qj_R + ~chi04
10287 IF(MINT(15).EQ.21) JS=2
10290 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10291 MINT(23-JS)=KSUSY1+35
10293 KCS=ISIGN(1,MINT(14+JS))
10295 ELSEIF(ISUB.EQ.254) THEN
10296 C...qj + g -> ~qk_L + ~chi+-1
10297 IF(MINT(15).EQ.21) JS=2
10300 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10301 IB=-IA+INT((IA+1)/2)*4-1
10302 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10304 KCS=ISIGN(1,MINT(14+JS))
10306 ELSEIF(ISUB.EQ.255) THEN
10307 C...qj + g -> ~qk_L + ~chi+-1
10308 IF(MINT(15).EQ.21) JS=2
10311 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
10312 IB=-IA+INT((IA+1)/2)*4-1
10313 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10315 KCS=ISIGN(1,MINT(14+JS))
10317 ELSEIF(ISUB.EQ.256) THEN
10318 C...qj + g -> ~qk_L + ~chi+-2
10319 IF(MINT(15).EQ.21) JS=2
10322 IB=-IA+INT((IA+1)/2)*4-1
10323 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
10324 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10326 KCS=ISIGN(1,MINT(14+JS))
10328 ELSEIF(ISUB.EQ.257) THEN
10329 C...qj + g -> ~qk_R + ~chi+-2
10330 IF(MINT(15).EQ.21) JS=2
10333 IB=-IA+INT((IA+1)/2)*4-1
10334 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
10335 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
10337 KCS=ISIGN(1,MINT(14+JS))
10339 ELSEIF(ISUB.EQ.258) THEN
10340 C...qj + g -> ~qj_L + ~g
10341 IF(MINT(15).EQ.21) JS=2
10344 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10345 MINT(23-JS)=KSUSY1+21
10347 IF(JS.EQ.2) KCC=KCC+2
10350 ELSEIF(ISUB.EQ.259) THEN
10351 C...qj + g -> ~qj_R + ~g
10352 IF(MINT(15).EQ.21) JS=2
10355 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10356 MINT(23-JS)=KSUSY1+21
10358 IF(JS.EQ.2) KCC=KCC+2
10362 ELSEIF(ISUB.LE.270) THEN
10363 IF(ISUB.EQ.261) THEN
10364 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
10366 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10367 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10369 C...Correct color combination
10370 IF(MINT(43).EQ.4) KCC=4
10372 ELSEIF(ISUB.EQ.262) THEN
10373 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
10375 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10376 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10378 C...Correct color combination
10379 IF(MINT(43).EQ.4) KCC=4
10381 ELSEIF(ISUB.EQ.263) THEN
10382 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
10383 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
10384 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
10385 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10386 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
10389 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
10390 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
10392 C...Correct color combination
10393 IF(MINT(43).EQ.4) KCC=4
10395 ELSEIF(ISUB.EQ.264) THEN
10396 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
10397 KCS=(-1)**INT(1.5D0+PYR(0))
10398 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10402 ELSEIF(ISUB.EQ.265) THEN
10403 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
10404 KCS=(-1)**INT(1.5D0+PYR(0))
10405 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10410 ELSEIF(ISUB.LE.296) THEN
10411 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
10412 C...qi + qj -> ~qi_L + ~qj_L
10414 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10415 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10416 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10418 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
10419 C...qi + qj -> ~qi_R + ~qj_R
10421 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10422 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10423 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10425 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
10426 C...qi + qj -> ~qi_L + ~qj_R
10427 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10428 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10430 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10432 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
10433 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
10434 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
10435 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
10437 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10439 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
10440 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10441 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
10442 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
10444 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10446 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
10447 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
10448 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10449 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
10451 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10453 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
10454 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
10456 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10457 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10459 IF(MINT(43).EQ.4) KCC=4
10461 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
10462 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
10464 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
10465 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
10467 IF(MINT(43).EQ.4) KCC=4
10469 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
10470 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
10472 KCS=(-1)**INT(1.5D0+PYR(0))
10473 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10477 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
10478 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
10479 KCS=(-1)**INT(1.5D0+PYR(0))
10480 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10484 ELSEIF(ISUB.EQ.294) THEN
10485 C...qj + g -> ~qj_L + ~g
10486 IF(MINT(15).EQ.21) JS=2
10489 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
10490 MINT(23-JS)=KSUSY1+21
10492 IF(JS.EQ.2) KCC=KCC+2
10495 ELSEIF(ISUB.EQ.295) THEN
10496 C...qj + g -> ~qj_R + ~g
10497 IF(MINT(15).EQ.21) JS=2
10500 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
10501 MINT(23-JS)=KSUSY1+21
10503 IF(JS.EQ.2) KCC=KCC+2
10507 ELSEIF(ISUB.LE.340) THEN
10509 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
10510 C...q + qbar' -> H+ + H0
10511 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10512 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10513 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10514 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
10515 MINT(23-JS)=KFPR(ISUB,2)
10516 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
10517 C...f + fbar -> A0 + H0; th arbitrary
10518 IF(PYR(0).GT.0.5D0) JS=2
10519 MINT(20+JS)=KFPR(ISUB,1)
10520 MINT(23-JS)=KFPR(ISUB,2)
10521 ELSEIF(ISUB.EQ.301) THEN
10522 C...f + fbar -> H+ H-
10523 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
10528 ELSEIF(ISUB.LE.360) THEN
10530 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
10531 C...l + l -> H_L++/--, H_R++/--
10532 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10533 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10534 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10536 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
10537 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
10538 IF(MINT(15).EQ.22) JS=2
10539 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
10540 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
10543 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
10544 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
10545 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
10548 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
10549 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
10550 C...as inner process).
10555 RVCKM=VINT(180+I)*PYR(0)
10558 IPM=(5-ISIGN(1,I))/2
10560 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
10561 MINT(20+JT)=ISIGN(IB,I)
10562 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10563 IF(RVCKM.LE.0D0) GOTO 450
10566 IB=2*((IA+1)/2)-1+MOD(IA,2)
10567 MINT(20+JT)=ISIGN(IB,I)
10571 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
10572 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
10574 ELSEIF(ISUB.EQ.353) THEN
10575 C...f + fbar -> Z_R0
10578 ELSEIF(ISUB.EQ.354) THEN
10579 C...f + fbar' -> W+/-
10580 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10581 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10582 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
10586 ELSEIF(ISUB.LE.380) THEN
10588 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
10589 C...f + fbar -> charged+ charged- technicolor
10590 KSW=(-1)**INT(1.5D0+PYR(0))
10591 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
10592 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
10594 ELSEIF(ISUB.LE.367) THEN
10595 C...f + fbar -> neutral neutral technicolor
10596 MINT(21)=KFPR(ISUB,1)
10597 MINT(22)=KFPR(ISUB,2)
10599 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375) THEN
10600 C...f + fbar' -> neutral charged technicolor
10603 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10604 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10605 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10606 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10607 MINT(20+JS)=KFPR(ISUB,IN)
10609 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
10610 C...f + fbar' -> charged neutral technicolor
10613 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10614 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10615 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10616 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
10617 MINT(23-JS)=KFPR(ISUB,IN)
10620 ELSEIF(ISUB.LE.400) THEN
10621 IF(ISUB.EQ.381) THEN
10622 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
10624 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10626 ELSEIF(ISUB.EQ.382) THEN
10627 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
10628 MINT(21)=ISIGN(KFLF,MINT(15))
10632 ELSEIF(ISUB.EQ.383) THEN
10633 C...f + fbar -> g + g; th arbitrary, TC extensions
10638 ELSEIF(ISUB.EQ.384) THEN
10639 C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
10640 IF(MINT(15).EQ.21) JS=2
10642 IF(MINT(15).EQ.21) KCC=KCC+2
10643 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10644 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10646 ELSEIF(ISUB.EQ.385) THEN
10647 C...g + g -> f + fbar; th arbitrary, TC extensions
10648 KCS=(-1)**INT(1.5D0+PYR(0))
10649 MINT(21)=ISIGN(KFLF,KCS)
10653 ELSEIF(ISUB.EQ.386) THEN
10654 C...g + g -> g + g; th arbitrary, TC extensions
10656 KCS=(-1)**INT(1.5D0+PYR(0))
10658 ELSEIF(ISUB.EQ.387) THEN
10659 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
10660 MINT(21)=ISIGN(MINT(55),MINT(15))
10664 ELSEIF(ISUB.EQ.388) THEN
10665 C...g + g -> Q + Qbar; th arbitrary, TC extensions
10666 KCS=(-1)**INT(1.5D0+PYR(0))
10667 MINT(21)=ISIGN(MINT(55),KCS)
10671 ELSEIF(ISUB.EQ.391) THEN
10672 C...f + fbar -> G*.
10675 ELSEIF(ISUB.EQ.392) THEN
10680 ELSEIF(ISUB.EQ.393) THEN
10681 C...q + qbar -> g + G*; th arbitrary.
10682 IF(PYR(0).GT.0.5D0) JS=2
10683 MINT(20+JS)=KFPR(ISUB,1)
10684 MINT(23-JS)=KFPR(ISUB,2)
10687 ELSEIF(ISUB.EQ.394) THEN
10688 C...q + g -> q + G*; th = (p(f) - p(f))**2
10689 IF(MINT(15).EQ.21) JS=2
10690 MINT(23-JS)=KFPR(ISUB,2)
10692 KCS=ISIGN(1,MINT(14+JS))
10694 ELSEIF(ISUB.EQ.395) THEN
10695 C...g + g -> G* + g; th arbitrary.
10696 IF(PYR(0).GT.0.5D0) JS=2
10697 MINT(23-JS)=KFPR(ISUB,2)
10702 IF(ISET(ISUB).EQ.11) THEN
10703 C...Store documentation for user-defined processes
10704 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
10705 KUPPO(1)=MINT(83)+5
10706 KUPPO(2)=MINT(83)+6
10710 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
10719 IF(IDUP(IUP).EQ.0) K(I,2)=90
10721 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
10729 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
10732 C...Store final state partons for user-defined processes
10737 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
10739 IF(IDUP(IUP).EQ.0) K(N,2)=90
10740 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
10743 K(N,3)=MINT(84)+MOTHUP(1,IUP)
10752 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
10754 C...Arrange colour flow for user-defined processes
10758 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
10759 IF(K(I1,1).EQ.1) K(I1,1)=3
10760 IF(K(I1,1).EQ.11) K(I1,1)=14
10761 C...Find a not yet considered colour/anticolour line.
10763 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
10766 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
10770 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
10771 C...Find all others belonging to same line.
10774 DO 520 IUP2=IUP1+1,NUP
10777 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
10778 IF(ISDE2.EQ.ISDE1) THEN
10779 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
10780 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
10782 ELSEIF(I4.NE.0) THEN
10783 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
10784 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
10786 ELSEIF(IUP2.LE.2) THEN
10787 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
10788 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
10791 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
10792 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
10802 ELSEIF(IDOC.EQ.7) THEN
10803 C...Resonance not decaying; store kinematics
10818 C...Special cases: colour flow in coloured resonances
10819 KCRES=PYCOMP(KFRES)
10820 IF(KCHG(KCRES,2).NE.0) THEN
10824 IF(KCS.EQ.-1) JC=3-J
10825 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
10826 & MINT(84)+ICOL(KCC,1,JC)
10827 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
10828 & MINT(84)+ICOL(KCC,2,JC)
10829 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
10830 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
10839 ELSEIF(IDOC.EQ.8) THEN
10840 C...2 -> 2 processes: store outgoing partons in their CM-frame
10843 KCA=PYCOMP(MINT(20+JT))
10845 IF(KCHG(KCA,2).NE.0) K(I,1)=3
10847 K(I,3)=MINT(83)+IDOC+JT-2
10849 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
10850 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10852 P(I,5)=PYMASS(K(I,2))
10854 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
10855 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
10857 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
10858 KFA1=IABS(MINT(21))
10859 KFA2=IABS(MINT(22))
10860 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
10868 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
10869 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
10870 P(IPU4,4)=SHR-P(IPU3,4)
10871 P(IPU4,3)=-P(IPU3,3)
10876 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
10877 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
10879 ELSEIF(IDOC.EQ.9) THEN
10880 C...2 -> 3 processes: store outgoing partons in their CM frame
10883 KCA=PYCOMP(MINT(20+JT))
10885 IF(KCHG(KCA,2).NE.0) K(I,1)=3
10887 K(I,3)=MINT(83)+IDOC+JT-3
10888 IF(IABS(K(I,2)).LE.22) THEN
10889 P(I,5)=PYMASS(K(I,2))
10891 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
10893 PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
10894 P(I,1)=PT*COS(VINT(198+5*JT))
10895 P(I,2)=PT*SIN(VINT(198+5*JT))
10899 K(IPU5,3)=MINT(83)+IDOC
10901 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10902 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10903 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
10904 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
10905 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
10907 P(IPU5,3)=PMT3*SINH(VINT(211))
10908 P(IPU5,4)=PMT3*COSH(VINT(211))
10909 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
10910 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
10911 IF(SQL12.LE.0D0) THEN
10915 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
10916 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
10917 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
10918 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
10919 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
10925 ELSEIF(IDOC.EQ.11) THEN
10926 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
10927 PHI(1)=PARU(2)*PYR(0)
10932 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10934 K(I,3)=MINT(83)+IDOC+JT-2
10935 P(I,5)=PYMASS(K(I,2))
10936 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
10940 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10941 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10942 P(I,1)=PTABS*COS(PHI(JT))
10943 P(I,2)=PTABS*SIN(PHI(JT))
10944 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10945 P(I,4)=0.5D0*SHPR*Z(JT)
10949 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
10953 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
10954 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
10955 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
10962 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
10963 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
10964 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
10965 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
10974 ELSEIF(IDOC.EQ.12) THEN
10975 C...Z0 and W+/- scattering: store bosons and outgoing partons
10976 PHI(1)=PARU(2)*PYR(0)
10978 JTRAN=INT(1.5D0+PYR(0))
10982 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
10984 K(I,3)=MINT(83)+IDOC+JT-2
10985 P(I,5)=PYMASS(K(I,2))
10986 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
10987 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
10988 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
10989 P(I,1)=PTABS*COS(PHI(JT))
10990 P(I,2)=PTABS*SIN(PHI(JT))
10991 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
10992 P(I,4)=0.5D0*SHPR*Z(JT)
10995 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
10998 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
11003 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
11004 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
11005 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
11008 K(IPU,2)=KFPR(ISUB,JT)
11009 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
11010 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
11011 K(IPU,3)=MINT(83)+8+JT
11012 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
11013 P(IPU,5)=PYMASS(K(IPU,2))
11015 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
11017 MINT(22+JT)=K(IPU,2)
11019 C...Find rotation and boost for hard scattering subsystem
11022 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
11023 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
11024 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
11025 GAMCM=(P(I1,4)+P(I2,4))/SHR
11026 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
11027 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
11028 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
11029 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
11030 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
11031 PHICM=PYANGL(PX,PY)
11032 C...Store hard scattering subsystem. Rotate and boost it
11033 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
11035 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
11037 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
11038 PHIWZ=VINT(24)-PHICM
11039 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
11040 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
11041 P(IPU5,3)=PABS*CTHWZ
11042 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
11043 P(IPU6,1)=-P(IPU5,1)
11044 P(IPU6,2)=-P(IPU5,2)
11045 P(IPU6,3)=-P(IPU5,3)
11046 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
11047 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
11059 MINT(8)=MINT(83)+10
11062 IF(ISET(ISUB).EQ.11) THEN
11063 ELSEIF(IDOC.GE.8) THEN
11064 C...Store colour connection indices
11067 IF(KCS.EQ.-1) JC=3-J
11068 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
11069 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
11070 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
11071 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
11072 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
11073 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
11074 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
11075 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
11078 C...Copy outgoing partons to documentation lines
11080 IF(IDOC.EQ.9) IMAX=3
11082 I1=MINT(83)+IDOC-IMAX+I
11086 IF(IDOC.LE.9) K(I1,3)=0
11087 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
11093 ELSEIF(IDOC.EQ.9) THEN
11094 C...Store colour connection indices
11097 IF(KCS.EQ.-1) JC=3-J
11098 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
11099 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
11100 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
11101 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
11102 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
11103 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
11104 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
11105 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
11106 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
11107 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
11110 C...Copy outgoing partons to documentation lines
11112 I1=MINT(83)+IDOC-3+I
11123 C...Low-pT events: remove gluons used for string drawing purposes
11124 IF(ISUB.EQ.95) THEN
11125 K(IPU3,1)=K(IPU3,1)+10
11126 K(IPU4,1)=K(IPU4,1)+10
11131 DO 710 I=MINT(83)+5,MINT(83)+8
11141 C*********************************************************************
11144 C...Generates spacelike parton showers.
11146 SUBROUTINE PYSSPA(IPU1,IPU2)
11148 C...Double precision and integer declarations.
11149 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11150 IMPLICIT INTEGER(I-N)
11151 INTEGER PYK,PYCHGE,PYCOMP
11153 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11154 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11155 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
11156 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
11157 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11158 COMMON/PYINT1/MINT(400),VINT(400)
11159 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
11160 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
11161 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
11163 C...Local arrays and data.
11164 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
11165 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
11166 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
11167 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
11168 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
11171 C...Read out basic information; set global Q^2 scale.
11176 IF(ISET(ISUB).EQ.2) Q2MX=MIN(VINT(2),PARP(67)*VINT(56))
11179 C...Define which processes ME corrections have been implemented for.
11181 IF(MSTP(68).EQ.1) THEN
11182 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
11183 & ISUB.EQ.144) MECOR=1
11184 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
11187 C...Initialize QCD evolution and check phase space.
11191 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
11194 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11195 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11196 Q2INT=SQRT(Q0S*Q2EFF)
11197 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
11198 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
11199 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
11201 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
11204 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
11205 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
11206 Q2INT=SQRT(Q0S*Q2EFF)
11207 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
11208 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
11209 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
11216 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
11218 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
11219 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
11220 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
11221 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
11225 C...Initialize QED evolution and check phase space.
11229 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
11230 &SPME=PMAS(13,1)**2
11231 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
11232 &SPME=PMAS(15,1)**2
11233 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
11236 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
11238 TEMX=LOG(Q2MX/SPME)
11239 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
11241 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11246 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
11248 C...Loopback point in case of failure to reconstruct kinematics.
11252 IF(LOOP.GT.100) THEN
11258 C...Initial values: flavours, momenta, virtualities.
11261 KFBEAM(JT)=MINT(10+JT)
11262 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
11263 KFLS(JT)=MINT(14+JT)
11264 KFLS(JT+2)=KFLS(JT)
11266 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
11268 Q2S(JT)=FCQ2MX*Q2MX
11275 C...Calculate initial parton distribution weights.
11276 MINT(105)=MINT(102+JT)
11277 MINT(109)=MINT(106+JT)
11278 VINT(120)=VINT(2+JT)
11280 C.... Store side in MINT(124)
11283 IF(XS(JT).LT.1D0-XEE) THEN
11284 IF(MSTP(57).LE.1) THEN
11285 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11287 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
11291 XFS(JT,KFL)=XFB(KFL)
11293 C...Special kinematics check for c/b quarks (that g -> c cbar or
11294 C...b bbar kinematically possible).
11295 KFLCB=IABS(KFLS(JT))
11296 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
11297 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
11304 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
11306 C...Find if interference with final state partons.
11308 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
11312 KCA=PYCOMP(IABS(KFLS(I)))
11313 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
11315 IF(KCFI(I).NE.0) THEN
11316 IF(I.EQ.1) IPFS=IPUS1
11317 IF(I.EQ.2) IPFS=IPUS2
11319 ICSI=MOD(K(IPFS,3+J),MSTU(5))
11320 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
11321 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
11323 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
11325 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
11330 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
11333 C...Pick up leg with highest virtuality.
11337 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
11338 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
11339 IF(MORE(JT).EQ.0) JT=3-JT
11344 XFB(KFL)=XFS(JT,KFL)
11349 C...Check if allowed to branch.
11351 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
11353 XEC=MAX(PARP(65)*DSHR/VINT(2),XB*(1D0/(1D0-PARP(66))-1D0))
11354 IF(XB.GE.1D0-2D0*XEC) MCEV=0
11357 IF(MINT(44+JT).EQ.3) THEN
11359 IF(XB.GE.1D0-2D0*XEE) MEEV=0
11360 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
11362 C***Currently kill QED shower for resolved photoproduction.
11363 IF(MINT(18+JT).EQ.1) MEEV=0
11364 C***Currently kill shower for W inside electron.
11365 IF(IABS(KFLB).EQ.24) THEN
11370 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
11372 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11377 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
11381 IF(MSTP(62).LE.1) THEN
11382 IF(ZS(JT).GT.0.99999D0) THEN
11385 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
11386 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
11387 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
11389 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11390 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11393 ALSDUM=PYALPS(FQ2C*Q2B)
11394 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
11396 B0=(33D0-2D0*MSTU(118))/6D0
11398 IF(MEEV.EQ.2) TEVEB=TEVCB
11402 C...Select side for interference with final state partons.
11403 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
11406 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
11408 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
11409 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
11410 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
11412 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
11416 C...Calculate preweighting factor for ME-corrected processes.
11417 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
11419 C...Calculate Altarelli-Parisi weights.
11425 C...q -> q (g or gamma emission), g -> q.
11426 IF(IABS(KFLB).LE.10) THEN
11427 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
11428 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
11430 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
11431 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
11433 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11434 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
11435 WTAPC(21)=WTGF*WTAPC(21)
11436 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11438 C...f -> f, gamma -> f.
11439 ELSEIF(IABS(KFLB).LE.20) THEN
11440 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
11441 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
11442 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
11443 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
11444 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11445 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
11446 WTAPE(22)=WTGF*WTAPE(22)
11448 C...f -> g, g -> g.
11449 ELSEIF(KFLB.EQ.21) THEN
11450 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
11451 DO 180 KFL=1,MSTP(58)
11455 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
11456 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11457 DO 190 KFL=1,MSTP(58)
11458 WTAPC(KFL)=WTFG*WTAPC(KFL)
11459 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
11461 WTAPC(21)=WTGG*WTAPC(21)
11463 C...f -> gamma, W+, W-.
11464 ELSEIF(KFLB.EQ.22) THEN
11465 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
11468 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11469 WTAPE(11)=WTFG*WTAPE(11)
11470 WTAPE(-11)=WTFG*WTAPE(-11)
11472 ELSEIF(KFLB.EQ.24) THEN
11473 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11474 & (XEE*(XB+XEE)))/XB
11475 ELSEIF(KFLB.EQ.-24) THEN
11476 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
11477 & (XEE*(XB+XEE)))/XB
11480 C...Calculate parton distribution weights and sum.
11483 IF(NTRY.GT.500) THEN
11489 XFBO=MAX(1D-10,XFB(KFLB))
11491 WTSF(KFL)=XFB(KFL)/XFBO
11492 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
11493 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
11495 WTSUMC=MAX(0.0001D0,WTSUMC)
11496 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
11498 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
11501 IF(NTRY2.GT.500) THEN
11506 IF(MSTP(64).LE.0) THEN
11507 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
11508 ELSEIF(MSTP(64).EQ.1) THEN
11509 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
11511 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
11515 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
11516 & (PARU(101)*FWTE*WTSUME*TEMX)))
11517 ELSEIF(MEEV.EQ.2) THEN
11518 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
11521 C...Translate t into Q2 scale; choose between QCD and QED evolution.
11522 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
11523 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
11524 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
11525 C...Ensure that Q2 is above threshold for charm/bottom.
11527 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11529 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
11530 Q2CB=1.1D0*PMAS(KFLCB,1)**2
11531 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11532 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
11535 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
11537 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
11540 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
11541 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
11542 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
11543 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
11544 IF(Q2EB.GT.Q2MNE) MCE=2
11545 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
11546 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
11547 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
11548 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
11549 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
11550 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
11552 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
11553 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
11556 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
11557 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
11560 C...Evolution possibly ended. Update t values.
11564 ELSEIF(MCE.EQ.1) THEN
11567 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
11568 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11572 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
11575 C...Select flavour for branching parton.
11576 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
11577 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
11580 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
11581 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
11582 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
11583 IF(KFLA.EQ.25) THEN
11588 C...Choose z value and corrective weight.
11590 C...q -> q + g or q -> q + gamma.
11591 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
11592 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
11593 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
11594 WTZ=0.5D0*(1D0+Z**2)
11596 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
11597 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
11598 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
11599 C...f -> f + gamma.
11600 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11601 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
11602 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
11603 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
11605 Z=XB+XB*(XEE/(1D0-XEE))*
11606 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11608 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
11609 C...f -> gamma + f.
11610 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
11611 Z=XB+XB*(XEE/(1D0-XEE))*
11612 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11613 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
11615 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
11616 Z=XB+XB*(XEE/(1D0-XEE))*
11617 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
11618 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
11619 & (Q2B/(Q2B+PMAS(24,1)**2))
11621 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
11622 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
11623 WTZ=1D0-2D0*Z*(1D0-Z)
11625 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11626 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
11627 WTZ=(1D0-Z*(1D0-Z))**2
11628 C...gamma -> f + fbar.
11629 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
11630 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
11631 WTZ=1D0-2D0*Z*(1D0-Z)
11633 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
11635 C...Option with resummation of soft gluon emission as effective z shift.
11637 IF(MSTP(65).GE.1) THEN
11639 IF(KFLB.NE.21) RSOFT=8D0/3D0
11640 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
11641 IF(Z.LE.XB) GOTO 220
11644 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
11645 IF(MSTP(64).GE.2) THEN
11646 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
11647 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
11648 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
11649 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
11653 C...Remove kinematically impossible branchings.
11654 UHAT=Q2B-DSH*(1D0-Z)/Z
11655 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
11657 C...Select phi angle of branching at random.
11658 PHIBR=PARU(2)*PYR(0)
11660 C...Matrix-element corrections for some processes.
11661 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
11662 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
11663 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
11665 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
11666 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
11668 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
11669 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
11671 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
11672 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
11677 C...Impose angular constraint in first branching from interference
11678 C...with final state partons.
11680 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
11681 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
11682 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
11683 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
11684 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
11685 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
11689 C...Option with angular ordering requirement.
11690 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
11691 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT(2))
11692 IF(THE2T.GT.THE2(JT)) GOTO 220
11696 C...Weighting with new parton distributions.
11697 MINT(105)=MINT(102+JT)
11698 MINT(109)=MINT(106+JT)
11699 VINT(120)=VINT(2+JT)
11701 C.... Store side in MINT(124)
11704 IF(MSTP(57).LE.1) THEN
11705 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
11707 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
11710 IF(XFBN.LT.1D-20) THEN
11711 IF(KFLA.EQ.KFLB) THEN
11717 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
11718 TEVCB=0.5D0*(TEVCBS+TEVCB)
11720 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
11721 TEVEB=0.5D0*(TEVEBS+TEVEB)
11733 C.... Store side in MINT(124)
11736 IF(MSTP(57).LE.1) THEN
11737 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
11739 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
11742 IF(XFAN.LT.1D-20) GOTO 200
11744 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
11746 C...Define two hard scatterers in their CM-frame.
11747 260 IF(N.EQ.NS+2) THEN
11749 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
11752 IF(JR.EQ.1) IPO=IPUS1
11753 IF(JR.EQ.2) IPO=IPUS2
11763 P(I,3)=DPLCM*(-1)**(JR+1)
11764 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
11765 P(I,5)=-SQRT(DQ2(JR))
11768 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
11769 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
11772 C...Find maximum allowed mass of timelike parton.
11773 ELSEIF(N.GT.NS+2) THEN
11778 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
11779 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
11780 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
11781 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
11782 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
11784 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
11785 & 1D-10*DPD(1)) IKIN=1
11786 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
11787 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
11788 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
11789 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
11791 C...Generate timelike parton shower (if required).
11798 C...f -> f + g (gamma).
11799 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
11801 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
11802 C...f -> g (gamma, W+-) + f.
11803 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
11805 IF(KFLS(JT+2).EQ.24) THEN
11807 ELSEIF(KFLS(JT+2).EQ.-24) THEN
11810 C...g (gamma) -> f + fbar, g + g.
11812 K(IT,2)=-KFLS(JT+2)
11813 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
11816 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
11817 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
11818 P(IT,5)=PYMASS(K(IT,2))
11819 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
11820 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
11823 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
11824 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
11825 IF(MSTP(63).EQ.1) THEN
11827 ELSEIF(MSTP(63).EQ.2) THEN
11828 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
11832 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11833 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
11834 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
11835 PARJ(85)=SQRT(MAX(0D0,DPT2))*
11836 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
11838 CALL PYSHOW(IT,0,SQRT(Q2TIM))
11841 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
11844 C...Reconstruct kinematics of branching: timelike parton shower.
11846 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
11847 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
11848 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
11849 & (4D0*DSH*DPC(3)**2)
11850 IF(DPT2.LT.0D0) GOTO 100
11851 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
11852 & DSHR)/DPC(3)-DPC(3)
11854 P(IT,3)=DPB(1)*(-1)**(JT+1)
11855 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
11857 DPB(1)=SQRT(DPB(1)**2+DPT2)
11858 DPB(2)=SQRT(DPB(1)**2+DMS)
11860 DPB(4)=SQRT(DPB(3)**2+DMS)
11861 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
11863 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
11864 THE=PYANGL(P(IT,3),P(IT,1))
11865 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
11868 C...Reconstruct kinematics of branching: spacelike parton.
11877 P(N+1,3)=P(IT,3)+P(IS(JT),3)
11878 P(N+1,4)=P(IT,4)+P(IS(JT),4)
11879 P(N+1,5)=-SQRT(DQ2(3))
11881 C...Define colour flow of branching.
11886 C...f -> f + gamma (Z, W).
11887 IF(IABS(K(IT,2)).GE.22) THEN
11891 C...f -> gamma (Z, W) + f.
11892 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
11895 C...gamma -> q + qbar, g + g.
11896 ELSEIF(K(N+1,2).EQ.22) THEN
11902 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
11906 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
11909 C...qbar -> qbar + g.
11910 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
11913 C...qbar -> g + qbar.
11914 ELSEIF(K(N+1,2).LT.0) THEN
11917 C...g -> g + g; g -> q + qbar.
11918 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
11925 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
11926 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
11927 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
11928 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
11929 IF(ID1.NE.ID2) THEN
11930 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
11931 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
11934 IF(K(IT,1).EQ.1) THEN
11939 C...Boost to new CM-frame.
11940 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
11941 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
11942 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
11943 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
11944 IR=N+(JT-1)*(IS(1)-N)
11945 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
11949 C...Update kinematics variables.
11952 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THE2(JT)=THE2T
11955 C...Save quantities; loop back.
11959 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
11960 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
11961 KFLS(JT+2)=KFLS(JT)
11966 XFS(JT,KFL)=XFA(KFL)
11975 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
11976 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
11977 IF(MSTU(21).GE.1) N=NS
11978 IF(MSTU(21).GE.1) RETURN
11980 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
11982 C...Boost hard scattering partons to frame of shower initiators.
11984 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
11990 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
11991 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
11992 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
11993 CALL PYROBO(MINT(83)+5,NS,0D0,-ROBO(2),0D0,0D0,0D0)
11994 CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
11997 C...Store user information. Reset Lambda value.
11998 K(IPU1,3)=MINT(83)+3
11999 K(IPU2,3)=MINT(83)+4
12001 MINT(12+JT)=KFLS(JT)
12002 VINT(140+JT)=XS(JT)
12003 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
12010 C*********************************************************************
12013 C...Generates maximum ME weight in some initial-state showers.
12014 C...Inparameter MECOR: kind of hard scattering process
12015 C...Outparameter WTFF: maximum weight for fermion -> fermion
12016 C... WTGF: maximum weight for gluon/photon -> fermion
12017 C... WTFG: maximum weight for fermion -> gluon/photon
12018 C... WTGG: maximum weight for gluon -> gluon
12020 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
12022 C...Double precision and integer declarations.
12023 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12024 IMPLICIT INTEGER(I-N)
12025 INTEGER PYK,PYCHGE,PYCOMP
12027 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12028 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12029 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12030 COMMON/PYINT1/MINT(400),VINT(400)
12031 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12032 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
12034 C...Default maximum weight.
12040 C...Select maximum weight by process.
12041 IF(MECOR.EQ.1) THEN
12044 ELSEIF(MECOR.EQ.2) THEN
12052 C*********************************************************************
12055 C...Calculates actual ME weight in some initial-state showers.
12056 C...Inparameter MECOR: kind of hard scattering process
12057 C... IFLCB: flavour combination of branching,
12058 C... 1 for fermion -> fermion,
12059 C... 2 for gluon/photon -> fermion
12060 C... 3 for fermion -> gluon/photon,
12061 C... 4 for gluon -> gluon
12062 C... Q2: Q2 value of shower branching
12063 C... Z: Z value of branching
12064 C...In+outparameter PHIBR: azimuthal angle of branching
12065 C...Outparameter WTME: actual ME weight
12067 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
12069 C...Double precision and integer declarations.
12070 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12071 IMPLICIT INTEGER(I-N)
12072 INTEGER PYK,PYCHGE,PYCOMP
12074 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12075 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12076 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12077 COMMON/PYINT1/MINT(400),VINT(400)
12078 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12079 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
12081 C...Default output.
12084 C...Define kinematics of shower branching in Mandelstam variables.
12088 UH=Q2-SQM*(1D0-Z)/Z
12090 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
12091 IF(MECOR.EQ.1) THEN
12092 IF(IFLCB.EQ.1) THEN
12093 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
12094 ELSEIF(IFLCB.EQ.2) THEN
12095 WTME=(SH**2+UH**2+2D0*SQM*TH)/((SH-SQM)**2+SQM**2)
12098 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
12099 ELSEIF(MECOR.EQ.2) THEN
12100 IF(IFLCB.EQ.3) THEN
12101 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
12102 ELSEIF(IFLCB.EQ.4) THEN
12103 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
12110 C*********************************************************************
12113 C...Administers the generation of successive final-state showers
12114 C...in external processes.
12116 SUBROUTINE PYADSH(NFIN)
12118 C...Double precision and integer declarations.
12119 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12120 IMPLICIT INTEGER(I-N)
12121 INTEGER PYK,PYCHGE,PYCOMP
12123 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12124 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12125 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12126 COMMON/PYINT1/MINT(400),VINT(400)
12127 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
12129 DIMENSION IBEG(100),KSAV(10,5),IORD(10),PSUM(4),BETA(3)
12131 C...Set primary vertex.
12133 V(MINT(83)+5,J)=0D0
12134 V(MINT(83)+6,J)=0D0
12135 V(MINT(84)+1,J)=0D0
12136 V(MINT(84)+2,J)=0D0
12139 C...Isolate systems of particles with the same mother.
12142 DO 140 I=MINT(84)+3,NFIN
12144 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
12151 C...Set production vertices.
12152 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
12159 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
12162 IF(MSTP(125).GE.1) THEN
12170 C...End loop over systems. Return if no showers to be performed.
12171 IBEG(NSYS+1)=NFIN+1
12172 IF(MSTP(71).LE.0) RETURN
12174 C...Loop through systems of particles; check that sensible size.
12176 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
12177 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
12178 ELSEIF(NSIZ.LE.1) THEN
12179 CALL PYERRM(2,'(PYADSH:) only one particle in system')
12180 ELSEIF(NSIZ.GT.7) THEN
12181 CALL PYERRM(2,'(PYADSH:) more than seven particles in system')
12184 C...Save status codes and daughters of showering pair; reset them.
12191 IF(K(I,1).GT.10) THEN
12193 IF(KSAV(II,1).EQ.14) K(I,1)=3
12195 IF(KSAV(II,1).LE.10) THEN
12196 ELSEIF(K(I,1).EQ.1) THEN
12202 KSAV(II,4)=MOD(K(I,4),MSTU(5))
12203 KSAV(II,5)=MOD(K(I,5),MSTU(5))
12204 K(I,4)=K(I,4)-KSAV(II,4)
12205 K(I,5)=K(I,5)-KSAV(II,5)
12208 PSUM(J)=PSUM(J)+P(I,J)
12212 C...Perform shower.
12213 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
12215 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
12218 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
12220 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
12223 C...Look up showered copies of original showering particles.
12227 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
12228 ELSEIF(K(I,1).EQ.11) THEN
12229 180 IMV=MOD(K(IMV,4),MSTU(5))
12230 IF(K(IMV,1).EQ.11) GOTO 180
12232 KDA1=MOD(K(I,4),MSTU(5))
12233 KDA2=MOD(K(I,5),MSTU(5))
12235 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
12238 KDA1=MOD(K(I3,4),MSTU(5))
12239 KDA2=MOD(K(I3,5),MSTU(5))
12244 C...Restore daughter info of original partons to showered copies.
12245 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
12246 IF(KSAV(II,1).LE.10) THEN
12247 ELSEIF(K(I,1).EQ.1) THEN
12248 K(IMV,4)=KSAV(II,4)
12249 K(IMV,5)=KSAV(II,5)
12251 K(IMV,4)=K(IMV,4)+KSAV(II,4)
12252 K(IMV,5)=K(IMV,5)+KSAV(II,5)
12255 C...Reset mother info of existing daughters to showered copies.
12256 DO 200 I3=IBEG(ISYS+1),NFIN
12257 IF(K(I3,3).EQ.I) K(I3,3)=IMV
12258 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
12259 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
12260 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
12264 C...Boost all original daughters to new frame of showered copy.
12267 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
12269 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
12271 BETA(J)=FAC*BETA(J)
12273 DO 240 I3=IBEG(ISYS+1),NFIN
12276 IF(MSTP(128).LE.0) THEN
12277 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 230
12278 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
12279 & CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
12281 IF(IMO.EQ.IMV) THEN
12282 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
12283 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
12291 C...End of loop over showering systems
12298 C*********************************************************************
12301 C...Allows resonances to decay (including parton showers for hadronic
12304 SUBROUTINE PYRESD(IRES)
12306 C...Double precision and integer declarations.
12307 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12308 IMPLICIT INTEGER(I-N)
12309 INTEGER PYK,PYCHGE,PYCOMP
12310 C...Parameter statement to help give large particle numbers.
12311 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
12312 &KEXCIT=4000000,KDIMEN=5000000)
12314 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12315 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12316 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12317 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
12318 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12319 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12320 COMMON/PYINT1/MINT(400),VINT(400)
12321 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12322 COMMON/PYINT4/MWID(500),WIDS(500,5)
12323 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
12324 &/PYINT1/,/PYINT2/,/PYINT4/
12325 C...Local arrays and complex and character variables.
12326 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
12327 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
12328 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
12329 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
12331 COMPLEX FGK,HA(6,6),HC(6,6)
12333 CHARACTER CODE*9,MASS*9
12335 C...The F, Xi and Xj functions of Gunion and Kunszt
12336 C...(Phys. Rev. D33, 665, plus errata from the authors).
12337 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
12338 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
12339 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
12340 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
12341 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
12342 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
12343 &2D0*(D34/D56+D56/D34))
12345 C...Some general constants.
12348 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
12352 GMMZ=PMAS(23,1)*PMAS(23,2)
12354 GMMW=PMAS(24,1)*PMAS(24,2)
12357 C...Boost and rotate to rest frame of incoming partons,
12358 C...to get proper amount of smearing of decay angles.
12362 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
12363 BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
12364 BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
12365 BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
12366 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
12367 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
12368 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
12369 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
12370 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
12373 C...Reset original resonance configuration.
12378 C...Define initial one, two or three objects for subprocess.
12382 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12383 IREF(1,1)=MINT(84)+2+ISET(ISUB)
12384 IREF(1,4)=MINT(83)+6+ISET(ISUB)
12386 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
12387 IREF(1,1)=MINT(84)+1+ISET(ISUB)
12388 IREF(1,2)=MINT(84)+2+ISET(ISUB)
12389 IREF(1,4)=MINT(83)+5+ISET(ISUB)
12390 IREF(1,5)=MINT(83)+6+ISET(ISUB)
12392 ELSEIF(ISET(ISUB).EQ.5) THEN
12393 IREF(1,1)=MINT(84)+3
12394 IREF(1,2)=MINT(84)+4
12395 IREF(1,3)=MINT(84)+5
12396 IREF(1,4)=MINT(83)+7
12397 IREF(1,5)=MINT(83)+8
12398 IREF(1,6)=MINT(83)+9
12402 C...Define original resonance for odd cases.
12405 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
12407 IF(IHDEC.EQ.1) ISUB=3
12409 IREF(1,4)=K(IRES,3)
12413 C...Check if initial resonance has been moved (in resonance + jet).
12415 IF(IREF(1,JT).GT.0) THEN
12416 IF(K(IREF(1,JT),1).GT.10) THEN
12417 KFA=IABS(K(IREF(1,JT),2))
12418 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
12419 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12420 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12421 DO 110 I=IREF(1,JT)+1,N
12422 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
12425 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
12426 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
12430 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
12431 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
12437 C.....Set decay vertex for initial resonances
12440 V(IREF(1,JT),I)=0D0
12444 C...Loop over decay history.
12450 IF(IREF(IP,2).EQ.0) JTMAX=1
12451 IF(IREF(IP,3).NE.0) JTMAX=3
12455 C...Check for Higgs which appears as decay product of user-process.
12458 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
12460 IF(IHDEC.EQ.1) ISUB=3
12463 C...Start treatment of one, two or three resonances in parallel.
12475 C...Check whether particle can/is allowed to decay.
12476 IF(ID.EQ.0) GOTO 310
12479 IF(MWID(KCA).EQ.0) GOTO 310
12480 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 310
12481 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
12482 & KFA.EQ.18) IT4=IT4+1
12483 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
12484 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
12486 C...Choose lifetime and determine decay vertex.
12487 IF(K(ID,1).EQ.5) THEN
12489 ELSEIF(K(ID,1).NE.4) THEN
12490 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
12493 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
12496 C...Determine whether decay allowed or not.
12498 IF(MSTJ(22).EQ.2) THEN
12499 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
12500 ELSEIF(MSTJ(22).EQ.3) THEN
12501 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
12502 ELSEIF(MSTJ(22).EQ.4) THEN
12503 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
12504 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
12506 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
12511 C...Info for selection of decay channel: sign, pairings.
12512 IF(KCHG(KCA,3).EQ.0) THEN
12515 IPM=(5-ISIGN(1,K(ID,2)))/2
12518 IF(JTMAX.EQ.2) THEN
12519 KFB=IABS(K(IREF(IP,3-JT),2))
12520 ELSEIF(JTMAX.EQ.3) THEN
12522 KFB=IABS(K(IREF(IP,JT2),2))
12523 IF(KFB.NE.KFA) THEN
12524 JT2=JT+2-3*((JT+1)/3)
12525 KFB=IABS(K(IREF(IP,JT2),2))
12529 C...Select decay channel.
12530 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
12531 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
12532 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
12533 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
12534 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
12535 IF(WDTE0S.LE.0D0) GOTO 310
12539 IDC=IDL+MDCY(KCA,2)-1
12540 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
12541 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
12542 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 180
12544 C...Read out flavours and colour charges of decay channel chosen.
12545 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
12546 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
12547 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
12548 KFC1A=PYCOMP(IABS(KFL1(JT)))
12549 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
12550 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
12551 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
12552 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
12553 KFC2A=PYCOMP(IABS(KFL2(JT)))
12554 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
12555 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
12556 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
12557 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
12559 IF(KFL3(JT).NE.0) THEN
12560 KFC3A=PYCOMP(IABS(KFL3(JT)))
12561 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
12562 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
12563 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
12566 C...Set/save further info on channel.
12568 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
12570 HGZ(JT,1)=VINT(111)
12571 HGZ(JT,2)=VINT(112)
12572 HGZ(JT,3)=VINT(114)
12575 C...Select masses; to begin with assume resonances narrow.
12580 KFLW=IABS(KFL1(JT))
12582 ELSEIF(I.EQ.2) THEN
12583 KFLW=IABS(KFL2(JT))
12585 ELSEIF(I.EQ.3) THEN
12586 IF(KFL3(JT).EQ.0) GOTO 200
12587 KFLW=IABS(KFL3(JT))
12590 P(N+I,5)=PMAS(KCW,1)
12592 C...This prevents SUSY/t particles from becoming too light.
12593 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
12594 PMMN(I)=PMAS(KCW,1)
12595 DO 190 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
12596 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
12597 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
12598 & PMAS(PYCOMP(KFDP(IDC,2)),1)
12599 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
12600 & PMAS(PYCOMP(KFDP(IDC,3)),1)
12601 PMMN(I)=MIN(PMMN(I),PMSUM)
12605 ELSEIF(KFLW.EQ.6) THEN
12606 PMMN(I)=PMAS(24,1)+PMAS(5,1)
12610 C...Check which two out of three are widest.
12613 PWID1=PMAS(KFC1A,2)
12614 PWID2=PMAS(KFC2A,2)
12615 KFLW1=IABS(KFL1(JT))
12616 KFLW2=IABS(KFL2(JT))
12617 IF(KFL3(JT).NE.0) THEN
12618 PWID3=PMAS(KFC3A,2)
12619 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
12622 KFLW1=IABS(KFL3(JT))
12623 ELSEIF(PWID3.GT.PWID2) THEN
12626 KFLW2=IABS(KFL3(JT))
12630 C...If all narrow then only check that masses consistent.
12631 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
12632 & PWID2.LT.PARP(41))) THEN
12634 C....Handle near degeneracy cases.
12635 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
12636 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12637 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
12638 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
12642 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
12643 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
12646 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
12647 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
12652 C...For three wide resonances select narrower of three
12653 C...according to BW decoupled from rest.
12656 IF(KFL3(JT).NE.0) THEN
12657 IWID3=6-IWID1-IWID2
12658 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
12662 P(N+IWID3,5)=PYMASS(KFLW3)
12663 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 210
12664 PMTOT=PMTOT-P(N+IWID3,5)
12666 C...Select other two correlated within remaining phase space.
12670 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
12671 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
12672 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12677 CKIN(49)=PMMN(IWID1)
12678 CKIN(50)=PMMN(IWID2)
12679 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
12684 IF(MINT(51).EQ.1) GOTO 700
12687 C...Begin fill decay products, with colour flow for coloured objects.
12693 C...1) Three-body decays of SUSY particles (plus special case top).
12694 IF(KFL3(JT).NE.0) THEN
12710 C...Set colour flow for t -> W + b + Z.
12714 IF(KCQM(JT).EQ.-1) ISID=5
12716 K(ID,ISID)=K(ID,ISID)+IDAU
12717 K(IDAU,ISID)=MSTU(5)*ID
12719 C...Set colour flow in three-body decays - programmed as special cases.
12720 ELSEIF(KFC2A.LE.6) THEN
12724 IF(KFL2(JT).LT.0) ISID=5
12725 K(N+2,ISID)=MSTU(5)*(N+3)
12726 K(N+3,9-ISID)=MSTU(5)*(N+2)
12728 IF(KFL1(JT).EQ.KSUSY1+21) THEN
12733 IF(KFL2(JT).LT.0) ISID=5
12734 K(N+1,ISID)=MSTU(5)*(N+2)
12735 K(N+1,9-ISID)=MSTU(5)*(N+3)
12736 K(N+2,ISID)=MSTU(5)*(N+1)
12737 K(N+3,9-ISID)=MSTU(5)*(N+1)
12739 IF(KFA.EQ.KSUSY1+21) THEN
12743 IF(KFL2(JT).LT.0) ISID=5
12744 K(ID,ISID)=K(ID,ISID)+(N+2)
12745 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
12746 K(N+2,ISID)=MSTU(5)*ID
12747 K(N+3,9-ISID)=MSTU(5)*ID
12751 IF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
12752 & IABS(KCQ2(JT)).EQ.1) THEN
12756 IF(KFL2(JT).LT.0) ISID=5
12757 K(N+2,ISID)=MSTU(5)*(N+3)
12758 K(N+3,9-ISID)=MSTU(5)*(N+2)
12761 C...Set colour flow in three-body decays with baryon number violation.
12762 C...Neutralino and chargino decays first.
12763 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
12764 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
12765 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
12766 K(N+4,4)=ITJUNC(JT)*MSTU(5)
12767 C...Insert junction to keep track of colours.
12768 IF(KCQ1(JT).NE.0) K(N+1,1)=3
12769 IF(KCQ2(JT).NE.0) K(N+2,1)=3
12770 IF(KCQ3(JT).NE.0) K(N+3,1)=3
12771 C...Set special junction codes:
12775 C...Order decay products by invariant mass. (will be used in PYSTRF).
12776 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)-
12777 & P(N+1,3)*P(N+2,3)
12778 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)-
12779 & P(N+1,3)*P(N+3,3)
12780 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)-
12781 & P(N+2,3)*P(N+3,3)
12782 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
12783 K(N+4,4)=N+3+K(N+4,4)
12784 K(N+4,5)=N+1+MSTU(5)*(N+2)
12785 ELSEIF(PM13.LT.PM23) THEN
12786 K(N+4,4)=N+2+K(N+4,4)
12787 K(N+4,5)=N+1+MSTU(5)*(N+3)
12789 K(N+4,4)=N+1+K(N+4,4)
12790 K(N+4,5)=N+2+MSTU(5)*(N+3)
12796 C...Connect daughters to junction.
12800 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
12802 C...Particle counter should be stepped up one extra for junction.
12806 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
12807 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
12808 K(N+4,4)=ITJUNC(JT)*MSTU(5)
12809 C...Insert junction to keep track of colours.
12810 IF(KCQ1(JT).NE.0) K(N+1,1)=3
12811 IF(KCQ2(JT).NE.0) K(N+2,1)=3
12812 IF(KCQ3(JT).NE.0) K(N+3,1)=3
12823 C...Start by connecting all daughters to junction.
12824 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
12825 C...Only consider colour topologies with off shell resonances.
12826 RMQ1=PMAS(PYCOMP(K(II,2)),1)
12827 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
12828 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
12829 IF (RMGLU-RMQ1.LT.RMRES) THEN
12830 C...Calculate propagators for each colour topology.
12831 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
12832 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
12833 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
12837 CTMSUM=CTMSUM+CTM2(II-N)
12839 CTMSUM=PYR(0)*CTMSUM
12840 C...Select colour topology J, with most off shell least likely.
12843 CTMSUM=CTMSUM-CTM2(J)
12844 IF (CTMSUM.GT.0D0) GOTO 280
12845 C...The lucky winner gets its colour (anti-colour) directly from gluino.
12846 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
12847 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
12848 C...The other gluino colour is connected to junction
12849 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
12851 K(N+4,4)=K(N+4,4)+ID
12852 C...Lastly, connect junction to remaining daughters.
12853 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
12854 C...Particle counter should be stepped up one extra for junction.
12858 C...Update particle counter.
12861 C...2) Everything else two-body decay.
12863 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
12864 C...First set colour flow as if mother colour singlet.
12865 IF(KCQ1(JT).NE.0) THEN
12867 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
12868 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
12870 IF(KCQ2(JT).NE.0) THEN
12872 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
12873 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
12875 C...Then redirect colour flow if mother (anti)triplet.
12876 IF(KCQM(JT).EQ.0) THEN
12877 ELSEIF(KCQM(JT).NE.2) THEN
12879 IF(KCQM(JT).EQ.-1) ISID=5
12881 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
12882 K(ID,ISID)=K(ID,ISID)+IDAU
12883 K(IDAU,ISID)=MSTU(5)*ID
12884 C...Then redirect colour flow if mother octet.
12885 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
12887 IF(KCQ1(JT).EQ.0) IDAU=N
12888 K(ID,4)=K(ID,4)+IDAU
12889 K(ID,5)=K(ID,5)+IDAU
12890 K(IDAU,4)=MSTU(5)*ID
12891 K(IDAU,5)=MSTU(5)*ID
12894 IF(KCQ1(JT).EQ.-1) ISID=5
12895 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
12896 K(ID,ISID)=K(ID,ISID)+(N-1)
12897 K(ID,9-ISID)=K(ID,9-ISID)+N
12898 K(N-1,ISID)=MSTU(5)*ID
12899 K(N,9-ISID)=MSTU(5)*ID
12902 C...Insert junction
12903 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
12905 C...~q* mother: type 3 junction. ~q mother: type 4.
12906 ITJUNC(JT)=(7+KCQM(JT))/2
12907 C...Specify junction KF and set colour flow from junction
12911 C...Junction type encoded together with mother:
12912 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
12913 K(N,5)=N-1+MSTU(5)*(N-2)
12914 C...Zero P and V for junction (V filled later)
12919 C...Set colour flow from mother to junction
12920 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
12921 C...Set colour flow from daughters to junction
12925 C...(Anti-)colour mother is junction.
12926 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
12931 C...End loop over resonances for daughter flavour and mass selection.
12933 310 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
12935 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
12936 & KFL1(JT).EQ.0) THEN
12937 WRITE(CODE,'(I9)') K(ID,2)
12938 WRITE(MASS,'(F9.3)') P(ID,5)
12939 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
12940 & CODE//' with mass'//MASS)
12946 C...Check for allowed combinations. Skip if no decays.
12947 IF(JTMAX.EQ.1) THEN
12948 IF(KDCY(1).EQ.0) GOTO 690
12949 ELSEIF(JTMAX.EQ.2) THEN
12950 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 690
12951 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12952 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12953 ELSEIF(JTMAX.EQ.3) THEN
12954 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 690
12955 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
12956 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12957 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
12958 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
12959 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12960 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
12963 C...Special case: matrix element option for Z0 decay to quarks.
12964 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
12965 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
12967 C...Check consistency of MSTJ options set.
12968 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
12970 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
12973 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
12975 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
12980 C...Select alpha_strong behaviour.
12983 MSTU(111)=MSTJ(108)
12984 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
12986 PARU(112)=PARJ(121)
12987 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
12989 C...Find axial fraction in total cross section for scalar gluon model.
12991 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
12992 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
12993 POLL=1D0-PARJ(131)*PARJ(132)
12994 SFF=1D0/(16D0*XW*XW1)
12995 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
12996 & (PARJ(123)*PARJ(124))**2)
12997 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
12999 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
13000 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
13001 & (PARJ(132)-PARJ(131)))
13004 QF=KCHG(KFLC,1)/3D0
13006 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
13007 & 1D0-(2D0*PMQ/P(ID,5))**2))
13008 VF=SIGN(1D0,QF)-4D0*QF*XW
13009 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
13010 & VF**2*HF1W)+VQ**3*HF1W
13011 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
13014 C...Choice of jet configuration.
13015 CALL PYXJET(P(ID,5),NJET,CUT)
13020 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
13021 ELSEIF(NJET.EQ.3) THEN
13022 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
13027 C...Fill jet configuration; return if incorrect kinematics.
13029 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
13030 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
13031 ELSEIF(NJET.EQ.2) THEN
13032 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
13033 ELSEIF(NJET.EQ.3) THEN
13034 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
13035 ELSEIF(KFLN.EQ.21) THEN
13036 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
13039 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
13042 IF(MSTU(24).NE.0) THEN
13049 C...Angular orientation according to matrix element.
13050 IF(MSTJ(106).EQ.1) THEN
13051 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
13052 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
13054 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
13055 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
13058 C...Boost partons to Z0 rest frame.
13059 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
13060 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
13062 C...Mark decayed resonance and add documentation lines,
13064 IDOC=MINT(83)+MINT(4)
13066 I1=MINT(83)+MINT(4)+1
13068 IF(MSTP(128).GE.1) K(I,3)=ID
13069 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
13080 C...Generate parton shower.
13081 IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
13083 C... End special case for Z0: skip ahead.
13089 C...Order incoming partons and outgoing resonances.
13090 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
13093 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
13094 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
13095 & ILIN(1)=2*MINT(84)+3-ILIN(1)
13096 ILIN(2)=2*MINT(84)+3-ILIN(1)
13098 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
13102 IF(K(IREF(IP,1),2).EQ.23) IORD=2
13103 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
13104 IAKIPD=IABS(K(IREF(IP,IORD),2))
13105 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
13106 IF(KDCY(IORD).EQ.0) IORD=3-IORD
13108 C...Order decay products of resonances.
13109 DO 350 JT=IORD,3-IORD,3-2*IORD
13110 IF(KDCY(JT).EQ.0) THEN
13111 ILIN(IMAX+1)=NSD(JT)
13113 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
13114 ILIN(IMAX+1)=N+2*JT-1
13115 ILIN(IMAX+2)=N+2*JT
13117 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
13118 K(N+2*JT,2)=K(NSD(JT)+2,2)
13120 ILIN(IMAX+1)=N+2*JT
13122 ILIN(IMAX+2)=N+2*JT-1
13124 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
13125 K(N+2*JT,2)=K(NSD(JT)+2,2)
13129 C...Find charge, isospin, left- and righthanded couplings.
13134 KFA=IABS(K(ILIN(I),2))
13135 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 370
13136 COUP(I,1)=KCHG(KFA,1)/3D0
13137 COUP(I,2)=(-1)**MOD(KFA,2)
13138 COUP(I,4)=-2D0*COUP(I,1)*XWV
13139 COUP(I,3)=COUP(I,2)+COUP(I,4)
13142 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
13143 IF(ISUB.EQ.22) THEN
13146 IF(I.EQ.5) I1=3-IORD
13149 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
13150 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
13151 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
13156 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
13157 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
13158 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
13159 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
13161 IF(COWT12.LT.PYR(0)*COMX12) GOTO 160
13165 C...Select angular orientation type - Z'/W' only.
13167 IF(ISUB.EQ.141) THEN
13168 IF(PYR(0).LT.PARU(130)) MZPWP=1
13170 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
13171 IAKIR=IABS(K(IREF(2,2),2))
13172 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
13173 IF(IAKIR.LE.20) MZPWP=2
13175 IF(IP.GE.3) MZPWP=2
13176 ELSEIF(ISUB.EQ.142) THEN
13177 IF(PYR(0).LT.PARU(136)) MZPWP=1
13179 IAKIR=IABS(K(IREF(2,2),2))
13180 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
13181 IF(IAKIR.LE.20) MZPWP=2
13183 IF(IP.GE.3) MZPWP=2
13186 C...Select random angles (begin of weighting procedure).
13187 410 DO 420 JT=1,JTMAX
13188 IF(KDCY(JT).EQ.0) GOTO 420
13189 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
13190 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
13191 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
13194 CTHE(JT)=2D0*PYR(0)-1D0
13195 PHI(JT)=PARU(2)*PYR(0)
13199 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
13200 C...Construct massless four-vectors.
13209 IF(KDCY(JT).EQ.0) GOTO 450
13211 P(N+2*JT-1,3)=0.5D0*P(ID,5)
13212 P(N+2*JT-1,4)=0.5D0*P(ID,5)
13213 P(N+2*JT,3)=-0.5D0*P(ID,5)
13214 P(N+2*JT,4)=0.5D0*P(ID,5)
13215 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
13216 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
13219 C...Store incoming and outgoing momenta, with random rotation to
13220 C...avoid accidental zeroes in HA expressions.
13224 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
13225 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
13226 P(N+4+I,5)=P(ILIN(I),5)
13228 P(N+4+I,J)=P(ILIN(I),J)
13231 480 THERR=ACOS(2D0*PYR(0)-1D0)
13232 PHIRR=PARU(2)*PYR(0)
13233 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
13235 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2)
13243 C...Calculate internal products.
13244 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
13245 & ISUB.EQ.142) THEN
13246 DO 520 I1=IMIN,IMAX-1
13247 DO 510 I2=I1+1,IMAX
13248 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
13249 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
13250 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
13251 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
13252 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
13253 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
13254 HC(I1,I2)=CONJG(HA(I1,I2))
13255 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
13256 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
13257 HA(I2,I1)=-HA(I1,I2)
13258 HC(I2,I1)=-HC(I1,I2)
13263 C...Calculate four-products.
13270 DO 560 I1=IMIN,IMAX-1
13271 DO 550 I2=I1+1,IMAX
13272 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
13273 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
13274 PKK(I2,I1)=PKK(I1,I2)
13280 KFAGM=IABS(IREF(IP,7))
13281 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
13282 C...Isotropic decay selected by user.
13286 ELSEIF(JTMAX.EQ.3) THEN
13287 C...Isotropic decay when three mother particles.
13291 ELSEIF(IT4.GE.1) THEN
13292 C... Isotropic decay t -> b + W etc for 4th generation q and l.
13296 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
13297 & IREF(IP,7).EQ.36) THEN
13298 C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
13299 C...CP-odd case added by Kari Ertresvag Myklevoll.
13300 IF(IP.EQ.1) WTMAX=SH**2
13301 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
13302 KFA=IABS(K(IREF(IP,1),2))
13304 KFLF1A=IABS(KFL1(1))
13305 EF1=KCHG(KFLF1A,1)/3D0
13306 AF1=SIGN(1D0,EF1+0.1D0)
13307 VF1=AF1-4D0*EF1*XWV
13308 KFLF2A=IABS(KFL1(2))
13309 EF2=KCHG(KFLF2A,1)/3D0
13310 AF2=SIGN(1D0,EF2+0.1D0)
13311 VF2=AF2-4D0*EF2*XWV
13312 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)
13313 & *(VF2**2+AF2**2))
13314 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
13317 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
13318 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
13321 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
13322 & -2*PKK(3,4)*PKK(5,6)
13323 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
13324 & (PKK(3,4)*PKK(5,6))
13325 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
13326 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
13328 ELSEIF(KFA.EQ.24) THEN
13329 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
13332 WT=16D0*PKK(3,5)*PKK(4,6)
13335 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
13336 & -2*PKK(3,4)*PKK(5,6)
13337 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
13338 & (PKK(3,4)*PKK(5,6))
13339 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
13340 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
13346 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
13347 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
13349 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
13351 IF(MOD(KFAGM,2).EQ.0) THEN
13359 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
13360 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
13361 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
13362 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
13364 ELSEIF(ISUB.EQ.1) THEN
13365 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
13366 EI=KCHG(IABS(MINT(15)),1)/3D0
13367 AI=SIGN(1D0,EI+0.1D0)
13369 EF=KCHG(IABS(KFL1(1)),1)/3D0
13370 AF=SIGN(1D0,EF+0.1D0)
13373 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
13374 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13375 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
13376 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13377 & (VI**2+AI**2)*VINT(114)*VF**2)
13378 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
13379 & 4D0*VI*AI*VINT(114)*VF*AF)
13380 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13381 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13382 WTMAX=2D0*(WT1+ABS(WT3))
13384 ELSEIF(ISUB.EQ.2) THEN
13385 C...Angular weight for W+/- -> 2 quarks/leptons.
13386 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
13387 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
13388 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13389 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13392 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
13393 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
13394 C...-> gluon/gamma + 2 quarks/leptons.
13395 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13396 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13397 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13398 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13399 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13400 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13401 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13402 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13403 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13404 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13405 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13406 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13407 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
13408 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
13409 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13410 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
13412 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
13413 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
13414 C...-> gluon/gamma + 2 quarks/leptons.
13415 WT=PKK(1,3)**2+PKK(2,4)**2
13416 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
13418 ELSEIF(ISUB.EQ.22) THEN
13419 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
13420 S34=P(IREF(IP,IORD),5)**2
13421 S56=P(IREF(IP,3-IORD),5)**2
13422 TI=PKK(1,3)+PKK(1,4)+S34
13423 UI=PKK(1,5)+PKK(1,6)+S56
13426 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
13427 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
13428 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
13429 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
13430 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
13431 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
13432 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
13433 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
13436 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
13437 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
13438 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
13439 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
13440 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
13441 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
13442 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
13445 ELSEIF(ISUB.EQ.23) THEN
13446 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
13447 D34=P(IREF(IP,IORD),5)**2
13448 D56=P(IREF(IP,3-IORD),5)**2
13449 DT=PKK(1,3)+PKK(1,4)+D34
13450 DU=PKK(1,5)+PKK(1,6)+D56
13451 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
13452 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13453 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
13454 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
13456 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
13457 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
13458 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
13459 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13460 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
13461 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
13463 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
13464 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
13465 C...(or H0, or A0).
13466 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
13467 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
13468 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
13469 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
13470 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13472 ELSEIF(ISUB.EQ.25) THEN
13473 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
13474 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
13475 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
13476 D34=P(IREF(IP,IORD),5)**2
13477 D56=P(IREF(IP,3-IORD),5)**2
13478 DT=PKK(1,3)+PKK(1,4)+D34
13479 DU=PKK(1,5)+PKK(1,6)+D56
13480 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
13481 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
13482 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
13483 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
13484 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
13485 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
13486 & REAL(CBWW)*FGK(1,2,5,6,3,4))
13487 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13488 IF(MSTP(50).LE.0) THEN
13489 WT=FGK135**2+(CCWW*FGK253)**2
13490 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
13491 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
13494 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
13495 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
13496 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
13497 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
13500 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
13501 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
13502 C...(or H0, or A0).
13503 WT=PKK(1,3)*PKK(2,4)
13504 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
13506 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
13507 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
13508 C...-> f + 2 quarks/leptons.
13509 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13510 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13511 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
13512 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13513 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13514 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
13515 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13516 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
13517 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
13518 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
13519 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
13520 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
13521 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
13522 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
13523 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
13524 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
13525 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
13526 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
13528 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
13529 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
13530 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
13531 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
13532 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
13534 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
13536 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
13537 WT=16D0*PKK(3,5)*PKK(4,6)
13540 ELSEIF(ISUB.EQ.110) THEN
13541 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
13545 ELSEIF(ISUB.EQ.141) THEN
13546 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13547 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
13548 C...Couplings of incoming flavour.
13549 KFAI=IABS(MINT(15))
13550 EI=KCHG(KFAI,1)/3D0
13551 AI=SIGN(1D0,EI+0.1D0)
13554 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
13555 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
13556 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
13557 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
13558 VPI=PARU(119+2*KFAIC)
13559 API=PARU(120+2*KFAIC)
13560 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
13561 VPI=PARJ(178+2*KFAIC)
13562 API=PARJ(179+2*KFAIC)
13564 VPI=PARJ(186+2*KFAIC)
13565 API=PARJ(187+2*KFAIC)
13567 C...Couplings of final flavour.
13569 EF=KCHG(KFAF,1)/3D0
13570 AF=SIGN(1D0,EF+0.1D0)
13573 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
13574 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
13575 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
13576 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
13577 VPF=PARU(119+2*KFAFC)
13578 APF=PARU(120+2*KFAFC)
13579 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
13580 VPF=PARJ(178+2*KFAFC)
13581 APF=PARJ(179+2*KFAFC)
13583 VPF=PARJ(186+2*KFAFC)
13584 APF=PARJ(187+2*KFAFC)
13586 C...Asymmetry and weight.
13587 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
13588 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
13589 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
13590 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
13591 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
13592 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
13593 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
13594 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13595 WTMAX=2D0+ABS(ASYM)
13596 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
13597 C...Angular weight for f + fbar -> Z' -> W+ + W-.
13598 RM1=P(NSD(1)+1,5)**2/SH
13599 RM2=P(NSD(1)+2,5)**2/SH
13600 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13601 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13602 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13604 WT=CFLAT+CCOS2*CTHE(1)**2
13605 WTMAX=CFLAT+MAX(0D0,CCOS2)
13606 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
13607 & IABS(KFL1(1)).EQ.37)) THEN
13608 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
13611 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13612 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
13613 RM1=P(NSD(1)+1,5)**2/SH
13614 RM2=P(NSD(1)+2,5)**2/SH
13615 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13616 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13617 WTMAX=1D0+FLAM2/(8D0*RM1)
13618 ELSEIF(MZPWP.EQ.0) THEN
13619 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13620 C...(W:s like if intermediate Z).
13621 D34=P(IREF(IP,IORD),5)**2
13622 D56=P(IREF(IP,3-IORD),5)**2
13623 DT=PKK(1,3)+PKK(1,4)+D34
13624 DU=PKK(1,5)+PKK(1,6)+D56
13625 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13626 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
13627 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
13628 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
13629 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13630 ELSEIF(MZPWP.EQ.1) THEN
13631 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
13632 C...(W:s approximately longitudinal, like if intermediate H).
13633 WT=16D0*PKK(3,5)*PKK(4,6)
13636 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
13637 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
13642 ELSEIF(ISUB.EQ.142) THEN
13643 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
13644 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
13645 KFAI=IABS(MINT(15))
13647 IF(KFAI.GT.10) KFAIC=2
13648 VI=PARU(129+2*KFAIC)
13649 AI=PARU(130+2*KFAIC)
13652 IF(KFAF.GT.10) KFAFC=2
13653 VF=PARU(129+2*KFAFC)
13654 AF=PARU(130+2*KFAFC)
13655 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
13656 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
13657 WTMAX=2D0+ABS(ASYM)
13658 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
13659 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
13660 RM1=P(NSD(1)+1,5)**2/SH
13661 RM2=P(NSD(1)+2,5)**2/SH
13662 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
13663 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13664 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
13666 WT=CFLAT+CCOS2*CTHE(1)**2
13667 WTMAX=CFLAT+MAX(0D0,CCOS2)
13668 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
13669 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
13670 RM1=P(NSD(1)+1,5)**2/SH
13671 RM2=P(NSD(1)+2,5)**2/SH
13672 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
13673 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
13674 WTMAX=1D0+FLAM2/(8D0*RM1)
13675 ELSEIF(MZPWP.EQ.0) THEN
13676 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13677 C...(W/Z like if intermediate W).
13678 D34=P(IREF(IP,IORD),5)**2
13679 D56=P(IREF(IP,3-IORD),5)**2
13680 DT=PKK(1,3)+PKK(1,4)+D34
13681 DU=PKK(1,5)+PKK(1,6)+D56
13682 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
13683 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
13684 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
13685 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
13686 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
13687 ELSEIF(MZPWP.EQ.1) THEN
13688 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
13689 C...(W/Z approximately longitudinal, like if intermediate H).
13690 WT=16D0*PKK(3,5)*PKK(4,6)
13693 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
13694 C...t + bbar -> t + W + bbar.
13699 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
13701 C...Isotropic decay of leptoquarks (assumed spin 0).
13705 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
13706 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
13708 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
13709 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
13710 WT=1D0+SIDE*CTHE(1)
13712 ELSEIF(IP.EQ.1) THEN
13714 RM1=P(NSD(1)+1,5)**2/SH
13715 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13716 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
13718 C...W/Z decay assumed isotropic, since not known.
13723 ELSEIF(ISUB.EQ.149) THEN
13724 C...Isotropic decay of techni-eta.
13728 ELSEIF(ISUB.EQ.191) THEN
13729 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13730 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
13731 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
13734 ELSEIF(IP.EQ.1) THEN
13735 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
13736 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13737 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
13738 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13739 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13740 KFAI=IABS(MINT(15))
13741 EI=KCHG(KFAI,1)/3D0
13742 AI=SIGN(1D0,EI+0.1D0)
13746 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
13747 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
13749 EF=KCHG(KFAF,1)/3D0
13750 AF=SIGN(1D0,EF+0.1D0)
13754 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
13755 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
13756 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
13757 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
13758 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
13759 WTMAX=4D0*MAX(ASAME,AFLIP)
13761 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
13766 ELSEIF(ISUB.EQ.192) THEN
13767 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13768 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
13769 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
13772 ELSEIF(IP.EQ.1) THEN
13773 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
13774 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13778 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
13783 ELSEIF(ISUB.EQ.193) THEN
13784 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
13785 C...Angular weight for f + fbar -> omega_tc0 ->
13786 C...gamma pi_tc0 or Z0 pi_tc0.
13789 ELSEIF(IP.EQ.1) THEN
13790 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
13791 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
13792 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13793 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13794 KFAI=IABS(MINT(15))
13795 EI=KCHG(KFAI,1)/3D0
13796 AI=SIGN(1D0,EI+0.1D0)
13800 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
13801 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
13803 EF=KCHG(KFAF,1)/3D0
13804 AF=SIGN(1D0,EF+0.1D0)
13808 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
13809 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
13810 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
13811 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
13812 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
13813 WTMAX=4D0*MAX(BSAME,BFLIP)
13815 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
13820 ELSEIF(ISUB.EQ.353) THEN
13821 C...Angular weight for Z_R0 -> 2 quarks/leptons.
13822 EI=KCHG(IABS(MINT(15)),1)/3D0
13823 AI=SIGN(1D0,EI+0.1D0)
13825 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
13826 AF=SIGN(1D0,EF+0.1D0)
13828 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
13829 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
13830 WT2=RMF*(VI**2+AI**2)*VF**2
13831 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
13832 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
13833 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
13834 WTMAX=2D0*(WT1+ABS(WT3))
13836 ELSEIF(ISUB.EQ.354) THEN
13837 C...Angular weight for W_R+/- -> 2 quarks/leptons.
13838 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
13839 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
13840 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
13841 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
13844 ELSEIF(ISUB.EQ.391) THEN
13845 C...Angular weight for f + fbar -> G* -> f + fbar
13846 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13847 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
13849 C...Other G* decays not yet implemented angular distributions.
13855 ELSEIF(ISUB.EQ.392) THEN
13856 C...Angular weight for g + g -> G* -> f + fbar
13857 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
13860 C...Other G* decays not yet implemented angular distributions.
13866 C...Obtain correct angular distribution by rejection techniques.
13871 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
13873 C...Construct massive four-vectors using angles chosen.
13874 570 DO 670 JT=1,JTMAX
13875 IF(KDCY(JT).EQ.0) GOTO 670
13880 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
13882 IF(KFL3(JT).EQ.0) THEN
13883 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
13884 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13887 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
13888 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
13893 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
13895 C...Fill in position of decay vertex.
13896 DO 610 I=NSD(JT)+1,N0
13905 C...Mark decayed resonances; trace history.
13909 IF(KCQM(JT).NE.0) THEN
13910 C...Do not kill colour flow through coloured resonance!
13914 C...If 3-body or 2-body with junction:
13915 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
13916 C...If 3-body with junction:
13917 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
13920 C...Add documentation lines.
13921 ISUBRG=MAX(1,MIN(500,MINT(1)))
13922 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
13923 IDOC=MINT(83)+MINT(4)
13926 IF(KFL3(JT).NE.0) IHI=IHI+1
13927 DO 630 I=NSD(JT)+1,IHI
13929 I1=MINT(83)+MINT(4)+1
13931 IF(MSTP(128).GE.1) K(I,3)=ID
13932 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
13936 K(I1,3)=IREF(IP,JT+3)
13945 C...If 3-body or 2-body with junction:
13946 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
13947 C...If 3-body with junction:
13948 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
13951 C...Do showering of two or three objects.
13953 IF(MSTP(71).GE.1) THEN
13954 IF(KFL3(JT).EQ.0) THEN
13955 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
13957 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
13961 IF(JT.EQ.1) NAFT1=N
13963 C...Check if decay products moved by shower.
13967 IF(NSHAFT.GT.NSHBEF) THEN
13968 IF(K(NSD1,1).GT.10) THEN
13969 DO 640 I=NSHBEF+1,NSHAFT
13970 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
13973 IF(K(NSD2,1).GT.10) THEN
13974 DO 650 I=NSHBEF+1,NSHAFT
13975 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
13976 & I.NE.NSD1) NSD2=I
13979 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
13980 DO 660 I=NSHBEF+1,NSHAFT
13981 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
13982 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
13987 C...Store decay products for further treatment.
13992 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
13996 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
13997 IREF(NP,7)=K(IREF(IP,JT),2)
13998 IREF(NP,8)=IREF(IP,JT)
14001 C...Fill information for 2 -> 1 -> 2.
14002 680 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
14003 MINT(7)=MINT(83)+6+2*ISET(ISUB)
14004 MINT(8)=MINT(83)+7+2*ISET(ISUB)
14010 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
14011 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
14012 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
14013 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
14014 VINT(47)=SQRT(VINT(48))
14017 C...Possibility of colour rearrangement in W+W- events.
14018 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
14019 IAKF1=IABS(KFL1(1))
14020 IAKF2=IABS(KFL1(2))
14021 IAKF3=IABS(KFL2(1))
14022 IAKF4=IABS(KFL2(2))
14023 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
14024 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
14025 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
14028 C...Loop back if needed.
14029 690 IF(IP.LT.NP) GOTO 150
14031 C...Boost back to standard frame.
14032 700 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
14038 C*********************************************************************
14041 C...Initializes treatment of multiple interactions, selects kinematics
14042 C...of hardest interaction if low-pT physics included in run, and
14043 C...generates all non-hardest interactions.
14045 SUBROUTINE PYMULT(MMUL)
14047 C...Double precision and integer declarations.
14048 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14049 IMPLICIT INTEGER(I-N)
14050 INTEGER PYK,PYCHGE,PYCOMP
14052 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14053 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14054 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14055 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
14056 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14057 COMMON/PYINT1/MINT(400),VINT(400)
14058 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14059 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
14060 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
14061 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
14062 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
14063 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
14064 C...Local arrays and saved variables.
14065 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
14066 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
14068 C...Initialization of multiple interaction treatment.
14070 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
14078 C...Loop over phase space points: xT2 choice in 20 bins.
14081 NMUL(IXT2)=MSTP(83)
14083 DO 110 ITRY=1,MSTP(83)
14084 RSCA=0.05D0*((21-IXT2)-PYR(0))
14085 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
14086 XT2=MAX(0.01D0*VINT(149),XT2)
14089 C...Choose tau and y*. Calculate cos(theta-hat).
14090 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14091 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14092 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14094 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14100 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14101 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14102 CALL PYKMAP(2,MYST,PYR(0))
14103 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14105 C...Calculate differential cross-section.
14106 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
14107 CALL PYSIGH(NCHN,SIGS)
14108 SIGM(IXT2)=SIGM(IXT2)+SIGS
14110 SIGSUM=SIGSUM+SIGM(IXT2)
14112 SIGSUM=SIGSUM/(20D0*MSTP(83))
14114 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
14115 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
14116 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
14117 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
14118 PARP(82)=0.9D0*PARP(82)
14119 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
14123 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
14124 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
14126 C...Start iteration to find k factor.
14127 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
14135 130 IF(IIT.EQ.0) THEN
14137 ELSEIF(IIT.EQ.1) THEN
14140 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
14143 C...Evaluate overlap integrals.
14144 IF(MSTP(82).EQ.2) THEN
14145 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
14148 IF(MSTP(82).EQ.3) DELTAB=0.02D0
14149 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
14154 IF(MSTP(82).EQ.3) THEN
14155 OV=EXP(-B**2)/PARU(2)
14158 OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
14159 & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
14160 & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
14161 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
14163 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
14164 SP=SP+PARU(2)*B*DELTAB*PACC
14165 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
14166 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
14168 YK=PARU(1)*XK*SO/SP
14170 C...Continue iteration until convergence.
14180 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
14182 C...Store some results for subsequent use.
14187 C...Initialize iteration in xT2 for hardest interaction.
14188 ELSEIF(MMUL.EQ.2) THEN
14189 IF(MSTP(82).LE.0) THEN
14190 ELSEIF(MSTP(82).EQ.1) THEN
14192 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
14193 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
14194 & VINT(317)/(VINT(318)*VINT(320))
14195 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
14196 ELSEIF(MSTP(82).EQ.2) THEN
14198 XT2FAC=VINT(146)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
14199 & VINT(149)*(1D0+VINT(149))
14201 XC2=4D0*CKIN(3)**2/VINT(2)
14202 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
14205 ELSEIF(MMUL.EQ.3) THEN
14206 C...Low-pT or multiple interactions (first semihard interaction):
14207 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
14208 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
14210 IF(MSTP(82).LE.0) THEN
14212 ELSEIF(MSTP(82).EQ.1) THEN
14213 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
14214 ELSEIF(MSTP(82).EQ.2) THEN
14215 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
14216 & VINT(149)))).GT.PYR(0)) XT2=1D0
14217 IF(XT2.GE.1D0) THEN
14218 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
14219 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
14222 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
14223 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
14226 XT2=MAX(0.01D0*VINT(149),XT2)
14228 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
14229 & PYR(0)*(1D0-XC2))-VINT(149)
14230 XT2=MAX(0.01D0*VINT(149),XT2)
14234 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
14235 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
14236 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
14237 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
14240 VINT(21)=0.01D0*VINT(149)
14243 VINT(25)=0.01D0*VINT(149)
14246 C...Multiple interactions (first semihard interaction).
14247 C...Choose tau and y*. Calculate cos(theta-hat).
14248 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14249 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14250 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14252 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14258 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14259 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14260 CALL PYKMAP(2,MYST,PYR(0))
14261 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14263 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
14265 C...Store results of cross-section calculation.
14266 ELSEIF(MMUL.EQ.4) THEN
14269 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
14270 IF(ISET(ISUB).EQ.2)
14271 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
14272 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
14273 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
14274 & (XTS+VINT(149))))
14275 IRBIN=INT(1D0+20D0*RBIN)
14276 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
14277 NMUL(IRBIN)=NMUL(IRBIN)+1
14278 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
14281 C...Choose impact parameter.
14282 ELSEIF(MMUL.EQ.5) THEN
14284 150 IF(MSTP(82).EQ.3) THEN
14285 VINT(148)=PYR(0)/(PARU(2)*VINT(147))
14289 IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
14291 ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
14292 B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
14294 B2=-CQ2*LOG(PYR(0))
14296 VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
14297 & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
14298 & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
14301 C...Multiple interactions (variable impact parameter) : reject with
14302 C...probability exp(-overlap*cross-section above pT/normalization).
14303 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
14304 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
14305 DO 160 IBIN=IRBIN+1,20
14306 RNCOR=RNCOR+NMUL(IBIN)
14307 SIGCOR=SIGCOR+SIGM(IBIN)
14309 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
14310 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
14311 VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
14312 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
14313 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
14314 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
14315 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
14316 IF(VINT(150).LT.PYR(0)) GOTO 150
14320 C...Generate additional multiple semihard interactions.
14321 ELSEIF(MMUL.EQ.6) THEN
14331 C...Reconstruct strings in hard scattering.
14333 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
14334 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
14336 DO 190 I=MINT(84)+1,NMAX
14337 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
14338 IF(KCS.EQ.0) GOTO 190
14340 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 180
14341 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 180
14343 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
14345 IST=MOD(K(I,J+1),MSTU(5))
14347 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 180
14348 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 180
14350 IF(J.EQ.1.OR.J.EQ.4) THEN
14360 C...Set up starting values for iteration in xT2.
14361 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
14362 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
14363 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
14364 & ISUBSV.NE.96)) THEN
14365 XT2=(1D0-VINT(141))*(1D0-VINT(142))
14368 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
14369 IF(ISET(ISUBSV).EQ.2)
14370 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
14371 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
14373 IF(MSTP(82).LE.1) THEN
14374 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
14375 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
14376 & VINT(317)/(VINT(318)*VINT(320))
14377 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
14379 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
14380 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
14384 VINT(143)=1D0-VINT(141)
14385 VINT(144)=1D0-VINT(142)
14387 C...Iterate downwards in xT2.
14388 200 IF(MSTP(82).LE.1) THEN
14389 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
14390 IF(XT2.LT.VINT(149)) GOTO 250
14392 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 250
14393 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
14394 & LOG(PYR(0)))-VINT(149)
14395 IF(XT2.LE.0D0) GOTO 250
14396 XT2=MAX(0.01D0*VINT(149),XT2)
14400 C...Choose tau and y*. Calculate cos(theta-hat).
14401 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14402 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14403 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14405 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14411 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14412 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14413 CALL PYKMAP(2,MYST,PYR(0))
14414 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14416 C...Check that x not used up. Accept or reject kinematical variables.
14417 X1M=SQRT(TAU)*EXP(VINT(22))
14418 X2M=SQRT(TAU)*EXP(-VINT(22))
14419 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 200
14420 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
14421 CALL PYSIGH(NCHN,SIGS)
14422 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
14423 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 200
14425 C...Reset K, P and V vectors. Select some variables.
14434 PT=0.5D0*VINT(1)*SQRT(XT2)
14438 C...Add first parton to event record.
14441 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
14442 & 1+INT((2D0+PARJ(2))*PYR(0))
14443 P(N+1,1)=PT*COS(PHI)
14444 P(N+1,2)=PT*SIN(PHI)
14445 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
14446 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
14449 C...Add second parton to event record.
14452 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
14455 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
14456 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
14459 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
14460 C....Choose relevant string pieces to place gluons on.
14466 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
14467 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
14468 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
14469 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
14470 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
14478 C....Colour flow adjustments, new string pieces.
14479 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
14480 & MOD(K(IST1,4),MSTU(5))
14481 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
14482 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
14483 K(I,5)=MSTU(5)*IST1
14484 K(I,4)=MSTU(5)*IST2
14485 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
14486 & MOD(K(IST2,5),MSTU(5))
14487 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
14488 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
14491 KSTR(NSTR+1,2)=IST2
14495 C...String drawing and colour flow for gluon loop.
14496 ELSEIF(K(N+1,2).EQ.21) THEN
14497 K(N+1,4)=MSTU(5)*(N+2)
14498 K(N+1,5)=MSTU(5)*(N+2)
14499 K(N+2,4)=MSTU(5)*(N+1)
14500 K(N+2,5)=MSTU(5)*(N+1)
14507 C...String drawing and colour flow for qqbar pair.
14509 K(N+1,4)=MSTU(5)*(N+2)
14510 K(N+2,5)=MSTU(5)*(N+1)
14516 C...Update remaining energy; iterate.
14518 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14519 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
14520 IF(MSTU(21).GE.1) RETURN
14522 MINT(31)=MINT(31)+1
14523 VINT(151)=VINT(151)+VINT(41)
14524 VINT(152)=VINT(152)+VINT(42)
14525 VINT(143)=VINT(143)-VINT(41)
14526 VINT(144)=VINT(144)-VINT(42)
14527 IF(MINT(31).LT.240) GOTO 200
14535 C...Format statements for printout.
14536 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
14537 &'actions for MSTP(82) =',I2,' ******')
14538 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14539 &D9.2,' mb: rejected')
14540 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
14541 &D9.2,' mb: accepted')
14546 C*********************************************************************
14549 C...Adds on target remnants (one or two from each side) and
14550 C...includes primordial kT for hadron beams.
14552 SUBROUTINE PYREMN(IPU1,IPU2)
14554 C...Double precision and integer declarations.
14555 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14556 IMPLICIT INTEGER(I-N)
14557 INTEGER PYK,PYCHGE,PYCOMP
14559 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14560 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14561 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14562 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14563 COMMON/PYINT1/MINT(400),VINT(400)
14564 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
14566 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
14567 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
14569 C...Find event type and remaining energy.
14572 IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
14573 VINT(143)=1D0-VINT(141)
14574 VINT(144)=1D0-VINT(142)
14577 C...Define initial partons.
14582 IF(JT.EQ.1) IPU=IPU1
14583 IF(JT.EQ.2) IPU=IPU2
14590 IF(MINT(47).EQ.1) THEN
14594 ELSEIF(ISUB.EQ.95) THEN
14599 C...No primordial kT, or chosen according to truncated Gaussian or
14600 C...exponential, or (for photon) predetermined or power law.
14601 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
14602 IF(MSTP(91).LE.0) THEN
14604 ELSEIF(MSTP(91).EQ.1) THEN
14605 PT=PARP(91)*SQRT(-LOG(PYR(0)))
14609 PT=-PARP(92)*LOG(RPT1*RPT2)
14611 IF(PT.GT.PARP(93)) GOTO 120
14612 ELSEIF(MINT(106+JT).EQ.3) THEN
14613 PTA=SQRT(VINT(282+JT))
14615 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
14616 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
14617 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
14620 PTB=-PARP(99)*LOG(RPT1*RPT2)
14622 IF(PTB.GT.PARP(100)) GOTO 120
14623 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
14624 PT=PT*0.8D0**MINT(57)
14625 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
14626 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
14627 IF(MSTP(93).LE.0) THEN
14629 ELSEIF(MSTP(93).EQ.1) THEN
14630 PT=PARP(99)*SQRT(-LOG(PYR(0)))
14631 ELSEIF(MSTP(93).EQ.2) THEN
14634 PT=-PARP(99)*LOG(RPT1*RPT2)
14635 ELSEIF(MSTP(93).EQ.3) THEN
14638 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
14642 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
14643 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
14645 IF(PT.GT.PARP(100)) GOTO 120
14653 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14656 IF(MINT(47).EQ.1) RETURN
14658 C...Kinematics construction for initial partons.
14661 IF(ISUB.EQ.95) THEN
14665 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
14666 & (P(I1,2)+P(I2,2))**2
14667 SHR=SQRT(MAX(0D0,SHS))
14668 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
14669 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
14670 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
14671 P(I2,4)=SHR-P(I1,4)
14674 C...Transform partons to overall CM-frame.
14675 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
14676 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
14677 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
14678 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
14679 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
14680 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
14681 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
14682 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
14683 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
14684 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
14685 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
14688 C...Optionally fix up x and Q2 definitions for leptoproduction.
14690 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
14691 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
14692 IF(IDISXQ.EQ.1) THEN
14694 C...Find where incoming and outgoing leptons/partons are sitting.
14696 IF(MINT(42).EQ.1) LESD=2
14697 LPIN=MINT(83)+3-LESD
14699 LQIN=MINT(84)+3-LESD
14700 LEOUT=MINT(84)+2+LESD
14701 LQOUT=MINT(84)+5-LESD
14702 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
14703 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
14705 DO 140 I=MINT(84)+5,N
14706 IF(K(I,2).EQ.94) THEN
14713 IF(LESD.EQ.1) LQBG=IPU2
14715 C...Calculate actual and wanted momentum transfer.
14718 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
14719 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
14720 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
14721 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
14722 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
14723 P(N+1,1)=FAC*P(LEOUT,1)
14724 P(N+1,2)=FAC*P(LEOUT,2)
14725 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
14726 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
14727 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
14730 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
14731 QNEW(J)=P(LEIN,J)-P(N+1,J)
14734 C...Boost outgoing electron and daughters.
14735 IF(LSCMS.EQ.0) THEN
14737 P(LEOUT,J)=P(N+1,J)
14741 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
14743 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
14745 DBE(J)=PINV*P(N+2,J)
14749 190 IORIG=K(IORIG,3)
14750 IF(IORIG.GT.LEOUT) GOTO 190
14751 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
14752 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
14756 C...Copy shower initiator and all outgoing partons.
14760 P(NCOP,J)=P(LQBG,J)
14762 DO 240 I=MINT(84)+1,N
14764 IF(K(I,1).GT.10) GOTO 240
14765 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
14769 220 IORIG=K(IORIG,3)
14770 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
14772 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
14785 C...Calculate relative rescaling factors.
14789 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
14792 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
14795 C...Transfer extra three-momentum of current.
14798 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
14800 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14803 C...Iterate change of initiator momentum to get energy right.
14806 PEEX=-P(N+1,4)-QNEW(4)
14807 PEMV=-P(N+1,3)/P(N+1,4)
14810 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
14812 IF(ABS(PEMV).LT.1D-10) THEN
14814 MINT(57)=MINT(57)+1
14818 P(N+1,3)=P(N+1,3)+PZCH
14819 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)
14821 P(I,3)=P(I,3)+V(I,1)*PZCH
14822 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
14824 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
14826 C...Modify momenta in event record.
14827 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
14828 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
14829 IF(ABS(HBE).GE.1D0) THEN
14831 MINT(57)=MINT(57)+1
14835 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
14844 C...Check minimum invariant mass of remnant system(s).
14845 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
14846 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
14847 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
14848 PMIN(0)=SQRT(PMS(0))
14850 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
14851 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
14853 IF(MINT(44+JT).EQ.1) GOTO 340
14854 MINT(105)=MINT(102+JT)
14855 MINT(109)=MINT(106+JT)
14856 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
14857 IF(MINT(51).NE.0) THEN
14858 MINT(57)=MINT(57)+1
14861 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
14862 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
14863 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
14864 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
14865 & P(MINT(83)+JT+2,2)**2)
14867 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
14868 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
14871 MINT(57)=MINT(57)+1
14875 C...Loop over two remnants; skip if none there.
14879 IF(MINT(44+JT).EQ.1) GOTO 410
14880 IF(JT.EQ.1) IPU=IPU1
14881 IF(JT.EQ.2) IPU=IPU2
14883 C...Store first remnant parton.
14895 P(I,5)=PYMASS(K(I,2))
14897 C...First parton colour connections and kinematics.
14898 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
14901 K(I,4)=MSTU(5)*IPU+IPU
14902 K(I,5)=MSTU(5)*IPU+IPU
14903 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14904 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14905 ELSEIF(KCOL.NE.0) THEN
14907 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
14909 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14911 IF(KFLCH(JT).EQ.0) THEN
14912 P(I,1)=-P(MINT(83)+JT+2,1)
14913 P(I,2)=-P(MINT(83)+JT+2,2)
14914 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14915 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
14919 C...When extra remnant parton or hadron: store extra remnant.
14931 P(I,5)=PYMASS(K(I,2))
14933 C...Find parton colour connections of extra remnant.
14934 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
14937 K(I,4)=MSTU(5)*IPU+IPU
14938 K(I,5)=MSTU(5)*IPU+IPU
14939 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
14940 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
14941 ELSEIF(KCOL.NE.0) THEN
14943 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
14945 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
14948 C...Relative transverse momentum when two remnants.
14951 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
14952 IF(IABS(MINT(10+JT)).LT.20) THEN
14956 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
14957 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
14959 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
14960 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
14961 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
14962 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
14964 C...Meson or baryon; photon as meson. For splitup below.
14966 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
14968 C***Relative distribution for electron into two electrons. Temporary!
14969 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
14973 C...Relative distribution of electron energy into electron plus parton.
14974 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
14977 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
14979 C...Relative distribution of energy for particle into two jets.
14980 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
14981 CHIK=PARP(92+2*IMB)
14982 IF(MSTP(92).LE.1) THEN
14983 IF(IMB.EQ.1) CHI(JT)=PYR(0)
14984 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
14985 ELSEIF(MSTP(92).EQ.2) THEN
14986 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
14987 ELSEIF(MSTP(92).EQ.3) THEN
14988 CUT=2D0*0.3D0/VINT(1)
14989 380 CHI(JT)=PYR(0)**2
14990 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
14991 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
14992 ELSEIF(MSTP(92).EQ.4) THEN
14993 CUT=2D0*0.3D0/VINT(1)
14994 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
14995 390 CHIR=CUT*CUTR**PYR(0)
14996 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
14997 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
14999 CUT=2D0*0.3D0/VINT(1)
15000 CUTA=CUT**(1D0-PARP(98))
15001 CUTB=(1D0+CUT)**(1D0-PARP(98))
15002 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
15003 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
15004 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
15007 C...Relative distribution of energy for particle into jet plus particle.
15009 IF(MSTP(94).LE.1) THEN
15010 IF(IMB.EQ.1) CHI(JT)=PYR(0)
15011 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
15012 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
15013 ELSEIF(MSTP(94).EQ.2) THEN
15014 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
15015 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
15016 ELSEIF(MSTP(94).EQ.3) THEN
15017 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
15020 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
15025 C...Construct total transverse mass; reject if too large.
15026 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
15027 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
15028 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
15029 IF(LOOP.LT.100) THEN
15033 MINT(57)=MINT(57)+1
15037 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
15038 VINT(158+JT)=CHI(JT)
15040 C...Subdivide longitudinal momentum according to value selected above.
15041 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
15042 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
15043 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
15044 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
15045 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
15050 C...Check if longitudinal boosts needed - if so pick two systems.
15051 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
15052 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
15053 IF(PDEV.LE.1D-6*VINT(1)) RETURN
15054 IF(ISN(1).EQ.0) THEN
15057 ELSEIF(ISN(2).EQ.0) THEN
15060 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
15063 ELSEIF(VINT(143).GT.0.2D0) THEN
15066 ELSEIF(VINT(144).GT.0.2D0) THEN
15069 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
15078 C...E+-pL wanted for system to be modified.
15079 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
15083 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
15084 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
15087 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
15088 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
15089 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
15090 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
15094 DO 450 I=MINT(84)+1,NS
15095 IF(K(I,1).GT.10) GOTO 450
15098 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
15100 IF(IORIG.GT.LPIN) GOTO 430
15101 IF(INCL.EQ.0) GOTO 450
15103 PSYS(0,J)=PSYS(0,J)+P(I,J)
15106 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
15107 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
15108 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
15111 C...Construct longitudinal boosts.
15115 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
15116 IF(DSQLAM.LE.1D-6*DPMTB) THEN
15118 MINT(57)=MINT(57)+1
15121 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
15122 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
15123 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
15124 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
15125 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
15126 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
15127 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
15129 C...Perform longitudinal boosts.
15130 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
15132 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
15133 ELSEIF(IR.EQ.1) THEN
15134 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
15135 ELSEIF(IDISXQ.EQ.1) THEN
15139 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
15141 IF(IORIG.GT.LPIN) GOTO 460
15142 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
15145 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
15147 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
15149 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
15150 ELSEIF(IL.EQ.2) THEN
15151 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
15152 ELSEIF(IDISXQ.EQ.1) THEN
15156 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
15158 IF(IORIG.GT.LPIN) GOTO 480
15159 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
15162 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
15165 C...Final check that energy-momentum conservation worked.
15168 DO 500 I=MINT(84)+1,N
15169 IF(K(I,1).GT.10) GOTO 500
15173 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
15174 IF(PDEV.GT.1D-4*VINT(1)) THEN
15176 MINT(57)=MINT(57)+1
15180 C...Calculate rotation and boost from overall CM frame to
15181 C...hadronic CM frame in leptoproduction.
15183 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
15186 IF(MINT(42).EQ.1) LESD=2
15187 LPIN=MINT(83)+3-LESD
15189 C...Sum upp momenta of everything not lepton or photon to define boost.
15194 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
15195 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
15196 IF(K(I,2).EQ.22) GOTO 530
15198 PSUM(J)=PSUM(J)+P(I,J)
15201 VINT(223)=-PSUM(1)/PSUM(4)
15202 VINT(224)=-PSUM(2)/PSUM(4)
15203 VINT(225)=-PSUM(3)/PSUM(4)
15205 C...Boost incoming hadron to hadronic CM frame to determine rotations.
15211 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
15212 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
15213 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
15215 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
15217 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
15224 C*********************************************************************
15227 C...Handles diffractive and elastic scattering.
15231 C...Double precision and integer declarations.
15232 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15233 IMPLICIT INTEGER(I-N)
15234 INTEGER PYK,PYCHGE,PYCOMP
15236 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15237 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15238 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15239 COMMON/PYINT1/MINT(400),VINT(400)
15240 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
15242 C...Reset K, P and V vectors. Store incoming particles.
15243 DO 110 JT=1,MSTP(126)+10
15263 P(I,J)=VINT(285+5*JT+J)
15268 C...Subprocess; kinematics.
15269 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
15270 PZ=SQRT(SQLAM)/(2D0*VINT(1))
15273 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
15276 C...Elastically scattered particle. (Except elastic GVMD states.)
15277 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
15278 & MINT(106+JT).NE.3)) THEN
15283 P(N,3)=PZ*(-1)**(JT+1)
15285 P(N,5)=SQRT(VINT(62+JT))
15287 C...Decay rho from elastic scattering of gamma with sin**2(theta)
15288 C...distribution of decay products (in rho rest frame).
15289 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
15291 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
15295 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
15296 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
15297 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
15298 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
15299 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
15300 140 CTHE=2D0*PYR(0)-1D0
15301 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
15302 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
15304 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
15307 C...Diffracted particle: low-mass system to two particles.
15308 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
15314 PMMAS=SQRT(VINT(62+JT))
15317 IF(NTRY.LT.20) THEN
15318 MINT(105)=MINT(102+JT)
15319 MINT(109)=MINT(106+JT)
15320 CALL PYSPLI(KFH,21,KFL1,KFL2)
15321 CALL PYKFDI(KFL1,0,KFL3,KF1)
15322 IF(KF1.EQ.0) GOTO 150
15323 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
15324 IF(KF2.EQ.0) GOTO 150
15331 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
15336 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
15337 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
15340 P(N-1,4)=SQRT(PM1**2+PZP**2)
15341 P(N,4)=SQRT(PM2**2+PZP**2)
15342 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
15344 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
15345 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
15347 C...Diffracted particle: valence quark kicked out.
15348 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
15355 MINT(105)=MINT(102+JT)
15356 MINT(109)=MINT(106+JT)
15357 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
15358 P(N-1,5)=PYMASS(K(N-1,2))
15359 P(N,5)=PYMASS(K(N,2))
15360 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
15361 & 4D0*P(N-1,5)**2*P(N,5)**2
15362 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
15363 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
15364 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
15365 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
15366 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
15368 C...Diffracted particle: gluon kicked out.
15377 MINT(105)=MINT(102+JT)
15378 MINT(109)=MINT(106+JT)
15379 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
15381 P(N-2,5)=PYMASS(K(N-2,2))
15383 P(N,5)=PYMASS(K(N,2))
15384 C...Energy distribution for particle into two jets.
15386 IF(MOD(KFH/1000,10).NE.0) IMB=2
15387 CHIK=PARP(92+2*IMB)
15388 IF(MSTP(92).LE.1) THEN
15389 IF(IMB.EQ.1) CHI=PYR(0)
15390 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15391 ELSEIF(MSTP(92).EQ.2) THEN
15392 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
15393 ELSEIF(MSTP(92).EQ.3) THEN
15394 CUT=2D0*0.3D0/VINT(1)
15396 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
15398 ELSEIF(MSTP(92).EQ.4) THEN
15399 CUT=2D0*0.3D0/VINT(1)
15400 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
15401 180 CHIR=CUT*CUTR**PYR(0)
15402 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
15403 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
15405 CUT=2D0*0.3D0/VINT(1)
15406 CUTA=CUT**(1D0-PARP(98))
15407 CUTB=(1D0+CUT)**(1D0-PARP(98))
15408 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
15409 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
15410 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
15412 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
15413 & VINT(62+JT)) GOTO 160
15414 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
15415 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
15416 & (2D0*VINT(62+JT))
15417 PEI=SQRT(PZI**2+SQM)
15418 PQQP=(1D0-CHI)*(PEI+PZI)
15419 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
15420 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
15421 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
15422 P(N-1,3)=P(N-1,4)*(-1)**JT
15423 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
15424 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
15427 C...Documentation lines.
15429 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
15430 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
15431 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
15433 P(I+2,3)=PZ*(-1)**(JT+1)
15435 P(I+2,5)=SQRT(VINT(62+JT))
15438 C...Rotate outgoing partons/particles using cos(theta).
15439 IF(VINT(23).LT.0.9D0) THEN
15440 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
15442 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
15448 C*********************************************************************
15451 C...Set up a DIS process as gamma* + f -> f, with beam remnant
15452 C...and showering added consecutively. Photon flux by the PYGAGA
15453 C...routine (if at all).
15457 C...Double precision and integer declarations.
15458 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15459 IMPLICIT INTEGER(I-N)
15460 INTEGER PYK,PYCHGE,PYCOMP
15461 C...Parameter statement to help give large particle numbers.
15462 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
15463 &KEXCIT=4000000,KDIMEN=5000000)
15465 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15466 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15467 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15468 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15469 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15470 COMMON/PYINT1/MINT(400),VINT(400)
15471 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
15475 C...Choice of subprocess, number of documentation lines
15483 IF(MINT(107).EQ.4) ISIDE=2
15485 C...Reset K, P and V vectors. Store incoming particles
15486 DO 110 JT=1,MSTP(126)+20
15499 P(I,J)=VINT(285+5*JT+J)
15504 C...Store incoming partons in hadronic CM-frame
15509 K(I,3)=MINT(83)+2+JT
15511 IF(MINT(15).EQ.22) THEN
15512 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
15513 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
15514 P(MINT(84)+1,5)=-SQRT(VINT(307))
15515 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
15516 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
15520 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
15521 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
15522 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
15523 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
15524 P(MINT(84)+1,5)=-SQRT(VINT(308))
15528 SIDESG=(-1D0)**(ISIDE-1)
15530 C...Copy incoming partons to documentation lines.
15541 C...Second copy for partons before ISR shower, since no such.
15551 C...Define initial partons.
15554 IF(NTRY.GT.100) THEN
15559 C...Scattered quark in hadronic CM frame.
15564 P(IPU3,5)=PYMASS(KFRES)
15565 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
15566 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
15570 K(I,3)=MINT(83)+4+ISIDE
15578 C...No primordial kT, or chosen according to truncated Gaussian or
15579 C...exponential, or (for photon) predetermined or power law.
15580 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
15581 IF(MSTP(91).LE.0) THEN
15583 ELSEIF(MSTP(91).EQ.1) THEN
15584 PT=PARP(91)*SQRT(-LOG(PYR(0)))
15588 PT=-PARP(92)*LOG(RPT1*RPT2)
15590 IF(PT.GT.PARP(93)) GOTO 190
15591 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
15592 PTA=SQRT(VINT(282+ISIDE))
15594 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
15595 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
15596 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
15599 PTB=-PARP(99)*LOG(RPT1*RPT2)
15601 IF(PTB.GT.PARP(100)) GOTO 190
15602 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
15603 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
15604 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
15605 IF(MSTP(93).LE.0) THEN
15607 ELSEIF(MSTP(93).EQ.1) THEN
15608 PT=PARP(99)*SQRT(-LOG(PYR(0)))
15609 ELSEIF(MSTP(93).EQ.2) THEN
15612 PT=-PARP(99)*LOG(RPT1*RPT2)
15613 ELSEIF(MSTP(93).EQ.3) THEN
15616 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
15620 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
15621 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
15623 IF(PT.GT.PARP(100)) GOTO 190
15629 P(IPU3,1)=PT*COS(PHI)
15630 P(IPU3,2)=PT*SIN(PHI)
15631 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
15632 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
15633 PCP=P(IPU3,4)+ABS(P(IPU3,3))
15635 C...Find one or two beam remnants.
15636 MINT(105)=MINT(102+ISIDE)
15637 MINT(109)=MINT(106+ISIDE)
15638 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
15639 IF(MINT(51).NE.0) THEN
15644 C...Store first remnant parton, with colour info and kinematics.
15648 K(I,3)=MINT(83)+ISIDE
15649 P(I,5)=PYMASS(K(I,2))
15650 KCOL=KCHG(PYCOMP(KFLSP),2)
15653 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
15654 K(I,KFLS+3)=MSTU(5)*IPU3
15655 K(IPU3,6-KFLS)=MSTU(5)*I
15658 IF(KFLCH.EQ.0) THEN
15661 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15663 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
15664 PRP=P(I,4)+ABS(P(I,3))
15666 C...When extra remnant parton or hadron: store extra remnant.
15671 K(I,3)=MINT(83)+ISIDE
15672 P(I,5)=PYMASS(K(I,2))
15673 KCOL=KCHG(PYCOMP(KFLCH),2)
15676 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
15677 K(I,KFLS+3)=MSTU(5)*IPU3
15678 K(IPU3,6-KFLS)=MSTU(5)*I
15682 C...Relative transverse momentum when two remnants.
15685 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
15686 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
15687 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
15688 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
15689 P(I,1)=-P(IPU3,1)-P(I-1,1)
15690 P(I,2)=-P(IPU3,2)-P(I-1,2)
15691 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
15693 C...Relative distribution of energy for particle into jet plus particle.
15695 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
15696 IF(MSTP(94).LE.1) THEN
15697 IF(IMB.EQ.1) CHI=PYR(0)
15698 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
15699 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15700 ELSEIF(MSTP(94).EQ.2) THEN
15701 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
15702 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
15703 ELSEIF(MSTP(94).EQ.3) THEN
15704 CALL PYZDIS(1,0,PMS(4),ZZ)
15707 CALL PYZDIS(1000,0,PMS(4),ZZ)
15711 C...Construct total transverse mass; reject if too large.
15712 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
15713 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
15714 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
15715 IF(LOOP.LT.10) GOTO 200
15718 VINT(158+ISIDE)=CHI
15720 C...Subdivide longitudinal momentum according to value selected above.
15721 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
15723 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
15724 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
15726 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
15727 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
15731 C...Boost current and remnant systems to correct frame.
15732 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
15733 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
15734 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
15736 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
15738 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
15739 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
15740 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
15741 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
15743 C...Let current quark shower; recoil but no showering by colour partner.
15744 QMAX=2D0*SQRT(VINT(309-ISIDE))
15749 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
15756 C*********************************************************************
15759 C...Handles the documentation of the process in MSTI and PARI,
15760 C...and also computes cross-sections based on accumulated statistics.
15764 C...Double precision and integer declarations.
15765 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15766 IMPLICIT INTEGER(I-N)
15767 INTEGER PYK,PYCHGE,PYCOMP
15769 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15770 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15771 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15772 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15773 COMMON/PYINT1/MINT(400),VINT(400)
15774 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15775 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15776 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
15779 C...Calculate Monte Carlo estimates of cross-sections.
15781 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
15782 NGEN(0,3)=NGEN(0,3)+1
15785 IF(I.EQ.96.OR.I.EQ.97) THEN
15787 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
15788 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
15789 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
15790 & DBLE(NGEN(96,2)))
15791 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
15792 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
15793 & DBLE(NGEN(96,2)))
15794 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
15796 ELSEIF(NGEN(I,2).EQ.0) THEN
15797 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
15800 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
15803 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
15806 C...Rescale to known low-pT cross-section for standard QCD processes.
15807 IF(MSUB(95).EQ.1) THEN
15808 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
15809 & XSEC(68,3)+XSEC(95,3)
15810 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
15811 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
15813 XSEC(11,3)=FAC*XSEC(11,3)
15814 XSEC(12,3)=FAC*XSEC(12,3)
15815 XSEC(13,3)=FAC*XSEC(13,3)
15816 XSEC(28,3)=FAC*XSEC(28,3)
15817 XSEC(53,3)=FAC*XSEC(53,3)
15818 XSEC(68,3)=FAC*XSEC(68,3)
15819 XSEC(95,3)=FAC*XSEC(95,3)
15820 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
15824 C...Save information for gamma-p and gamma-gamma.
15825 IF(MINT(121).GT.1) THEN
15831 C...Reset information on hard interaction.
15837 C...Copy integer valued information from MINT into MSTI.
15841 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
15843 C...Store cross-section variables in PARI.
15845 PARI(2)=XSEC(0,3)/MINT(5)
15849 VINT(98)=VINT(98)+VINT(100)
15850 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
15852 C...Store kinematics variables in PARI.
15855 IF(ISUB.NE.95) THEN
15863 PARI(35)=PARI(33)-PARI(34)
15870 PARI(42)=2D0*VINT(47)/VINT(1)
15873 C...Store information on scattered partons in PARI.
15874 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
15877 PARI(36+IS)=P(I,3)/VINT(1)
15878 PARI(38+IS)=P(I,4)/VINT(1)
15879 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
15880 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15881 & SQRT(PR),1D20)),P(I,3))
15882 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
15883 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
15884 & SQRT(PR),1D20)),P(I,3))
15885 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
15886 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
15887 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
15891 C...Store sum up transverse and longitudinal momenta.
15892 PARI(65)=2D0*PARI(17)
15893 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
15894 DO 150 I=MSTP(126)+1,N
15895 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
15896 PT=SQRT(P(I,1)**2+P(I,2)**2)
15897 PARI(69)=PARI(69)+PT
15898 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
15899 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
15911 C...Store various other pieces of information into PARI.
15919 C...Store information on lepton -> lepton + gamma in PYGAGA.
15922 PARI(101)=VINT(301)
15923 PARI(102)=VINT(302)
15925 PARI(I)=VINT(I+202)
15928 C...Set information for PYTABU.
15929 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
15932 ELSEIF(ISET(ISUB).EQ.5) THEN
15943 C*********************************************************************
15946 C...Performs transformations between different coordinate frames.
15948 SUBROUTINE PYFRAM(IFRAME)
15950 C...Double precision and integer declarations.
15951 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15952 IMPLICIT INTEGER(I-N)
15953 INTEGER PYK,PYCHGE,PYCOMP
15955 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15956 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15957 COMMON/PYINT1/MINT(400),VINT(400)
15958 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
15960 C...Check that transformation can and should be done.
15961 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
15962 &MINT(91).EQ.1)) THEN
15963 IF(IFRAME.EQ.MINT(6)) RETURN
15965 WRITE(MSTU(11),5000) IFRAME,MINT(6)
15969 IF(MINT(6).EQ.1) THEN
15970 C...Transform from fixed target or user specified frame to
15971 C...overall CM frame.
15972 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
15973 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
15974 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
15975 ELSEIF(MINT(6).EQ.3) THEN
15976 C...Transform from hadronic CM frame in DIS to overall CM frame.
15977 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
15981 IF(IFRAME.EQ.1) THEN
15982 C...Transform from overall CM frame to fixed target or user specified
15984 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
15985 ELSEIF(IFRAME.EQ.3) THEN
15986 C...Transform from overall CM frame to hadronic CM frame in DIS.
15987 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
15988 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
15989 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
15992 C...Set information about new frame.
15996 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
15997 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
16003 C*********************************************************************
16006 C...Calculates full and partial widths of resonances.
16008 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
16010 C...Double precision and integer declarations.
16011 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16012 IMPLICIT INTEGER(I-N)
16013 INTEGER PYK,PYCHGE,PYCOMP
16014 C...Parameter statement to help give large particle numbers.
16015 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16016 &KEXCIT=4000000,KDIMEN=5000000)
16018 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16019 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16020 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16021 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16022 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16023 COMMON/PYINT1/MINT(400),VINT(400)
16024 COMMON/PYINT4/MWID(500),WIDS(500,5)
16025 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
16026 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
16027 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
16028 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
16029 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
16030 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/
16031 C...Local arrays and saved variables.
16032 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
16033 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
16034 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
16035 SAVE MOFSV,WIDWSV,WID2SV
16036 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
16038 C...Compressed code and sign; mass.
16045 C...Reset width information.
16046 DO 110 I=0,MDCY(KC,3)
16053 C...Allow for fudge factor to rescale resonance width.
16055 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
16056 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
16057 IF(MSTP(110).EQ.KFLA) THEN
16059 ELSEIF(MSTP(110).EQ.-1) THEN
16060 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
16061 ELSEIF(MSTP(110).EQ.-2) THEN
16066 C...Not to be treated as a resonance: return.
16067 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
16076 C...Treatment as a resonance based on tabulated branching ratios.
16077 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
16078 C...Loop over possible decay channels; skip irrelevant ones.
16079 DO 120 I=1,MDCY(KC,3)
16081 IF(MDME(IDC,1).LT.0) GOTO 120
16083 C...Read out decay products and nominal masses.
16086 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
16090 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
16096 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
16100 C...Naive partial width and alternative threshold factors.
16101 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
16102 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
16103 & PM1+PM2+PM3.GE.SHR) THEN
16105 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
16106 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
16107 & 4D0*PM1**2*PM2**2))/SH
16108 ELSEIF(MDME(IDC,2).EQ.52) THEN
16109 PMA=MAX(PM1,PM2,PM3)
16110 PMC=MIN(PM1,PM2,PM3)
16111 PMB=PM1+PM2+PM3-PMA-PMC
16112 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
16117 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
16118 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
16119 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
16120 & ((SHR-PMA)**2-(PMB+PMC)**2)*
16121 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
16122 & ((1D0-PMBCN)*PMBCN*SH)
16123 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
16124 WDTP(I)=WDTP(I)*SQRT(
16125 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
16126 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
16127 ELSEIF(MDME(IDC,2).EQ.53) THEN
16128 PMA=MAX(PM1,PM2,PM3)
16129 PMC=MIN(PM1,PM2,PM3)
16130 PMB=PM1+PM2+PM3-PMA-PMC
16131 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
16136 FACACT=SQRT(MAX(0D0,
16137 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
16138 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
16139 & ((SHR-PMA)**2-(PMB+PMC)**2)*
16140 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
16141 & ((1D0-PMBCN)*PMBCN*SH)
16142 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
16146 PMBCN=PMBC**2/PMR**2
16147 FACNOM=SQRT(MAX(0D0,
16148 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
16149 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
16150 & ((PMR-PMA)**2-(PMB+PMC)**2)*
16151 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
16152 & ((1D0-PMBCN)*PMBCN*PMR**2)
16153 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
16155 WDTP(I)=FUDGE*WDTP(I)
16156 WDTP(0)=WDTP(0)+WDTP(I)
16158 C...Calculate secondary width (at most two identical/opposite).
16160 IF(MDME(IDC,1).GT.0) THEN
16161 IF(KFD2.EQ.KFD1) THEN
16162 IF(KCHG(KFC1,3).EQ.0) THEN
16164 ELSEIF(KFD1.GT.0) THEN
16170 WID2=WID2*WIDS(KFC3,2)
16171 ELSEIF(KFD3.LT.0) THEN
16172 WID2=WID2*WIDS(KFC3,3)
16174 ELSEIF(KFD2.EQ.-KFD1) THEN
16177 WID2=WID2*WIDS(KFC3,2)
16178 ELSEIF(KFD3.LT.0) THEN
16179 WID2=WID2*WIDS(KFC3,3)
16181 ELSEIF(KFD3.EQ.KFD1) THEN
16182 IF(KCHG(KFC1,3).EQ.0) THEN
16184 ELSEIF(KFD1.GT.0) THEN
16190 WID2=WID2*WIDS(KFC2,2)
16191 ELSEIF(KFD2.LT.0) THEN
16192 WID2=WID2*WIDS(KFC2,3)
16194 ELSEIF(KFD3.EQ.-KFD1) THEN
16197 WID2=WID2*WIDS(KFC2,2)
16198 ELSEIF(KFD2.LT.0) THEN
16199 WID2=WID2*WIDS(KFC2,3)
16201 ELSEIF(KFD3.EQ.KFD2) THEN
16202 IF(KCHG(KFC2,3).EQ.0) THEN
16204 ELSEIF(KFD2.GT.0) THEN
16210 WID2=WID2*WIDS(KFC1,2)
16211 ELSEIF(KFD1.LT.0) THEN
16212 WID2=WID2*WIDS(KFC1,3)
16214 ELSEIF(KFD3.EQ.-KFD2) THEN
16217 WID2=WID2*WIDS(KFC1,2)
16218 ELSEIF(KFD1.LT.0) THEN
16219 WID2=WID2*WIDS(KFC1,3)
16228 WID2=WID2*WIDS(KFC2,2)
16230 WID2=WID2*WIDS(KFC2,3)
16233 WID2=WID2*WIDS(KFC3,2)
16234 ELSEIF(KFD3.LT.0) THEN
16235 WID2=WID2*WIDS(KFC3,3)
16239 C...Store effective widths according to case.
16240 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16241 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16242 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16243 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16253 C...Here begins detailed dynamical calculation of resonance widths.
16254 C...Shared treatment of Higgs states.
16257 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
16262 C...Common electroweak and strong constants.
16265 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
16268 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
16270 RADC=1D0+AS/PARU(1)
16274 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16275 RADCT=1D0-2.5D0*AS/PARU(1)
16276 DO 140 I=1,MDCY(KC,3)
16278 IF(MDME(IDC,1).LT.0) GOTO 140
16279 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16280 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16281 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
16283 IF(I.GE.4.AND.I.LE.7) THEN
16284 C...t -> W + q; including approximate QCD correction factor.
16285 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
16286 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16287 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16290 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
16293 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
16295 ELSEIF(I.EQ.9) THEN
16297 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16298 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16300 IF(KFLR.LT.0) WID2=WIDS(37,3)
16302 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
16303 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
16306 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
16309 KFC1=PYCOMP(KFDP(IDC,1))
16310 KFC2=PYCOMP(KFDP(IDC,2))
16311 PMNCHI=PMAS(KFC1,1)
16312 PMSTOP=PMAS(KFC2,1)
16313 IF(SHR.GT.PMNCHI+PMSTOP) THEN
16316 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
16318 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
16319 AR=-ET*ZMIXC(IZ,1)*TANW
16320 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
16322 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
16323 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
16324 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
16325 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
16326 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
16327 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
16328 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
16330 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
16332 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
16335 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
16337 KFC1=PYCOMP(KFDP(IDC,1))
16338 KFC2=PYCOMP(KFDP(IDC,2))
16339 PMNCHI=PMAS(KFC1,1)
16340 PMSTOP=PMAS(KFC2,1)
16341 IF(SHR.GT.PMNCHI+PMSTOP) THEN
16344 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
16345 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
16346 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
16347 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
16349 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
16351 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
16354 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
16355 C...t -> ~gravitino + ~t
16357 KFC1=PYCOMP(KFDP(IDC,1))
16358 XMGR2=PMAS(KFC1,1)**2
16359 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
16360 KFC2=PYCOMP(KFDP(IDC,2))
16362 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
16365 WDTP(I)=FUDGE*WDTP(I)
16366 WDTP(0)=WDTP(0)+WDTP(I)
16367 IF(MDME(IDC,1).GT.0) THEN
16368 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16369 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16370 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16371 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16375 ELSEIF(KFLA.EQ.7) THEN
16377 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16378 DO 150 I=1,MDCY(KC,3)
16380 IF(MDME(IDC,1).LT.0) GOTO 150
16381 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16382 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16383 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
16385 IF(I.GE.4.AND.I.LE.7) THEN
16387 WDTP(I)=FAC*VCKM(I-3,4)*
16388 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16389 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16392 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
16393 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
16396 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
16397 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
16400 IF(KFLR.LT.0) WID2=WIDS(24,2)
16401 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16403 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16404 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16407 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
16410 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
16413 WDTP(I)=FUDGE*WDTP(I)
16414 WDTP(0)=WDTP(0)+WDTP(I)
16415 IF(MDME(IDC,1).GT.0) THEN
16416 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16417 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16418 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16419 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16423 ELSEIF(KFLA.EQ.8) THEN
16425 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16426 DO 160 I=1,MDCY(KC,3)
16428 IF(MDME(IDC,1).LT.0) GOTO 160
16429 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16430 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16431 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
16433 IF(I.GE.4.AND.I.LE.7) THEN
16435 WDTP(I)=FAC*VCKM(4,I-3)*
16436 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16437 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16440 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
16443 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
16445 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
16447 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16448 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16451 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
16454 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
16457 WDTP(I)=FUDGE*WDTP(I)
16458 WDTP(0)=WDTP(0)+WDTP(I)
16459 IF(MDME(IDC,1).GT.0) THEN
16460 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16461 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16462 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16463 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16467 ELSEIF(KFLA.EQ.17) THEN
16469 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16470 DO 170 I=1,MDCY(KC,3)
16472 IF(MDME(IDC,1).LT.0) GOTO 170
16473 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16474 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16475 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
16478 C...tau' -> W + nu'_tau.
16479 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16480 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16483 WID2=WID2*WIDS(18,2)
16486 WID2=WID2*WIDS(18,3)
16488 ELSEIF(I.EQ.5) THEN
16489 C...tau' -> H + nu'_tau.
16490 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16491 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
16494 WID2=WID2*WIDS(18,2)
16497 WID2=WID2*WIDS(18,3)
16500 WDTP(I)=FUDGE*WDTP(I)
16501 WDTP(0)=WDTP(0)+WDTP(I)
16502 IF(MDME(IDC,1).GT.0) THEN
16503 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16504 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16505 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16506 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16510 ELSEIF(KFLA.EQ.18) THEN
16511 C...nu'_tau neutrino.
16512 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
16513 DO 180 I=1,MDCY(KC,3)
16515 IF(MDME(IDC,1).LT.0) GOTO 180
16516 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
16517 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
16518 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
16521 C...nu'_tau -> W + tau'.
16522 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16523 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
16526 WID2=WID2*WIDS(17,2)
16529 WID2=WID2*WIDS(17,3)
16531 ELSEIF(I.EQ.3) THEN
16532 C...nu'_tau -> H + tau'.
16533 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
16534 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
16537 WID2=WID2*WIDS(17,2)
16540 WID2=WID2*WIDS(17,3)
16543 WDTP(I)=FUDGE*WDTP(I)
16544 WDTP(0)=WDTP(0)+WDTP(I)
16545 IF(MDME(IDC,1).GT.0) THEN
16546 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16547 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16548 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16549 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16553 ELSEIF(KFLA.EQ.21) THEN
16555 C***Note that widths are not given in dimensional quantities here.
16556 DO 190 I=1,MDCY(KC,3)
16558 IF(MDME(IDC,1).LT.0) GOTO 190
16559 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16560 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16561 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
16564 C...QCD -> q + qbar
16565 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16566 IF(I.EQ.6) WID2=WIDS(6,1)
16567 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16569 WDTP(I)=FUDGE*WDTP(I)
16570 WDTP(0)=WDTP(0)+WDTP(I)
16571 IF(MDME(IDC,1).GT.0) THEN
16572 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16573 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16574 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16575 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16579 ELSEIF(KFLA.EQ.22) THEN
16581 C***Note that widths are not given in dimensional quantities here.
16582 DO 200 I=1,MDCY(KC,3)
16584 IF(MDME(IDC,1).LT.0) GOTO 200
16585 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16586 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16587 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
16590 C...QED -> q + qbar.
16593 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16594 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16595 IF(I.EQ.6) WID2=WIDS(6,1)
16596 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16597 ELSEIF(I.LE.12) THEN
16598 C...QED -> l+ + l-.
16599 EF=KCHG(9+2*(I-8),1)/3D0
16600 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
16601 IF(I.EQ.12) WID2=WIDS(17,1)
16603 WDTP(I)=FUDGE*WDTP(I)
16604 WDTP(0)=WDTP(0)+WDTP(I)
16605 IF(MDME(IDC,1).GT.0) THEN
16606 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16607 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16608 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16609 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16613 ELSEIF(KFLA.EQ.23) THEN
16616 XWC=1D0/(16D0*XW*XW1)
16617 FAC=(AEM*XWC/3D0)*SHR
16619 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
16624 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16626 IF(KFI.GT.20) KFI=IABS(MINT(16))
16632 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
16633 IF(MSTP(43).EQ.3) VINT(112)=
16634 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
16635 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16636 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
16638 DO 220 I=1,MDCY(KC,3)
16640 IF(MDME(IDC,1).LT.0) GOTO 220
16641 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16642 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16643 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
16648 AF=SIGN(1D0,EF+0.1D0)
16651 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
16652 IF(I.EQ.6) WID2=WIDS(6,1)
16653 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16654 ELSEIF(I.LE.16) THEN
16655 C...Z0 -> l+ + l-, nu + nubar
16657 AF=SIGN(1D0,EF+0.1D0)
16660 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
16662 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16663 IF(ICASE.EQ.1) THEN
16664 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
16666 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
16667 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
16668 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
16669 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
16670 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16671 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
16672 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16673 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
16675 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
16676 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
16677 IF(MDME(IDC,1).GT.0) THEN
16678 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
16679 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
16680 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16681 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
16682 & WDTE(I,MDME(IDC,1))
16683 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16684 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16686 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
16687 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
16688 & VINT(111)+FGGF*WID2
16689 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
16690 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
16691 & VINT(114)+FZZF*WID2
16695 IF(MINT(61).GE.1) ICASE=3-ICASE
16696 IF(ICASE.EQ.2) GOTO 210
16698 ELSEIF(KFLA.EQ.24) THEN
16700 FAC=(AEM/(24D0*XW))*SHR
16701 DO 230 I=1,MDCY(KC,3)
16703 IF(MDME(IDC,1).LT.0) GOTO 230
16704 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
16705 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
16706 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
16709 C...W+/- -> q + qbar'
16710 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
16712 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
16713 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
16714 IF(I.GE.13) WID2=WID2*WIDS(7,3)
16716 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
16717 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
16718 IF(I.GE.13) WID2=WID2*WIDS(7,2)
16720 ELSEIF(I.LE.20) THEN
16721 C...W+/- -> l+/- + nu
16724 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
16726 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
16729 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
16730 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
16731 WDTP(I)=FUDGE*WDTP(I)
16732 WDTP(0)=WDTP(0)+WDTP(I)
16733 IF(MDME(IDC,1).GT.0) THEN
16734 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
16735 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
16736 WDTE(I,0)=WDTE(I,MDME(IDC,1))
16737 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
16741 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
16742 C...h0 (or H0, or A0):
16744 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
16745 DO 270 I=1,MDCY(KFHIGG,3)
16746 IDC=I+MDCY(KFHIGG,2)-1
16747 IF(MDME(IDC,1).LT.0) GOTO 270
16748 KFC1=PYCOMP(KFDP(IDC,1))
16749 KFC2=PYCOMP(KFDP(IDC,2))
16750 RM1=PMAS(KFC1,1)**2/SH
16751 RM2=PMAS(KFC2,1)**2/SH
16752 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
16758 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
16759 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
16760 C...A0 behaves like beta, ho and H0 like beta**3.
16761 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16762 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16763 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
16764 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
16765 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
16766 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
16767 IF(IHIGG.NE.3) THEN
16768 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
16769 & PARU(151+10*IHIGG))**2
16773 IF(I.EQ.6) WID2=WIDS(6,1)
16774 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
16775 ELSEIF(I.LE.12) THEN
16777 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
16778 C...A0 behaves like beta, ho and H0 like beta**3.
16779 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
16780 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
16781 & PARU(153+10*IHIGG)**2
16782 IF(I.EQ.12) WID2=WIDS(17,1)
16784 ELSEIF(I.EQ.13) THEN
16785 C...h0 -> g + g; quark loop contribution only
16788 DO 240 J=1,2*MSTP(1)
16789 EPS=(2D0*PMAS(J,1))**2/SH
16790 C...Loop integral; function of eps=4m^2/shat; different for A0.
16791 IF(EPS.LE.1D0) THEN
16792 IF(EPS.GT.1D-4) THEN
16794 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16796 RLN=LOG(4D0/EPS-2D0)
16798 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16799 PHIIM=0.5D0*PARU(1)*RLN
16801 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16804 IF(IHIGG.LE.2) THEN
16805 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16806 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
16808 ETAREJ=-0.5D0*EPS*PHIRE
16809 ETAIMJ=-0.5D0*EPS*PHIIM
16811 C...Couplings (=1 for standard model Higgs).
16812 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16813 IF(MOD(J,2).EQ.1) THEN
16814 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
16815 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
16817 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
16818 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
16824 ETA2=ETARE**2+ETAIM**2
16825 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
16827 ELSEIF(I.EQ.14) THEN
16828 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
16832 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16834 IF(J.LE.2*MSTP(1)) THEN
16836 EPS=(2D0*PMAS(J,1))**2/SH
16837 ELSEIF(J.LE.3*MSTP(1)) THEN
16838 JL=2*(J-2*MSTP(1))-1
16839 EJ=KCHG(10+JL,1)/3D0
16840 EPS=(2D0*PMAS(10+JL,1))**2/SH
16841 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16842 EPS=(2D0*PMAS(24,1))**2/SH
16844 EPS=(2D0*PMAS(37,1))**2/SH
16846 C...Loop integral; function of eps=4m^2/shat.
16847 IF(EPS.LE.1D0) THEN
16848 IF(EPS.GT.1D-4) THEN
16850 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16852 RLN=LOG(4D0/EPS-2D0)
16854 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16855 PHIIM=0.5D0*PARU(1)*RLN
16857 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16860 IF(J.LE.3*MSTP(1)) THEN
16861 C...Fermion loops: loop integral different for A0; charges.
16862 IF(IHIGG.LE.2) THEN
16863 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
16864 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
16866 PHIPRE=-0.5D0*EPS*PHIRE
16867 PHIPIM=-0.5D0*EPS*PHIIM
16869 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16871 EJH=PARU(151+10*IHIGG)
16872 ELSEIF(J.LE.2*MSTP(1)) THEN
16874 EJH=PARU(152+10*IHIGG)
16877 EJH=PARU(153+10*IHIGG)
16879 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16880 ETAREJ=EJC*EJH*PHIPRE
16881 ETAIMJ=EJC*EJH*PHIPIM
16882 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16883 C...W loops: loop integral and charges.
16884 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
16885 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
16886 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16887 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16888 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16891 C...Charged H loops: loop integral and charges.
16892 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
16893 & PARU(158+10*IHIGG+2*(IHIGG/3))
16894 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
16895 ETAIMJ=-EPS**2*PHIIM*FACHHH
16900 ETA2=ETARE**2+ETAIM**2
16901 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
16903 ELSEIF(I.EQ.15) THEN
16904 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
16908 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
16910 IF(J.LE.2*MSTP(1)) THEN
16912 AJ=SIGN(1D0,EJ+0.1D0)
16914 EPS=(2D0*PMAS(J,1))**2/SH
16915 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
16916 ELSEIF(J.LE.3*MSTP(1)) THEN
16917 JL=2*(J-2*MSTP(1))-1
16918 EJ=KCHG(10+JL,1)/3D0
16919 AJ=SIGN(1D0,EJ+0.1D0)
16921 EPS=(2D0*PMAS(10+JL,1))**2/SH
16922 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
16924 EPS=(2D0*PMAS(24,1))**2/SH
16925 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
16927 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
16928 IF(EPS.LE.1D0) THEN
16930 IF(EPS.GT.1D-4) THEN
16931 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16933 RLN=LOG(4D0/EPS-2D0)
16935 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
16936 PHIIM=0.5D0*PARU(1)*RLN
16937 PSIRE=0.5D0*ROOT*RLN
16938 PSIIM=-0.5D0*ROOT*PARU(1)
16940 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
16942 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
16945 IF(EPSP.LE.1D0) THEN
16946 ROOT=SQRT(1D0-EPSP)
16947 IF(EPSP.GT.1D-4) THEN
16948 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
16950 RLN=LOG(4D0/EPSP-2D0)
16952 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
16953 PHIIMP=0.5D0*PARU(1)*RLN
16954 PSIREP=0.5D0*ROOT*RLN
16955 PSIIMP=-0.5D0*ROOT*PARU(1)
16957 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
16959 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
16962 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
16963 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
16964 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
16965 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
16966 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
16967 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
16968 IF(J.LE.3*MSTP(1)) THEN
16969 C...Fermion loops: loop integral different for A0; charges.
16970 IF(IHIGG.EQ.3) FXYRE=0D0
16971 IF(IHIGG.EQ.3) FXYIM=0D0
16972 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
16974 EJH=PARU(151+10*IHIGG)
16975 ELSEIF(J.LE.2*MSTP(1)) THEN
16977 EJH=PARU(152+10*IHIGG)
16980 EJH=PARU(153+10*IHIGG)
16982 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
16983 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
16984 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
16985 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
16986 C...W loops: loop integral and charges.
16987 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
16988 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
16989 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
16990 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16991 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
16992 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
16995 C...Charged H loops: loop integral and charges.
16996 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
16997 & PARU(158+10*IHIGG+2*(IHIGG/3))
16998 ETAREJ=FACHHH*FXYRE
16999 ETAIMJ=FACHHH*FXYIM
17004 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
17005 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
17008 ELSEIF(I.LE.17) THEN
17009 C...h0 -> Z0 + Z0, W+ + W-
17010 PM1=PMAS(IABS(KFDP(IDC,1)),1)
17011 PG1=PMAS(IABS(KFDP(IDC,1)),2)
17012 IF(MINT(62).GE.1) THEN
17013 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
17014 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
17015 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
17016 MOFSV(IHIGG,I-15)=0
17017 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
17021 MOFSV(IHIGG,I-15)=1
17022 RMAS=SQRT(MAX(0D0,SH))
17023 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
17025 WIDWSV(IHIGG,I-15)=WIDW
17026 WID2SV(IHIGG,I-15)=WID2
17029 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
17030 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
17034 WIDW=WIDWSV(IHIGG,I-15)
17035 WID2=WID2SV(IHIGG,I-15)
17038 WDTP(I)=FAC*WIDW/(2D0*(18-I))
17039 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
17040 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
17041 & PARU(138+I+10*IHIGG)**2
17042 WID2=WID2*WIDS(7+I,1)
17044 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
17045 C...H0 -> Z0 + h0, A0-> Z0 + h0
17046 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
17047 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17048 IF(IHIGG.EQ.2) THEN
17049 WDTP(I)=WDTP(I)*PARU(179)**2
17050 ELSEIF(IHIGG.EQ.3) THEN
17051 WDTP(I)=WDTP(I)*PARU(186)**2
17053 WID2=WIDS(23,2)*WIDS(25,2)
17055 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
17056 C...H0 -> h0 + h0, A0-> h0 + h0
17057 WDTP(I)=FAC*0.25D0*
17058 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
17059 IF(IHIGG.EQ.2) THEN
17060 WDTP(I)=WDTP(I)*PARU(176)**2
17061 ELSEIF(IHIGG.EQ.3) THEN
17062 WDTP(I)=WDTP(I)*PARU(169)**2
17065 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
17066 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
17067 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
17068 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17069 & *PARU(195+IHIGG)**2
17071 WID2=WIDS(24,2)*WIDS(37,3)
17072 ELSEIF(I.EQ.21) THEN
17073 WID2=WIDS(24,3)*WIDS(37,2)
17076 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
17078 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
17079 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*0.0D0
17080 WID2=WIDS(36,2)*WIDS(23,2)
17082 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
17084 WDTP(I)=FAC*0.5D0*PARU(180)**2*
17085 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
17086 WID2=WIDS(25,2)*WIDS(36,2)
17088 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
17090 WDTP(I)=FAC*0.25D0*PARU(177)**2*
17091 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
17096 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
17099 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
17100 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
17101 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
17106 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
17108 IF(KFC2.EQ.KFC1) THEN
17112 IF(KFDP(IDC,1).LT.0) KSGN1=3
17114 IF(KFDP(IDC,2).LT.0) KSGN2=3
17115 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
17118 WDTP(I)=FUDGE*WDTP(I)
17119 WDTP(0)=WDTP(0)+WDTP(I)
17120 IF(MDME(IDC,1).GT.0) THEN
17121 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17122 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17123 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17124 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17128 ELSEIF(KFLA.EQ.32) THEN
17131 XWC=1D0/(16D0*XW*XW1)
17132 FAC=(AEM*XWC/3D0)*SHR
17135 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
17143 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17144 KFAI=IABS(MINT(15))
17145 EI=KCHG(KFAI,1)/3D0
17146 AI=SIGN(1D0,EI+0.1D0)
17149 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
17150 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
17151 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
17152 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
17153 VPI=PARU(119+2*KFAIC)
17154 API=PARU(120+2*KFAIC)
17155 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
17156 VPI=PARJ(178+2*KFAIC)
17157 API=PARJ(179+2*KFAIC)
17159 VPI=PARJ(186+2*KFAIC)
17160 API=PARJ(187+2*KFAIC)
17164 SQMZP=PMAS(32,1)**2
17166 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
17167 & MSTP(44).EQ.7) VINT(111)=1D0
17168 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
17169 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
17170 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
17171 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
17172 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
17173 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
17174 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
17175 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
17176 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
17177 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
17178 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
17180 DO 290 I=1,MDCY(KC,3)
17182 IF(MDME(IDC,1).LT.0) GOTO 290
17183 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17184 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17185 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
17189 C...Z'0 -> q + qbar
17191 AF=SIGN(1D0,EF+0.1D0)
17194 VPF=PARU(123-2*MOD(I,2))
17195 APF=PARU(124-2*MOD(I,2))
17196 ELSEIF(I.LE.4) THEN
17197 VPF=PARJ(182-2*MOD(I,2))
17198 APF=PARJ(183-2*MOD(I,2))
17200 VPF=PARJ(190-2*MOD(I,2))
17201 APF=PARJ(191-2*MOD(I,2))
17204 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
17205 & PYHFTH(SH,SH*RM1,1D0)
17206 IF(I.EQ.6) WID2=WIDS(6,1)
17207 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
17208 ELSEIF(I.LE.16) THEN
17209 C...Z'0 -> l+ + l-, nu + nubar
17211 AF=SIGN(1D0,EF+0.1D0)
17214 VPF=PARU(127-2*MOD(I,2))
17215 APF=PARU(128-2*MOD(I,2))
17216 ELSEIF(I.LE.12) THEN
17217 VPF=PARJ(186-2*MOD(I,2))
17218 APF=PARJ(187-2*MOD(I,2))
17220 VPF=PARJ(194-2*MOD(I,2))
17221 APF=PARJ(195-2*MOD(I,2))
17224 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
17226 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17227 IF(ICASE.EQ.1) THEN
17228 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
17229 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
17230 & APF**2*(1D0-4D0*RM1))*BE34
17231 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17232 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
17233 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
17234 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
17235 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
17236 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
17237 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
17238 ELSEIF(MINT(61).EQ.2) THEN
17239 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
17240 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17241 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
17242 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
17243 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
17245 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
17248 ELSEIF(I.EQ.17) THEN
17250 WDTPZP=PARU(129)**2*XW1**2*
17251 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17252 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17253 IF(ICASE.EQ.1) THEN
17256 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17257 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
17258 ELSEIF(MINT(61).EQ.2) THEN
17267 ELSEIF(I.EQ.18) THEN
17269 CZC=2D0*(1D0-2D0*XW)
17270 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
17271 IF(ICASE.EQ.1) THEN
17272 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
17273 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
17274 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17275 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
17276 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
17277 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
17278 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
17279 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
17280 ELSEIF(MINT(61).EQ.2) THEN
17282 FGZF=0.25D0*PARU(142)*CZC*BE34C
17283 FGZPF=0.25D0*PARU(143)*CZC*BE34C
17284 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
17285 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
17286 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
17289 ELSEIF(I.EQ.19) THEN
17290 C...Z'0 -> Z0 + gamma.
17291 ELSEIF(I.EQ.20) THEN
17293 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17294 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
17295 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
17296 IF(ICASE.EQ.1) THEN
17299 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17300 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
17301 ELSEIF(MINT(61).EQ.2) THEN
17309 WID2=WIDS(23,2)*WIDS(25,2)
17310 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
17311 C...Z' -> h0 + A0 or H0 + A0.
17312 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17320 IF(ICASE.EQ.1) THEN
17321 WDTPZ=CZAH**2*BE34C
17322 WDTP(I)=FAC*CZPAH**2*BE34C
17323 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
17324 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
17325 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
17327 ELSEIF(MINT(61).EQ.2) THEN
17332 FZZPF=CZAH*CZPAH*BE34C
17333 FZPZPF=CZPAH**2*BE34C
17335 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
17336 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
17338 IF(ICASE.EQ.1) THEN
17339 VINT(117)=VINT(117)+FAC*WDTPZ
17340 WDTP(I)=FUDGE*WDTP(I)
17341 WDTP(0)=WDTP(0)+WDTP(I)
17343 IF(MDME(IDC,1).GT.0) THEN
17344 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
17345 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
17346 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17347 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
17348 & WDTE(I,MDME(IDC,1))
17349 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17350 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17352 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
17353 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
17354 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
17355 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
17357 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
17359 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
17360 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
17361 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
17363 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
17364 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
17368 IF(MINT(61).GE.1) ICASE=3-ICASE
17369 IF(ICASE.EQ.2) GOTO 280
17371 ELSEIF(KFLA.EQ.34) THEN
17373 FAC=(AEM/(24D0*XW))*SHR
17374 DO 300 I=1,MDCY(KC,3)
17376 IF(MDME(IDC,1).LT.0) GOTO 300
17377 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17378 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17379 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
17383 C...W'+/- -> q + qbar'
17384 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
17385 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
17387 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
17388 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
17389 IF(I.GE.13) WID2=WID2*WIDS(7,3)
17391 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
17392 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
17393 IF(I.GE.13) WID2=WID2*WIDS(7,2)
17395 ELSEIF(I.LE.20) THEN
17396 C...W'+/- -> l+/- + nu
17397 FCOF=PARU(133)**2+PARU(134)**2
17399 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17401 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17404 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
17405 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17406 ELSEIF(I.EQ.21) THEN
17407 C...W'+/- -> W+/- + Z0
17408 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
17409 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17410 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17411 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
17412 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
17413 ELSEIF(I.EQ.23) THEN
17414 C...W'+/- -> W+/- + h0
17415 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17416 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
17417 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17418 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17420 WDTP(I)=FUDGE*WDTP(I)
17421 WDTP(0)=WDTP(0)+WDTP(I)
17422 IF(MDME(IDC,1).GT.0) THEN
17423 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17424 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17425 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17426 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17430 ELSEIF(KFLA.EQ.37) THEN
17432 C IF(MSTP(49).EQ.0) THEN
17435 C SHFS=PMAS(37,1)**2
17437 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
17438 DO 310 I=1,MDCY(KC,3)
17440 IF(MDME(IDC,1).LT.0) GOTO 310
17441 KFC1=PYCOMP(KFDP(IDC,1))
17442 KFC2=PYCOMP(KFDP(IDC,2))
17443 RM1=PMAS(KFC1,1)**2/SH
17444 RM2=PMAS(KFC2,1)**2/SH
17445 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
17448 C...H+/- -> q + qbar'
17449 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
17450 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
17451 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
17452 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
17453 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17455 IF(I.EQ.3) WID2=WIDS(6,2)
17456 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
17458 IF(I.EQ.3) WID2=WIDS(6,3)
17459 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
17461 ELSEIF(I.LE.8) THEN
17462 C...H+/- -> l+/- + nu
17463 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
17464 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
17465 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
17467 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
17469 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
17471 ELSEIF(I.EQ.9) THEN
17472 C...H+/- -> W+/- + h0.
17473 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
17474 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17475 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
17476 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
17480 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
17483 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
17484 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
17485 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
17490 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
17493 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
17495 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
17496 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
17498 WDTP(I)=FUDGE*WDTP(I)
17499 WDTP(0)=WDTP(0)+WDTP(I)
17500 IF(MDME(IDC,1).GT.0) THEN
17501 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17502 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17503 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17504 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17508 ELSEIF(KFLA.EQ.41) THEN
17510 FAC=(AEM/(12D0*XW))*SHR
17511 DO 320 I=1,MDCY(KC,3)
17513 IF(MDME(IDC,1).LT.0) GOTO 320
17514 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17515 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17516 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
17521 ELSEIF(I.LE.9) THEN
17525 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17526 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17528 IF(I.EQ.4) WID2=WIDS(6,3)
17529 IF(I.EQ.5) WID2=WIDS(7,3)
17530 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
17531 IF(I.EQ.9) WID2=WIDS(17,3)
17533 IF(I.EQ.4) WID2=WIDS(6,2)
17534 IF(I.EQ.5) WID2=WIDS(7,2)
17535 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
17536 IF(I.EQ.9) WID2=WIDS(17,2)
17538 WDTP(I)=FUDGE*WDTP(I)
17539 WDTP(0)=WDTP(0)+WDTP(I)
17540 IF(MDME(IDC,1).GT.0) THEN
17541 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17542 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17543 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17544 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17548 ELSEIF(KFLA.EQ.42) THEN
17549 C...LQ (leptoquark).
17550 FAC=(AEM/4D0)*PARU(151)*SHR
17551 DO 330 I=1,MDCY(KC,3)
17553 IF(MDME(IDC,1).LT.0) GOTO 330
17554 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17555 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17556 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
17557 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17559 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
17560 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
17561 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
17562 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
17563 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
17564 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
17565 WDTP(I)=FUDGE*WDTP(I)
17566 WDTP(0)=WDTP(0)+WDTP(I)
17567 IF(MDME(IDC,1).GT.0) THEN
17568 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17569 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17570 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17571 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17575 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
17576 C...Techni-pi0 and techni-pi0':
17577 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
17578 DO 340 I=1,MDCY(KC,3)
17580 IF(MDME(IDC,1).LT.0) GOTO 340
17581 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17582 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17585 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
17589 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
17590 & /(8D0*PARU(1))*SH*SHR
17591 IF(KFLA.EQ.KTECHN+111) THEN
17598 C...pi_tc -> f + fbar.
17600 IKA=IABS(KFDP(IDC,1))
17601 IF(IKA.LT.10) FCOF=3D0*RADC
17604 IF(IKA.GE.4.AND.IKA.LE.6) THEN
17605 FCOF=FCOF*RTCM(1+IKA)**2
17606 HM1=PYMRUN(KFDP(IDC,1),SH)
17607 HM2=PYMRUN(KFDP(IDC,2),SH)
17608 ELSEIF(IKA.EQ.15) THEN
17609 FCOF=FCOF*RTCM(8)**2
17611 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17612 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17614 WDTP(I)=FUDGE*WDTP(I)
17615 WDTP(0)=WDTP(0)+WDTP(I)
17616 IF(MDME(IDC,1).GT.0) THEN
17617 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17618 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17619 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17620 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17624 ELSEIF(KFLA.EQ.KTECHN+211) THEN
17626 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
17627 DO 350 I=1,MDCY(KC,3)
17629 IF(MDME(IDC,1).LT.0) GOTO 350
17630 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
17631 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
17633 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
17637 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
17639 C...pi_tc -> f + f'.
17641 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
17642 C...pi_tc+ -> W b b~
17643 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
17645 XMT2=PMAS(6,1)**2/SH
17646 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
17647 KFC3=PYCOMP(KFDP(IDC,3))
17648 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
17650 T0 = (1D0-CHECK**2)*
17651 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
17652 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
17653 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
17654 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
17655 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
17656 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
17665 IKA=IABS(KFDP(IDC,1))
17666 IF(IKA.LT.10) FCOF=3D0*RADC
17669 IF(I.GE.1.AND.I.LE.5) THEN
17671 FCOF=FCOF*RTCM(5)**2
17672 ELSEIF(I.LE.4) THEN
17673 FCOF=FCOF*RTCM(6)**2
17674 ELSEIF(I.EQ.5) THEN
17675 FCOF=FCOF*RTCM(7)**2
17677 HM1=PYMRUN(KFDP(IDC,1),SH)
17678 HM2=PYMRUN(KFDP(IDC,2),SH)
17679 ELSEIF(I.EQ.8) THEN
17680 FCOF=FCOF*RTCM(8)**2
17682 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
17683 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17685 WDTP(I)=FUDGE*WDTP(I)
17686 WDTP(0)=WDTP(0)+WDTP(I)
17687 IF(MDME(IDC,1).GT.0) THEN
17688 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17689 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17690 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17691 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17695 ELSEIF(KFLA.EQ.KTECHN+331) THEN
17697 FAC=(SH/PARP(46)**2)*SHR
17698 DO 360 I=1,MDCY(KC,3)
17700 IF(MDME(IDC,1).LT.0) GOTO 360
17701 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17702 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17703 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
17706 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
17707 IF(I.EQ.2) WID2=WIDS(6,1)
17709 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
17711 WDTP(I)=FUDGE*WDTP(I)
17712 WDTP(0)=WDTP(0)+WDTP(I)
17713 IF(MDME(IDC,1).GT.0) THEN
17714 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17715 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17716 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17717 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17721 ELSEIF(KFLA.EQ.KTECHN+113) THEN
17723 ALPRHT=2.91D0*(3D0/ITCM(1))
17724 FAC=(ALPRHT/12D0)*SHR
17725 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
17729 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17731 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
17732 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17733 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17734 DO 370 I=1,MDCY(KC,3)
17736 IF(MDME(IDC,1).LT.0) GOTO 370
17737 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17738 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17739 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
17742 C...rho_tc0 -> W+ + W-.
17743 WDTP(I)=FAC*RTCM(3)**4*
17744 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17746 ELSEIF(I.EQ.2) THEN
17747 C...rho_tc0 -> W+ + pi_tc-.
17748 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17749 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17750 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17751 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17752 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
17753 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17754 ELSEIF(I.EQ.3) THEN
17755 C...rho_tc0 -> pi_tc+ + W-.
17756 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17757 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17758 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17759 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17760 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
17761 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
17762 ELSEIF(I.EQ.4) THEN
17763 C...rho_tc0 -> pi_tc+ + pi_tc-.
17764 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
17765 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17766 WID2=WIDS(PYCOMP(KTECHN+211),1)
17767 ELSEIF(I.EQ.5) THEN
17768 C...rho_tc0 -> gamma + pi_tc0
17769 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17770 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17772 WID2=WIDS(PYCOMP(KTECHN+111),2)
17773 ELSEIF(I.EQ.6) THEN
17774 C...rho_tc0 -> gamma + pi_tc0'
17775 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17776 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
17777 WID2=WIDS(PYCOMP(KTECHN+221),2)
17778 ELSEIF(I.EQ.7) THEN
17779 C...rho_tc0 -> Z0 + pi_tc0
17780 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17781 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17783 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17784 ELSEIF(I.EQ.8) THEN
17785 C...rho_tc0 -> Z0 + pi_tc0'
17786 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17787 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
17789 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17791 C...rho_tc0 -> f + fbar.
17796 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
17800 IF(IA.GE.17) WID2=WIDS(IA,1)
17803 AI=SIGN(1D0,EI+0.1D0)
17807 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
17808 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
17809 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
17810 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
17812 WDTP(I)=FUDGE*WDTP(I)
17813 WDTP(0)=WDTP(0)+WDTP(I)
17814 IF(MDME(IDC,1).GT.0) THEN
17815 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17816 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17817 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17818 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17822 ELSEIF(KFLA.EQ.KTECHN+213) THEN
17824 ALPRHT=2.91D0*(3D0/ITCM(1))
17825 FAC=(ALPRHT/12D0)*SHR
17829 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
17831 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
17832 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
17833 DO 380 I=1,MDCY(KC,3)
17835 IF(MDME(IDC,1).LT.0) GOTO 380
17836 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17837 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17838 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
17841 C...rho_tc+ -> W+ + Z0.
17842 WDTP(I)=FAC*RTCM(3)**4*
17843 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17845 WID2=WIDS(24,2)*WIDS(23,2)
17847 WID2=WIDS(24,3)*WIDS(23,2)
17849 ELSEIF(I.EQ.2) THEN
17850 C...rho_tc+ -> W+ + pi_tc0.
17851 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17852 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17853 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17854 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
17855 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
17857 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
17859 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
17861 ELSEIF(I.EQ.3) THEN
17862 C...rho_tc+ -> pi_tc+ + Z0.
17863 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
17864 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
17865 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
17866 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
17867 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
17868 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17869 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17872 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
17874 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
17876 ELSEIF(I.EQ.4) THEN
17877 C...rho_tc+ -> pi_tc+ + pi_tc0.
17878 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
17879 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17881 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
17883 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
17885 ELSEIF(I.EQ.5) THEN
17886 C...rho_tc+ -> pi_tc+ + gamma
17887 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17888 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
17891 WID2=WIDS(PYCOMP(KTECHN+211),2)
17893 WID2=WIDS(PYCOMP(KTECHN+211),3)
17895 ELSEIF(I.EQ.6) THEN
17896 C...rho_tc+ -> W+ + pi_tc0'
17897 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17898 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
17900 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
17902 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
17905 C...rho_tc+ -> f + fbar'.
17909 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
17911 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
17912 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
17913 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
17915 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
17916 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
17917 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
17922 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
17924 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
17927 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
17928 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
17930 WDTP(I)=FUDGE*WDTP(I)
17931 WDTP(0)=WDTP(0)+WDTP(I)
17932 IF(MDME(IDC,1).GT.0) THEN
17933 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
17934 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
17935 WDTE(I,0)=WDTE(I,MDME(IDC,1))
17936 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
17940 ELSEIF(KFLA.EQ.KTECHN+223) THEN
17942 ALPRHT=2.91D0*(3D0/ITCM(1))
17943 FAC=(ALPRHT/12D0)*SHR
17944 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
17947 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
17949 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17950 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17951 DO 390 I=1,MDCY(KC,3)
17953 IF(MDME(IDC,1).LT.0) GOTO 390
17954 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
17955 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
17956 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
17959 C...omega_tc0 -> gamma + pi_tc0.
17960 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
17961 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
17962 WID2=WIDS(PYCOMP(KTECHN+111),2)
17963 ELSEIF(I.EQ.2) THEN
17964 C...omega_tc0 -> Z0 + pi_tc0
17965 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17966 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
17968 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
17969 ELSEIF(I.EQ.3) THEN
17970 C...omega_tc0 -> gamma + pi_tc0'
17971 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17972 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
17974 WID2=WIDS(PYCOMP(KTECHN+221),2)
17975 ELSEIF(I.EQ.4) THEN
17976 C...omega_tc0 -> Z0 + pi_tc0'
17977 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17978 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
17980 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
17981 ELSEIF(I.EQ.5) THEN
17982 C...omega_tc0 -> W+ + pi_tc-
17983 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17984 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
17985 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
17986 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17987 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
17988 ELSEIF(I.EQ.6) THEN
17989 C...omega_tc0 -> pi_tc+ + W-
17990 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
17991 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
17992 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
17993 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
17994 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
17995 ELSEIF(I.EQ.7) THEN
17996 C...omega_tc0 -> W+ + W-.
17997 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
17998 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
18000 ELSEIF(I.EQ.8) THEN
18001 C...omega_tc0 -> pi_tc+ + pi_tc-.
18002 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
18003 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
18004 WID2=WIDS(PYCOMP(KTECHN+211),1)
18006 C...omega_tc0 -> f + fbar.
18011 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
18015 IF(IA.GE.17) WID2=WIDS(IA,1)
18018 AI=SIGN(1D0,EI+0.1D0)
18020 VALI=-0.5D0*(VI+AI)
18021 VARI=-0.5D0*(VI-AI)
18022 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
18023 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
18024 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
18025 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
18027 WDTP(I)=FUDGE*WDTP(I)
18028 WDTP(0)=WDTP(0)+WDTP(I)
18029 IF(MDME(IDC,1).GT.0) THEN
18030 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18031 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18032 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18033 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18037 C.....V8 -> quark anti-quark
18038 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
18041 IF(ITCM(2).EQ.0) THEN
18043 ELSEIF(ITCM(2).EQ.1) THEN
18046 DO 400 I=1,MDCY(KC,3)
18048 IF(MDME(IDC,1).LT.0) GOTO 400
18049 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
18051 IF(RM1.GT.0.25D0) GOTO 400
18053 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
18058 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
18059 IF(I.EQ.6) WID2=WIDS(6,1)
18060 WDTP(I)=FUDGE*WDTP(I)
18061 WDTP(0)=WDTP(0)+WDTP(I)
18062 IF(MDME(IDC,1).GT.0) THEN
18063 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18064 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18065 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18066 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18070 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
18071 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
18073 DO 410 I=1,MDCY(KC,3)
18075 IF(MDME(IDC,1).LT.0) GOTO 410
18076 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18077 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18078 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
18082 IF(KFLA.EQ.KTECHN+100111) THEN
18087 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
18088 & /(2D0*PARU(1))*SH*SHR*CLEBG
18091 C...pi_tc -> f + fbar.
18092 IF(I.EQ.6) WID2=WIDS(6,1)
18094 IKA=IABS(KFDP(IDC,1))
18095 IF(IKA.LT.10) FCOF=3D0*RADC
18096 HM1=PYMRUN(KFDP(IDC,1),SH)
18097 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
18098 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18100 WDTP(I)=FUDGE*WDTP(I)
18101 WDTP(0)=WDTP(0)+WDTP(I)
18102 IF(MDME(IDC,1).GT.0) THEN
18103 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18104 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18105 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18106 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18110 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
18112 ALPRHT=2.91D0*(3D0/ITCM(1))
18114 SIN2T=2D0*TANT3/(TANT3**2+1D0)
18115 SINT3=TANT3/SQRT(TANT3**2+1D0)
18118 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
18119 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
18120 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
18121 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
18122 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
18124 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
18126 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
18128 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
18130 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
18131 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
18132 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
18133 IF(ITCM(2).EQ.0) THEN
18138 DO 420 I=1,MDCY(KC,3)
18139 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
18140 & KFLA.EQ.KTECHN+300113)) GOTO 420
18142 IF(MDME(IDC,1).LT.0) GOTO 420
18143 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18144 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18145 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
18148 IF(I.EQ.6) WID2=WIDS(6,1)
18150 IF(KFLA.EQ.KTECHN+200113) THEN
18153 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
18156 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
18161 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
18162 FMIX=1D0/TANT3/SIN2T
18166 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
18167 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
18168 ELSEIF(I.EQ.7) THEN
18169 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
18170 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
18171 PSH=SHR*(1D0-RM1)/2D0
18172 WDTP(I)=AS/9D0*PSH**3/RM82
18174 WDTP(I)=2D0*WDTP(I)*CSXPP**2
18175 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
18177 WDTP(I)=5D0*WDTP(I)
18178 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
18181 WDTP(I)=FUDGE*WDTP(I)
18182 WDTP(0)=WDTP(0)+WDTP(I)
18183 IF(MDME(IDC,1).GT.0) THEN
18184 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18185 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18186 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18187 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18191 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
18192 C...d* excited quark.
18193 FAC=(SH/RTCM(41)**2)*SHR
18194 DO 430 I=1,MDCY(KC,3)
18196 IF(MDME(IDC,1).LT.0) GOTO 430
18197 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18198 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18199 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
18203 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
18205 ELSEIF(I.EQ.2) THEN
18206 C...d* -> gamma + d.
18207 QF=-RTCM(43)/2D0+RTCM(44)/6D0
18208 WDTP(I)=FAC*AEM*QF**2/4D0
18210 ELSEIF(I.EQ.3) THEN
18212 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
18213 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18214 & (1D0-RM1)**2*(2D0+RM1)
18216 ELSEIF(I.EQ.4) THEN
18218 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18219 & (1D0-RM1)**2*(2D0+RM1)
18220 IF(KFLR.GT.0) WID2=WIDS(24,3)
18221 IF(KFLR.LT.0) WID2=WIDS(24,2)
18223 WDTP(I)=FUDGE*WDTP(I)
18224 WDTP(0)=WDTP(0)+WDTP(I)
18225 IF(MDME(IDC,1).GT.0) THEN
18226 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18227 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18228 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18229 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18233 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
18234 C...u* excited quark.
18235 FAC=(SH/RTCM(41)**2)*SHR
18236 DO 440 I=1,MDCY(KC,3)
18238 IF(MDME(IDC,1).LT.0) GOTO 440
18239 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18240 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18241 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
18245 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
18247 ELSEIF(I.EQ.2) THEN
18248 C...u* -> gamma + u.
18249 QF=RTCM(43)/2D0+RTCM(44)/6D0
18250 WDTP(I)=FAC*AEM*QF**2/4D0
18252 ELSEIF(I.EQ.3) THEN
18254 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
18255 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18256 & (1D0-RM1)**2*(2D0+RM1)
18258 ELSEIF(I.EQ.4) THEN
18260 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18261 & (1D0-RM1)**2*(2D0+RM1)
18262 IF(KFLR.GT.0) WID2=WIDS(24,2)
18263 IF(KFLR.LT.0) WID2=WIDS(24,3)
18265 WDTP(I)=FUDGE*WDTP(I)
18266 WDTP(0)=WDTP(0)+WDTP(I)
18267 IF(MDME(IDC,1).GT.0) THEN
18268 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18269 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18270 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18271 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18275 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
18276 C...e* excited lepton.
18277 FAC=(SH/RTCM(41)**2)*SHR
18278 DO 450 I=1,MDCY(KC,3)
18280 IF(MDME(IDC,1).LT.0) GOTO 450
18281 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18282 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18283 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
18286 C...e* -> gamma + e.
18287 QF=-RTCM(43)/2D0-RTCM(44)/2D0
18288 WDTP(I)=FAC*AEM*QF**2/4D0
18290 ELSEIF(I.EQ.2) THEN
18292 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
18293 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18294 & (1D0-RM1)**2*(2D0+RM1)
18296 ELSEIF(I.EQ.3) THEN
18298 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18299 & (1D0-RM1)**2*(2D0+RM1)
18300 IF(KFLR.GT.0) WID2=WIDS(24,3)
18301 IF(KFLR.LT.0) WID2=WIDS(24,2)
18303 WDTP(I)=FUDGE*WDTP(I)
18304 WDTP(0)=WDTP(0)+WDTP(I)
18305 IF(MDME(IDC,1).GT.0) THEN
18306 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18307 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18308 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18309 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18313 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
18314 C...nu*_e excited neutrino.
18315 FAC=(SH/RTCM(41)**2)*SHR
18316 DO 460 I=1,MDCY(KC,3)
18318 IF(MDME(IDC,1).LT.0) GOTO 460
18319 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18320 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18321 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
18324 C...nu*_e -> Z0 + nu*_e.
18325 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
18326 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
18327 & (1D0-RM1)**2*(2D0+RM1)
18329 ELSEIF(I.EQ.2) THEN
18330 C...nu*_e -> W+ + e.
18331 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
18332 & (1D0-RM1)**2*(2D0+RM1)
18333 IF(KFLR.GT.0) WID2=WIDS(24,2)
18334 IF(KFLR.LT.0) WID2=WIDS(24,3)
18336 WDTP(I)=FUDGE*WDTP(I)
18337 WDTP(0)=WDTP(0)+WDTP(I)
18338 IF(MDME(IDC,1).GT.0) THEN
18339 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18340 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18341 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18342 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18346 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
18347 C...G* (graviton resonance):
18348 FAC=(PARP(50)**2/PARU(1))*SHR
18349 DO 470 I=1,MDCY(KC,3)
18351 IF(MDME(IDC,1).LT.0) GOTO 470
18352 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18353 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18354 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
18359 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
18360 & PYHFTH(SH,SH*RM1,1D0)
18361 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
18362 & (1D0+8D0*RM1/3D0)/320D0
18363 IF(I.EQ.6) WID2=WIDS(6,1)
18364 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
18365 ELSEIF(I.LE.16) THEN
18366 C...G* -> l+ + l-, nu + nubar
18368 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
18369 & (1D0+8D0*RM1/3D0)/320D0
18370 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
18371 ELSEIF(I.EQ.17) THEN
18374 ELSEIF(I.EQ.18) THEN
18375 C...G* -> gamma + gamma.
18377 ELSEIF(I.EQ.19) THEN
18379 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
18380 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
18382 ELSEIF(I.EQ.20) THEN
18384 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
18385 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
18388 WDTP(I)=FUDGE*WDTP(I)
18389 WDTP(0)=WDTP(0)+WDTP(I)
18390 IF(MDME(IDC,1).GT.0) THEN
18391 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18392 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18393 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18394 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18398 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
18399 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
18400 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
18401 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
18402 DO 480 I=1,MDCY(KC,3)
18404 IF(MDME(IDC,1).LT.0) GOTO 480
18405 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
18406 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
18407 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
18408 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
18411 C...nu_lR -> l- qbar q'
18412 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18413 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18414 ELSEIF(I.LE.18) THEN
18415 C...nu_lR -> l+ q qbar'
18416 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
18417 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
18419 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
18421 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
18423 X=(PM1+PM2+PM3)/SHR
18424 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
18426 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
18427 WDTP(I)=FAC*FCOF*FX*FY
18428 WDTP(I)=FUDGE*WDTP(I)
18429 WDTP(0)=WDTP(0)+WDTP(I)
18430 IF(MDME(IDC,1).GT.0) THEN
18431 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18432 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18433 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18434 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18438 ELSEIF(KFLA.EQ.9900023) THEN
18440 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
18441 DO 490 I=1,MDCY(KC,3)
18443 IF(MDME(IDC,1).LT.0) GOTO 490
18444 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18445 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18446 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
18450 C...Z_R0 -> q + qbar
18452 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
18453 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
18455 IF(I.EQ.6) WID2=WIDS(6,1)
18456 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
18457 C...Z_R0 -> l+ + l-
18461 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
18462 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
18467 ELSEIF(I.LE.15) THEN
18468 C...Z0 -> nu_R + nu_R, assumed Majorana.
18472 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
18475 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
18476 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
18477 WDTP(I)=FUDGE*WDTP(I)
18478 WDTP(0)=WDTP(0)+WDTP(I)
18479 IF(MDME(IDC,1).GT.0) THEN
18480 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18481 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18482 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18483 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18487 ELSEIF(KFLA.EQ.9900024) THEN
18489 FAC=(AEM/(24D0*XW))*SHR
18490 DO 500 I=1,MDCY(KC,3)
18492 IF(MDME(IDC,1).LT.0) GOTO 500
18493 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18494 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18495 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
18498 C...W_R+/- -> q + qbar'
18499 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
18501 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
18503 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
18505 ELSEIF(I.LE.12) THEN
18506 C...W_R+/- -> l+/- + nu_R
18509 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
18510 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18511 WDTP(I)=FUDGE*WDTP(I)
18512 WDTP(0)=WDTP(0)+WDTP(I)
18513 IF(MDME(IDC,1).GT.0) THEN
18514 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18515 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18516 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18517 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18521 ELSEIF(KFLA.EQ.9900041) THEN
18523 FAC=(1D0/(8D0*PARU(1)))*SHR
18524 DO 510 I=1,MDCY(KC,3)
18526 IF(MDME(IDC,1).LT.0) GOTO 510
18527 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18528 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18529 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
18532 C...H_L++/-- -> l+/- + l'+/-
18533 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18534 & (IABS(KFDP(IDC,2))-9)/2)**2
18535 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18536 ELSEIF(I.EQ.7) THEN
18537 C...H_L++/-- -> W_L+/- + W_L+/-
18538 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
18539 & (3D0*RM1+0.25D0/RM1-1D0)
18540 WID2=WIDS(24,4+(1-KFLS)/2)
18543 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18544 WDTP(I)=FUDGE*WDTP(I)
18545 WDTP(0)=WDTP(0)+WDTP(I)
18546 IF(MDME(IDC,1).GT.0) THEN
18547 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18548 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18549 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18550 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18554 ELSEIF(KFLA.EQ.9900042) THEN
18556 FAC=(1D0/(8D0*PARU(1)))*SHR
18557 DO 520 I=1,MDCY(KC,3)
18559 IF(MDME(IDC,1).LT.0) GOTO 520
18560 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
18561 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
18562 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
18565 C...H_R++/-- -> l+/- + l'+/-
18566 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
18567 & (IABS(KFDP(IDC,2))-9)/2)**2
18568 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
18569 ELSEIF(I.EQ.7) THEN
18570 C...H_R++/-- -> W_R+/- + W_R+/-
18571 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
18572 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
18575 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18576 WDTP(I)=FUDGE*WDTP(I)
18577 WDTP(0)=WDTP(0)+WDTP(I)
18578 IF(MDME(IDC,1).GT.0) THEN
18579 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
18580 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
18581 WDTE(I,0)=WDTE(I,MDME(IDC,1))
18582 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
18593 C***********************************************************************
18596 C...Calculates partial width and differential cross-section maxima
18597 C...of channels/processes not allowed on mass-shell, and selects
18598 C...masses in such channels/processes.
18600 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
18602 C...Double precision and integer declarations.
18603 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18604 IMPLICIT INTEGER(I-N)
18605 INTEGER PYK,PYCHGE,PYCOMP
18607 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18608 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18609 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
18610 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
18611 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18612 COMMON/PYINT1/MINT(400),VINT(400)
18613 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
18614 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
18615 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
18618 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
18619 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
18620 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
18623 C...Find if particles equal, maximum mass, matrix elements, etc.
18629 IF(KFD(1).EQ.KFD(2)) MEQL=1
18631 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
18632 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
18638 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
18641 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
18642 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
18643 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
18644 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
18645 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
18646 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
18649 C...Find where Breit-Wigners are required, else select discrete masses.
18651 KFCA=PYCOMP(KFD(I))
18653 PMD(I)=PMAS(KFCA,1)
18654 PGD(I)=PMAS(KFCA,2)
18659 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
18662 RMG(I)=(PMG(I)/PMMX)**2
18668 C...Find allowed mass range and Breit-Wigner parameters.
18670 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
18672 PMU(I)=PMMX-PARP(42)
18673 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18674 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18675 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
18677 IF(MLM.EQ.2) ILM=3-I
18678 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
18679 IF(MBW(3-I).EQ.0) THEN
18680 PMU(I)=PMMX-PMD(3-I)
18682 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
18684 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
18685 & MIN(PMU(I),CKIN(NOFF+2*ILM))
18686 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18687 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18688 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18689 IF(MBW(I).EQ.1) THEN
18690 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18691 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18692 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18695 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
18697 IF(MLM.EQ.2) ILM=3-I
18698 PML(I)=MAX(CKIN(48+I),PARP(42))
18699 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
18700 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
18701 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
18702 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
18703 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
18704 IF(MBW(I).EQ.1) THEN
18705 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18706 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
18707 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
18712 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
18714 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
18719 C...Calculation of partial width of resonance.
18720 IF(MOFSH.EQ.1) THEN
18722 C..If only one integration, pick that to be the inner.
18723 IF(MBW(1).EQ.0) THEN
18729 ELSEIF(MBW(2).EQ.0) THEN
18733 C...Start outer loop of integration.
18734 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18735 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18736 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
18742 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18743 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
18744 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
18748 C...Start inner loop of integration.
18750 PMU1=MIN(PMU(1),PMMX-PM2)
18751 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
18752 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18753 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
18754 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
18762 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
18763 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
18766 C...Evaluate function value - inner loop.
18767 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
18768 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
18769 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
18770 & RM2**2+10D0*RM1*RM2)
18771 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
18774 C...Go to next position in inner loop.
18780 ELSEIF(NPT1.LE.8) THEN
18782 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
18784 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18785 INX1(NPT1)=INX1(ISH1)
18788 ELSEIF(NPT1.LT.100) THEN
18791 IF(ISH1.GT.NPT1) ISH1=2
18792 IF(ISH1.EQ.ISN1) GOTO 160
18793 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
18794 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
18796 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
18797 INX1(NPT1)=INX1(ISH1)
18802 C...Calculate integral over inner loop.
18805 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
18806 & (XPT1(INX1(IPT1))-XPT1(IPT1))
18808 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
18809 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
18810 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
18813 C...Go to next position in outer loop.
18819 ELSEIF(NPT2.LE.8) THEN
18821 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
18823 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18824 INX2(NPT2)=INX2(ISH2)
18827 ELSEIF(NPT2.LT.100) THEN
18830 IF(ISH2.GT.NPT2) ISH2=2
18831 IF(ISH2.EQ.ISN2) GOTO 200
18832 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
18833 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
18835 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
18836 INX2(NPT2)=INX2(ISH2)
18841 C...Calculate integral over outer loop.
18844 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
18845 & (XPT2(INX2(IPT2))-XPT2(IPT2))
18847 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
18848 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
18853 C...Save result; second integration for user-selected mass range.
18854 IF(LOOP.EQ.1) WIDW=FSUM2
18856 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
18857 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
18864 C...Select two decay product masses of a resonance.
18865 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
18867 IF(MBW(I).EQ.0) GOTO 230
18868 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
18870 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
18871 RMG(I)=(PMG(I)/PMMX)**2
18873 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18874 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
18876 C...Weight with matrix element (if none known, use beta factor).
18877 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
18879 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
18880 ELSEIF(MMED.EQ.2) THEN
18881 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
18882 & RMG(2)**2+10D0*RMG(1)*RMG(2))
18883 ELSEIF(MMED.EQ.3) THEN
18884 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
18888 IF(WTBE.LT.PYR(0)) GOTO 220
18892 C...Find suitable set of masses for initialization of 2 -> 2 processes.
18893 ELSEIF(MOFSH.EQ.3) THEN
18894 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
18895 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
18897 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
18899 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
18903 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
18904 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
18905 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
18910 C...Evaluate importance of excluded tails of Breit-Wigners.
18911 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18912 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18916 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
18920 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
18921 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
18923 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
18924 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
18925 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
18926 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
18928 C...Pick one particle to be the lighter (if improves efficiency).
18929 ELSEIF(MOFSH.EQ.4) THEN
18930 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
18931 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
18932 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
18934 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
18936 IF(MBW(I).EQ.0) GOTO 270
18938 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18940 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18942 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18943 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
18944 IF(RBR.LT.0.8D0) THEN
18945 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
18946 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
18947 ELSEIF(RBR.LT.0.9D0) THEN
18948 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
18949 ELSEIF(RBR.LT.1.5D0) THEN
18950 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
18952 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
18953 & (PMV**2-PML(I)**2))))
18956 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
18957 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
18958 IF(MINT(48).EQ.1) THEN
18959 NGEN(0,1)=NGEN(0,1)+1
18960 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
18970 C...Give weight for selected mass distribution.
18973 IF(MBW(I).EQ.0) GOTO 280
18975 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
18977 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
18978 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
18979 & (PMD(I)*PGD(I))**2)/PARU(1)
18983 FI0=(ATV-ATL(I))/PARU(1)
18984 FI1=PMV**2-PML(I)**2
18985 FI2=2D0*LOG(PMV/PML(I))
18986 FI3=1D0/PML(I)**2-1D0/PMV**2
18987 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
18988 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
18989 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
18992 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
18994 VINT(80)=VINT(80)*FI0
18996 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
19002 C***********************************************************************
19005 C...Handles the possibility of colour reconnection in W+W- events,
19006 C...Based on the main scenarios of the Sjostrand and Khoze study:
19007 C...I, II, II', intermediate and instantaneous; plus one model
19008 C...along the lines of the Gustafson and Hakkinen: GH.
19009 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
19010 C...is as if first resonance is W+ and second W-.
19012 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
19014 C...Double precision and integer declarations.
19015 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19016 IMPLICIT INTEGER(I-N)
19017 INTEGER PYK,PYCHGE,PYCOMP
19018 C...Parameter value; number of points in MC integration.
19019 PARAMETER (NPT=100)
19021 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19022 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19023 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19024 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19025 COMMON/PYINT1/MINT(400),VINT(400)
19026 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19028 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
19029 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
19030 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
19031 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
19032 &TMC(20),IJOIN(100)
19034 C...Functions to give four-product and to do determinants.
19035 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)
19036 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
19037 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
19038 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
19040 C...Only allow fraction of recoupling for GH, intermediate and
19042 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
19043 IF(PYR(0).GT.PARP(120)) RETURN
19047 C...Common part for scenarios I, II, II', and GH.
19048 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
19049 &MSTP(115).EQ.5) THEN
19051 C...Read out frequently-used parameters.
19055 IF(ISUB.EQ.22) PMW=PMAS(23,1)
19057 IF(ISUB.EQ.22) PGW=PMAS(23,2)
19064 C...Find range of decay products of the W's.
19065 C...Background: the W's are stored in IW1 and IW2.
19066 C...Their direct decay products in NSD1+1 through NSD1+4.
19067 C...Products after shower (if any) in NSD1+5 through NAFT1
19068 C...for first W and in NAFT1+1 through N for the second.
19069 IF(NAFT1.GT.NSD1+4) THEN
19076 IF(N.GT.NAFT1) THEN
19084 C...Rearrange parton shower products along strings.
19086 CALL PYPREP(NSD1+1)
19088 C...Find partons pointing back to W+ and W-; store them with quark
19089 C...end of string first.
19095 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
19096 IF(IABS(K(I,2)).GE.22) GOTO 120
19097 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
19098 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
19108 IF(K(I,1).EQ.1) ISGP=0
19109 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
19110 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
19120 IF(K(I,1).EQ.1) ISGM=0
19124 C...Boost to W+W- rest frame (not strictly needed).
19126 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
19128 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
19129 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
19130 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
19132 C...Select decay vertices of W+ and W-.
19133 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
19134 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
19135 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
19136 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
19139 XP(J)=TP*P(IW1,J)/P(IW1,4)
19140 XM(J)=TM*P(IW2,J)/P(IW2,4)
19143 C...Begin scenario I specifics.
19144 IF(MSTP(115).EQ.1) THEN
19146 C...Reconstruct velocity and direction of W+ string pieces.
19148 IF(K(INP(IIP),2).LT.0) GOTO 170
19151 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
19152 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
19156 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
19157 DIRP(IIP,J)=V1(J)-V2(J)
19159 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
19161 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
19163 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
19167 C...Reconstruct velocity and direction of W- string pieces.
19169 IF(K(INM(IIM),2).LT.0) GOTO 200
19172 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
19173 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
19177 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
19178 DIRM(IIM,J)=V1(J)-V2(J)
19180 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
19182 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
19184 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
19188 C...Loop over number of space-time points.
19193 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
19194 R=SQRT(-LOG(PYR(0)))
19196 X=BLOWR*RHAD*R*COS(PHI)
19197 Y=BLOWR*RHAD*R*SIN(PHI)
19198 R=SQRT(-LOG(PYR(0)))
19200 Z=BLOWR*RHAD*R*COS(PHI)
19201 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
19203 C...Reject impossible points. Weight for sample distribution.
19204 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
19205 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
19206 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
19208 C...Loop over W+ string pieces and find one with largest weight.
19216 IF(K(INP(IIP),2).LT.0) GOTO 220
19217 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
19218 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
19220 XB(J)=XD(J)+BEDG*BETP(IIP,J)
19222 XB(4)=BETP(IIP,4)*(XD(4)-BED)
19223 SR2=XB(1)**2+XB(2)**2+XB(3)**2
19224 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
19225 & DIRP(IIP,3)*XB(3))**2
19226 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
19228 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
19229 IF(WTP.GT.WTMAXP) THEN
19235 C...Loop over W- string pieces and find one with largest weight.
19243 IF(K(INM(IIM),2).LT.0) GOTO 240
19244 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
19245 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
19247 XB(J)=XD(J)+BEDG*BETM(IIM,J)
19249 XB(4)=BETM(IIM,4)*(XD(4)-BED)
19250 SR2=XB(1)**2+XB(2)**2+XB(3)**2
19251 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
19252 & DIRM(IIM,3)*XB(3))**2
19253 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
19255 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
19256 IF(WTM.GT.WTMAXM) THEN
19262 C...Result of integration.
19264 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
19265 WT=WTMAXP*WTMAXM/WTSMP
19273 RES=BLOWR**3*BLOWT*SUM/NPT
19275 C...Decide whether to reconnect and, if so, where.
19277 PREC=1D0-EXP(-FACT*RES)
19278 IF(PREC.GT.PYR(0)) THEN
19283 IF(RSUM.LE.0D0) GOTO 270
19289 C...Begin scenario II and II' specifics.
19290 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
19292 C...Loop through all string pieces, one from W+ and one from W-.
19296 IF(K(INP(IIP),2).LT.0) GOTO 340
19300 IF(K(INM(IIM),2).LT.0) GOTO 330
19304 C...Find endpoint velocity vectors.
19306 V1P(J)=P(I1P,J)/P(I1P,4)
19307 V2P(J)=P(I2P,J)/P(I2P,4)
19308 V1M(J)=P(I1M,J)/P(I1M,4)
19309 V2M(J)=P(I2M,J)/P(I2M,4)
19312 C...Define q matrix and find t.
19314 Q(1,J)=V2P(J)-V1P(J)
19315 Q(2,J)=-(V2M(J)-V1M(J))
19316 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
19317 Q(4,J)=V1P(J)-V1M(J)
19319 T=-DETER(1,2,3)/DETER(1,2,4)
19321 C...Find alpha and beta; i.e. coordinates of crossing point.
19324 S13=Q(3,1)+Q(4,1)*T
19327 S23=Q(3,2)+Q(4,2)*T
19328 DEN=S11*S22-S12*S21
19329 ALP=(S12*S23-S22*S13)/DEN
19330 BET=(S21*S13-S11*S23)/DEN
19332 C...Check if solution acceptable.
19334 IF(T.LT.GTMAX) IANSW=0
19335 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
19336 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
19338 C...Find point of crossing and check that not inconsistent.
19340 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
19341 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
19343 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
19344 & (XPP(3)-XMM(3))**2
19345 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
19346 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
19347 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
19349 C...Find string eigentimes at crossing.
19350 IF(IANSW.EQ.1) THEN
19351 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
19352 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
19353 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
19354 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
19360 C...Order crossings by time. End loop over crossings.
19361 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
19363 DO 310 I1=NCROSS,1,-1
19364 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
19384 C...Loop over crossings; find first (if any) acceptable one.
19386 IF(NCROSS.GE.1) THEN
19388 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
19389 IF(PNFRAG.GT.PYR(0)) THEN
19390 C...Scenario II: only compare with fragmentation time.
19391 IF(MSTP(115).EQ.2) THEN
19396 C...Scenario II': also require that string length decreases.
19404 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19405 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19406 IF(ELNEW.LT.ELOLD) THEN
19418 C...Begin scenario GH specifics.
19419 ELSEIF(MSTP(115).EQ.5) THEN
19421 C...Loop through all string pieces, one from W+ and one from W-.
19425 IF(K(INP(IIP),2).LT.0) GOTO 380
19429 IF(K(INM(IIM),2).LT.0) GOTO 370
19433 C...Look for largest decrease of (exponent of) Lambda measure.
19434 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
19435 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
19436 ELDIF=ELNEW/MAX(1D-10,ELOLD)
19437 IF(ELDIF.LT.ELMIN) THEN
19449 C...Common for scenarios I, II, II' and GH: reconnect strings.
19453 DO 390 IS=1,NNP+NNM
19457 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
19459 ELSEIF(IS.LE.IIP+NNM) THEN
19460 I=INM(IS-IIP-NNM+IIM)
19465 IF(K(I,2).LT.0) THEN
19466 CALL PYJOIN(NJOIN,IJOIN)
19471 C...Restore original event record if no reconnection.
19473 DO 400 I=NSD1+1,NOLD
19474 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
19475 K(I,4)=MOD(K(I,4),MSTU(5)**2)
19476 K(I,5)=MOD(K(I,5),MSTU(5)**2)
19485 C...Boost back system.
19486 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19487 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
19488 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
19489 & BEWW(1),BEWW(2),BEWW(3))
19491 C...Common part for intermediate and instantaneous scenarios.
19492 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
19495 C...Remove old shower products and reset showering ones.
19497 DO 420 I=NSD1+1,NSD1+4
19499 K(I,4)=MOD(K(I,4),MSTU(5)**2)
19500 K(I,5)=MOD(K(I,5),MSTU(5)**2)
19503 C...Identify quark-antiquark pairs.
19507 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
19510 C...Reconnect strings.
19513 CALL PYJOIN(2,IJOIN)
19516 CALL PYJOIN(2,IJOIN)
19518 C...Do new parton showers in intermediate scenario.
19519 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
19522 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
19523 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
19526 C...Do new parton showers in instantaneous scenario.
19527 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
19528 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
19529 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
19530 PPM=SQRT(MAX(0D0,PPM2))
19531 CALL PYSHOW(IQ1,IQ4,PPM)
19532 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
19533 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
19534 PPM=SQRT(MAX(0D0,PPM2))
19535 CALL PYSHOW(IQ3,IQ2,PPM)
19542 C***********************************************************************
19545 C...Checks generated variables against pre-set kinematical limits;
19546 C...also calculates limits on variables used in generation.
19548 SUBROUTINE PYKLIM(ILIM)
19550 C...Double precision and integer declarations.
19551 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19552 IMPLICIT INTEGER(I-N)
19553 INTEGER PYK,PYCHGE,PYCOMP
19555 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19556 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19557 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19558 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19559 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19560 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19561 COMMON/PYINT1/MINT(400),VINT(400)
19562 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19563 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19566 C...Common kinematical expressions.
19570 IF(ISUB.EQ.96) GOTO 100
19574 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
19575 CKIN09=MAX(CKIN(9),CKIN(13))
19576 CKIN10=MIN(CKIN(10),CKIN(14))
19577 CKIN11=MAX(CKIN(11),CKIN(15))
19578 CKIN12=MIN(CKIN(12),CKIN(16))
19580 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
19581 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
19582 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
19583 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
19588 RM3=SQM3/(TAU*VINT(2))
19589 RM4=SQM4/(TAU*VINT(2))
19590 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19593 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
19594 &PTHMIN=MAX(CKIN(3),CKIN(5))
19597 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
19598 C...pre-set kinematical limits.
19603 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
19604 X1=SQRT(TAUE)*EXP(YST)
19605 X2=SQRT(TAUE)*EXP(-YST)
19607 IF(MINT(47).NE.1) THEN
19608 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
19609 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
19610 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
19611 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
19613 IF(MINT(45).NE.1) THEN
19614 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
19616 IF(MINT(46).NE.1) THEN
19617 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
19619 IF(MINT(45).EQ.2) THEN
19620 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19622 IF(MINT(46).EQ.2) THEN
19623 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
19625 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
19626 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
19627 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
19628 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
19629 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
19630 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
19631 Y3=YST+0.5D0*LOG(EXPY3)
19632 Y4=YST+0.5D0*LOG(EXPY4)
19637 STH=SQRT(MAX(0D0,1D0-CTH**2))
19638 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
19639 & CTH)**2-4D0*RM3))
19640 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
19641 & CTH)**2-4D0*RM4))
19642 IF(STH.GE.1D-10) THEN
19643 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
19645 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
19647 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
19648 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
19649 ETALAR=MAX(ETA3,ETA4)
19650 ETASMA=MIN(ETA3,ETA4)
19652 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
19653 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
19654 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
19655 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
19657 RPTS=4D0*VINT(71)**2/SH
19658 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
19659 RM34=MAX(1D-20,2D0*RM3*RM4)
19660 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
19661 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
19662 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
19663 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
19664 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
19665 IF(PTH.LT.PTHMIN) MINT(51)=1
19666 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
19667 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
19668 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
19669 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
19670 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
19671 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
19672 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
19673 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
19674 IF(THA.LT.CKIN(35)) MINT(51)=1
19675 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
19676 IF(UHA.LT.CKIN(37)) MINT(51)=1
19677 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
19679 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
19680 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
19681 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
19684 C...Additional cuts on W2 (approximately) in DIS.
19685 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
19687 IF(IABS(MINT(12)).LT.20) XBJ=X1
19689 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
19690 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
19691 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
19694 ELSEIF(ILIM.EQ.1) THEN
19695 C...Calculate limits on tau
19696 C...0) due to definition
19699 C...1) due to limits on subsystem mass
19700 TAUMN1=CKIN(1)**2/VINT(2)
19702 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
19703 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
19704 TM3=SQRT(SQM3+PTHMIN**2)
19705 TM4=SQRT(SQM4+PTHMIN**2)
19707 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
19708 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
19710 C...3) due to limits on pT-hat and cos(theta-hat)
19711 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
19712 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
19714 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
19715 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
19716 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
19718 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
19719 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
19720 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
19721 C...4) due to limits on x1 and x2
19722 TAUMN4=CKIN(21)*CKIN(23)
19723 TAUMX4=CKIN(22)*CKIN(24)
19724 C...5) due to limits on xF
19726 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
19727 C...6) due to limits on that and uhat
19728 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
19730 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
19731 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
19733 C...Net effect of all separate limits.
19734 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
19735 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
19736 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19739 ELSEIF(MINT(47).EQ.5) THEN
19740 VINT(31)=MIN(VINT(31),1D0-2D-10)
19741 ELSEIF(MINT(47).GE.6) THEN
19742 VINT(31)=MIN(VINT(31),1D0-1D-10)
19744 IF(VINT(31).LE.VINT(11)) MINT(51)=1
19746 ELSEIF(ILIM.EQ.2) THEN
19747 C...Calculate limits on y*
19749 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
19751 C...0) due to kinematics
19754 C...1) due to explicit limits
19757 C...2) due to limits on x1
19758 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
19759 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
19760 C...3) due to limits on x2
19761 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
19762 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
19763 C...4) due to limits on xF
19764 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
19765 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
19766 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
19767 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
19768 C...5) due to simultaneous limits on y-large and y-small
19769 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
19770 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
19771 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
19772 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
19773 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
19774 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
19775 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
19777 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
19778 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
19779 RZMX=BE34*MIN(CKIN(28),CTHLIM)
19780 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
19781 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
19782 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
19783 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
19784 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
19785 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
19787 C...Net effect of all separate limits.
19788 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
19789 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
19790 IF(MINT(47).EQ.1) THEN
19793 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
19794 VINT(12)=(1D0-1D-9)*YSTMX0
19795 VINT(32)=(1D0+1D-9)*YSTMX0
19796 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
19797 VINT(12)=-(1D0+1D-9)*YSTMX0
19798 VINT(32)=-(1D0-1D-9)*YSTMX0
19799 ELSEIF(MINT(47).EQ.5) THEN
19800 YSTEE=LOG((1D0-1D-10)/TAURT)
19801 VINT(12)=MAX(VINT(12),-YSTEE)
19802 VINT(32)=MIN(VINT(32),YSTEE)
19804 IF(VINT(32).LE.VINT(12)) MINT(51)=1
19806 ELSEIF(ILIM.EQ.3) THEN
19807 C...Calculate limits on cos(theta-hat)
19809 C...0) due to definition
19814 C...1) due to explicit limits
19815 CTNMN1=MIN(0D0,CKIN(27))
19816 CTNMX1=MIN(0D0,CKIN(28))
19817 CTPMN1=MAX(0D0,CKIN(27))
19818 CTPMX1=MAX(0D0,CKIN(28))
19819 C...2) due to limits on pT-hat
19820 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
19824 IF(CKIN(4).GE.0D0) THEN
19825 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
19826 & (BE34**2*TAU*VINT(2))))
19829 C...3) due to limits on y-large and y-small
19830 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
19831 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
19832 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
19833 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
19834 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
19835 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
19836 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
19837 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
19838 C...4) due to limits on that
19844 IF(CKIN(35).GT.0D0) THEN
19845 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
19846 IF(CTLIM.GT.0D0) THEN
19853 IF(CKIN(36).GT.0D0) THEN
19854 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
19855 IF(CTLIM.LT.0D0) THEN
19862 C...5) due to limits on uhat
19867 IF(CKIN(37).GT.0D0) THEN
19868 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
19869 IF(CTLIM.LT.0D0) THEN
19876 IF(CKIN(38).GT.0D0) THEN
19877 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
19878 IF(CTLIM.GT.0D0) THEN
19886 C...Net effect of all separate limits.
19887 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
19888 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
19889 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
19890 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
19891 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
19893 ELSEIF(ILIM.EQ.4) THEN
19894 C...Calculate limits on tau'
19895 C...0) due to kinematics
19897 IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
19898 PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
19899 TAPMN0=(SQRT(TAU)+PQRAT)**2
19902 C...1) due to explicit limits
19903 TAPMN1=CKIN(31)**2/VINT(2)
19905 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
19907 C...Net effect of all separate limits.
19908 VINT(16)=MAX(TAPMN0,TAPMN1)
19909 VINT(36)=MIN(TAPMX0,TAPMX1)
19910 IF(MINT(47).EQ.1) THEN
19913 ELSEIF(MINT(47).EQ.5) THEN
19914 VINT(36)=MIN(VINT(36),1D0-2D-10)
19915 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
19916 VINT(36)=MIN(VINT(36),1D0-1D-10)
19918 IF(VINT(36).LE.VINT(16)) MINT(51)=1
19923 C...Special case for low-pT and multiple interactions:
19924 C...effective kinematical limits for tau, y*, cos(theta-hat).
19925 100 IF(ILIM.EQ.0) THEN
19926 ELSEIF(ILIM.EQ.1) THEN
19927 IF(MSTP(82).LE.1) THEN
19928 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19931 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
19934 ELSEIF(ILIM.EQ.2) THEN
19935 VINT(12)=0.5D0*LOG(VINT(21))
19937 ELSEIF(ILIM.EQ.3) THEN
19938 IF(MSTP(82).LE.1) THEN
19939 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
19940 & (VINT(21)*VINT(2))
19942 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19943 & (VINT(21)*VINT(2))
19945 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
19954 C*********************************************************************
19957 C...Maps a uniform distribution into a distribution of a kinematical
19958 C...variable according to one of the possibilities allowed. It is
19959 C...assumed that kinematical limits have been set by a PYKLIM call.
19961 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
19963 C...Double precision and integer declarations.
19964 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19965 IMPLICIT INTEGER(I-N)
19966 INTEGER PYK,PYCHGE,PYCOMP
19968 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19969 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19970 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19971 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19972 COMMON/PYINT1/MINT(400),VINT(400)
19973 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19974 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
19976 C...Convert VVAR to tau variable.
19982 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
19985 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
19989 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
19991 ELSEIF(MVAR.EQ.1) THEN
19992 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
19993 ELSEIF(MVAR.EQ.2) THEN
19994 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
19995 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
19996 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
19997 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
19998 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
19999 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
20000 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
20001 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
20002 ELSEIF(MINT(47).EQ.5) THEN
20003 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
20004 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
20005 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20007 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
20008 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
20009 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20011 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
20013 C...Convert VVAR to y* variable.
20014 ELSEIF(IVAR.EQ.2) THEN
20018 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
20019 IF(MINT(47).EQ.1) THEN
20021 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
20022 YST=-0.5D0*LOG(TAUE)
20023 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
20024 YST=0.5D0*LOG(TAUE)
20025 ELSEIF(MVAR.EQ.1) THEN
20026 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
20027 ELSEIF(MVAR.EQ.2) THEN
20028 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
20029 ELSEIF(MVAR.EQ.3) THEN
20030 AUPP=ATAN(EXP(YSTMAX))
20031 ALOW=ATAN(EXP(YSTMIN))
20032 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
20033 ELSEIF(MVAR.EQ.4) THEN
20034 YST0=-0.5D0*LOG(TAUE)
20035 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
20036 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
20037 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
20039 YST0=-0.5D0*LOG(TAUE)
20040 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
20041 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
20042 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
20044 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
20046 C...Convert VVAR to cos(theta-hat) variable.
20047 ELSEIF(IVAR.EQ.3) THEN
20048 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
20050 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
20051 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
20059 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20060 VCTN=VVAR*(ANEG+APOS)/ANEG
20061 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
20063 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20064 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
20066 ELSEIF(MVAR.EQ.2) THEN
20067 RMNMIN=MAX(RM34,RSQM-CTNMIN)
20068 RMNMAX=MAX(RM34,RSQM-CTNMAX)
20069 RMPMIN=MAX(RM34,RSQM-CTPMIN)
20070 RMPMAX=MAX(RM34,RSQM-CTPMAX)
20071 ANEG=LOG(RMNMIN/RMNMAX)
20072 APOS=LOG(RMPMIN/RMPMAX)
20073 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20074 VCTN=VVAR*(ANEG+APOS)/ANEG
20075 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
20077 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20078 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
20080 ELSEIF(MVAR.EQ.3) THEN
20081 RMNMIN=MAX(RM34,RSQM+CTNMIN)
20082 RMNMAX=MAX(RM34,RSQM+CTNMAX)
20083 RMPMIN=MAX(RM34,RSQM+CTPMIN)
20084 RMPMAX=MAX(RM34,RSQM+CTPMAX)
20085 ANEG=LOG(RMNMAX/RMNMIN)
20086 APOS=LOG(RMPMAX/RMPMIN)
20087 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20088 VCTN=VVAR*(ANEG+APOS)/ANEG
20089 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
20091 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20092 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
20094 ELSEIF(MVAR.EQ.4) THEN
20095 RMNMIN=MAX(RM34,RSQM-CTNMIN)
20096 RMNMAX=MAX(RM34,RSQM-CTNMAX)
20097 RMPMIN=MAX(RM34,RSQM-CTPMIN)
20098 RMPMAX=MAX(RM34,RSQM-CTPMAX)
20099 ANEG=1D0/RMNMAX-1D0/RMNMIN
20100 APOS=1D0/RMPMAX-1D0/RMPMIN
20101 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20102 VCTN=VVAR*(ANEG+APOS)/ANEG
20103 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
20105 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20106 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
20108 ELSEIF(MVAR.EQ.5) THEN
20109 RMNMIN=MAX(RM34,RSQM+CTNMIN)
20110 RMNMAX=MAX(RM34,RSQM+CTNMAX)
20111 RMPMIN=MAX(RM34,RSQM+CTPMIN)
20112 RMPMAX=MAX(RM34,RSQM+CTPMAX)
20113 ANEG=1D0/RMNMIN-1D0/RMNMAX
20114 APOS=1D0/RMPMIN-1D0/RMPMAX
20115 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
20116 VCTN=VVAR*(ANEG+APOS)/ANEG
20117 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
20119 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
20120 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
20123 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
20124 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
20127 C...Convert VVAR to tau' variable.
20128 ELSEIF(IVAR.EQ.4) THEN
20132 IF(MINT(47).EQ.1) THEN
20134 ELSEIF(MVAR.EQ.1) THEN
20135 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
20136 ELSEIF(MVAR.EQ.2) THEN
20137 AUPP=(1D0-TAU/TAUPMX)**4
20138 ALOW=(1D0-TAU/TAUPMN)**4
20139 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
20140 ELSEIF(MINT(47).EQ.5) THEN
20141 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
20142 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
20143 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20145 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
20146 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
20147 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
20149 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
20151 C...Selection of extra variables needed in 2 -> 3 process:
20152 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
20153 C...Since no options are available, the functions of PYKLIM
20154 C...and PYKMAP are joint for these choices.
20155 ELSEIF(IVAR.EQ.5) THEN
20157 C...Read out total energy and particle masses.
20160 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
20161 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
20163 SHP=VINT(26)*VINT(2)
20167 PM3=SQRT(VINT(21))*VINT(1)
20168 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
20175 C...Specify coefficients of pT choice; upper and lower limits.
20176 IF(MPTPK.EQ.1) THEN
20184 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
20186 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
20188 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
20190 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
20193 C...Select transverse momenta according to
20194 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
20197 IF(HMX.LT.1.0001D0*HMN) THEN
20203 IF(RPT.LT.HWT1) THEN
20204 PTS1=PTSMN1+PYR(0)*HDE
20205 ELSEIF(RPT.LT.HWT1+HWT2) THEN
20206 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
20208 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
20210 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
20211 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
20214 IF(HMX.LT.1.0001D0*HMN) THEN
20220 IF(RPT.LT.HWT1) THEN
20221 PTS2=PTSMN2+PYR(0)*HDE
20222 ELSEIF(RPT.LT.HWT1+HWT2) THEN
20223 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
20225 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
20227 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
20228 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
20230 C...Select azimuthal angles and check pT choice.
20231 PHI1=PARU(2)*PYR(0)
20232 PHI2=PARU(2)*PYR(0)
20234 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
20235 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
20236 & CKIN(56)**2)) THEN
20241 C...Calculate transverse masses and check phase space not closed.
20248 PM12=(PMT1+PMT2)**2
20249 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
20254 C...Select rapidity for particle 3 and check phase space not closed.
20255 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
20256 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
20257 IF(Y3MAX.LT.1D-6) THEN
20261 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
20265 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
20268 PMS12=PE12**2-PZ12**2
20269 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
20270 IF(SQL12.LT.1D-6*SHP) THEN
20274 PMM1=PMS12+PMS1-PMS2
20275 PMM2=PMS12+PMS2-PMS1
20276 TFAC=-SHPR/(2D0*PMS12)
20277 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
20278 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
20279 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
20280 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
20282 C...Construct relative mirror weights and make choice.
20283 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
20287 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
20288 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
20290 WTP=WTPU/(WTPU+WTNU)
20291 WTN=WTNU/(WTPU+WTNU)
20293 IF(WTN.GT.PYR(0)) EPS=-1D0
20295 C...Store result of variable choice and associated weights.
20305 IF(EPS.GT.0D0) THEN
20314 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
20315 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
20316 VINT(219)=0.5D0*(PMS12-PTS3)
20323 C***********************************************************************
20326 C...Differential matrix elements for all included subprocesses
20327 C...Note that what is coded is (disregarding the COMFAC factor)
20328 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
20329 C...when d(sigma-hat) is given in the zero-width limit, the delta
20330 C...function in tau is replaced by a (modified) Breit-Wigner:
20331 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
20332 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
20333 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
20334 C...i.e., dimensionless quantities
20335 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
20336 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
20337 C...(2pi)^4 delta^4(P - sum p_i)
20338 C...COMFAC contains the factor pi/s (or equivalent) and
20339 C...the conversion factor from GeV^-2 to mb
20341 SUBROUTINE PYSIGH(NCHN,SIGS)
20343 C...Double precision and integer declarations
20344 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20345 IMPLICIT INTEGER(I-N)
20346 INTEGER PYK,PYCHGE,PYCOMP
20347 C...Parameter statement to help give large particle numbers.
20348 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
20349 &KEXCIT=4000000,KDIMEN=5000000)
20351 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20352 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20353 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20354 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20355 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20356 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20357 COMMON/PYINT1/MINT(400),VINT(400)
20358 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20359 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20360 COMMON/PYINT4/MWID(500),WIDS(500,5)
20361 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20362 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20363 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
20364 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
20365 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
20366 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
20367 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
20368 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
20369 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
20370 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
20371 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20372 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
20373 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYSGCM/
20374 C...Local arrays and complex variables
20375 DIMENSION X(2),XPQ(-25:25)
20377 C...Map of processes onto which routine to call
20378 C...in order to evaluate cross section:
20379 C...0 = not implemented;
20380 C...1 = standard QCD (including photons);
20381 C...2 = heavy flavours;
20383 C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
20385 C...6 = Technicolor;
20386 C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
20387 DIMENSION MAPPR(500)
20388 DATA (MAPPR(I),I=1,180)/
20389 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
20390 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
20391 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
20392 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
20393 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
20394 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
20395 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
20396 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
20397 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
20398 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
20399 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
20400 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
20401 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
20402 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
20403 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
20404 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
20405 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
20406 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
20407 DATA (MAPPR(I),I=181,500)/
20408 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
20409 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
20411 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
20413 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
20414 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
20415 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
20416 7 6, 6, 6, 6, 6, 6, 6, 0, 0, 0,
20417 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
20418 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
20421 C...Reset number of channels and cross-section
20425 C...Read process to consider.
20430 C...Read kinematical variables and limits
20448 C...Derive kinematical quantities
20450 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
20451 X(1)=SQRT(TAUE)*EXP(YST)
20452 X(2)=SQRT(TAUE)*EXP(-YST)
20453 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
20454 IF(X(1).GT.1D0-1D-7) RETURN
20455 ELSEIF(MINT(45).EQ.3) THEN
20456 X(1)=MIN(1D0-1.1D-10,X(1))
20458 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
20459 IF(X(2).GT.1D0-1D-7) RETURN
20460 ELSEIF(MINT(46).EQ.3) THEN
20461 X(2)=MIN(1D0-1.1D-10,X(2))
20463 SH=MAX(1D0,TAU*VINT(2))
20468 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
20469 RPTS=4D0*VINT(71)**2/SH
20470 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
20471 RM34=MAX(1D-20,2D0*RM3*RM4)
20473 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
20474 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
20475 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
20476 IF(ISTSB.EQ.0) THEN
20478 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
20479 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
20481 C...Kinematics with incoming masses tricky: now depends on how
20482 C...subprocess has been set up w.r.t. order of incoming partons.
20484 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
20486 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
20487 IF(ISUB.EQ.35) THEN
20491 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
20492 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
20493 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
20495 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
20497 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
20504 C...Choice of Q2 scale: hard, parton distributions, parton showers
20505 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
20507 ELSEIF(ISTSB.EQ.8) THEN
20508 IF(MINT(107).EQ.4) Q2=VINT(307)
20509 IF(MINT(108).EQ.4) Q2=VINT(308)
20510 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
20512 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
20514 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
20515 IF(MSTP(32).EQ.1) THEN
20516 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
20517 ELSEIF(MSTP(32).EQ.2) THEN
20518 Q2=SQPTH+0.5D0*(SQM3+SQM4)
20519 ELSEIF(MSTP(32).EQ.3) THEN
20521 ELSEIF(MSTP(32).EQ.4) THEN
20523 ELSEIF(MSTP(32).EQ.5) THEN
20525 ELSEIF(MSTP(32).EQ.6) THEN
20527 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
20529 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
20530 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
20531 & (SQPTH+0.5D0*(SQM3+SQM4))
20532 ELSEIF(MSTP(32).EQ.7) THEN
20533 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
20534 ELSEIF(MSTP(32).EQ.8) THEN
20535 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
20536 ELSEIF(MSTP(32).EQ.9) THEN
20537 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
20538 ELSEIF(MSTP(32).EQ.10) THEN
20541 IF(ISTSB.EQ.9) Q2=SQPTH
20542 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
20543 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
20546 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20548 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
20549 & ISUB.EQ.351) Q2SF=PMAS(24,1)**2
20550 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
20551 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
20552 & ISUB.EQ.186.OR.ISUB.EQ.187) THEN
20553 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
20554 IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
20555 IF(MSTP(39).EQ.3) Q2SF=SH
20556 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
20557 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
20562 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
20563 IF(MSTP(69).GE.2) Q2SF=VINT(2)
20564 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
20565 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20567 IF(MINT(43).EQ.3) XBJ=X(1)
20568 IF(MSTP(22).EQ.1) THEN
20570 ELSEIF(MSTP(22).EQ.2) THEN
20571 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
20572 ELSEIF(MSTP(22).EQ.3) THEN
20573 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
20575 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
20578 IF(MSTP(68).EQ.1.AND.(ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.
20579 &ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
20580 &ISUBSV.EQ.144.OR.ISUBSV.EQ.152.OR.ISUBSV.EQ.157)) THEN
20582 ELSEIF(MSTP(68).GE.2.AND.(ISUBSV.NE.11.AND.ISUBSV.NE.12.AND.
20583 &ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.ISUBSV.NE.53.AND.
20584 &ISUBSV.NE.68)) THEN
20588 C...Store derived kinematical quantities
20595 IF(ISTSB.NE.8) VINT(48)=SQPTH
20596 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
20597 VINT(50)=TAUP*VINT(2)
20598 VINT(49)=SQRT(MAX(0D0,VINT(50)))
20602 VINT(53)=SQRT(Q2SF)
20604 VINT(55)=SQRT(Q2PS)
20606 C...Calculate parton distributions
20607 IF(ISTSB.LE.0) GOTO 160
20608 IF(MINT(47).GE.2) THEN
20609 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
20611 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
20612 IF(ISUB.EQ.99) THEN
20613 IF(MINT(140+I).EQ.0) THEN
20614 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
20616 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
20621 MINT(105)=MINT(102+I)
20622 MINT(109)=MINT(106+I)
20623 VINT(120)=VINT(2+I)
20625 C.... Store side in MINT(124)
20628 IF(MSTP(57).LE.1) THEN
20629 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
20631 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
20634 XSFX(I,KFL)=XPQ(KFL)
20639 C...Calculate alpha_em, alpha_strong and K-factor
20642 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
20643 &1D0-(PMAS(24,1)/PMAS(23,1))**2
20645 XWC=1D0/(16D0*XW*XW1)
20647 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
20648 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
20651 IF(MSTP(33).EQ.1) THEN
20653 ELSEIF(MSTP(33).EQ.2) THEN
20655 FACA=PARP(32)/PARP(31)
20656 ELSEIF(MSTP(33).EQ.3) THEN
20658 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
20659 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
20666 C...Set flags for allowed reacting partons/leptons
20671 IF(MINT(44+I).EQ.1) THEN
20672 KFAC(I,MINT(10+I))=1
20673 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
20674 KFAC(I,MINT(10+I))=1
20680 KFAC(I,J)=KFIN(I,J)
20681 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
20682 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
20687 C...Lower and upper limit for fermion flavour loops
20693 IF(KFAC(1,-J).EQ.1) MMIN1=-J
20694 IF(KFAC(1,J).EQ.1) MMAX1=J
20695 IF(KFAC(2,-J).EQ.1) MMIN2=-J
20696 IF(KFAC(2,J).EQ.1) MMAX2=J
20698 MMINA=MIN(MMIN1,MMIN2)
20699 MMAXA=MAX(MMAX1,MMAX2)
20701 C...Common resonance mass and width combinations
20704 GMMZ=PMAS(23,1)*PMAS(23,2)
20705 GMMW=PMAS(24,1)*PMAS(24,2)
20707 C...Polarization factors...implemented so far for W+W-(25)
20708 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
20709 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
20710 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
20711 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
20713 C...Phase space integral in tau
20714 COMFAC=PARU(1)*PARU(5)/VINT(2)
20715 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
20716 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
20717 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
20718 ATAU1=LOG(TAUMAX/TAUMIN)
20719 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
20720 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
20721 IF(MINT(72).GE.1) THEN
20724 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
20726 IF(ATAUD.GT.1D-10) H1=H1+
20727 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
20728 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
20730 IF(ATAUD.GT.1D-10) H1=H1+
20731 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
20733 IF(MINT(72).EQ.2) THEN
20736 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
20738 IF(ATAUD.GT.1D-10) H1=H1+
20739 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
20740 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
20742 IF(ATAUD.GT.1D-10) H1=H1+
20743 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
20745 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20746 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
20747 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20748 & MAX(2D-10,1D0-TAU)
20749 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
20750 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
20751 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
20752 & MAX(1D-10,1D0-TAU)
20754 COMFAC=COMFAC*ATAU1/(TAU*H1)
20757 C...Phase space integral in y*
20758 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
20760 AYST0=YSTMAX-YSTMIN
20761 IF(AYST0.LT.1D-10) THEN
20764 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20766 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20767 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20768 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20769 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20770 IF(MINT(45).EQ.3) THEN
20771 YST0=-0.5D0*LOG(TAUE)
20772 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
20773 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
20774 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
20775 & MAX(1D-10,1D0-EXP(YST-YST0))
20777 IF(MINT(46).EQ.3) THEN
20778 YST0=-0.5D0*LOG(TAUE)
20779 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
20780 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
20781 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
20782 & MAX(1D-10,1D0-EXP(-YST-YST0))
20784 COMFAC=COMFAC*AYST0/H2
20788 C...2 -> 1 processes: reduction in angular part of phase space integral
20789 C...for case of decaying resonance
20790 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
20791 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
20792 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
20793 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
20794 & KFPR(ISUB,1).EQ.39) THEN
20795 COMFAC=COMFAC*0.5D0*ACTH0
20797 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
20798 & CTPMAX**3-CTPMIN**3)
20802 C...2 -> 2 processes: angular part of phase space integral
20803 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
20804 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
20805 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
20806 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
20807 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
20808 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
20809 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
20810 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
20811 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
20812 H3=COEF(ISUBSV,13)+
20813 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
20814 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
20815 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
20816 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
20817 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
20819 C...2 -> 2 processes: take into account final state Breit-Wigners
20820 COMFAC=COMFAC*VINT(80)
20823 C...2 -> 3, 4 processes: phace space integral in tau'
20824 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
20825 ATAUP1=LOG(TAUPMX/TAUPMN)
20826 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
20827 H4=COEF(ISUBSV,18)+
20828 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
20829 IF(MINT(47).EQ.5) THEN
20830 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
20831 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
20832 ELSEIF(MINT(47).GE.6) THEN
20833 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
20834 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
20836 COMFAC=COMFAC*ATAUP1/H4
20839 C...2 -> 3, 4 processes: effective W/Z parton distributions
20840 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
20841 IF(1D0-TAU/TAUP.GT.1D-4) THEN
20842 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
20844 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
20849 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
20850 IF(ISTSB.EQ.5) THEN
20851 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
20852 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
20855 C...Phase space integral for low-pT and multiple interactions
20856 IF(ISTSB.EQ.9) THEN
20857 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
20858 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
20859 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
20860 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
20861 COMFAC=COMFAC*ATAU1/H1
20862 AYST0=YSTMAX-YSTMIN
20863 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
20864 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
20865 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
20866 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
20867 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
20868 COMFAC=COMFAC*AYST0/H2
20869 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
20870 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
20871 C...introduced to make cross-section finite for xT2 -> 0
20872 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
20876 C...Real gamma + gamma: include factor 2 when different nature
20877 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
20878 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
20880 C...Extra factors to include the effects of
20881 C...longitudinal resolved photons (but not direct or DIS ones).
20883 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
20884 & MINT(106+ISDE).LE.3) THEN
20887 IF(MSTP(16).EQ.0) THEN
20888 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
20889 & XY=VINT(304+ISDE)
20891 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
20892 & XY=VINT(308+ISDE)
20894 Q2GA=VINT(306+ISDE)
20895 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
20896 & Q2GA.GT.0D0) THEN
20898 IF(MSTP(17).EQ.1) THEN
20899 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
20900 ELSEIF(MSTP(17).EQ.2) THEN
20901 REDUCE=4D0*Q2GA/(Q2+Q2GA)
20902 ELSEIF(MSTP(17).EQ.3) THEN
20903 PMVIRT=PMAS(PYCOMP(113),1)
20904 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20905 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
20906 PMVIRT=PMAS(PYCOMP(113),1)
20907 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20908 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
20909 PMVIRT=PMAS(PYCOMP(113),1)
20910 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
20911 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
20912 PMVSMN=4D0*PARP(15)**2
20913 PMVSMX=4D0*VINT(154)**2
20914 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20915 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
20916 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
20917 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
20918 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
20919 PMVIRT=PMAS(PYCOMP(113),1)
20920 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20921 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
20922 PMVIRT=PMAS(PYCOMP(113),1)
20923 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
20924 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
20925 PMVSMN=4D0*PARP(15)**2
20926 PMVSMX=4D0*VINT(154)**2
20927 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
20928 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
20929 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
20932 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
20933 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
20934 & (1D0-2D0*BEAMAS**2/Q2GA))
20935 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
20940 COMFAC=COMFAC*VINT(314+ISDE)
20943 C...Evaluate cross sections - done in separate routines by kind
20944 C...of physics, to keep PYSIGH of sensible size.
20946 C...Standard QCD (including photons).
20947 CALL PYSGQC(NCHN,SIGS)
20948 ELSEIF(MAP.EQ.2) THEN
20949 C...Heavy flavours.
20950 CALL PYSGHF(NCHN,SIGS)
20951 ELSEIF(MAP.EQ.3) THEN
20953 CALL PYSGWZ(NCHN,SIGS)
20954 ELSEIF(MAP.EQ.4) THEN
20955 C...Higgs (2 doublets; including longitudinal W/Z scattering).
20956 CALL PYSGHG(NCHN,SIGS)
20957 ELSEIF(MAP.EQ.5) THEN
20959 CALL PYSGSU(NCHN,SIGS)
20960 ELSEIF(MAP.EQ.6) THEN
20962 CALL PYSGTC(NCHN,SIGS)
20963 ELSEIF(MAP.EQ.7) THEN
20964 C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
20965 CALL PYSGEX(NCHN,SIGS)
20968 C...Multiply with parton distributions
20969 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
20971 IF(MINT(45).GE.2) THEN
20973 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
20975 IF(MINT(46).GE.2) THEN
20977 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
20979 SIGS=SIGS+SIGH(ICHN)
20986 C*********************************************************************
20989 C...Subprocess cross sections for QCD processes,
20990 C...including photons.
20991 C...Auxiliary to PYSIGH.
20993 SUBROUTINE PYSGQC(NCHN,SIGS)
20995 C...Double precision and integer declarations
20996 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20997 IMPLICIT INTEGER(I-N)
20998 INTEGER PYK,PYCHGE,PYCOMP
20999 C...Parameter statement to help give large particle numbers.
21000 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
21001 &KEXCIT=4000000,KDIMEN=5000000)
21003 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21004 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21005 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
21006 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21007 COMMON/PYINT1/MINT(400),VINT(400)
21008 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
21009 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
21010 COMMON/PYINT4/MWID(500),WIDS(500,5)
21011 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
21012 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
21013 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
21014 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
21015 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
21016 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
21017 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
21019 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
21021 C...Differential cross section expressions.
21023 IF(ISUB.LE.20) THEN
21024 IF(ISUB.EQ.10) THEN
21025 C...f + f' -> f + f' (gamma/Z/W exchange)
21026 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
21027 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
21028 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
21029 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
21030 DO 110 I=MMIN1,MMAX1
21031 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
21033 DO 100 J=MMIN2,MMAX2
21034 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
21036 C...Electroweak couplings
21037 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
21038 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
21040 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
21041 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
21044 C...gamma/Z exchange, only gamma exchange, or only Z exchange
21045 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
21046 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
21047 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
21048 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
21049 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
21050 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21051 ELSEIF(MSTP(21).EQ.2) THEN
21052 FACNCF=FACGGF*EI**2*EJ**2
21054 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
21055 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
21057 C...Extrafactor 2 for only one incoming neutrino spin state.
21058 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
21059 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
21067 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
21068 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
21069 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
21070 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
21071 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
21081 ELSEIF(ISUB.EQ.11) THEN
21082 C...f + f' -> f + f' (g exchange)
21083 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
21084 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
21085 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
21086 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
21087 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
21088 DO 130 I=MMIN1,MMAX1
21090 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
21091 DO 120 J=MMIN2,MMAX2
21093 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
21099 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
21101 SIGH(NCHN)=0.5D0*SIGH(NCHN)
21106 SIGH(NCHN)=0.5D0*FACQQ2
21111 ELSEIF(ISUB.EQ.12) THEN
21112 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
21113 CALL PYWIDT(21,SH,WDTP,WDTE)
21114 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
21115 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
21116 DO 140 I=MMINA,MMAXA
21117 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21118 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
21126 ELSEIF(ISUB.EQ.13) THEN
21127 C...f + fbar -> g + g (q + qbar -> g + g only)
21128 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21130 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21132 DO 150 I=MMINA,MMAXA
21133 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21134 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
21139 SIGH(NCHN)=0.5D0*FACGG1
21144 SIGH(NCHN)=0.5D0*FACGG2
21147 ELSEIF(ISUB.EQ.14) THEN
21148 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
21149 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
21150 DO 160 I=MMINA,MMAXA
21151 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21152 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
21153 EI=KCHG(IABS(I),1)/3D0
21158 SIGH(NCHN)=FACGG*EI**2
21161 ELSEIF(ISUB.EQ.18) THEN
21162 C...f + fbar -> gamma + gamma
21163 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
21164 DO 170 I=MMINA,MMAXA
21165 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
21166 EI=KCHG(IABS(I),1)/3D0
21168 IF(IABS(I).LE.10) FCOI=FACA/3D0
21173 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
21177 ELSEIF(ISUB.LE.40) THEN
21178 IF(ISUB.EQ.28) THEN
21179 C...f + g -> f + g (q + g -> q + g only)
21180 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
21182 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
21184 DO 190 I=MMINA,MMAXA
21185 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
21187 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
21188 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
21191 ISIG(NCHN,3-ISDE)=21
21196 ISIG(NCHN,3-ISDE)=21
21202 ELSEIF(ISUB.EQ.29) THEN
21203 C...f + g -> f + gamma (q + g -> q + gamma only)
21204 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
21205 DO 210 I=MMINA,MMAXA
21206 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
21207 EI=KCHG(IABS(I),1)/3D0
21210 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
21211 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
21214 ISIG(NCHN,3-ISDE)=21
21220 ELSEIF(ISUB.EQ.33) THEN
21221 C...f + gamma -> f + g (q + gamma -> q + g only)
21222 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
21223 DO 230 I=MMINA,MMAXA
21224 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
21225 EI=KCHG(IABS(I),1)/3D0
21228 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
21229 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
21232 ISIG(NCHN,3-ISDE)=22
21238 ELSEIF(ISUB.EQ.34) THEN
21239 C...f + gamma -> f + gamma
21240 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
21241 DO 250 I=MMINA,MMAXA
21242 IF(I.EQ.0) GOTO 250
21243 EI=KCHG(IABS(I),1)/3D0
21246 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
21247 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
21250 ISIG(NCHN,3-ISDE)=22
21257 ELSEIF(ISUB.LE.80) THEN
21258 IF(ISUB.EQ.53) THEN
21259 C...g + g -> f + fbar (g + g -> q + qbar only)
21260 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
21262 C...Begin by d, u, s flavours.
21264 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
21265 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
21266 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
21267 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
21268 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
21269 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
21270 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21271 & UH2/SH2)*FLAVWT*FACA
21272 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21273 & TH2/SH2)*FLAVWT*FACA
21284 C...Next c and b flavours: modified that and uhat for fixed
21285 C...cos(theta-hat).
21287 SQMAVG=PMAS(IFL,1)**2
21288 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
21289 BE34=SQRT(1D0-4D0*SQMAVG/SH)
21290 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21291 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21292 THUHQ=THQ*UHQ-SQMAVG*SH
21293 IF(MSTP(34).EQ.0) THEN
21294 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
21295 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
21297 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21298 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
21299 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21300 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
21302 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
21303 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
21307 ISIG(NCHN,3)=1+2*(IFL-3)
21312 ISIG(NCHN,3)=2+2*(IFL-3)
21318 ELSEIF(ISUB.EQ.54) THEN
21319 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
21320 CALL PYWIDT(21,SH,WDTP,WDTE)
21322 DO 280 I=1,MIN(8,MDCY(21,3))
21324 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21327 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
21328 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
21335 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
21343 ELSEIF(ISUB.EQ.58) THEN
21344 C...gamma + gamma -> f + fbar
21345 CALL PYWIDT(22,SH,WDTP,WDTE)
21347 DO 290 I=1,MIN(12,MDCY(22,3))
21348 IF(I.LE.8) EF= KCHG(I,1)/3D0
21349 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
21350 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21353 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
21354 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
21362 ELSEIF(ISUB.EQ.68) THEN
21364 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
21365 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
21367 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
21369 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
21375 SIGH(NCHN)=0.5D0*FACGG1
21380 SIGH(NCHN)=0.5D0*FACGG2
21385 SIGH(NCHN)=0.5D0*FACGG3
21388 ELSEIF(ISUB.EQ.80) THEN
21389 C...q + gamma -> q' + pi+/-
21390 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
21391 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
21392 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
21393 DELSH=UH*SQRT(ASSH*Q2FPSH)
21394 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
21395 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
21396 DELUH=SH*SQRT(ASUH*Q2FPUH)
21397 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
21398 IF(I.EQ.0) GOTO 320
21399 EI=KCHG(IABS(I),1)/3D0
21400 EJ=SIGN(1D0-ABS(EI),EI)
21402 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
21403 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
21406 ISIG(NCHN,3-ISDE)=22
21408 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
21413 ELSEIF(ISUB.LE.100) THEN
21414 IF(ISUB.EQ.91) THEN
21415 C...Elastic scattering
21416 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
21418 ELSEIF(ISUB.EQ.92) THEN
21419 C...Single diffractive scattering (first side, i.e. XB)
21420 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
21422 ELSEIF(ISUB.EQ.93) THEN
21423 C...Single diffractive scattering (second side, i.e. AX)
21424 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
21426 ELSEIF(ISUB.EQ.94) THEN
21427 C...Double diffractive scattering
21428 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
21430 ELSEIF(ISUB.EQ.95) THEN
21431 C...Low-pT scattering
21432 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
21434 ELSEIF(ISUB.EQ.96) THEN
21435 C...Multiple interactions: sum of QCD processes
21436 CALL PYWIDT(21,SH,WDTP,WDTE)
21438 C...q + q' -> q + q'
21439 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
21440 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
21441 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
21442 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
21443 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
21444 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
21446 IF(I.EQ.0) GOTO 340
21448 IF(J.EQ.0) GOTO 330
21454 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
21456 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
21461 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
21466 C...q + qbar -> q' + qbar' or g + g
21467 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
21468 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
21469 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21471 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21474 IF(I.EQ.0) GOTO 350
21484 SIGH(NCHN)=0.5D0*FACGG1
21489 SIGH(NCHN)=0.5D0*FACGG2
21493 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
21495 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
21498 IF(I.EQ.0) GOTO 370
21502 ISIG(NCHN,3-ISDE)=21
21507 ISIG(NCHN,3-ISDE)=21
21513 C...g + g -> q + qbar (only d, u, s)
21516 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
21517 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
21518 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
21519 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
21520 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
21521 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
21522 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
21523 & UH2/SH2)*FLAVWT*FACA
21524 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
21525 & TH2/SH2)*FLAVWT*FACA
21537 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
21540 SQMAVG=PMAS(IFL,1)**2
21541 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
21542 BE34=SQRT(1D0-4D0*SQMAVG/SH)
21543 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21544 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21545 THUHQ=THQ*UHQ-SQMAVG*SH
21546 IF(MSTP(34).EQ.0) THEN
21547 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
21548 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
21550 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21551 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
21552 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21553 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
21555 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
21556 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
21560 ISIG(NCHN,3)=531+2*(IFL-3)
21565 ISIG(NCHN,3)=532+2*(IFL-3)
21571 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
21572 & 2D0*TH/SH+TH2/SH2)*FACA
21573 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
21574 & 2D0*SH/UH+SH2/UH2)*FACA
21575 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
21576 & 2D0*UH/TH+UH2/TH2)
21581 SIGH(NCHN)=0.5D0*FACGG1
21586 SIGH(NCHN)=0.5D0*FACGG2
21591 SIGH(NCHN)=0.5D0*FACGG3
21593 ELSEIF(ISUB.EQ.99) THEN
21594 C...f + gamma* -> f.
21595 IF(MINT(107).EQ.4) THEN
21604 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
21605 PM2RHO=PMAS(PYCOMP(113),1)**2
21606 IF(MSTP(19).EQ.0) THEN
21608 ELSEIF(MSTP(19).EQ.1) THEN
21609 COMFAC=COMFAC/(Q2GA+PM2RHO)
21610 ELSEIF(MSTP(19).EQ.2) THEN
21611 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
21613 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
21615 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
21616 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
21617 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
21618 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
21620 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
21622 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
21624 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
21625 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
21627 DO 390 I=MMINA,MMAXA
21628 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
21629 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
21630 EI=KCHG(IABS(I),1)/3D0
21633 ISIG(NCHN,3-ISDE)=22
21635 SIGH(NCHN)=COMFAC*EI**2
21640 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
21641 C...g + g -> gamma + gamma or g + g -> g + gamma
21656 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
21658 EI=KCHG(IABS(I),1)/3D0
21660 IF(ISUB.EQ.115) EIWT=EI
21665 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
21666 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
21669 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
21670 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
21671 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
21672 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
21678 CALL PYWAUX(1,EPSS,W1SR,W1SI)
21679 CALL PYWAUX(1,EPST,W1TR,W1TI)
21680 CALL PYWAUX(1,EPSU,W1UR,W1UI)
21681 CALL PYWAUX(2,EPSS,W2SR,W2SI)
21682 CALL PYWAUX(2,EPST,W2TR,W2TI)
21683 CALL PYWAUX(2,EPSU,W2UR,W2UI)
21684 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
21685 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
21686 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
21687 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
21688 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
21689 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
21690 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
21691 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
21692 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
21693 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
21694 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
21695 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
21696 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
21697 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
21698 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
21699 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
21700 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
21701 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
21702 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
21703 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
21704 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
21705 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
21706 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
21707 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
21708 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
21709 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
21710 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
21711 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
21712 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
21713 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
21714 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
21715 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
21716 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
21717 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
21718 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
21719 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
21720 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
21721 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
21722 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
21723 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
21724 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
21725 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
21726 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
21727 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
21728 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
21729 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
21730 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
21731 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
21732 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
21733 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
21734 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
21735 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
21736 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
21737 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
21738 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
21739 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
21741 A0STUR=A0STUR+EIWT*B0STUR
21742 A0STUI=A0STUI+EIWT*B0STUI
21743 A0TSUR=A0TSUR+EIWT*B0TSUR
21744 A0TSUI=A0TSUI+EIWT*B0TSUI
21745 A0UTSR=A0UTSR+EIWT*B0UTSR
21746 A0UTSI=A0UTSI+EIWT*B0UTSI
21747 A1STUR=A1STUR+EIWT*B1STUR
21748 A1STUI=A1STUI+EIWT*B1STUI
21749 A2STUR=A2STUR+EIWT*B2STUR
21750 A2STUI=A2STUI+EIWT*B2STUI
21752 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
21753 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
21754 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
21755 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
21756 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
21761 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
21762 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
21765 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
21766 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
21768 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
21770 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
21772 IF(ISUB.EQ.131) THEN
21773 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
21774 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
21776 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
21778 DO 430 I=MMINA,MMAXA
21779 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
21780 EI=KCHG(IABS(I),1)/3D0
21783 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
21784 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
21787 ISIG(NCHN,3-ISDE)=22
21793 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
21794 C...f + gamma*_(T,L) -> f + gamma
21796 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
21798 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
21800 IF(ISUB.EQ.133) THEN
21801 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
21802 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
21804 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
21806 DO 450 I=MMINA,MMAXA
21807 IF(I.EQ.0) GOTO 450
21808 EI=KCHG(IABS(I),1)/3D0
21811 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
21812 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
21815 ISIG(NCHN,3-ISDE)=22
21821 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
21822 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
21824 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
21826 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
21828 CALL PYWIDT(21,SH,WDTP,WDTE)
21830 DO 460 I=1,MIN(8,MDCY(21,3))
21832 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21835 IF(ISUB.EQ.135) THEN
21836 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
21837 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
21839 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
21841 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
21848 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
21856 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
21857 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
21859 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
21861 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
21862 CALL PYWIDT(22,SH,WDTP,WDTE)
21864 DO 470 I=1,MIN(12,MDCY(22,3))
21865 IF(I.LE.8) EF= KCHG(I,1)/3D0
21866 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
21867 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
21870 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
21871 IF(ISUB.EQ.137) THEN
21872 FPARAM=-SH*(TH+UH)/DLAMB2
21873 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
21874 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
21875 & 2D0*PH1*PH2*FPARAM**2)
21876 ELSEIF(ISUB.EQ.138) THEN
21877 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
21878 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
21879 & 2D0*PH1**2*(TH-UH)**2)
21880 ELSEIF(ISUB.EQ.139) THEN
21881 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
21882 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
21883 & 2D0*PH2**2*(TH-UH)**2)
21885 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
21886 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
21888 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
21902 C*********************************************************************
21905 C...Subprocess cross sections for heavy flavour production,
21906 C...open and closed.
21907 C...Auxiliary to PYSIGH.
21909 SUBROUTINE PYSGHF(NCHN,SIGS)
21911 C...Double precision and integer declarations
21912 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21913 IMPLICIT INTEGER(I-N)
21914 INTEGER PYK,PYCHGE,PYCOMP
21915 C...Parameter statement to help give large particle numbers.
21916 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
21917 &KEXCIT=4000000,KDIMEN=5000000)
21919 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21920 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21921 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21922 COMMON/PYINT1/MINT(400),VINT(400)
21923 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
21924 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
21925 COMMON/PYINT4/MWID(500),WIDS(500,5)
21926 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
21927 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
21928 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
21929 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
21930 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
21933 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
21935 C...Differential cross section expressions.
21937 IF(ISUB.LE.100) THEN
21938 IF(ISUB.EQ.81) THEN
21939 C...q + qbar -> Q + Qbar
21940 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21941 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21942 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21943 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
21945 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
21947 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21948 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21950 DO 100 I=MMINA,MMAXA
21951 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
21952 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
21960 ELSEIF(ISUB.EQ.82) THEN
21961 C...g + g -> Q + Qbar
21962 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
21963 THQ=-0.5D0*SH*(1D0-BE34*CTH)
21964 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
21965 THUHQ=THQ*UHQ-SQMAVG*SH
21966 IF(MSTP(34).EQ.0) THEN
21967 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
21968 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
21970 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21971 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
21972 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
21973 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
21975 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
21976 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
21977 IF(MSTP(35).GE.1) THEN
21978 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
21979 FACQQ1=FACQQ1*FATRE
21980 FACQQ2=FACQQ2*FATRE
21983 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
21984 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
21987 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
22000 ELSEIF(ISUB.EQ.83) THEN
22001 C...f + q -> f' + Q
22002 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
22003 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
22004 DO 130 I=MMIN1,MMAX1
22005 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
22006 DO 120 J=MMIN2,MMAX2
22007 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
22008 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
22009 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
22010 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
22016 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
22017 & (IABS(I)+1)/2)*VINT(180+J)
22018 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
22019 & (MINT(55)+1)/2)*VINT(180+J)
22022 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
22023 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22026 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
22027 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22030 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
22031 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
22033 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
22039 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
22040 & (IABS(J)+1)/2)*VINT(180+I)
22041 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
22042 & (MINT(55)+1)/2)*VINT(180+I)
22044 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
22045 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22048 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
22049 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
22052 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
22053 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
22058 ELSEIF(ISUB.EQ.84) THEN
22059 C...g + gamma -> Q + Qbar
22060 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22061 THQ=-0.5D0*SH*(1D0-BE34*CTH)
22062 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
22063 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
22064 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
22066 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
22068 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
22069 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
22071 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
22078 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
22086 ELSEIF(ISUB.EQ.85) THEN
22087 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
22088 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22089 THQ=-0.5D0*SH*(1D0-BE34*CTH)
22090 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
22091 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
22092 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
22093 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
22094 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
22095 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
22096 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
22097 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
22099 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
22100 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
22101 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
22103 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
22111 ELSEIF(ISUB.EQ.86) THEN
22112 C...g + g -> J/Psi + g
22113 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
22114 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22115 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22116 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22124 ELSEIF(ISUB.EQ.87) THEN
22125 C...g + g -> chi_0c + g
22126 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
22127 QGTW=(SH*TH*UH)/SH**3
22129 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
22130 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
22131 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
22132 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
22133 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
22134 & (QGTW*(QGTW-RGTW*PGTW)**4)
22135 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22143 ELSEIF(ISUB.EQ.88) THEN
22144 C...g + g -> chi_1c + g
22145 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
22146 QGTW=(SH*TH*UH)/SH**3
22148 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
22149 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
22150 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
22151 & (QGTW-RGTW*PGTW)**4
22152 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22160 ELSEIF(ISUB.EQ.89) THEN
22161 C...g + g -> chi_2c + g
22162 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
22163 QGTW=(SH*TH*UH)/SH**3
22165 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
22166 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
22167 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
22168 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
22169 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
22170 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
22171 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22180 ELSEIF(ISUB.LE.200) THEN
22181 IF(ISUB.EQ.104) THEN
22182 C...g + g -> chi_c0.
22184 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
22185 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
22186 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
22187 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22195 ELSEIF(ISUB.EQ.105) THEN
22196 C...g + g -> chi_c2.
22198 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
22199 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
22200 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
22201 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22209 ELSEIF(ISUB.EQ.106) THEN
22210 C...g + g -> J/Psi + gamma.
22212 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
22213 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22214 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22215 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
22223 ELSEIF(ISUB.EQ.107) THEN
22224 C...g + gamma -> J/Psi + g.
22226 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
22227 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22228 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22229 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
22236 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
22244 ELSEIF(ISUB.EQ.108) THEN
22245 C...gamma + gamma -> J/Psi + gamma.
22247 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
22248 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
22249 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
22250 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
22263 C*********************************************************************
22266 C...Subprocess cross sections for W/Z processes,
22267 C...except that longitudinal WW scattering is in Higgs sector.
22268 C...Auxiliary to PYSIGH.
22270 SUBROUTINE PYSGWZ(NCHN,SIGS)
22272 C...Double precision and integer declarations
22273 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22274 IMPLICIT INTEGER(I-N)
22275 INTEGER PYK,PYCHGE,PYCOMP
22276 C...Parameter statement to help give large particle numbers.
22277 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
22278 &KEXCIT=4000000,KDIMEN=5000000)
22280 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22281 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22282 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
22283 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
22284 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22285 COMMON/PYINT1/MINT(400),VINT(400)
22286 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
22287 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
22288 COMMON/PYINT4/MWID(500),WIDS(500,5)
22289 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
22290 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
22291 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
22292 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
22293 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
22294 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
22295 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
22296 C...Local arrays and complex numbers
22297 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
22299 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
22301 C...Differential cross section expressions.
22303 IF(ISUB.LE.20) THEN
22305 C...f + fbar -> gamma*/Z0
22307 CALL PYWIDT(23,SH,WDTP,WDTE)
22309 FACZ=4D0*COMFAC*3D0
22312 DO 100 I=MMINA,MMAXA
22313 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
22314 EI=KCHG(IABS(I),1)/3D0
22318 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
22320 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
22325 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
22326 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
22327 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
22328 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
22331 ELSEIF(ISUB.EQ.2) THEN
22332 C...f + fbar' -> W+/-
22333 CALL PYWIDT(24,SH,WDTP,WDTE)
22335 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
22336 HP=AEM/(24D0*XW)*SH
22337 DO 120 I=MMIN1,MMAX1
22338 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
22340 DO 110 J=MMIN2,MMAX2
22341 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
22343 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
22344 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22346 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22348 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
22353 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
22354 SIGH(NCHN)=HI*FACBW*HF
22358 ELSEIF(ISUB.EQ.15) THEN
22359 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
22360 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22361 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22365 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22366 DO 130 I=1,MIN(16,MDCY(23,3))
22368 IF(MDME(IDC,1).LT.0) GOTO 130
22370 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22374 AF=SIGN(1D0,EF+0.1D0)
22376 ELSEIF(I.LE.16) THEN
22378 AF=SIGN(1D0,EF+0.1D0)
22381 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22382 IF(4D0*RM1.LT.1D0) THEN
22384 IF(I.LE.8) FCOF=3D0*RADC4
22385 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22387 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22388 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22389 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22390 & AF**2*(1D0-4D0*RM1))*BE34
22394 C...Propagators: as simulated in PYOFSH and as desired
22395 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22399 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22401 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22402 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22403 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22404 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22405 C...Loop over flavours; consider full gamma/Z structure
22406 DO 140 I=MMINA,MMAXA
22407 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
22408 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
22409 EI=KCHG(IABS(I),1)/3D0
22416 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
22417 & (VI**2+AI**2)*HFZZ)/HBW4
22420 ELSEIF(ISUB.EQ.16) THEN
22421 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
22422 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22423 C...Propagators: as simulated in PYOFSH and as desired
22424 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22425 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22426 GMMWC=SQRT(SQM4)*WDTP(0)
22427 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22428 FACWG=FACWG*HBW4C/HBW4
22429 DO 160 I=MMIN1,MMAX1
22431 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
22432 DO 150 J=MMIN2,MMAX2
22434 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
22435 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
22436 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22437 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22438 FCKM=VCKM((IA+1)/2,(JA+1)/2)
22443 SIGH(NCHN)=FACWG*FCKM*WIDSC
22447 ELSEIF(ISUB.EQ.19) THEN
22448 C...f + fbar -> gamma + (gamma*/Z0)
22449 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22450 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22454 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22455 DO 170 I=1,MIN(16,MDCY(23,3))
22457 IF(MDME(IDC,1).LT.0) GOTO 170
22459 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22463 AF=SIGN(1D0,EF+0.1D0)
22465 ELSEIF(I.LE.16) THEN
22467 AF=SIGN(1D0,EF+0.1D0)
22470 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22471 IF(4D0*RM1.LT.1D0) THEN
22473 IF(I.LE.8) FCOF=3D0*RADC4
22474 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22476 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22477 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22478 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22479 & AF**2*(1D0-4D0*RM1))*BE34
22483 C...Propagators: as simulated in PYOFSH and as desired
22484 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22488 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22490 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22491 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22492 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22493 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22494 C...Loop over flavours; consider full gamma/Z structure
22495 DO 180 I=MMINA,MMAXA
22496 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
22497 EI=KCHG(IABS(I),1)/3D0
22501 IF(IABS(I).LE.10) FCOI=FACA/3D0
22506 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
22507 & (VI**2+AI**2)*HFZZ)/HBW4
22510 ELSEIF(ISUB.EQ.20) THEN
22511 C...f + fbar' -> gamma + W+/-
22512 FACGW=COMFAC*0.5D0*AEM**2/XW
22513 C...Propagators: as simulated in PYOFSH and as desired
22514 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22515 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22516 GMMWC=SQRT(SQM4)*WDTP(0)
22517 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22518 FACGW=FACGW*HBW4C/HBW4
22519 C...Anomalous couplings
22520 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
22523 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
22524 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
22525 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
22526 & (4D0*SQMW))/(TH+UH)**2
22528 DO 200 I=MMIN1,MMAX1
22530 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
22531 DO 190 J=MMIN2,MMAX2
22533 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
22534 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
22535 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22537 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22538 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22540 FACWR=UH/(TH+UH)-1D0/3D0
22541 FCKM=VCKM((IA+1)/2,(JA+1)/2)
22548 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
22553 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
22558 ELSEIF(ISUB.LE.40) THEN
22559 IF(ISUB.EQ.22) THEN
22560 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
22561 C...Kinematics dependence
22562 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
22563 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
22564 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22570 RADC3=1D0+PYALPS(SQM3)/PARU(1)
22571 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22572 DO 230 I=1,MIN(16,MDCY(23,3))
22574 IF(MDME(IDC,1).LT.0) GOTO 230
22576 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
22577 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
22580 AF=SIGN(1D0,EF+0.1D0)
22582 ELSEIF(I.LE.16) THEN
22584 AF=SIGN(1D0,EF+0.1D0)
22587 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
22588 IF(4D0*RM1.LT.1D0) THEN
22590 IF(I.LE.8) FCOF=3D0*RADC3
22591 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22593 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22594 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22595 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
22596 & AF**2*(1D0-4D0*RM1))*BE34
22599 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22600 IF(4D0*RM1.LT.1D0) THEN
22602 IF(I.LE.8) FCOF=3D0*RADC4
22603 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22605 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22606 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22607 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
22608 & AF**2*(1D0-4D0*RM1))*BE34
22612 C...Propagators: as simulated in PYOFSH and as desired
22613 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
22614 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22618 CALL PYWIDT(23,SQM3,WDTP,WDTE)
22620 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22622 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
22623 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
22624 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
22629 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22631 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22633 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
22634 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
22635 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
22637 C...Loop over flavours; separate left- and right-handed couplings
22638 DO 270 I=MMINA,MMAXA
22639 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
22640 EI=KCHG(IABS(I),1)/3D0
22646 IF(IABS(I).LE.10) FCOI=FACA/3D0
22648 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
22649 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
22650 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
22651 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
22653 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
22654 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
22655 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
22656 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
22661 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
22664 ELSEIF(ISUB.EQ.23) THEN
22665 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
22666 FACZW=COMFAC*0.5D0*(AEM/XW)**2
22667 FACZW=FACZW*WIDS(23,2)
22668 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
22669 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
22670 DO 290 I=MMIN1,MMAX1
22672 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
22673 DO 280 J=MMIN2,MMAX2
22675 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
22676 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
22677 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
22679 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
22681 AI=SIGN(1D0,EI+0.1D0)
22684 AJ=SIGN(1D0,EJ+0.1D0)
22686 IF(VI+AI.GT.0) THEN
22695 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
22697 IF(IA.LE.10) FCOI=FACA/3D0
22702 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
22703 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
22704 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
22705 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
22706 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
22707 & WIDS(24,(5-KCHW)/2)
22708 C***Protect against slightly negative cross sections. (Reason yet to be
22709 C***sorted out. One possibility: addition of width to the W propagator.)
22710 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
22714 ELSEIF(ISUB.EQ.25) THEN
22715 C...f + fbar -> W+ + W-
22716 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
22718 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
22719 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
22720 CALL PYWIDT(24,SQM3,WDTP,WDTE)
22721 GMMW3=SQRT(SQM3)*WDTP(0)
22722 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
22723 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22724 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22725 GMMW4=SQRT(SQM4)*WDTP(0)
22726 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
22727 C...Kinematical functions
22728 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
22729 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
22730 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
22731 GT=THUH34+4D0*THUH/TH2
22732 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
22733 GU=THUH34+4D0*THUH/UH2
22734 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
22735 C...Common factors and couplings
22736 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
22737 FACWW=FACWW*WIDS(24,1)
22739 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
22740 CZZ=AEM**2/(32D0*XW**2)*HBWZC
22741 CNG=AEM**2/(4D0*XW)
22742 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
22743 CNN=AEM**2/(16D0*XW**2)
22744 C...Coulomb factor for W+W- pair
22745 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
22746 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
22747 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
22748 IF(COULE.LT.100D0*PMAS(24,2)) THEN
22749 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
22750 & PMAS(24,2)**2)-COULE))
22752 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
22754 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
22755 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
22756 & PMAS(24,2)**2)+COULE))
22758 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
22761 IF(MSTP(40).EQ.1) THEN
22762 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
22763 & MAX(1D-10,2D0*COULP*COULP1))
22764 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
22765 ELSEIF(MSTP(40).EQ.2) THEN
22766 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
22767 COULCP=DCMPLX(0D0,DBLE(COULP))
22768 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
22769 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
22770 & (4D0*COULCP)*LOG(COULCD)
22771 COULCS=DCMPLX(0D0,0D0)
22774 COULXX=(ISTP-0.5)/NSTP
22775 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
22776 & (1D0+COULXX/COULCD))
22778 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
22780 FACCOU=ABS(COULCR)**2
22781 ELSEIF(MSTP(40).EQ.3) THEN
22782 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
22783 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
22784 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
22786 ELSEIF(MSTP(40).EQ.4) THEN
22787 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
22793 C...Loop over allowed flavours
22794 DO 310 I=MMINA,MMAXA
22795 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
22796 EI=KCHG(IABS(I),1)/3D0
22797 AI=SIGN(1D0,EI+0.1D0)
22800 IF(IABS(I).LE.10) FCOI=FACA/3D0
22801 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
22803 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
22804 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
22806 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
22807 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
22810 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
22811 BET=SQRT(1D0-4D0*XMW02/SH)
22812 GAT=1D0/SQRT(1D0-BET**2)
22814 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
22815 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
22816 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
22817 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
22818 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
22819 & (1D0-2D0*BET*CTH+BET**2))
22820 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
22821 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
22822 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
22823 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
22824 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
22825 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
22826 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
22833 SIGH(NCHN)=FACWW*FCOI*DSIGWW
22836 ELSEIF(ISUB.EQ.30) THEN
22837 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
22838 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
22840 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22844 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22845 DO 320 I=1,MIN(16,MDCY(23,3))
22847 IF(MDME(IDC,1).LT.0) GOTO 320
22849 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22853 AF=SIGN(1D0,EF+0.1D0)
22855 ELSEIF(I.LE.16) THEN
22857 AF=SIGN(1D0,EF+0.1D0)
22860 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22861 IF(4D0*RM1.LT.1D0) THEN
22863 IF(I.LE.8) FCOF=3D0*RADC4
22864 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22866 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22867 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22868 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22869 & AF**2*(1D0-4D0*RM1))*BE34
22873 C...Propagators: as simulated in PYOFSH and as desired
22874 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22878 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22880 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22881 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22882 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22883 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22884 C...Loop over flavours; consider full gamma/Z structure
22885 DO 340 I=MMINA,MMAXA
22886 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
22887 EI=KCHG(IABS(I),1)/3D0
22890 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
22891 & (VI**2+AI**2)*HFZZ)/HBW4
22893 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
22894 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
22897 ISIG(NCHN,3-ISDE)=21
22903 ELSEIF(ISUB.EQ.31) THEN
22904 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
22905 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
22906 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
22907 C...Propagators: as simulated in PYOFSH and as desired
22908 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
22909 CALL PYWIDT(24,SQM4,WDTP,WDTE)
22910 GMMWC=SQRT(SQM4)*WDTP(0)
22911 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
22912 FACWQ=FACWQ*HBW4C/HBW4
22913 DO 360 I=MMINA,MMAXA
22914 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
22916 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
22917 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
22919 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
22920 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
22923 ISIG(NCHN,3-ISDE)=21
22925 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
22929 ELSEIF(ISUB.EQ.35) THEN
22930 C...f + gamma -> f + (gamma*/Z0)
22931 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
22932 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
22933 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
22934 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
22935 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
22936 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
22938 FZQN=SH2+UH2+2D0*SQM4*TH
22941 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
22942 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
22946 RADC4=1D0+PYALPS(SQM4)/PARU(1)
22947 DO 370 I=1,MIN(16,MDCY(23,3))
22949 IF(MDME(IDC,1).LT.0) GOTO 370
22951 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
22955 AF=SIGN(1D0,EF+0.1D0)
22957 ELSEIF(I.LE.16) THEN
22959 AF=SIGN(1D0,EF+0.1D0)
22962 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
22963 IF(4D0*RM1.LT.1D0) THEN
22965 IF(I.LE.8) FCOF=3D0*RADC4
22966 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
22968 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
22969 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
22970 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
22971 & AF**2*(1D0-4D0*RM1))*BE34
22975 C...Propagators: as simulated in PYOFSH and as desired
22976 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
22980 CALL PYWIDT(23,SQM4,WDTP,WDTE)
22982 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
22983 HFGG=HFGG*HFAEM*VINT(111)/SQM4
22984 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
22985 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
22986 C...Loop over flavours; consider full gamma/Z structure
22987 DO 390 I=MMINA,MMAXA
22988 IF(I.EQ.0) GOTO 390
22989 EI=KCHG(IABS(I),1)/3D0
22992 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
22993 & (VI**2+AI**2)*HFZZ)/HBW4
22994 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
22996 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
22997 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
23000 ISIG(NCHN,3-ISDE)=22
23002 SIGH(NCHN)=FACZQ*FZQN/FZQD
23006 ELSEIF(ISUB.EQ.36) THEN
23007 C...f + gamma -> f' + W+/-
23008 FWQ=COMFAC*AEM**2/(2D0*XW)*
23009 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
23010 C...Propagators: as simulated in PYOFSH and as desired
23011 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
23012 CALL PYWIDT(24,SQM4,WDTP,WDTE)
23013 GMMWC=SQRT(SQM4)*WDTP(0)
23014 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
23016 DO 410 I=MMINA,MMAXA
23017 IF(I.EQ.0) GOTO 410
23019 EIA=ABS(KCHG(IABS(I),1)/3D0)
23020 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
23021 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
23022 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
23024 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
23025 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
23028 ISIG(NCHN,3-ISDE)=22
23030 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
23035 ELSEIF(ISUB.LE.100) THEN
23036 IF(ISUB.EQ.69) THEN
23037 C...gamma + gamma -> W+ + W-
23038 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
23039 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
23040 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
23041 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
23042 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
23050 ELSEIF(ISUB.EQ.70) THEN
23051 C...gamma + W+/- -> Z0 + W+/-
23052 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
23053 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
23054 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
23055 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
23056 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
23057 DO 440 KCHW=1,-1,-2
23059 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
23062 ISIG(NCHN,3-ISDE)=24*KCHW
23064 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
23073 C*********************************************************************
23076 C...Subprocess cross sections for Higgs processes,
23077 C...except Higgs pairs in PYSGSU, but including WW scattering.
23078 C...Auxiliary to PYSIGH.
23080 SUBROUTINE PYSGHG(NCHN,SIGS)
23082 C...Double precision and integer declarations
23083 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23084 IMPLICIT INTEGER(I-N)
23085 INTEGER PYK,PYCHGE,PYCOMP
23086 C...Parameter statement to help give large particle numbers.
23087 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23088 &KEXCIT=4000000,KDIMEN=5000000)
23090 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23091 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23092 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23093 COMMON/PYINT1/MINT(400),VINT(400)
23094 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
23095 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
23096 COMMON/PYINT4/MWID(500),WIDS(500,5)
23097 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23098 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
23099 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
23100 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
23101 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
23102 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
23103 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
23104 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
23105 C...Local arrays and complex variables
23106 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
23107 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
23108 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
23110 C...Convert H or A process into equivalent h one
23113 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
23114 &ISUB.LE.190)) THEN
23116 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
23118 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
23119 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
23120 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
23121 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
23122 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
23123 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
23124 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
23125 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
23126 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
23127 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
23128 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
23129 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
23131 SQMH=PMAS(KFHIGG,1)**2
23132 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
23134 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23135 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
23136 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
23137 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
23138 IF(MSTP(46).LE.4) THEN
23139 HDTLH=LOG(PMAS(25,1)/PARP(44))
23140 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
23141 HDTNR=-1D0/18D0+HDTLH/6D0
23143 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
23144 HDTLQ=LOG(PARP(45)/PARP(44))
23145 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
23146 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
23149 C...Calculate lowest and next-to-lowest order partial wave amplitudes
23150 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
23154 HDTLS=LOG(SH/PARP(44)**2)
23155 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
23156 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
23157 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
23158 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
23159 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
23160 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
23161 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
23162 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
23164 C...Unitarize partial wave amplitudes with Pade or K-matrix method
23165 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
23166 A00U=A00L/(1D0-A004/A00L)
23167 A20U=A20L/(1D0-A204/A20L)
23168 A11U=A11L/(1D0-A114/A11L)
23170 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
23171 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
23172 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
23176 C...Differential cross section expressions.
23178 IF(ISUB.LE.60) THEN
23180 C...f + fbar -> h0 (or H0, or A0)
23181 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23183 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23184 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23186 HP=AEM/(8D0*XW)*SH/SQMW*SH
23187 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23188 DO 100 I=MMINA,MMAXA
23189 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
23191 RMQ=PYMRUN(IA,SH)**2/SH
23193 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
23194 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
23196 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
23197 IF(IA.GT.10) IKFI=3
23198 HI=HI*PARU(150+10*IHIGG+IKFI)**2
23199 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
23200 HI=HI/(1D0+RMSS(41))**2
23201 IF(IHIGG.NE.3) THEN
23202 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
23203 & PARU(151+10*IHIGG))**2
23211 SIGH(NCHN)=HI*FACBW*HF
23214 ELSEIF(ISUB.EQ.5) THEN
23216 CALL PYWIDT(25,SH,WDTP,WDTE)
23218 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23219 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
23220 HP=AEM/(8D0*XW)*SH/SQMW*SH
23221 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23223 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
23224 DO 120 I=MMIN1,MMAX1
23225 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
23226 DO 110 J=MMIN2,MMAX2
23227 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
23228 EI=KCHG(IABS(I),1)/3D0
23231 EJ=KCHG(IABS(J),1)/3D0
23238 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
23242 ELSEIF(ISUB.EQ.8) THEN
23244 CALL PYWIDT(25,SH,WDTP,WDTE)
23246 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23247 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
23248 HP=AEM/(8D0*XW)*SH/SQMW*SH
23249 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23251 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
23252 DO 140 I=MMIN1,MMAX1
23253 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
23254 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23255 DO 130 J=MMIN2,MMAX2
23256 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
23257 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23258 IF(EI*EJ.GT.0D0) GOTO 130
23263 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
23267 ELSEIF(ISUB.EQ.24) THEN
23268 C...f + fbar -> Z0 + h0 (or H0, or A0)
23269 C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
23270 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
23271 CALL PYWIDT(23,SQM3,WDTP,WDTE)
23272 GMMZ3=SQRT(SQM3)*WDTP(0)
23273 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
23274 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23275 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23276 GMMH4=SQRT(SQM4)*WDTP(0)
23277 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
23278 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
23279 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
23280 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
23281 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
23282 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
23283 & PARU(154+10*IHIGG)**2
23284 DO 150 I=MMINA,MMAXA
23285 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
23286 EI=KCHG(IABS(I),1)/3D0
23290 IF(IABS(I).LE.10) FCOI=FACA/3D0
23295 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
23298 ELSEIF(ISUB.EQ.26) THEN
23299 C...f + fbar' -> W+/- + h0 (or H0, or A0)
23300 C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
23301 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
23302 CALL PYWIDT(24,SQM3,WDTP,WDTE)
23303 GMMW3=SQRT(SQM3)*WDTP(0)
23304 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
23305 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23306 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23307 GMMH4=SQRT(SQM4)*WDTP(0)
23308 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
23309 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
23310 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
23311 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
23312 FACHW=FACHW*WIDS(KFHIGG,2)
23313 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
23314 & PARU(155+10*IHIGG)**2
23315 DO 170 I=MMIN1,MMAX1
23317 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
23318 DO 160 J=MMIN2,MMAX2
23320 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
23321 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
23322 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
23324 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
23326 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
23328 IF(IA.LE.10) FCOI=FACA/3D0
23333 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
23337 ELSEIF(ISUB.EQ.32) THEN
23338 C...f + g -> f + h0 (q + g -> q + h0 only)
23339 SQMHC=PMAS(25,1)**2
23340 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
23341 DO 190 I=MMINA,MMAXA
23343 IF(IA.NE.5) GOTO 190
23345 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
23346 & (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
23347 & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
23350 FACHCQ=FHCQ*SQML/SQMW*
23351 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
23352 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
23353 & (SQMHC-SQMQ-SH)/SH)
23354 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
23356 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
23357 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 180
23360 ISIG(NCHN,3-ISDE)=21
23362 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
23367 ELSEIF(ISUB.LE.80) THEN
23368 IF(ISUB.EQ.71) THEN
23369 C...Z0 + Z0 -> Z0 + Z0
23370 IF(SH.LE.4.01D0*SQMZ) GOTO 220
23372 IF(MSTP(46).LE.2) THEN
23373 C...Exact scattering ME:s for on-mass-shell gauge bosons
23374 BE2=1D0-4D0*SQMZ/SH
23375 TH=-0.5D0*SH*BE2*(1D0-CTH)
23376 UH=-0.5D0*SH*BE2*(1D0+CTH)
23377 IF(MAX(TH,UH).GT.-1D0) GOTO 220
23378 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
23379 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23380 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23381 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
23382 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
23383 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
23384 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
23385 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
23386 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
23387 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
23388 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
23389 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
23390 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
23391 & (ASHIM+ATHIM+AUHIM)**2)
23392 IF(MSTP(46).EQ.2) FACZZ=0D0
23395 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23396 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
23397 & ABS(A00U+2D0*A20U)**2
23399 FACZZ=FACZZ*WIDS(23,1)
23401 DO 210 I=MMIN1,MMAX1
23402 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
23403 EI=KCHG(IABS(I),1)/3D0
23407 DO 200 J=MMIN2,MMAX2
23408 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
23409 EJ=KCHG(IABS(J),1)/3D0
23417 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
23422 ELSEIF(ISUB.EQ.72) THEN
23423 C...Z0 + Z0 -> W+ + W-
23424 IF(SH.LE.4.01D0*SQMZ) GOTO 250
23426 IF(MSTP(46).LE.2) THEN
23427 C...Exact scattering ME:s for on-mass-shell gauge bosons
23428 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
23430 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
23431 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
23432 IF(MAX(TH,UH).GT.-1D0) GOTO 250
23433 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
23434 & (1D0-2D0*SQMZ/SH)
23435 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23436 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23437 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
23438 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23439 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23440 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
23441 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23443 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
23444 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23445 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23446 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
23447 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23449 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
23451 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
23452 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
23453 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
23454 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
23455 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
23456 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
23457 & (ATWIM+AUWIM+A4IM)**2)
23460 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23461 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
23462 & ABS(A00U-A20U)**2
23464 FACWW=FACWW*WIDS(24,1)
23466 DO 240 I=MMIN1,MMAX1
23467 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
23468 EI=KCHG(IABS(I),1)/3D0
23472 DO 230 J=MMIN2,MMAX2
23473 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
23474 EJ=KCHG(IABS(J),1)/3D0
23482 SIGH(NCHN)=FACWW*AVI*AVJ
23487 ELSEIF(ISUB.EQ.73) THEN
23488 C...Z0 + W+/- -> Z0 + W+/-
23489 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
23491 IF(MSTP(46).LE.2) THEN
23492 C...Exact scattering ME:s for on-mass-shell gauge bosons
23493 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
23494 EP1=1D0-(SQMZ-SQMW)/SH
23495 EP2=1D0+(SQMZ-SQMW)/SH
23496 TH=-0.5D0*SH*BE2*(1D0-CTH)
23497 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
23498 IF(MAX(TH,UH).GT.-1D0) GOTO 280
23499 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
23500 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
23501 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
23502 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
23503 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
23504 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
23505 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
23507 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
23508 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
23509 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
23510 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
23511 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
23512 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
23513 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
23514 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
23515 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
23516 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
23517 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
23518 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
23520 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
23521 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
23523 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
23524 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
23525 IF(MSTP(46).LE.0) FACZW=0D0
23526 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
23527 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
23528 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
23529 & (ASWIM+AUWIM+A4IM)**2)
23532 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23533 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
23534 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
23536 FACZW=FACZW*WIDS(23,2)
23538 DO 270 I=MMIN1,MMAX1
23539 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
23540 EI=KCHG(IABS(I),1)/3D0
23544 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
23545 DO 260 J=MMIN2,MMAX2
23546 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
23547 EJ=KCHG(IABS(J),1)/3D0
23551 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
23556 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
23561 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
23566 ELSEIF(ISUB.EQ.75) THEN
23567 C...W+ + W- -> gamma + gamma
23569 ELSEIF(ISUB.EQ.76) THEN
23570 C...W+ + W- -> Z0 + Z0
23571 IF(SH.LE.4.01D0*SQMZ) GOTO 310
23573 IF(MSTP(46).LE.2) THEN
23574 C...Exact scattering ME:s for on-mass-shell gauge bosons
23575 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
23577 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
23578 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
23579 IF(MAX(TH,UH).GT.-1D0) GOTO 310
23580 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
23581 & (1D0-2D0*SQMZ/SH)
23582 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23583 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23584 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
23585 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23586 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23587 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
23588 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23590 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
23591 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
23592 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
23593 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
23594 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
23596 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
23598 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
23600 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
23601 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
23602 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
23603 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
23604 & (ATWIM+AUWIM+A4IM)**2)
23607 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23608 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
23609 & ABS(A00U-A20U)**2
23611 FACZZ=FACZZ*WIDS(23,1)
23613 DO 300 I=MMIN1,MMAX1
23614 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
23615 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23616 DO 290 J=MMIN2,MMAX2
23617 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
23618 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23619 IF(EI*EJ.GT.0D0) GOTO 290
23624 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
23629 ELSEIF(ISUB.EQ.77) THEN
23630 C...W+/- + W+/- -> W+/- + W+/-
23631 IF(SH.LE.4.01D0*SQMW) GOTO 340
23633 IF(MSTP(46).LE.2) THEN
23634 C...Exact scattering ME:s for on-mass-shell gauge bosons
23635 BE2=1D0-4D0*SQMW/SH
23639 TH=-0.5D0*SH*BE2*(1D0-CTH)
23640 UH=-0.5D0*SH*BE2*(1D0+CTH)
23641 IF(MAX(TH,UH).GT.-1D0) GOTO 340
23643 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
23644 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
23646 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
23647 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
23649 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
23650 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
23651 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
23654 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
23656 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
23657 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
23658 ATGRE=0.5D0*XW*SH/TH*TGZANG
23660 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
23662 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
23663 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
23664 AUGRE=0.5D0*XW*SH/UH*UGZANG
23666 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
23668 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
23670 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
23672 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
23674 IF(MSTP(46).LE.0) THEN
23679 ELSEIF(MSTP(46).EQ.1) THEN
23680 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23681 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23682 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23683 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23685 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
23686 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
23687 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
23688 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
23690 AWWA2=AWWARE**2+AWWAIM**2
23691 AWWS2=AWWSRE**2+AWWSIM**2
23694 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
23695 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
23696 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
23697 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
23700 DO 330 I=MMIN1,MMAX1
23701 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
23702 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
23703 DO 320 J=MMIN2,MMAX2
23704 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
23705 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
23706 IF(EI*EJ.LT.0D0) THEN
23708 IF(MSTP(45).EQ.1) GOTO 320
23709 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
23710 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
23713 IF(MSTP(45).EQ.2) GOTO 320
23714 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
23715 IF(MSTP(46).GE.3) FACWW=FWWS
23716 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
23717 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
23723 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
23724 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
23730 ELSEIF(ISUB.LE.120) THEN
23731 IF(ISUB.EQ.102) THEN
23732 C...g + g -> h0 (or H0, or A0)
23733 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23735 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23736 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23737 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23739 HI=SHR*WDTP(13)/32D0
23740 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
23745 SIGH(NCHN)=HI*FACBW*HF
23748 ELSEIF(ISUB.EQ.103) THEN
23749 C...gamma + gamma -> h0 (or H0, or A0)
23750 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
23752 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
23753 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
23754 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
23756 HI=SHR*WDTP(14)*2D0
23757 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
23762 SIGH(NCHN)=HI*FACBW*HF
23765 ELSEIF(ISUB.EQ.110) THEN
23766 C...f + fbar -> gamma + h0
23767 THUH=MAX(TH*UH,SH*CKIN(3)**2)
23768 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
23769 FACHG=FACHG*WIDS(KFHIGG,2)
23770 C...Calculate loop contributions for intermediate gamma* and Z0
23771 CIGTOT=DCMPLX(0D0,0D0)
23772 CIZTOT=DCMPLX(0D0,0D0)
23775 IF(J.LE.2*MSTP(1)) THEN
23778 AJ=SIGN(1D0,EJ+0.1D0)
23780 BALP=SQM4/(2D0*PMAS(J,1))**2
23781 BBET=SH/(2D0*PMAS(J,1))**2
23782 ELSEIF(J.LE.3*MSTP(1)) THEN
23784 JL=2*(J-2*MSTP(1))-1
23785 EJ=KCHG(10+JL,1)/3D0
23786 AJ=SIGN(1D0,EJ+0.1D0)
23788 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
23789 BBET=SH/(2D0*PMAS(10+JL,1))**2
23791 BALP=SQM4/(2D0*PMAS(24,1))**2
23792 BBET=SH/(2D0*PMAS(24,1))**2
23794 BABI=1D0/(BALP-BBET)
23795 IF(BALP.LT.1D0) THEN
23796 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
23799 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
23800 & -DBLE(0.5D0*PARU(1)))
23803 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
23804 IF(BBET.LT.1D0) THEN
23805 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
23808 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
23809 & -DBLE(0.5D0*PARU(1)))
23812 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
23813 IF(J.LE.3*MSTP(1)) THEN
23814 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
23815 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
23816 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
23817 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
23820 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
23821 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
23822 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
23823 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
23824 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
23825 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
23829 CIGTOT=CIGTOT/DBLE(SH)
23830 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
23831 C...Loop over initial flavours
23832 DO 380 I=MMINA,MMAXA
23833 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
23834 EI=KCHG(IABS(I),1)/3D0
23838 IF(IABS(I).LE.10) FCOI=FACA/3D0
23843 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
23844 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
23847 ELSEIF(ISUB.EQ.111) THEN
23848 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
23849 IF(MSTP(38).NE.0) THEN
23850 C...Simple case: only do gg <-> h exactly.
23851 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23852 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
23853 & (TH**2+UH**2)/(SH*SQM4)
23854 C...Propagators: as simulated in PYOFSH and as desired
23855 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23856 GMMHC=SQRT(SQM4)*WDTP(0)
23857 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23858 & ((SQM4-SQMH)**2+GMMHC**2)
23859 FACGH=FACGH*HBW4C/HBW4
23861 C...Messy case: do full loop integrals
23864 DO 390 I=1,2*MSTP(1)
23868 CALL PYWAUX(1,EPSS,W1SR,W1SI)
23869 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23870 CALL PYWAUX(2,EPSS,W2SR,W2SI)
23871 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23872 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
23873 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
23874 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
23875 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
23877 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23878 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
23879 FACGH=FACGH*WIDS(25,2)
23881 DO 400 I=MMINA,MMAXA
23882 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
23883 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
23891 ELSEIF(ISUB.EQ.112) THEN
23892 C...f + g -> f + h0 (q + g -> q + h0 only)
23893 IF(MSTP(38).NE.0) THEN
23894 C...Simple case: only do gg <-> h exactly.
23895 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23896 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
23897 & (SH**2+UH**2)/(-TH*SQM4)
23898 C...Propagators: as simulated in PYOFSH and as desired
23899 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23900 GMMHC=SQRT(SQM4)*WDTP(0)
23901 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23902 & ((SQM4-SQMH)**2+GMMHC**2)
23903 FACQH=FACQH*HBW4C/HBW4
23905 C...Messy case: do full loop integrals
23908 DO 410 I=1,2*MSTP(1)
23912 CALL PYWAUX(1,EPST,W1TR,W1TI)
23913 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23914 CALL PYWAUX(2,EPST,W2TR,W2TI)
23915 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23916 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
23917 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
23918 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
23919 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
23921 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
23922 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
23923 FACQH=FACQH*WIDS(25,2)
23925 DO 430 I=MMINA,MMAXA
23926 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
23928 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
23929 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
23932 ISIG(NCHN,3-ISDE)=21
23938 ELSEIF(ISUB.EQ.113) THEN
23939 C...g + g -> g + h0
23940 IF(MSTP(38).NE.0) THEN
23941 C...Simple case: only do gg <-> h exactly.
23942 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
23943 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
23944 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
23945 C...Propagators: as simulated in PYOFSH and as desired
23946 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
23947 GMMHC=SQRT(SQM4)*WDTP(0)
23948 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
23949 & ((SQM4-SQMH)**2+GMMHC**2)
23950 FACGH=FACGH*HBW4C/HBW4
23952 C...Messy case: do full loop integrals
23961 DO 440 I=1,2*MSTP(1)
23967 IF(EPSH.LT.1D-6) GOTO 440
23968 CALL PYWAUX(1,EPSS,W1SR,W1SI)
23969 CALL PYWAUX(1,EPST,W1TR,W1TI)
23970 CALL PYWAUX(1,EPSU,W1UR,W1UI)
23971 CALL PYWAUX(1,EPSH,W1HR,W1HI)
23972 CALL PYWAUX(2,EPSS,W2SR,W2SI)
23973 CALL PYWAUX(2,EPST,W2TR,W2TI)
23974 CALL PYWAUX(2,EPSU,W2UR,W2UI)
23975 CALL PYWAUX(2,EPSH,W2HR,W2HI)
23976 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
23977 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
23978 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
23979 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
23980 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
23981 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
23982 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
23983 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
23984 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
23985 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
23986 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
23987 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
23988 W3STUR=YHSTUR-Y3STUR-Y3UTSR
23989 W3STUI=YHSTUI-Y3STUI-Y3UTSI
23990 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
23991 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
23992 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
23993 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
23994 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
23995 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
23996 W3USTR=YHUSTR-Y3USTR-Y3TSUR
23997 W3USTI=YHUSTI-Y3USTI-Y3TSUI
23998 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
23999 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
24000 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
24001 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
24002 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
24003 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
24004 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
24005 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
24006 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
24007 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
24008 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
24009 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
24010 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
24011 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
24012 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
24013 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
24014 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
24015 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
24016 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
24017 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
24018 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
24019 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
24020 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
24021 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
24022 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
24023 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
24024 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
24025 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
24026 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
24027 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
24028 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
24029 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
24030 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
24031 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
24032 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
24033 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
24034 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
24035 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
24036 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
24037 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
24038 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
24039 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
24040 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
24041 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
24042 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
24043 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
24044 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
24045 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
24046 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
24047 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
24048 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
24049 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
24050 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
24051 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
24052 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
24053 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
24054 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
24055 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
24056 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
24057 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
24058 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
24059 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
24060 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24061 & (W2SR-W2HR+W3STUR))
24062 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
24063 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24064 & (W2TR-W2HR+W3TUSR))
24065 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
24066 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
24067 & (W2UR-W2HR+W3USTR))
24068 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
24069 A2STUR=A2STUR+B2STUR+B2SUTR
24070 A2STUI=A2STUI+B2STUI+B2SUTI
24071 A2USTR=A2USTR+B2USTR+B2UTSR
24072 A2USTI=A2USTI+B2USTI+B2UTSI
24073 A2TUSR=A2TUSR+B2TUSR+B2TSUR
24074 A2TUSI=A2TUSI+B2TUSI+B2TSUI
24075 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
24076 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
24078 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
24079 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
24080 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
24081 FACGH=FACGH*WIDS(25,2)
24083 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
24092 ELSEIF(ISUB.LE.170) THEN
24093 IF(ISUB.EQ.121) THEN
24094 C...g + g -> Q + Qbar + h0
24095 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
24098 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24099 & (0.5D0*PMF/PMAS(24,1))**2
24101 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24103 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24105 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24106 IF(IA.GT.10) IKFI=3
24107 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24108 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24109 FACQQH=FACQQH/(1D0+RMSS(41))**2
24110 IF(IHIGG.NE.3) THEN
24111 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24112 & PARU(151+10*IHIGG))**2
24116 CALL PYQQBH(WTQQBH)
24117 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24119 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24120 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24121 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24127 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24130 ELSEIF(ISUB.EQ.122) THEN
24131 C...q + qbar -> Q + Qbar + h0
24134 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
24135 & (0.5D0*PMF/PMAS(24,1))**2
24137 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
24139 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24141 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
24142 IF(IA.GT.10) IKFI=3
24143 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
24144 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
24145 FACQQH=FACQQH/(1D0+RMSS(41))**2
24146 IF(IHIGG.NE.3) THEN
24147 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24148 & PARU(151+10*IHIGG))**2
24152 CALL PYQQBH(WTQQBH)
24153 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24155 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24156 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24157 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24159 DO 470 I=MMINA,MMAXA
24160 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
24161 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
24166 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
24169 ELSEIF(ISUB.EQ.123) THEN
24170 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
24172 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
24173 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24174 & PARU(154+10*IHIGG)**2
24175 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24176 & (VINT(216)-VINT(209)**2))**2
24177 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24178 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
24179 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24181 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24182 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24183 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24185 DO 490 I=MMIN1,MMAX1
24186 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
24188 DO 480 J=MMIN2,MMAX2
24189 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
24191 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
24192 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
24194 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
24195 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
24197 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
24198 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
24203 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
24207 ELSEIF(ISUB.EQ.124) THEN
24208 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
24210 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
24211 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
24212 & PARU(155+10*IHIGG)**2
24213 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
24214 & (VINT(216)-VINT(209)**2))**2
24215 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
24216 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
24218 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
24219 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
24220 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
24222 DO 510 I=MMIN1,MMAX1
24223 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
24224 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
24225 DO 500 J=MMIN2,MMAX2
24226 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
24227 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
24228 IF(EI*EJ.GT.0D0) GOTO 500
24229 FACLR=VINT(180+I)*VINT(180+J)
24234 SIGH(NCHN)=FACLR*FACWW*FACBW
24238 ELSEIF(ISUB.EQ.143) THEN
24239 C...f + fbar' -> H+/-
24240 SQMHC=PMAS(37,1)**2
24241 CALL PYWIDT(37,SH,WDTP,WDTE)
24243 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
24244 HP=AEM/(8D0*XW)*SH/SQMW*SH
24245 DO 530 I=MMIN1,MMAX1
24246 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
24248 IM=(MOD(IA,10)+1)/2
24249 DO 520 J=MMIN2,MMAX2
24250 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
24252 JM=(MOD(JA,10)+1)/2
24253 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
24254 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
24256 IF(MOD(IA,2).EQ.0) THEN
24263 RML=PYMRUN(IL,SH)**2/SH
24264 RMU=PYMRUN(IU,SH)**2/SH
24265 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
24266 IF(IA.LE.10) HI=HI*FACA/3D0
24267 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
24268 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
24273 SIGH(NCHN)=HI*FACBW*HF
24277 ELSEIF(ISUB.EQ.161) THEN
24278 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
24279 C...(choice of only b and t to avoid kinematics problems)
24280 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
24281 C...H propagator: as simulated in PYOFSH and as desired
24282 SQMHC=PMAS(37,1)**2
24283 GMMHC=PMAS(37,1)*PMAS(37,2)
24284 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
24285 CALL PYWIDT(37,SQM4,WDTP,WDTE)
24286 GMMHCC=SQRT(SQM4)*WDTP(0)
24287 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
24288 FHCQ=FHCQ*HBW4C/HBW4
24289 DO 550 I=MMINA,MMAXA
24291 IF(IA.NE.5) GOTO 550
24292 SQML=PYMRUN(IA,SH)**2
24294 SQMQ=PYMRUN(IUA,SH)**2
24295 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
24296 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
24297 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
24298 & (SQMHC-SQMQ-SH)/SH)
24299 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
24301 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
24302 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 540
24305 ISIG(NCHN,3-ISDE)=21
24307 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
24316 C*********************************************************************
24319 C...Subprocess cross sections for SUSY processes,
24320 C...including Higgs pair production.
24321 C...Auxiliary to PYSIGH.
24323 SUBROUTINE PYSGSU(NCHN,SIGS)
24325 C...Double precision and integer declarations
24326 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24327 IMPLICIT INTEGER(I-N)
24328 INTEGER PYK,PYCHGE,PYCOMP
24329 C...Parameter statement to help give large particle numbers.
24330 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24331 &KEXCIT=4000000,KDIMEN=5000000)
24333 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24334 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24335 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24336 COMMON/PYINT1/MINT(400),VINT(400)
24337 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24338 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
24339 COMMON/PYINT4/MWID(500),WIDS(500,5)
24340 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24341 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24342 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
24343 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
24344 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
24345 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
24346 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
24347 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
24348 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
24349 C...Local arrays and complex variables
24350 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
24351 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
24352 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
24353 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
24356 C...Z and W width, combinations of weak mixing angle
24360 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
24362 C...Convert almost equivalent SUSY processes into each other
24363 C...Extract differences in flavours and couplings
24365 C...Sleptons and sneutrinos
24366 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
24367 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24370 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
24371 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24374 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
24375 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24377 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
24378 IF(ISUB.EQ.210) THEN
24380 ELSEIF(ISUB.EQ.211) THEN
24382 ELSEIF(ISUB.EQ.212) THEN
24386 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
24387 IF(ISUB.EQ.213) THEN
24388 KFID=MOD(KFPR(ISUB,1),KSUSY1)
24390 ELSEIF(ISUB.EQ.214) THEN
24397 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
24398 IF(ISUB.EQ.216) THEN
24401 ELSEIF(ISUB.EQ.217) THEN
24404 ELSEIF(ISUB.EQ.218) THEN
24407 ELSEIF(ISUB.EQ.219) THEN
24410 ELSEIF(ISUB.EQ.220) THEN
24413 ELSEIF(ISUB.EQ.221) THEN
24416 ELSEIF(ISUB.EQ.222) THEN
24419 ELSEIF(ISUB.EQ.223) THEN
24422 ELSEIF(ISUB.EQ.224) THEN
24425 ELSEIF(ISUB.EQ.225) THEN
24432 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
24433 IF(ISUB.EQ.226) THEN
24436 ELSEIF(ISUB.EQ.227) THEN
24439 ELSEIF(ISUB.EQ.228) THEN
24445 C...Neutralino + chargino
24446 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
24447 IF(ISUB.EQ.229) THEN
24450 ELSEIF(ISUB.EQ.230) THEN
24453 ELSEIF(ISUB.EQ.231) THEN
24456 ELSEIF(ISUB.EQ.232) THEN
24459 ELSEIF(ISUB.EQ.233) THEN
24462 ELSEIF(ISUB.EQ.234) THEN
24465 ELSEIF(ISUB.EQ.235) THEN
24468 ELSEIF(ISUB.EQ.236) THEN
24474 C...Gluino + neutralino
24475 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
24476 IF(ISUB.EQ.237) THEN
24478 ELSEIF(ISUB.EQ.238) THEN
24480 ELSEIF(ISUB.EQ.239) THEN
24482 ELSEIF(ISUB.EQ.240) THEN
24487 C...Gluino + chargino
24488 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
24489 IF(ISUB.EQ.241) THEN
24491 ELSEIF(ISUB.EQ.242) THEN
24496 C...Squark + neutralino
24497 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
24499 IF(MOD(ISUB,2).NE.0) ILR=1
24500 IF(ISUB.LE.247) THEN
24502 ELSEIF(ISUB.LE.249) THEN
24504 ELSEIF(ISUB.LE.251) THEN
24506 ELSEIF(ISUB.LE.253) THEN
24512 C...Squark + chargino
24513 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
24514 IF(ISUB.LE.255) THEN
24516 ELSEIF(ISUB.LE.257) THEN
24519 IF(MOD(ISUB,2).EQ.0) THEN
24527 C...Squark + gluino
24528 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
24533 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
24535 IF(ISUB.EQ.262) ILR=1
24537 ELSEIF(ISUB.EQ.265) THEN
24541 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
24543 IF(ISUB.LE.273) THEN
24544 IF(ISUB.EQ.273) ILR=1
24547 ELSEIF(ISUB.LE.276) THEN
24548 IF(ISUB.EQ.276) ILR=1
24551 ELSEIF(ISUB.LE.278) THEN
24552 IF(ISUB.EQ.278) ILR=1
24556 IF(ISUB.EQ.280) ILR=1
24561 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
24563 IF(ISUB.LE.283) THEN
24564 IF(ISUB.EQ.283) ILR=1
24567 ELSEIF(ISUB.LE.286) THEN
24568 IF(ISUB.EQ.286) ILR=1
24571 ELSEIF(ISUB.LE.288) THEN
24572 IF(ISUB.EQ.288) ILR=1
24575 ELSEIF(ISUB.LE.290) THEN
24576 IF(ISUB.EQ.290) ILR=1
24579 ELSEIF(ISUB.LE.293) THEN
24580 IF(ISUB.EQ.293) ILR=1
24583 ELSEIF(ISUB.EQ.296) THEN
24587 C...Squark + gluino
24588 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
24593 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
24594 IF(ISUB.EQ.297) THEN
24595 RKF=.5D0*PARU(195)**2
24596 ELSEIF(ISUB.EQ.298) THEN
24597 RKF=.5D0*(1D0-PARU(195)**2)
24601 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
24602 IF(ISUB.EQ.299) THEN
24605 ELSEIF(ISUB.EQ.300) THEN
24611 ELSEIF(ISUB.EQ.301) THEN
24617 C...Supersymmetric processes - all of type 2 -> 2 :
24618 C...correct final-state Breit-Wigners from fixed to running width.
24619 IF(MSTP(42).GT.0) THEN
24621 KFLW=KFPR(ISUBSV,I)
24623 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
24624 IF(I.EQ.1) SQMI=SQM3
24625 IF(I.EQ.2) SQMI=SQM4
24626 SQMS=PMAS(KCW,1)**2
24627 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
24628 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
24629 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
24630 GMMI=SQRT(SQMI)*WDTP(0)
24631 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
24632 COMFAC=COMFAC*(HBWI/HBWS)
24636 C...Differential cross section expressions.
24638 IF(ISUB.LE.210) THEN
24639 IF(ISUB.EQ.201) THEN
24640 C...f + fbar -> e_L + e_Lbar
24641 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24642 DO 130 I=MMIN1,MMAX1
24644 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
24646 TT3I=SIGN(1D0,EI+1D-6)/2D0
24650 C...Color factor for e+ e-
24651 IF(IA.GE.11) FCOL=3D0
24652 IF(ISUBSV.EQ.301) THEN
24655 ELSEIF(ILR.EQ.1) THEN
24656 A1=SFMIX(KFID,3)**2
24657 A2=SFMIX(KFID,4)**2
24658 ELSEIF(ILR.EQ.0) THEN
24659 A1=SFMIX(KFID,1)**2
24660 A2=SFMIX(KFID,2)**2
24662 XLQ=(TT3J-EJ*XW)*A1
24666 TAA=(EI*EJ)**2*(POLL+POLR)
24667 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
24668 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
24669 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
24670 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
24674 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
24680 DK=1D0/(TH-SMZ(II)**2)
24681 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
24683 FREK=FAC2*TANW*EI*ZMIX(II,1)
24684 TNN1=TNN1+FLEK**2*DK
24685 TNN2=TNN2+FREK**2*DK
24687 DL=1D0/(TH-SMZ(JJ)**2)
24688 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
24690 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
24691 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
24694 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
24695 & A2**2*TNN2**2*POLR)
24696 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
24697 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
24698 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
24699 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
24700 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
24703 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
24706 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
24707 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
24708 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
24713 SIGH(NCHN)=FACQQ1+FACQQ2
24716 ELSEIF(ISUB.EQ.203) THEN
24717 C...f + fbar -> e_L + e_Rbar
24718 DO 160 I=MMIN1,MMAX1
24720 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
24721 EI=KCHG(IABS(I),1)/3D0
24722 TT3I=SIGN(1D0,EI)/2D0
24726 C...Color factor for e+ e-
24727 IF(IA.GE.11) FCOL=3D0
24728 A1=SFMIX(KFID,1)**2
24729 A2=SFMIX(KFID,2)**2
24734 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
24735 & /XW**2/XW1**2*A1*A2
24736 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
24741 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
24747 DK=1D0/(TH-SMZ(II)**2)
24748 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
24750 FREK=FAC2*TANW*EI*ZMIX(II,1)
24751 TNN1=TNN1+FLEK**2*DK
24752 TNN2=TNN2+FREK**2*DK
24754 DL=1D0/(TH-SMZ(JJ)**2)
24755 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
24757 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
24758 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
24761 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
24762 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
24763 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
24764 TZN=(UH*TH-SQM3*SQM4)*A1*A2
24765 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
24766 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
24769 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
24770 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
24771 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
24777 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24778 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
24783 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
24784 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24787 ELSEIF(ISUB.EQ.210) THEN
24788 C...q + qbar' -> W*- > ~l_L + ~nu_L
24789 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
24790 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
24791 DO 180 I=MMIN1,MMAX1
24793 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
24794 DO 170 J=MMIN2,MMAX2
24796 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
24797 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
24799 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
24800 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
24802 IF(KCHSUM.LT.0) KCHW=3
24807 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
24808 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
24809 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24811 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
24812 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
24814 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
24819 ELSEIF(ISUB.LE.220) THEN
24820 IF(ISUB.EQ.213) THEN
24821 C...f + fbar -> ~nu_L + ~nu_Lbar
24822 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
24823 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24824 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24826 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24829 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
24832 DO 190 I=MMIN1,MMAX1
24834 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
24837 C...Color factor for e+ e-
24838 IF(IA.GE.11) FCOL=3D0
24839 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
24843 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
24844 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
24847 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
24849 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
24855 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
24856 & *AEM**2*FCOL/3D0/XW**2
24859 ELSEIF(ISUB.EQ.216) THEN
24860 C...q + qbar -> ~chi0_1 + ~chi0_1
24861 IF(IZID1.EQ.IZID2) THEN
24862 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24864 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24865 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24867 FACXX=COMFAC*AEM**2/3D0/XW**2
24868 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
24871 WU2 = (UH-ZM12)*(UH-ZM22)
24872 WT2 = (TH-ZM12)*(TH-ZM22)
24873 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
24874 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
24875 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
24877 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
24878 IF(IZID2.NE.IZID1) THEN
24879 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
24882 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
24883 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
24885 DO 210 I=MMINA,MMAXA
24886 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
24887 EI=KCHG(IABS(I),1)/3D0
24888 T3I=SIGN(1D0,EI+1D-6)/2D0
24889 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
24890 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
24891 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
24892 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
24893 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
24894 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
24895 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
24897 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
24898 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
24899 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
24901 IF(IABS(I).GE.11) FCOL=3D0
24902 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
24903 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
24904 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
24905 & QRL*DCONJG(QRR)*POLR)*WS2
24910 SIGH(NCHN)=FACXX*FACGG1*FCOL
24914 ELSEIF(ISUB.LE.230) THEN
24915 IF(ISUB.EQ.226) THEN
24916 C...f + fbar -> ~chi+_1 + ~chi-_1
24917 FACXX=COMFAC*AEM**2/3D0
24920 WU2 = (UH-ZM12)*(UH-ZM22)
24921 WT2 = (TH-ZM12)*(TH-ZM22)
24922 WS2 = SMW(IZID1)*SMW(IZID2)*SH
24923 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
24924 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
24926 IF(IZID1.EQ.IZID2) DIFF=1D0
24928 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
24929 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
24930 IF(IZID2.NE.IZID1) THEN
24931 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
24932 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
24935 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
24936 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
24937 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
24938 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
24939 DO 230 I=MMINA,MMAXA
24940 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
24941 EI=KCHG(IABS(I),1)/3D0
24942 T3I=SIGN(1D0,EI+1D-6)/2D0
24943 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
24944 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
24945 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
24946 IF(MOD(I,2).EQ.0) THEN
24947 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
24948 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
24949 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
24950 & DCMPLX(T3I/XW/(TH-XML2))
24952 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
24953 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
24954 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
24955 & DCMPLX(T3I/XW/(TH-XML2))
24958 IF(IABS(I).GE.11) FCOL=3D0
24959 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
24960 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
24961 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
24962 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
24967 IF(IZID1.EQ.IZID2) THEN
24968 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
24970 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
24971 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
24976 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
24977 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
24981 ELSEIF(ISUB.EQ.229) THEN
24982 C...q + qbar' -> ~chi0_1 + ~chi+-_1
24983 FACXX=COMFAC*AEM**2/6D0/XW**2
24986 WU2 = (UH-ZM12)*(UH-ZM22)
24987 WT2 = (TH-ZM12)*(TH-ZM22)
24988 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
24989 RT2I = 1D0/SQRT(2D0)
24990 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
24991 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
24993 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
24994 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
24997 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
24999 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
25000 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
25001 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
25002 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
25004 DO 270 I=MMIN1,MMAX1
25006 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
25008 T3I=SIGN(1D0,EI+1D-6)/2D0
25009 DO 260 J=MMIN2,MMAX2
25011 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
25012 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
25014 T3J=SIGN(1D0,EJ+1D-6)/2D0
25016 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25017 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25019 IF(KCHSUM.LT.0) KCHW=3
25020 IF(MOD(IA,2).EQ.0) THEN
25021 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
25022 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
25023 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
25024 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
25025 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25026 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
25029 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
25030 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
25031 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
25032 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
25033 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
25034 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
25037 ZINTR=DBLE(QLR*DCONJG(QLL))
25038 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
25044 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25045 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25050 ELSEIF(ISUB.LE.240) THEN
25051 IF(ISUB.EQ.237) THEN
25052 C...q + qbar -> gluino + ~chi0_1
25053 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25054 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25055 FAC0=COMFAC*AS*AEM*4D0/9D0/XW
25058 DO 280 I=MMINA,MMAXA
25059 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
25060 EI=KCHG(IABS(I),1)/3D0
25062 XLQC = -TANW*EI*ZMIX(IZID,1)
25063 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25064 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25067 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
25068 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
25069 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
25070 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
25071 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
25072 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25073 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
25074 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
25075 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
25076 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
25081 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
25085 ELSEIF(ISUB.LE.250) THEN
25086 IF(ISUB.EQ.241) THEN
25087 C...q + qbar' -> ~chi+-_1 + gluino
25088 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
25091 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
25092 FAC0=UMIX(IZID,1)**2
25093 FAC1=VMIX(IZID,1)**2
25094 DO 300 I=MMIN1,MMAX1
25096 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
25097 DO 290 J=MMIN2,MMAX2
25099 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
25100 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
25102 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
25103 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
25105 IF(KCHSUM.LT.0) KCHW=3
25106 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
25107 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
25108 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
25109 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
25110 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
25111 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
25112 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
25113 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
25114 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
25115 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
25116 & SH/(TH-XMU2)/(UH-XMD2))/2D0
25121 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
25122 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25123 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
25127 ELSEIF(ISUB.EQ.243) THEN
25128 C...q + qbar -> gluino + gluino
25129 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25132 DO 310 I=MMINA,MMAXA
25133 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
25134 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
25136 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
25137 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
25138 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25139 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25140 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25141 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25142 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
25143 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
25144 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
25145 & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
25146 & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
25147 & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
25151 C...1/2 for identical particles
25152 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
25155 ELSEIF(ISUB.EQ.244) THEN
25156 C...g + g -> gluino + gluino
25157 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25160 FACQQ1=COMFAC*AS**2*9D0/4D0*(
25161 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
25162 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
25163 FACQQ2=COMFAC*AS**2*9D0/4D0*(
25164 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
25165 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
25166 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
25167 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
25168 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
25173 SIGH(NCHN)=FACQQ1/2D0
25178 SIGH(NCHN)=FACQQ2/2D0
25183 SIGH(NCHN)=FACQQ3/2D0
25186 ELSEIF(ISUB.EQ.246) THEN
25187 C...g + q_j -> ~chi0_1 + ~q_j
25188 FAC0=COMFAC*AS*AEM/6D0/XW
25191 FACZQ0=FAC0*( (ZM2-TH)/SH +
25192 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25193 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25194 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25195 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
25196 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
25197 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
25198 EI=KCHG(IABS(I),1)/3D0
25200 XRQZ = -TANW*EI*ZMIX(IZID,1)
25201 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
25202 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
25204 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
25206 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
25212 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
25213 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
25216 ISIG(NCHN,3-ISDE)=21
25218 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25219 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25224 ELSEIF(ISUB.LE.260) THEN
25225 IF(ISUB.EQ.254) THEN
25226 C...g + q_j -> ~chi1_1 + ~q_i
25227 FAC0=COMFAC*AS*AEM/12D0/XW
25232 FACZQ0=FAC0*( (ZM2-TH)/SH +
25233 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
25234 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
25235 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
25236 IF(MOD(KFNSQ1,2).EQ.0) THEN
25243 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
25244 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
25245 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
25247 IF(MOD(IA,2).EQ.0) THEN
25252 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
25256 IF(I.LT.0) KCHWQ=5-KCHW
25258 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
25259 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
25262 ISIG(NCHN,3-ISDE)=21
25264 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25265 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
25269 ELSEIF(ISUB.EQ.258) THEN
25270 C...g + q_j -> gluino + ~q_i
25277 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
25278 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
25279 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
25280 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
25281 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
25283 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
25284 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
25285 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
25286 FACQG1=COMFAC*AS**2*FACQG1/2D0
25287 FACQG2=COMFAC*AS**2*FACQG2/2D0
25288 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25289 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
25290 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
25291 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
25294 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25295 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25297 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
25298 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
25301 ISIG(NCHN,3-ISDE)=21
25303 SIGH(NCHN)=FACQG1*FACSEL
25306 ISIG(NCHN,3-ISDE)=21
25308 SIGH(NCHN)=FACQG2*FACSEL
25313 ELSEIF(ISUB.LE.270) THEN
25314 IF(ISUB.EQ.261) THEN
25315 C...q_i + q_ibar -> ~t_1 + ~t_1bar
25316 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
25317 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25318 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25320 DO 390 I=MMIN1,MMAX1
25322 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
25323 IF(IA.GE.11.AND.IA.LE.18) THEN
25325 EJ=KCHG(KFNSQ,1)/3D0
25326 T3I=SIGN(1D0,EI)/2D0
25327 T3J=SIGN(1D0,EJ)/2D0
25328 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
25329 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
25330 XLF=2D0*(T3I-EI*XW)
25332 TAA=0.5D0*(EI*EJ)**2
25333 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
25334 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25335 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
25336 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25337 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
25343 SIGH(NCHN)=FACQQ1*FAC0
25346 ELSEIF(ISUB.EQ.263) THEN
25347 C...f + fbar -> ~t1 + ~t2bar
25348 DO 400 I=MMIN1,MMAX1
25350 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
25351 EI=KCHG(IABS(I),1)/3D0
25352 TT3I=SIGN(1D0,EI)/2D0
25356 C...Color factor for e+ e-
25357 IF(IA.GE.11) FCOL=3D0
25358 XLQ=2D0*(TT3J-EJ*XW)
25360 XLF=2D0*(TT3I-EI*XW)
25362 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
25363 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
25364 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25365 C...Factor of 2 for t1 t2bar + t2 t1bar
25366 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
25367 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
25372 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
25373 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
25378 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
25379 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
25382 ELSEIF(ISUB.EQ.264) THEN
25383 C...g + g -> ~t_1 + ~t_1bar
25386 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
25387 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25388 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
25389 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
25390 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
25404 ELSEIF(ISUB.LE.280) THEN
25405 IF(ISUB.EQ.271) THEN
25406 C...q + q' -> ~q + ~q' (~g exchange)
25407 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
25415 FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
25416 FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
25419 FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
25420 FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
25421 FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
25424 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
25425 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
25426 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
25427 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
25429 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
25432 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
25433 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
25435 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
25436 IF(I*J.LT.0) GOTO 420
25441 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25442 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
25445 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
25446 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
25448 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
25449 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25450 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
25457 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
25458 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
25460 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
25461 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25462 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
25468 ELSEIF(ISUB.EQ.274) THEN
25469 C...q + qbar' -> ~q + ~qbar'
25470 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
25474 C...Mrenna...Normalization.and.1/XMT
25475 FACQQ1=COMFAC*AS**2*2D0/9D0*(
25476 & (UH*TH-SQM3*SQM4)/XMT**2 )
25477 FACQQB=COMFAC*AS**2*2D0/9D0*(
25478 & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT))
25479 FACQQB=FACQQB+FACQQ1
25481 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
25484 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
25485 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
25486 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
25487 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
25489 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
25492 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
25493 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
25495 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
25496 IF(I*J.GT.0) GOTO 440
25501 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
25502 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
25503 IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
25504 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25508 ELSEIF(ISUB.EQ.277) THEN
25509 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
25510 C...if i .eq. j covered in 274
25511 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
25512 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
25514 DO 460 I=MMIN1,MMAX1
25516 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
25517 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
25518 IF(IA.EQ.KFNSQ) GOTO 460
25519 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
25521 EJ=KCHG(KFNSQ,1)/3D0
25523 T3I=SIGN(1D0,EI)/2D0
25525 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
25526 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
25528 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
25529 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
25531 XLF=2D0*(T3I-EI*XW)
25538 TAA=0.5D0*(EI*EJ)**2
25539 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
25540 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
25541 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
25542 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
25543 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
25544 ELSEIF(IA.LE.6) THEN
25545 FAC0=AS**2*8D0/9D0/2D0
25551 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25554 ELSEIF(ISUB.EQ.279) THEN
25555 C...g + g -> ~q_j + ~q_jbar
25558 C...5=RKF because ~t ~tbar treated separately
25559 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
25560 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
25561 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
25562 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
25567 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25572 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
25582 C*********************************************************************
25585 C...Subprocess cross sections for Technicolor processes.
25586 C...Auxiliary to PYSIGH.
25588 SUBROUTINE PYSGTC(NCHN,SIGS)
25590 C...Double precision and integer declarations
25591 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25592 IMPLICIT INTEGER(I-N)
25593 INTEGER PYK,PYCHGE,PYCOMP
25594 C...Parameter statement to help give large particle numbers.
25595 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
25596 &KEXCIT=4000000,KDIMEN=5000000)
25598 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25599 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25600 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
25601 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25602 COMMON/PYINT1/MINT(400),VINT(400)
25603 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
25604 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
25605 COMMON/PYINT4/MWID(500),WIDS(500,5)
25606 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
25607 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
25608 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
25609 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
25610 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
25611 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
25612 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
25613 C...Local arrays and complex variables
25614 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
25615 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
25616 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
25617 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
25618 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
25619 COMPLEX*16 DVVS,DVVT,DVVU
25622 C...Combinations of weak mixing angle.
25624 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
25626 C...Convert almost equivalent technicolor processes into
25627 C...a few basic processes, and set distinguishing parameters.
25628 IF(ISUB.GE.361.AND.ISUB.LE.379) THEN
25631 SN2W=2D0*SQRT(PARU(102)*(1D0-PARU(102)))
25632 CS2W=1D0-2D0*PARU(102)
25633 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
25635 CSXI=COS(ASIN(RTCM(3)))
25636 CSXIP=COS(ASIN(RTCM(4)))
25637 QUPD=2D0*RTCM(2)-1D0
25638 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
25639 C... rho_tc0 -> W_L W_L
25640 IF(ISUB.EQ.361) THEN
25644 C... rho_tc0 -> W_L pi_tc-
25645 ELSEIF(ISUB.EQ.362) THEN
25649 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
25651 ELSEIF(ISUB.EQ.363) THEN
25655 CAB2=(1D0-RTCM(3)**2)**2
25656 C... rho_tc0/omega_tc -> gamma pi_tc
25657 ELSEIF(ISUB.EQ.364) THEN
25666 VZGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
25668 ELSEIF(ISUB.EQ.365) THEN
25672 VRGP=CSXIP/RTCM(12)
25677 VAGP=2D0*Q2UD*CSXIP
25678 VZGP=CSXIP/SN2W*(1D0-4D0*PARU(102)*Q2UD)
25680 ELSEIF(ISUB.EQ.366) THEN
25684 VOGP=CSXI*CT2W/RTCM(12)
25685 VRGP=-QUPD*CSXI*TANW/RTCM(12)
25688 VAGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
25689 VZGP=-QUPD*CSXI*CS2W/(1D0-PARU(102))
25691 ELSEIF(ISUB.EQ.367) THEN
25695 VRGP=CSXIP*CT2W/RTCM(12)
25696 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
25699 VAGP=CSXIP*(1D0-4D0*Q2UD*PARU(102))/SN2W
25700 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*PARU(102)**2)/SN2W**2
25702 ELSEIF(ISUB.EQ.368) THEN
25706 VOGP=CSXI/(2D0*SQRT(PARU(102)))/RTCM(12)
25710 ARGP=-CSXI/(2D0*SQRT(PARU(102)))/RTCM(13)
25711 VAGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
25712 VZGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
25713 C... rho_tc+ -> W_L Z_L
25714 ELSEIF(ISUB.EQ.370) THEN
25719 ELSEIF(ISUB.EQ.371) THEN
25723 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
25725 ELSEIF(ISUB.EQ.372) THEN
25729 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
25731 ELSEIF(ISUB.EQ.373) THEN
25735 CAB2=(1D0-RTCM(3)**2)**2
25737 ELSEIF(ISUB.EQ.374) THEN
25742 VWGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
25744 ELSEIF(ISUB.EQ.375) THEN
25748 VRGP=-QUPD*CSXI*TANW
25749 ARGP=CSXI/(2D0*SQRT(PARU(102)*(1D0-PARU(102))))
25750 VWGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
25752 ELSEIF(ISUB.EQ.376) THEN
25757 ARGP=-CSXI/(2D0*SQRT(PARU(102)))
25760 ELSEIF(ISUB.EQ.377) THEN
25765 VRGP=CSXIP/(2D0*SQRT(PARU(102)))
25766 VWGP=CSXIP/(2D0*PARU(102))
25770 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
25771 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
25772 IF(ITCM(5).LE.4) THEN
25790 ELSEIF(ITCM(5).EQ.5) THEN
25792 IF(ITCM(2).EQ.0) THEN
25797 ALPRHT=2.91D0*(3D0/ITCM(1))
25798 SIN2T=2D0*TANT3/(TANT3**2+1D0)
25799 SINT3=TANT3/SQRT(TANT3**2+1D0)
25800 XIG=SQRT(PYALPS(SH)/ALPRHT)
25801 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
25802 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
25803 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
25804 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
25805 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
25806 & SINT3**2)*2D0/SIN2T
25807 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
25808 & SINT3**2)*2D0/SIN2T
25810 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
25811 SM1112=X12*RTCM(28)**2*SIN2T
25812 SM1121=-X21*RTCM(28)**2*SIN2T
25815 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
25816 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
25819 ZTC(1,1)=DCMPLX(SH,0D0)
25820 CALL PYWIDT(3100021,SH,WDTP,WDTE)
25821 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
25822 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
25823 CALL PYWIDT(3100113,SH,WDTP,WDTE)
25824 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
25825 CALL PYWIDT(3400113,SH,WDTP,WDTE)
25826 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
25827 CALL PYWIDT(3200113,SH,WDTP,WDTE)
25828 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
25829 CALL PYWIDT(3300113,SH,WDTP,WDTE)
25830 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
25832 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
25836 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
25837 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
25838 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
25839 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
25852 CALL PYLDCM(ZTC,6,6,INDX,D)
25856 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
25861 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
25867 XIG=SQRT(PYALPS(-TH)/ALPRHT)
25869 ZTC(1,1)=DCMPLX(TH)
25870 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
25871 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
25872 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
25873 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
25874 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
25876 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
25880 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
25881 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
25882 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
25883 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
25895 CALL PYLDCM(ZTC,6,6,INDX,D)
25899 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
25903 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
25909 XIG=SQRT(PYALPS(-UH)/ALPRHT)
25911 ZTC(1,1)=DCMPLX(UH,0D0)
25912 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
25913 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
25914 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
25915 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
25916 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
25918 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
25922 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
25923 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
25924 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
25925 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
25937 CALL PYLDCM(ZTC,6,6,INDX,D)
25941 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
25945 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
25952 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
25953 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
25954 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
25955 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
25956 DQGS=DGGS-DGVS*DCMPLX(TANT3)
25957 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
25959 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
25960 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
25961 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
25962 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
25963 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
25964 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
25967 SQDQTS=ABS(DQTS)**2
25968 SQDQQS=ABS(DQQS)**2
25969 SQDQQT=ABS(DQQT)**2
25970 SQDQQU=ABS(DQQU)**2
25971 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
25973 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
25975 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
25977 SQDGGS=ABS(DGGS)**2
25978 SQDGGT=ABS(DGGT)**2
25979 SQDGGU=ABS(DGGU)**2
25983 REDGTU=DBLE(DGGU*DCONJG(DGGT))
25984 REDGSU=DBLE(DGGU*DCONJG(DGGS))
25985 REDGST=DBLE(DGGS*DCONJG(DGGT))
25986 REDQST=DBLE(DQQS*DCONJG(DQQT))
25987 REDQTU=DBLE(DQQT*DCONJG(DQQU))
25992 C...Differential cross section expressions.
25994 IF(ISUB.LE.190) THEN
25995 IF(ISUB.EQ.149) THEN
25996 C...g + g -> eta_tc
25997 KCTC=PYCOMP(KTECHN+331)
25998 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
26000 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
26001 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26003 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
26005 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26010 SIGH(NCHN)=HI*FACBW*HF
26013 ELSEIF(ISUB.EQ.165) THEN
26014 C...q + qbar -> l+ + l- (including contact term for compositeness)
26015 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26016 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26017 KFF=IABS(KFPR(ISUB,1))
26019 AF=SIGN(1D0,EF+0.1D0)
26024 IF(KFF.LE.10) FCOF=3D0
26026 IF(KFF.EQ.6) WID2=WIDS(6,1)
26027 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
26028 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
26029 DO 260 I=MMINA,MMAXA
26030 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
26031 EI=KCHG(IABS(I),1)/3D0
26032 AI=SIGN(1D0,EI+0.1D0)
26037 IF(IABS(I).LE.10) FCOI=FACA/3D0
26038 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
26039 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
26040 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
26041 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
26043 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
26044 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
26046 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
26047 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
26048 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
26049 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
26050 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
26055 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
26058 ELSEIF(ISUB.EQ.166) THEN
26059 C...q + q'bar -> l + nu_l (including contact term for compositeness)
26060 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
26061 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
26062 KFF=IABS(KFPR(ISUB,1))
26064 IF(KFF.LE.10) FCOF=3D0
26065 DO 280 I=MMIN1,MMAX1
26066 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
26068 DO 270 J=MMIN2,MMAX2
26069 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
26071 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
26072 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26075 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
26077 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
26078 & MOD(J,2).EQ.0)) THEN
26079 IF(KFF.EQ.5) WID2=WIDS(6,2)
26080 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
26081 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
26083 IF(KFF.EQ.5) WID2=WIDS(6,3)
26084 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
26085 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
26091 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
26092 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
26093 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
26098 ELSEIF(ISUB.LE.200) THEN
26099 IF(ISUB.EQ.191) THEN
26100 C...q + qbar -> rho_tc0.
26101 KCTC=PYCOMP(KTECHN+113)
26102 SQMRHT=PMAS(KCTC,1)**2
26103 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26105 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
26106 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26107 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26108 ALPRHT=2.91D0*(3D0/ITCM(1))
26109 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
26110 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26111 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26112 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26113 DO 290 I=MMINA,MMAXA
26114 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
26116 EI=KCHG(IABS(I),1)/3D0
26117 AI=SIGN(1D0,EI+0.1D0)
26121 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26122 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
26123 IF(IA.LE.10) HI=HI*FACA/3D0
26128 SIGH(NCHN)=HI*FACBW*HF
26131 ELSEIF(ISUB.EQ.192) THEN
26132 C...q + qbar' -> rho_tc+/-.
26133 KCTC=PYCOMP(KTECHN+213)
26134 SQMRHT=PMAS(KCTC,1)**2
26135 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26137 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
26138 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26139 ALPRHT=2.91D0*(3D0/ITCM(1))
26140 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
26141 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26142 DO 310 I=MMIN1,MMAX1
26143 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
26145 DO 300 J=MMIN2,MMAX2
26146 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
26148 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
26149 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26151 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26152 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
26154 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
26159 SIGH(NCHN)=HI*FACBW*HF
26163 ELSEIF(ISUB.EQ.193) THEN
26164 C...q + qbar -> omega_tc0.
26165 KCTC=PYCOMP(KTECHN+223)
26166 SQMOMT=PMAS(KCTC,1)**2
26167 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26169 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
26170 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
26171 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26172 ALPRHT=2.91D0*(3D0/ITCM(1))
26173 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
26174 & (2D0*RTCM(2)-1D0)**2
26175 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26176 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26177 DO 320 I=MMINA,MMAXA
26178 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
26180 EI=KCHG(IABS(I),1)/3D0
26181 AI=SIGN(1D0,EI+0.1D0)
26185 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
26186 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
26187 IF(IA.LE.10) HI=HI*FACA/3D0
26192 SIGH(NCHN)=HI*FACBW*HF
26195 ELSEIF(ISUB.EQ.194) THEN
26196 C...f + fbar -> f' + fbar' via s-channel rho_tc and omega_tc.
26198 ALPRHT=2.91D0*(3D0/ITCM(1))
26200 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
26201 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
26203 QUPD=2D0*RTCM(2)-1D0
26204 FAR=SQRT(AEM/ALPRHT)
26212 CALL PYWIDT(23,SH,WDTP,WDTE)
26213 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26214 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26215 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26216 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26217 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26218 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26219 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26220 DAA=(-Sfzr*SSMO - Sfzo*SSMR + SSMO*SSMR*SSMZ)/DETD/SH
26221 DZZ=(-Sfar*SSMO - Sfao*SSMR + SSMO*SSMR)/DETD/SH
26222 DAZ=(far*fzr*SSMO + fao*fzo*SSMR)/DETD/SH
26224 XWRHT=1D0/(4D0*XW*(1D0-XW))
26225 KFF=IABS(KFPR(ISUB,1))
26227 AF=SIGN(1D0,EF+0.1D0)
26232 IF(KFF.LE.10) FCOF=3D0
26235 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
26236 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
26237 DZZ=DZZ*DCMPLX(XWRHT,0D0)
26238 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
26240 DO 330 I=MMINA,MMAXA
26241 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
26242 EI=KCHG(IABS(I),1)/3D0
26243 AI=SIGN(1D0,EI+0.1D0)
26248 IF(IABS(I).LE.10) FCOI=FCOI/3D0
26249 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
26250 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
26251 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
26252 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
26253 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
26254 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
26259 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
26262 ELSEIF(ISUB.EQ.195) THEN
26263 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+
26266 ALPRHT=2.91D0*(3D0/ITCM(1))
26267 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
26269 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26270 CALL PYWIDT(24,SH,WDTP,WDTE)
26271 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26272 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26273 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26276 IF(KFA.LE.8) FCOF=3D0
26277 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26278 HP=FACTC*ABS(SSMR/DETD)**2/SH**2*FCOF
26280 DO 350 I=MMIN1,MMAX1
26281 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
26283 DO 340 J=MMIN2,MMAX2
26284 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
26286 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
26287 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26289 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26291 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26296 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
26301 ELSEIF(ISUB.LE.380) THEN
26302 IF(ISUB.EQ.361) THEN
26303 C...f + fbar -> W_L W_L, W_L pi_tc, pi_tc pi_tc
26304 FACA=(SH**2*BE34**2-(TH-UH)**2)
26305 ALPRHT=2.91D0*(3D0/ITCM(1))
26306 HP=(1D0/12D0)*AEM**2*CAB2*COMFAC*FACA*3D0
26307 FAR=SQRT(AEM/ALPRHT)
26315 CALL PYWIDT(23,SH,WDTP,WDTE)
26316 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26317 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26318 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26319 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26320 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26321 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26322 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26323 DARHO=-(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26324 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26325 DAA=-(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
26326 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
26327 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH
26329 DO 360 I=MMINA,MMAXA
26330 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 360
26332 EI=KCHG(IABS(I),1)/3D0
26333 AI=SIGN(1D0,EI+0.1D0)
26335 VALI=0.25D0*(VI+AI)
26336 VARI=0.25D0*(VI-AI)
26337 F2L=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
26338 $ VALI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
26339 F2R=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
26340 $ VARI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
26341 HI=ABS(F2L)**2+ABS(F2R)**2
26342 IF(IA.LE.10) HI=HI/3D0
26347 IF(KFA.EQ.KFB) THEN
26348 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
26350 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26355 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26359 ELSEIF(ISUB.EQ.364) THEN
26360 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
26362 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
26363 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
26364 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
26366 ALPRHT=2.91D0*(3D0/ITCM(1))
26367 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
26368 FAR=SQRT(AEM/ALPRHT)
26376 CALL PYWIDT(23,SH,WDTP,WDTE)
26377 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
26378 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
26379 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
26380 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
26381 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
26382 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
26383 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
26384 DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
26385 DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
26386 DAOME=(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)/DETD/SH
26387 DZOME=(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH
26388 DAA=(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
26389 DZZ=(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
26390 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH
26392 DO 370 I=MMINA,MMAXA
26393 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
26395 EI=KCHG(IABS(I),1)/3D0
26396 AI=SIGN(1D0,EI+0.1D0)
26398 VALI=0.25D0*(VI+AI)
26399 VARI=0.25D0*(VI-AI)
26400 C...........Add in anomaly contribution
26401 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
26402 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
26403 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
26404 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
26405 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
26406 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
26407 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
26408 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
26409 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
26410 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
26411 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
26412 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
26413 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
26414 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
26416 IF(IA.LE.10) HI=HI/3D0
26421 IF(ISUBSV.NE.368) THEN
26422 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
26424 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
26429 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
26433 ELSEIF(ISUB.EQ.370) THEN
26434 C...f + fbar' -> W_L Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
26436 FACA=(SH**2*BE34**2-(TH-UH)**2)
26437 ALPRHT=2.91D0*(3D0/ITCM(1))
26438 HP=(1D0/96D0)*AEM**2*CAB2*COMFAC*FACA*3D0/XW**2
26439 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26440 CALL PYWIDT(24,SH,WDTP,WDTE)
26441 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26442 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26443 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26444 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26447 HP=HP*ABS(DWW+DWRHO)**2
26448 DO 390 I=MMIN1,MMAX1
26449 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 390
26451 DO 380 J=MMIN2,MMAX2
26452 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 380
26454 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 380
26455 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26457 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26459 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26464 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26465 & WIDS(PYCOMP(KFB),2)
26469 ELSEIF(ISUB.EQ.374) THEN
26470 C...f + fbar' -> gamma pi_tc
26471 FANOM=SQRT(AEM)*ITCM(1)/2D0/PARU(2)/RTCM(1)
26472 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
26473 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*ARGP**2
26474 ALPRHT=2.91D0*(3D0/ITCM(1))
26475 HP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
26476 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
26477 CALL PYWIDT(24,SH,WDTP,WDTE)
26478 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
26479 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
26480 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
26481 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
26483 DWRHO=-DCMPLX(FWR,0D0)/DETD/SH
26484 HP=HP*(AFAC*ABS(DWRHO)**2+
26485 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP/SQRT(SQTV))**2)
26486 DO 410 I=MMIN1,MMAX1
26487 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
26489 DO 400 J=MMIN2,MMAX2
26490 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
26492 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
26493 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
26495 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
26497 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
26502 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
26503 & WIDS(PYCOMP(KFB),2)
26508 ELSEIF(ISUB.LE.390) THEN
26509 IF(ISUB.EQ.381) THEN
26510 C...f + f' -> f + f' (g exchange)
26511 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
26512 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
26513 & MSTP(34)*2D0/3D0*UH2*REDQST)
26514 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
26515 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
26516 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
26517 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
26518 C...Modifications from contact interactions (compositeness)
26519 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
26520 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
26521 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
26522 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
26523 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
26524 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
26525 RATCII=(FACCI1*FACCI2+FACQQI)/(FACCI1+FACCI2)
26526 ELSEIF(ITCM(5).EQ.5) THEN
26531 CSM.......Check this change from
26535 DO 430 I=MMIN1,MMAX1
26537 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
26538 DO 420 J=MMIN2,MMAX2
26540 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
26545 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
26548 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
26551 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
26552 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
26559 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
26560 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
26561 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
26563 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
26564 SIGH(NCHN)=0.5D0*FACCI2*RATCII
26570 ELSEIF(ISUB.EQ.382) THEN
26571 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
26572 CALL PYWIDT(21,SH,WDTP,WDTE)
26573 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
26574 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26575 IF(ITCM(5).EQ.1) THEN
26576 C...Modifications from contact interactions (compositeness)
26579 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
26580 & WDTE(I,2)+WDTE(I,4))
26582 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
26583 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
26584 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
26585 ELSEIF(ITCM(5).EQ.5) THEN
26586 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
26587 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
26588 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
26590 DO 450 I=MMINA,MMAXA
26591 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26592 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
26597 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
26599 ELSEIF(ITCM(5).EQ.5) THEN
26611 ELSEIF(ISUB.EQ.383) THEN
26612 C...f + fbar -> g + g (q + qbar -> g + g only)
26613 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
26614 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
26615 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
26616 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
26617 IF(ITCM(5).EQ.5) THEN
26618 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
26619 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
26620 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
26621 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
26623 DO 460 I=MMINA,MMAXA
26624 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26625 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
26630 SIGH(NCHN)=0.5D0*FACGG1
26631 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
26636 SIGH(NCHN)=0.5D0*FACGG2
26637 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
26640 ELSEIF(ISUB.EQ.384) THEN
26641 C...f + g -> f + g (q + g -> q + g only)
26642 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
26643 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
26644 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
26645 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
26646 DO 480 I=MMINA,MMAXA
26647 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
26649 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
26650 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
26653 ISIG(NCHN,3-ISDE)=21
26658 ISIG(NCHN,3-ISDE)=21
26664 ELSEIF(ISUB.EQ.385) THEN
26665 C...g + g -> f + fbar (g + g -> q + qbar only)
26666 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
26668 C...Begin by d, u, s flavours.
26670 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
26671 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
26672 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
26673 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
26674 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
26675 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
26676 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
26677 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
26678 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
26679 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
26690 C...Next c and b flavours: modified that and uhat for fixed
26691 C...cos(theta-hat).
26693 SQMAVG=PMAS(IFL,1)**2
26694 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
26695 BE34=SQRT(1D0-4D0*SQMAVG/SH)
26696 THQ=-0.5D0*SH*(1D0-BE34*CTH)
26697 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
26698 THUHQ=THQ*UHQ-SQMAVG*SH
26699 IF(MSTP(34).EQ.0) THEN
26700 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
26701 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
26703 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26704 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
26705 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26706 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
26708 IF(ITCM(5).GE.5) THEN
26710 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
26711 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26712 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
26713 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26715 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
26716 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26717 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
26718 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26721 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
26722 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
26726 ISIG(NCHN,3)=1+2*(IFL-3)
26731 ISIG(NCHN,3)=2+2*(IFL-3)
26737 ELSEIF(ISUB.EQ.386) THEN
26739 IF(ITCM(5).LE.4) THEN
26740 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
26741 & 2D0*TH/SH+TH2/SH2)*FACA
26742 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
26743 & 2D0*SH/UH+SH2/UH2)*FACA
26744 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
26745 & 2D0*UH/TH+UH2/TH2)
26747 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
26748 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
26749 & 4D0*REDGST*(SH + 2D0*TH)*
26750 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
26751 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
26752 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
26753 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
26754 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
26755 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
26756 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
26757 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
26758 & 4D0*REDGSU*(SH + 2D0*UH)*
26759 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
26760 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
26761 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
26762 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
26763 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
26764 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
26765 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
26766 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
26767 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
26768 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
26769 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
26770 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
26771 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
26772 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
26773 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
26774 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
26775 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
26776 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
26777 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
26778 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
26779 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
26780 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
26782 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
26787 SIGH(NCHN)=0.5D0*FACGG1
26792 SIGH(NCHN)=0.5D0*FACGG2
26797 SIGH(NCHN)=0.5D0*FACGG3
26800 ELSEIF(ISUB.EQ.387) THEN
26801 C...q + qbar -> Q + Qbar
26802 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
26803 THQ=-0.5D0*SH*(1D0-BE34*CTH)
26804 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
26805 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
26807 IF(ITCM(5).GE.5) THEN
26808 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
26809 FACQQB=FACQQB*SH2*SQDQTS
26811 FACQQB=FACQQB*SH2*SQDQQS
26814 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
26816 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
26817 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
26819 DO 520 I=MMINA,MMAXA
26820 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
26821 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
26829 ELSEIF(ISUB.EQ.388) THEN
26830 C...g + g -> Q + Qbar
26831 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
26832 THQ=-0.5D0*SH*(1D0-BE34*CTH)
26833 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
26834 THUHQ=THQ*UHQ-SQMAVG*SH
26835 IF(MSTP(34).EQ.0) THEN
26836 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
26837 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
26839 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26840 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
26841 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
26842 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
26844 IF(ITCM(5).GE.5) THEN
26845 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
26846 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
26847 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26848 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
26849 & 2.25D0*THQ*UHQ/SH2*SQDHGS
26851 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
26852 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26853 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
26854 & 2.25D0*THQ*UHQ/SH2*SQDLGS
26857 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
26858 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
26859 IF(MSTP(35).GE.1) THEN
26860 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
26861 FACQQ1=FACQQ1*FATRE
26862 FACQQ2=FACQQ2*FATRE
26865 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
26866 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
26869 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
26889 C*********************************************************************
26892 C...Subprocess cross sections for assorted exotic processes,
26893 C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
26894 C...Auxiliary to PYSIGH.
26896 SUBROUTINE PYSGEX(NCHN,SIGS)
26898 C...Double precision and integer declarations
26899 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26900 IMPLICIT INTEGER(I-N)
26901 INTEGER PYK,PYCHGE,PYCOMP
26902 C...Parameter statement to help give large particle numbers.
26903 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
26904 &KEXCIT=4000000,KDIMEN=5000000)
26906 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26907 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26908 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
26909 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26910 COMMON/PYINT1/MINT(400),VINT(400)
26911 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
26912 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
26913 COMMON/PYINT4/MWID(500),WIDS(500,5)
26914 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
26915 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
26916 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
26917 &SHR,SQPTH,TAUP,BE34,CTH,SQMZ,SQMW,GMMZ,GMMW,
26918 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
26919 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
26920 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
26922 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
26924 C...Differential cross section expressions.
26926 IF(ISUB.LE.160) THEN
26927 IF(ISUB.EQ.141) THEN
26928 C...f + fbar -> gamma*/Z0/Z'0
26929 SQMZP=PMAS(32,1)**2
26931 CALL PYWIDT(32,SH,WDTP,WDTE)
26937 FACZP=4D0*COMFAC*3D0
26938 DO 100 I=MMINA,MMAXA
26939 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
26940 EI=KCHG(IABS(I),1)/3D0
26946 VPI=PARU(123-2*MOD(IABS(I),2))
26947 API=PARU(124-2*MOD(IABS(I),2))
26948 ELSEIF(IA.LE.4) THEN
26949 VPI=PARJ(182-2*MOD(IABS(I),2))
26950 API=PARJ(183-2*MOD(IABS(I),2))
26952 VPI=PARJ(190-2*MOD(IABS(I),2))
26953 API=PARJ(191-2*MOD(IABS(I),2))
26957 VPI=PARU(127-2*MOD(IABS(I),2))
26958 API=PARU(128-2*MOD(IABS(I),2))
26959 ELSEIF(IA.LE.14) THEN
26960 VPI=PARJ(186-2*MOD(IABS(I),2))
26961 API=PARJ(187-2*MOD(IABS(I),2))
26963 VPI=PARJ(194-2*MOD(IABS(I),2))
26964 API=PARJ(195-2*MOD(IABS(I),2))
26968 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
26970 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
26972 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
26977 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
26978 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
26979 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
26980 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
26981 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
26982 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
26983 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
26984 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
26987 ELSEIF(ISUB.EQ.142) THEN
26988 C...f + fbar' -> W'+/-
26989 SQMWP=PMAS(34,1)**2
26990 CALL PYWIDT(34,SH,WDTP,WDTE)
26992 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
26993 HP=AEM/(24D0*XW)*SH
26994 DO 120 I=MMIN1,MMAX1
26995 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
26997 DO 110 J=MMIN2,MMAX2
26998 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
27000 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
27001 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
27003 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
27004 HI=HP*(PARU(133)**2+PARU(134)**2)
27005 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
27006 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
27011 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
27012 SIGH(NCHN)=HI*FACBW*HF
27016 ELSEIF(ISUB.EQ.144) THEN
27019 CALL PYWIDT(41,SH,WDTP,WDTE)
27021 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
27022 HP=AEM/(12D0*XW)*SH
27023 DO 140 I=MMIN1,MMAX1
27024 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
27026 DO 130 J=MMIN2,MMAX2
27027 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
27029 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
27031 IF(IA.LE.10) HI=HI*FACA/3D0
27032 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
27037 SIGH(NCHN)=HI*FACBW*HF
27041 ELSEIF(ISUB.EQ.145) THEN
27042 C...q + l -> LQ (leptoquark)
27043 SQMLQ=PMAS(42,1)**2
27044 CALL PYWIDT(42,SH,WDTP,WDTE)
27046 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
27047 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
27049 KFLQQ=KFDP(MDCY(42,2),1)
27050 KFLQL=KFDP(MDCY(42,2),2)
27051 DO 160 I=MMIN1,MMAX1
27052 IF(KFAC(1,I).EQ.0) GOTO 160
27054 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
27055 DO 150 J=MMIN2,MMAX2
27056 IF(KFAC(2,J).EQ.0) GOTO 150
27058 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
27059 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
27060 IF(JA.EQ.IA) GOTO 150
27061 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
27062 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
27064 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
27069 SIGH(NCHN)=HI*FACBW*HF
27073 ELSEIF(ISUB.EQ.146) THEN
27074 C...e + gamma* -> e* (excited lepton)
27075 KFQSTR=KFPR(ISUB,1)
27076 KCQSTR=PYCOMP(KFQSTR)
27077 KFQEXC=MOD(KFQSTR,KEXCIT)
27078 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
27080 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
27081 QF=-RTCM(43)/2D0-RTCM(44)/2D0
27082 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
27083 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
27086 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
27088 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
27089 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
27091 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27092 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
27095 ISIG(NCHN,3-ISDE)=22
27097 SIGH(NCHN)=HI*FACBW*HF
27101 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
27102 C...d + g -> d* and u + g -> u* (excited quarks)
27103 KFQSTR=KFPR(ISUB,1)
27104 KCQSTR=PYCOMP(KFQSTR)
27105 KFQEXC=MOD(KFQSTR,KEXCIT)
27106 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
27108 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
27109 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
27110 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
27113 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
27115 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
27116 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
27118 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27119 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
27122 ISIG(NCHN,3-ISDE)=21
27124 SIGH(NCHN)=HI*FACBW*HF
27129 ELSEIF(ISUB.LE.190) THEN
27130 IF(ISUB.EQ.162) THEN
27131 C...q + g -> LQ + lbar; LQ=leptoquark
27132 SQMLQ=PMAS(42,1)**2
27133 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
27134 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
27135 KFLQQ=KFDP(MDCY(42,2),1)
27136 DO 220 I=MMINA,MMAXA
27137 IF(IABS(I).NE.KFLQQ) GOTO 220
27140 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
27141 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
27144 ISIG(NCHN,3-ISDE)=21
27146 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
27150 ELSEIF(ISUB.EQ.163) THEN
27151 C...g + g -> LQ + LQbar; LQ=leptoquark
27152 SQMLQ=PMAS(42,1)**2
27153 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
27154 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
27155 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
27156 & ((TH-SQMLQ)*(UH-SQMLQ)))
27157 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
27161 C...Since don't know proper colour flow, randomize between alternatives
27162 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
27166 ELSEIF(ISUB.EQ.164) THEN
27167 C...q + qbar -> LQ + LQbar; LQ=leptoquark
27168 DELTA=0.25D0*(SQM3-SQM4)**2/SH
27169 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
27172 C SQMLQ=PMAS(42,1)**2
27173 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
27174 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
27175 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
27176 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
27177 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
27178 KFLQQ=KFDP(MDCY(42,2),1)
27179 DO 240 I=MMINA,MMAXA
27180 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
27181 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
27187 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
27190 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
27191 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
27192 KFQSTR=KFPR(ISUB,2)
27193 KCQSTR=PYCOMP(KFQSTR)
27194 KFQEXC=MOD(KFQSTR,KEXCIT)
27195 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
27196 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
27197 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
27198 C...Propagators: as simulated in PYOFSH and as desired
27199 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
27200 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
27201 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
27202 GMMQC=SQRT(SQM4)*WDTP(0)
27203 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
27204 FACQSA=FACQSA*HBW4C/HBW4
27205 FACQSB=FACQSB*HBW4C/HBW4
27206 C...Branching ratios.
27207 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
27208 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
27209 DO 260 I=MMIN1,MMAX1
27211 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
27212 DO 250 J=MMIN2,MMAX2
27214 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
27215 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
27220 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
27221 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
27226 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
27227 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
27228 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
27233 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
27234 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
27235 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
27236 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
27241 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
27242 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
27247 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
27248 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
27249 ELSEIF(I.EQ.-J) THEN
27254 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27255 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27260 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27261 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27262 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
27267 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
27268 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
27269 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
27274 ELSEIF(ISUB.EQ.169) THEN
27275 C...q + qbar -> e + e* (excited lepton)
27276 KFQSTR=KFPR(ISUB,2)
27277 KCQSTR=PYCOMP(KFQSTR)
27278 KFQEXC=MOD(KFQSTR,KEXCIT)
27279 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
27280 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
27281 C...Propagators: as simulated in PYOFSH and as desired
27282 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
27283 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
27284 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
27285 GMMQC=SQRT(SQM4)*WDTP(0)
27286 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
27287 FACQSB=FACQSB*HBW4C/HBW4
27288 C...Branching ratios.
27289 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
27290 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
27291 DO 270 I=MMIN1,MMAX1
27293 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
27296 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
27301 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27302 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27307 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
27308 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
27312 ELSEIF(ISUB.LE.360) THEN
27313 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
27314 C...l + l -> H_L++/-- or H_R++/--.
27316 KFREC=PYCOMP(KFRES)
27317 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
27319 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
27320 DO 290 I=MMIN1,MMAX1
27322 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
27324 DO 280 J=MMIN2,MMAX2
27326 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
27328 IF(I*J.LT.0) GOTO 280
27329 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
27334 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
27335 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
27336 SIGH(NCHN)=HI*FACBW*HF
27340 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
27341 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
27343 KFREC=PYCOMP(KFRES)
27344 C...Propagators: as simulated in PYOFSH and as desired
27345 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
27346 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
27347 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
27348 GMMC=SQRT(SQM3)*WDTP(0)
27349 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
27350 FHCC=COMFAC*AEM*HBW3C/HBW3
27351 DO 310 I=MMINA,MMAXA
27353 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
27355 J=ISIGN(KFPR(ISUB,2),-I)
27356 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
27357 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
27358 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
27360 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
27361 & (TH-SQM4)*SH)/(TH-SQM4)**2
27362 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
27364 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
27365 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
27366 & ((UH-SQM3)*(TH-SQM4))
27367 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
27368 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
27369 & ((UH-SQM3)*(SH-SQML))
27370 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
27371 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
27372 & ((SH-SQML)*(TH-SQM4))
27373 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
27374 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
27376 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
27377 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
27380 ISIG(NCHN,3-ISDE)=22
27382 SIGH(NCHN)=FHCC*SMM*WIDSC
27386 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
27387 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
27389 KFREC=PYCOMP(KFRES)
27390 SQMH=PMAS(KFREC,1)**2
27391 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
27392 C...Propagators: H++/-- as simulated in PYOFSH and as desired
27393 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
27394 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
27395 GMMH3=SQRT(SQM3)*WDTP(0)
27396 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
27397 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
27398 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
27399 GMMH4=SQRT(SQM4)*WDTP(0)
27400 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
27401 C...Kinematical and coupling functions
27402 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
27403 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
27404 C...Loop over allowed flavours
27405 DO 320 I=MMINA,MMAXA
27406 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
27407 EI=KCHG(IABS(I),1)/3D0
27408 AI=SIGN(1D0,EI+0.1D0)
27411 IF(IABS(I).LE.10) FCOI=FACA/3D0
27412 IF(ISUB.EQ.349) THEN
27413 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
27414 IF(IABS(I).LT.10) THEN
27415 DSIGHH=8D0*AEM**2*(EI**2/SH2+
27416 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
27417 & (VI**2+AI**2)*XWHH**2*HBWZ)
27419 IAOFF=181+3*((IABS(I)-11)/2)
27420 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
27422 DSIGHH=8D0*AEM**2*(EI**2/SH2+
27423 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
27424 & (VI**2+AI**2)*XWHH**2*HBWZ)+
27425 & 8D0*AEM*(EI*HSUM/(SH*TH)+
27426 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
27430 IF(IABS(I).LT.10) THEN
27431 DSIGHH=8D0*AEM**2*EI**2/SH2
27433 IAOFF=181+3*((IABS(I)-11)/2)
27434 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
27436 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
27444 SIGH(NCHN)=FACHH*FCOI*DSIGHH
27447 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
27448 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
27450 KFREC=PYCOMP(KFRES)
27451 SQMH=PMAS(KFREC,1)**2
27452 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
27453 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
27454 & PMAS(PYCOMP(9900024),1)**2
27455 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
27456 FACPRT=1D0/((VINT(204)**2-VINT(215))*
27457 & (VINT(209)**2-VINT(216)))
27458 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
27459 & (VINT(209)**2+2D0*VINT(218)))
27460 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
27462 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
27463 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
27465 DO 340 I=MMIN1,MMAX1
27466 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
27467 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
27468 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
27469 DO 330 J=MMIN2,MMAX2
27470 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
27471 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
27472 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
27474 IF(IABS(KCHH).NE.2) GOTO 330
27475 FACLR=VINT(180+I)*VINT(180+J)
27476 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
27477 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
27478 FACPRP=0.5D0*(FACPRT+FACPRU)**2
27486 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
27490 ELSEIF(ISUB.EQ.353) THEN
27491 C...f + fbar -> Z_R0
27492 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
27493 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
27495 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
27496 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27497 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
27498 DO 350 I=MMINA,MMAXA
27499 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
27500 IF(IABS(I).LE.8) THEN
27501 EI=KCHG(IABS(I),1)/3D0
27502 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
27503 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
27508 HI=HP*(VI**2+AI**2)
27509 IF(IABS(I).LE.10) HI=HI*FACA/3D0
27514 SIGH(NCHN)=HI*FACBW*HF
27517 ELSEIF(ISUB.EQ.354) THEN
27518 C...f + fbar' -> W_R+/-
27519 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
27520 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
27522 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
27523 HP=AEM/(24D0*XW)*SH
27524 DO 370 I=MMIN1,MMAX1
27525 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
27527 DO 360 J=MMIN2,MMAX2
27528 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
27530 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
27531 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
27533 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
27535 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
27540 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
27541 SIGH(NCHN)=HI*FACBW*HF
27546 ELSEIF(ISUB.LE.400) THEN
27547 IF(ISUB.EQ.391) THEN
27548 C...f + fbar -> G*.
27549 KFGSTR=KFPR(ISUB,1)
27550 KCGSTR=PYCOMP(KFGSTR)
27551 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
27553 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27554 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
27555 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
27556 DO 380 I=MMINA,MMAXA
27557 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
27559 IF(IABS(I).LE.10) HI=HI*FACA/3D0
27567 ELSEIF(ISUB.EQ.392) THEN
27569 KFGSTR=KFPR(ISUB,1)
27570 KCGSTR=PYCOMP(KFGSTR)
27571 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
27573 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27574 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
27575 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
27576 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
27584 ELSEIF(ISUB.EQ.393) THEN
27585 C...q + qbar -> g + G*.
27586 KFGSTR=KFPR(ISUB,2)
27587 KCGSTR=PYCOMP(KFGSTR)
27588 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
27589 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
27590 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
27592 C...Propagators: as simulated in PYOFSH and as desired
27593 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
27594 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
27595 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
27596 HS=SQRT(SQM4)*WDTP(0)
27597 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27598 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
27599 FACG=FACG*HBW4C/HBW4
27600 DO 400 I=MMINA,MMAXA
27601 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
27602 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
27610 ELSEIF(ISUB.EQ.394) THEN
27611 C...q + g -> q + G*.
27612 KFGSTR=KFPR(ISUB,2)
27613 KCGSTR=PYCOMP(KFGSTR)
27614 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
27615 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
27616 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
27617 & 2D0*TH2*TH/(UH*SH2))
27618 C...Propagators: as simulated in PYOFSH and as desired
27619 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
27620 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
27621 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
27622 HS=SQRT(SQM4)*WDTP(0)
27623 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27624 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
27625 FACG=FACG*HBW4C/HBW4
27626 DO 420 I=MMINA,MMAXA
27627 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
27629 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
27630 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
27633 ISIG(NCHN,3-ISDE)=21
27639 ELSEIF(ISUB.EQ.395) THEN
27640 C...g + g -> g + G*.
27641 KFGSTR=KFPR(ISUB,2)
27642 KCGSTR=PYCOMP(KFGSTR)
27643 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
27644 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
27645 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
27646 C...Propagators: as simulated in PYOFSH and as desired
27647 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
27648 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
27649 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
27650 HS=SQRT(SQM4)*WDTP(0)
27651 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
27652 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
27653 FACG=FACG*HBW4C/HBW4
27654 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
27667 C*********************************************************************
27670 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
27671 C...parton distributions according to a few different parametrizations.
27672 C...Note that what is coded is x times the probability distribution,
27673 C...i.e. xq(x,Q2) etc.
27675 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
27677 C...Double precision and integer declarations.
27678 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27679 IMPLICIT INTEGER(I-N)
27680 INTEGER PYK,PYCHGE,PYCOMP
27682 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27683 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27684 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27685 COMMON/PYINT1/MINT(400),VINT(400)
27686 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
27688 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
27690 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
27691 &XPPI(-6:6),XPPR(-6:6)
27693 C...Interface to PDFLIB.
27694 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
27696 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
27697 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
27698 CHARACTER*20 PARM(20)
27699 DATA VALUE/20*0D0/,PARM/20*' '/
27701 C...Data related to Schuler-Sjostrand photon distributions.
27702 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
27704 C...Reset parton distributions.
27710 C...Check x and particle species.
27711 IF(X.LE.0D0.OR.X.GE.1D0) THEN
27712 WRITE(MSTU(11),5000) X
27716 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
27717 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
27718 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
27719 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
27720 &KFA.NE.310.AND.KFA.NE.130) THEN
27721 WRITE(MSTU(11),5100) KF
27725 C...Electron (or muon or tau) parton distribution call.
27726 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
27727 CALL PYPDEL(KFA,X,Q2,XPEL)
27732 C...Photon parton distribution call (VDM+anomalous).
27733 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
27734 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
27735 CALL PYPDGA(X,Q2,XPGA)
27739 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
27742 IF(MSTP(55).GE.7) P2MX=4.0D0
27743 IF(MSTP(57).EQ.0) Q2MX=P2MX
27745 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27746 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
27751 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
27754 IF(MSTP(55).GE.11) P2MX=4.0D0
27755 IF(MSTP(57).EQ.0) Q2MX=P2MX
27757 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27758 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
27760 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
27763 ELSEIF(MSTP(56).EQ.2) THEN
27764 C...Call PDFLIB parton distributions.
27768 VALUE(2)=MSTP(55)/1000
27770 VALUE(3)=MOD(MSTP(55),1000)
27771 IF(MINT(93).NE.3000000+MSTP(55)) THEN
27772 CALL PDFSET(PARM,VALUE)
27773 MINT(93)=3000000+MSTP(55)
27776 QQ2=MAX(0D0,Q2MIN,Q2)
27777 IF(MSTP(57).EQ.0) QQ2=Q2MIN
27779 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27781 IF(MSTP(55).EQ.5004) THEN
27782 IF(5D0*P2.LT.QQ2.AND.
27783 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
27784 & P2.GE.0D0.AND.P2.LT.10D0.AND.
27785 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
27786 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
27801 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
27830 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
27833 C...Pion/gammaVDM parton distribution call.
27834 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
27835 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
27836 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
27837 & MSTP(55).LE.12) THEN
27838 ISET=1+MOD(MSTP(55)-1,4)
27841 IF(ISET.GE.3) P2MX=4.0D0
27842 IF(MSTP(57).EQ.0) Q2MX=P2MX
27844 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27845 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
27847 XPQ(KFL)=XPVMD(KFL)
27850 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
27851 CALL PYPDPI(X,Q2,XPPI)
27855 ELSEIF(MSTP(54).EQ.2) THEN
27856 C...Call PDFLIB parton distributions.
27860 VALUE(2)=MSTP(53)/1000
27862 VALUE(3)=MOD(MSTP(53),1000)
27863 IF(MINT(93).NE.2000000+MSTP(53)) THEN
27864 CALL PDFSET(PARM,VALUE)
27865 MINT(93)=2000000+MSTP(53)
27868 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27869 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27870 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27886 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
27889 C...Anomalous photon parton distribution call.
27890 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
27893 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
27894 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
27895 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
27896 IF(MSTP(57).EQ.0) Q2MX=P2MX
27898 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27899 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
27901 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
27904 ELSEIF(MSTP(56).EQ.1) THEN
27905 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
27906 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
27907 IF(MSTP(57).EQ.0) Q2MX=P2MX
27909 IF(VINT(120).LT.0D0) P2=VINT(120)**2
27910 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
27912 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
27915 ELSEIF(MSTP(56).EQ.2) THEN
27916 IF(MSTP(57).EQ.0) Q2MX=P2MX
27917 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
27922 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
27923 IF(MSTP(57).EQ.0) Q2MX=P2MX
27924 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
27930 210 RKF=11D0*PYR(0)
27932 IF(RKF.GT.1D0) KFR=2
27933 IF(RKF.GT.5D0) KFR=3
27934 IF(RKF.GT.6D0) KFR=4
27935 IF(RKF.GT.10D0) KFR=5
27936 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
27937 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
27938 IF(MSTP(57).EQ.0) Q2MX=P2MX
27939 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
27946 C...Proton parton distribution call.
27948 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
27949 CALL PYPDPR(X,Q2,XPPR)
27953 ELSEIF(MSTP(52).EQ.2) THEN
27954 C...Call PDFLIB parton distributions.
27958 VALUE(2)=MSTP(51)/1000
27960 VALUE(3)=MOD(MSTP(51),1000)
27961 IF(MINT(93).NE.1000000+MSTP(51)) THEN
27962 CALL PDFSET_ALICE(PARM,VALUE)
27963 MINT(93)=1000000+MSTP(51)
27966 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
27967 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
27969 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
27985 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
27989 C...Isospin average for pi0/gammaVDM.
27990 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
27991 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
27996 XPS=0.5D0*(XPQ(1)+XPQ(-2))
27997 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
28001 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
28002 XPQ(1)=XPQ(1)+0.2D0*XPV
28003 XPQ(-1)=XPQ(-1)+0.2D0*XPV
28004 XPQ(2)=XPQ(2)+0.8D0*XPV
28005 XPQ(-2)=XPQ(-2)+0.8D0*XPV
28006 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
28008 XPQ(-3)=XPQ(-3)+XPV
28009 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
28011 XPQ(-4)=XPQ(-4)+XPV
28012 IF(MSTP(55).GE.9) THEN
28018 XPQ(1)=XPQ(1)+0.5D0*XPV
28019 XPQ(-1)=XPQ(-1)+0.5D0*XPV
28020 XPQ(2)=XPQ(2)+0.5D0*XPV
28021 XPQ(-2)=XPQ(-2)+0.5D0*XPV
28024 C...Rescale for gammaVDM by effective gamma -> rho coupling.
28025 C+++Do not rescale?
28026 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
28027 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
28029 XPQ(KFL)=VINT(281)*XPQ(KFL)
28031 VINT(232)=VINT(281)*XPV
28034 C...Simple recipes for kaons.
28035 ELSEIF(KFA.EQ.321) THEN
28036 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
28038 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
28039 XPS=0.5D0*(XPQ(1)+XPQ(-2))
28040 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
28043 XPQ(1)=XPQ(1)+0.5D0*XPV
28044 XPQ(-1)=XPQ(-1)+0.5D0*XPV
28045 XPQ(3)=XPQ(3)+0.5D0*XPV
28046 XPQ(-3)=XPQ(-3)+0.5D0*XPV
28048 C...Isospin conjugation for neutron.
28049 ELSEIF(KFA.EQ.2112) THEN
28057 C...Simple recipes for hyperon (average valence parton distribution).
28058 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
28059 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
28060 XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
28061 XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
28066 XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
28067 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
28068 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
28071 C...Charge conjugation for antiparticle.
28074 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
28081 C...Allow gluon also in position 21.
28084 C...Check positivity and reset above maximum allowed flavour.
28086 XPQ(KFL)=MAX(0D0,XPQ(KFL))
28087 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
28090 C...Formats for error printouts.
28091 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
28092 5100 FORMAT(' Error: illegal particle code for parton distribution;',
28094 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
28100 C*********************************************************************
28103 C...Gives proton parton distribution at small x and/or Q^2 according to
28104 C...correct limiting behaviour.
28106 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
28108 C...Double precision and integer declarations.
28109 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28110 IMPLICIT INTEGER(I-N)
28111 INTEGER PYK,PYCHGE,PYCOMP
28113 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28114 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28115 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28116 COMMON/PYINT1/MINT(400),VINT(400)
28117 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28119 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
28120 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
28122 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
28126 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
28127 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
28128 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
28130 CALL PYPDFU(KF,X,Q2,XPQ)
28134 C...Reset. Check x.
28138 IF(X.LE.0D0.OR.X.GE.1D0) THEN
28139 WRITE(MSTU(11),5000) X
28143 C...Define valence content.
28147 IF(KF.EQ.2212) THEN
28150 ELSEIF(KF.EQ.-2212) THEN
28153 ELSEIF(KF.EQ.2112) THEN
28156 ELSEIF(KF.EQ.-2112) THEN
28159 ELSEIF(KF.EQ.211) THEN
28163 ELSEIF(KF.EQ.-211) THEN
28167 ELSEIF(MINT(105).LE.223) THEN
28172 ELSEIF(MINT(105).EQ.333) THEN
28177 ELSEIF(MINT(105).EQ.443) THEN
28184 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
28185 CALL PYPDFU(KFC,X,Q2,XPA)
28186 Q2MN=MAX(3D0,VINT(231))
28187 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
28188 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
28190 C...Large Q2 and large x: naive call is enough.
28191 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
28197 C...Small Q2 and large x: dampen boundary value.
28198 ELSEIF(X.GT.XMN) THEN
28200 C...Evaluate at boundary and define dampening factors.
28201 CALL PYPDFU(KFC,X,Q2MN,XPA)
28202 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
28203 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
28205 C...Separate valence and sea parts of parton distribution.
28207 XFV1=XPA(KFV1)-XPA(-KFV1)
28208 XPA(KFV1)=XPA(-KFV1)
28209 XFV2=XPA(KFV2)-XPA(-KFV2)
28210 XPA(KFV2)=XPA(-KFV2)
28212 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
28213 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
28214 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
28215 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
28218 C...Dampen valence and sea separately. Put back together.
28220 XPQ(KFL)=FS*XPA(KFL)
28223 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
28224 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
28226 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
28227 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
28228 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
28229 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
28233 C...Large Q2 and small x: interpolate behaviour.
28234 ELSEIF(Q2.GT.Q2MN) THEN
28236 C...Evaluate at extremes and define coefficients for interpolation.
28237 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
28239 CALL PYPDFU(KFC,X,Q2B,XPB)
28241 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
28242 FVA=(X/XMN)**0.45D0*FLA
28243 FSA=(X/XMN)**(-0.08D0)*FLA
28246 C...Separate valence and sea parts of parton distribution.
28248 XFVA1=XPA(KFV1)-XPA(-KFV1)
28249 XPA(KFV1)=XPA(-KFV1)
28250 XFVA2=XPA(KFV2)-XPA(-KFV2)
28251 XPA(KFV2)=XPA(-KFV2)
28252 XFVB1=XPB(KFV1)-XPB(-KFV1)
28253 XPB(KFV1)=XPB(-KFV1)
28254 XFVB2=XPB(KFV2)-XPB(-KFV2)
28255 XPB(KFV2)=XPB(-KFV2)
28257 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
28258 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
28259 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
28260 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
28261 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
28262 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
28263 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
28264 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
28267 C...Interpolate for valence and sea. Put back together.
28269 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
28272 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
28273 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
28275 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
28276 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
28277 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
28278 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
28282 C...Small Q2 and small x: dampen boundary value and add term.
28285 C...Evaluate at boundary and define dampening factors.
28286 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
28287 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
28289 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
28290 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
28291 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
28292 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
28293 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
28294 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
28296 C...Separate valence and sea parts of parton distribution.
28298 XFV1=XPA(KFV1)-XPA(-KFV1)
28299 XPA(KFV1)=XPA(-KFV1)
28300 XFV2=XPA(KFV2)-XPA(-KFV2)
28301 XPA(KFV2)=XPA(-KFV2)
28303 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
28304 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
28305 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
28306 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
28309 C...Dampen valence and sea separately. Add constant terms.
28310 C...Put back together.
28312 XPQ(KFL)=FSA*XPA(KFL)
28316 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
28318 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
28319 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
28322 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
28324 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
28325 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
28326 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
28327 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
28333 C...Format for error printout.
28334 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
28339 C*********************************************************************
28342 C...Gives electron (or muon, or tau) parton distribution.
28344 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
28346 C...Double precision and integer declarations.
28347 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28348 IMPLICIT INTEGER(I-N)
28349 INTEGER PYK,PYCHGE,PYCOMP
28351 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28352 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28353 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28354 COMMON/PYINT1/MINT(400),VINT(400)
28355 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28357 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
28359 C...Interface to PDFLIB.
28360 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
28362 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
28363 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
28364 CHARACTER*20 PARM(20)
28365 DATA VALUE/20*0D0/,PARM/20*' '/
28367 C...Some common constants.
28373 IF(KFA.EQ.13) PME=PMAS(13,1)
28374 IF(KFA.EQ.15) PME=PMAS(15,1)
28375 XL=LOG(MAX(1D-10,X))
28376 X1L=LOG(MAX(1D-10,1D0-X))
28377 HLE=LOG(MAX(3D0,Q2/PME**2))
28378 HBE2=(AEM/PARU(1))*(HLE-1D0)
28380 C...Electron inside electron, see R. Kleiss et al., in Z physics at
28381 C...LEP 1, CERN 89-08, p. 34
28382 IF(MSTP(59).LE.1) THEN
28383 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
28384 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
28385 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
28386 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
28387 & 4D0*XL/(1D0-X)-5D0-X)
28389 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
28390 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
28391 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
28393 C...Zero distribution for very large x and rescale it for intermediate.
28394 IF(X.GT.1D0-1D-10) THEN
28396 ELSEIF(X.GT.1D0-1D-7) THEN
28397 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
28401 C...Photon and (transverse) W- inside electron.
28402 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
28403 IF(MSTP(13).LE.1) THEN
28406 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
28408 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
28409 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
28410 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
28412 C...Electron or positron inside photon inside electron.
28413 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
28414 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
28415 & 2D0*X*(1D0+X)*XL)
28416 XPEL(11)=XPEL(11)+XFSEA
28419 C...Initialize PDFLIB photon parton distributions.
28420 IF(MSTP(56).EQ.2) THEN
28424 VALUE(2)=MSTP(55)/1000
28426 VALUE(3)=MOD(MSTP(55),1000)
28427 IF(MINT(93).NE.3000000+MSTP(55)) THEN
28428 CALL PDFSET(PARM,VALUE)
28429 MINT(93)=3000000+MSTP(55)
28433 C...Quarks and gluons inside photon inside electron:
28434 C...numerical convolution required.
28443 IF(ITER.EQ.0) NSTP=2
28445 SXP(KFL)=0.5D0*SXP(KFL)
28448 IF(ITER.EQ.0) WTSTP=0.5D0
28449 C...Pick grid of x_{gamma} values logarithmically even.
28454 XLE=XL*(ISTP-0.5D0)/NSTP
28456 XE=MIN(1D0-1D-10,EXP(XLE))
28457 XG=MIN(1D0-1D-10,X/XE)
28458 C...Evaluate photon inside electron parton distribution for convolution.
28459 XPGP=1D0+(1D0-XE)**2
28460 IF(MSTP(13).LE.1) THEN
28463 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
28465 C...Evaluate photon parton distributions for convolution.
28466 IF(MSTP(56).EQ.1) THEN
28467 IF(MSTP(55).EQ.1) THEN
28468 CALL PYPDGA(XG,Q2,XPGA)
28469 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
28472 IF(MSTP(55).GE.7) P2MX=4.0D0
28473 IF(MSTP(57).EQ.0) Q2MX=P2MX
28475 IF(VINT(120).LT.0D0) P2=VINT(120)**2
28476 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
28478 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
28481 IF(MSTP(55).GE.11) P2MX=4.0D0
28482 IF(MSTP(57).EQ.0) Q2MX=P2MX
28484 IF(VINT(120).LT.0D0) P2=VINT(120)**2
28485 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
28489 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
28491 ELSEIF(MSTP(56).EQ.2) THEN
28492 C...Call PDFLIB parton distributions.
28494 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
28495 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
28496 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
28497 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
28498 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
28499 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
28500 SXP(3)=SXP(3)+WTSTP*XPGP*STR
28501 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
28502 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
28503 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
28506 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
28507 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
28508 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
28510 C...Put convolution into output arrays.
28512 XPEL(0)=FCONV*SXP(0)
28514 XPEL(KFL)=FCONV*SXP(KFL)
28515 XPEL(-KFL)=XPEL(KFL)
28522 C*********************************************************************
28525 C...Gives photon parton distribution.
28527 SUBROUTINE PYPDGA(X,Q2,XPGA)
28529 C...Double precision and integer declarations.
28530 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28531 IMPLICIT INTEGER(I-N)
28532 INTEGER PYK,PYCHGE,PYCOMP
28534 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28535 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28536 COMMON/PYINT1/MINT(400),VINT(400)
28537 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
28539 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
28540 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
28541 &DGCS(4,3),DGDS(4,3),DGES(4,3)
28543 C...The following data lines are coefficients needed in the
28544 C...Drees and Grassie photon parton distribution parametrization.
28545 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
28546 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
28547 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
28548 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
28549 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
28550 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
28551 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
28552 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
28553 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
28554 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
28555 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
28556 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
28557 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
28558 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
28559 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
28560 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
28561 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
28562 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
28563 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
28564 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
28565 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
28566 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
28567 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
28568 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
28569 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
28570 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
28572 C...Photon parton distribution from Drees and Grassie.
28573 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
28578 IF(MSTP(57).LE.0) THEN
28581 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
28585 IF(Q2.GT.25D0) NF=4
28586 IF(Q2.GT.300D0) NF=5
28590 C...Evaluate gluon content.
28591 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
28592 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
28593 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
28594 XPGL=DGA*X**DGB*X1**DGC
28596 C...Evaluate up- and down-type quark content.
28597 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
28598 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
28599 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
28600 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
28601 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
28602 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
28603 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
28604 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
28605 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
28606 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
28607 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
28609 IF(NF.EQ.4) DGF=10D0
28610 IF(NF.EQ.5) DGF=55D0/6D0
28611 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
28613 XPQU=(XPQS+9D0*XPQN)/6D0
28614 XPQD=(XPQS-4.5D0*XPQN)/6D0
28615 ELSEIF(NF.EQ.4) THEN
28616 XPQU=(XPQS+6D0*XPQN)/8D0
28617 XPQD=(XPQS-6D0*XPQN)/8D0
28619 XPQU=(XPQS+7.5D0*XPQN)/10D0
28620 XPQD=(XPQS-5D0*XPQN)/10D0
28623 C...Put into output arrays.
28628 IF(NF.GE.4) XPGA(4)=AEM*XPQU
28629 IF(NF.GE.5) XPGA(5)=AEM*XPQD
28631 XPGA(-KFL)=XPGA(KFL)
28637 C*********************************************************************
28640 C...Constructs the F2 and parton distributions of the photon
28641 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
28642 C...For F2, c and b are included by the Bethe-Heitler formula;
28643 C...in the 'MSbar' scheme additionally a Cgamma term is added.
28644 C...Contains the SaS sets 1D, 1M, 2D and 2M.
28645 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28647 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
28649 C...Double precision and integer declarations.
28650 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28651 IMPLICIT INTEGER(I-N)
28652 INTEGER PYK,PYCHGE,PYCOMP
28654 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
28656 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
28657 SAVE /PYINT8/,/PYINT9/
28659 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
28660 C...Charm and bottom masses (low to compensate for J/psi etc.).
28661 DATA PMC/1.3D0/, PMB/4.6D0/
28662 C...alpha_em and alpha_em/(2*pi).
28663 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
28664 C...Lambda value for 4 flavours.
28666 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
28668 C...VMD couplings f_V**2/(4*pi).
28669 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
28670 C...Masses for rho (=omega) and phi.
28671 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
28672 C...Number of points in integration for IP2=1.
28690 C...Set Q0 cut-off parameter as function of set used.
28698 C...Scale choice for off-shell photon; common factors.
28703 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
28704 FACNOR=LOG(Q2/Q02)/NSTEP
28705 ELSEIF(IP2.EQ.2) THEN
28707 ELSEIF(IP2.EQ.3) THEN
28709 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
28710 ELSEIF(IP2.EQ.4) THEN
28711 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28712 & ((Q2+P2)*(Q02+P2)))
28713 ELSEIF(IP2.EQ.5) THEN
28714 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28715 & ((Q2+P2)*(Q02+P2)))
28716 P2MX=Q0*SQRT(P2MXA)
28717 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
28718 ELSEIF(IP2.EQ.6) THEN
28719 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28720 & ((Q2+P2)*(Q02+P2)))
28721 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
28723 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
28724 & ((Q2+P2)*(Q02+P2)))
28725 P2MX=Q0*SQRT(P2MXA)
28727 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
28728 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
28729 IF(ABS(Q2-Q02).GT.1D-6) THEN
28730 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
28731 ELSEIF(P2.LT.Q02) THEN
28732 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
28738 C...Call VMD parametrization for d quark and use to give rho, omega,
28739 C...phi. Note dipole dampening for off-shell photon.
28740 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28744 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
28745 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
28747 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
28749 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
28750 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
28751 XPVMD(3)=XPVMD(3)+FACS*XFVAL
28752 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
28753 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
28754 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
28755 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
28756 VXPVMD(2)=FRACU*FACUD*XFVAL
28757 VXPVMD(3)=FACS*XFVAL
28758 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
28759 VXPVMD(-2)=FRACU*FACUD*XFVAL
28760 VXPVMD(-3)=FACS*XFVAL
28763 C...Anomalous parametrizations for different strategies
28764 C...for off-shell photons; except full integration.
28766 C...Call anomalous parametrization for d + u + s.
28767 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28769 XPANL(KFL)=FACNOR*XPGA(KFL)
28770 VXPANL(KFL)=FACNOR*VXPGA(KFL)
28773 C...Call anomalous parametrization for c and b.
28774 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28776 XPANH(KFL)=FACNOR*XPGA(KFL)
28777 VXPANH(KFL)=FACNOR*VXPGA(KFL)
28779 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
28781 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
28782 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
28786 C...Special option: loop over flavours and integrate over k2.
28788 DO 160 ISTEP=1,NSTEP
28789 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
28790 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
28791 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
28792 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
28793 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
28794 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
28795 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
28797 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
28798 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
28799 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
28800 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
28806 C...Call Bethe-Heitler term expression for charm and bottom.
28807 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
28810 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
28814 C...For MSbar subtraction call C^gamma term expression for d, u, s.
28815 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
28816 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
28818 XPDIR(KFL)=XPGA(KFL)
28822 C...Store result in output array.
28825 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
28826 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
28827 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
28828 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
28829 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
28835 C*********************************************************************
28838 C...Evaluates the VMD parton distributions of a photon,
28839 C...evolved homogeneously from an initial scale P2 to Q2.
28840 C...Does not include dipole suppression factor.
28841 C...ISET is parton distribution set, see above;
28842 C...additionally ISET=0 is used for the evolution of an anomalous photon
28843 C...which branched at a scale P2 and then evolved homogeneously to Q2.
28844 C...ALAM is the 4-flavour Lambda, which is automatically converted
28845 C...to 3- and 5-flavour equivalents as needed.
28846 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
28848 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
28850 C...Double precision and integer declarations.
28851 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28852 IMPLICIT INTEGER(I-N)
28853 INTEGER PYK,PYCHGE,PYCOMP
28854 C...Local arrays and data.
28855 DIMENSION XPGA(-6:6), VXPGA(-6:6)
28856 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
28865 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
28866 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
28867 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
28868 P2EFF=MAX(P2,1.2D0*ALAM3**2)
28869 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
28870 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
28871 Q2EFF=MAX(Q2,P2EFF)
28873 C...Find number of flavours at lower and upper scale.
28875 IF(P2EFF.LT.PMC**2) NFP=3
28876 IF(P2EFF.GT.PMB**2) NFP=5
28878 IF(Q2EFF.LT.PMC**2) NFQ=3
28879 IF(Q2EFF.GT.PMB**2) NFQ=5
28881 C...Find s as sum of 3-, 4- and 5-flavour parts.
28885 IF(NFQ.EQ.3) Q2DIV=Q2EFF
28886 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
28888 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
28890 IF(NFP.EQ.3) P2DIV=PMC**2
28892 IF(NFQ.EQ.5) Q2DIV=PMB**2
28893 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
28897 IF(NFP.EQ.5) P2DIV=P2EFF
28898 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
28901 C...Calculate frequent combinations of x and s.
28908 C...Evaluate homogeneous anomalous parton distributions below or
28909 C...above threshold.
28911 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28912 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28913 XVAL = X * 1.5D0 * (X**2+X1**2)
28917 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
28918 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
28919 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
28920 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
28921 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
28922 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
28923 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
28924 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
28925 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
28926 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
28927 & (2D0*X-1D0)*X*XL**2)
28930 C...Evaluate set 1D parton distributions below or above threshold.
28931 ELSEIF(ISET.EQ.1) THEN
28932 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28933 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28934 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
28935 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
28936 XSEA = 0.100D0 * X1**3.76D0
28938 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
28939 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
28940 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
28941 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
28942 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
28943 & X**0.40D0 * X1**(1.76D0+3D0*S)
28944 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
28945 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
28946 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
28947 XSEA0 = 0.100D0 * X1**3.76D0
28950 C...Evaluate set 1M parton distributions below or above threshold.
28951 ELSEIF(ISET.EQ.2) THEN
28952 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28953 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28954 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
28955 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
28958 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
28959 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
28960 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
28961 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
28962 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
28963 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
28964 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
28965 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
28970 C...Evaluate set 2D parton distributions below or above threshold.
28971 ELSEIF(ISET.EQ.3) THEN
28972 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28973 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28974 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
28975 XGLU = 1.925D0 * X1**2
28976 XSEA = 0.242D0 * X1**4
28978 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
28979 & X**(0.46D0+0.25D0*S) *
28980 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
28981 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
28982 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
28983 & EXP(-18.67D0*S) *
28984 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
28985 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
28986 & XL**(9.3D0*S/(1D0+1.7D0*S))
28987 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
28988 & (1D0-0.607D0*S+21.95D0*S2) *
28989 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
28990 XSEA0 = 0.242D0 * X1**4
28993 C...Evaluate set 2M parton distributions below or above threshold.
28994 ELSEIF(ISET.EQ.4) THEN
28995 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
28996 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
28997 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
28998 XGLU = 1.808D0 * X1**2
28999 XSEA = 0.209D0 * X1**4
29001 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
29002 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
29003 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
29004 & XL**(5.15D0*S/(1D0+2D0*S)) +
29005 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
29006 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
29007 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
29008 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
29009 & XL**(10.9D0*S/(1D0+2.5D0*S))
29010 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
29011 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
29012 & X1**(4D0+S) * XL**(0.45D0*S)
29013 XSEA0 = 0.209D0 * X1**4
29017 C...Threshold factors for c and b sea.
29018 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
29020 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29021 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29023 XCHM=XSEA*(1D0-(SCH/SLL)**2)
29025 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
29029 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29030 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29032 XBOT=XSEA*(1D0-(SBT/SLL)**2)
29034 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
29038 C...Fill parton distributions.
29045 XPGA(KFA)=XPGA(KFA)+XVAL
29047 XPGA(-KFL)=XPGA(KFL)
29055 C*********************************************************************
29058 C...Evaluates the parton distributions of the anomalous photon,
29059 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
29060 C...KF=0 gives the sum over (up to) 5 flavours,
29061 C...KF<0 limits to flavours up to abs(KF),
29062 C...KF>0 is for flavour KF only.
29063 C...ALAM is the 4-flavour Lambda, which is automatically converted
29064 C...to 3- and 5-flavour equivalents as needed.
29065 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
29067 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
29069 C...Double precision and integer declarations.
29070 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29071 IMPLICIT INTEGER(I-N)
29072 INTEGER PYK,PYCHGE,PYCOMP
29073 C...Local arrays and data.
29074 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
29075 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
29082 IF(Q2.LE.P2) RETURN
29085 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
29086 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
29088 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
29089 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
29090 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
29091 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
29092 Q2EFF=MAX(Q2,P2EFF)
29095 C...Find number of flavours at lower and upper scale.
29097 IF(P2EFF.LT.PMC**2) NFP=3
29098 IF(P2EFF.GT.PMB**2) NFP=5
29100 IF(Q2EFF.LT.PMC**2) NFQ=3
29101 IF(Q2EFF.GT.PMB**2) NFQ=5
29103 C...Define range of flavour loop.
29107 ELSEIF(KF.LT.0) THEN
29115 C...Loop over flavours the photon can branch into.
29116 DO 110 KFL=KFLMN,KFLMX
29118 C...Light flavours: calculate t range and (approximate) s range.
29119 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
29120 TDIFF=LOG(Q2EFF/P2EFF)
29121 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
29122 & LOG(P2EFF/ALAMSQ(NFQ)))
29123 IF(NFQ.GT.NFP) THEN
29125 IF(NFQ.EQ.4) Q2DIV=PMC**2
29126 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
29127 & LOG(P2EFF/ALAMSQ(NFQ)))
29128 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
29129 & LOG(P2EFF/ALAMSQ(NFQ-1)))
29130 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
29132 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
29134 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
29135 & LOG(P2EFF/ALAMSQ(4)))
29136 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
29137 & LOG(P2EFF/ALAMSQ(3)))
29138 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
29141 C...u and s quark do not need a separate treatment when d has been done.
29142 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
29144 C...Charm: as above, but only include range above c threshold.
29145 ELSEIF(KFL.EQ.4) THEN
29146 IF(Q2.LE.PMC**2) GOTO 110
29147 P2EFF=MAX(P2EFF,PMC**2)
29148 Q2EFF=MAX(Q2EFF,P2EFF)
29149 TDIFF=LOG(Q2EFF/P2EFF)
29150 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
29151 & LOG(P2EFF/ALAMSQ(NFQ)))
29152 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
29154 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
29155 & LOG(P2EFF/ALAMSQ(NFQ)))
29156 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
29157 & LOG(P2EFF/ALAMSQ(NFQ-1)))
29158 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
29161 C...Bottom: as above, but only include range above b threshold.
29162 ELSEIF(KFL.EQ.5) THEN
29163 IF(Q2.LE.PMB**2) GOTO 110
29164 P2EFF=MAX(P2EFF,PMB**2)
29165 Q2EFF=MAX(Q2,P2EFF)
29166 TDIFF=LOG(Q2EFF/P2EFF)
29167 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
29168 & LOG(P2EFF/ALAMSQ(NFQ)))
29171 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
29173 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
29174 FAC=AEM2PI*2D0*CHSQ*TDIFF
29176 C...Evaluate parton distributions (normalized to unit momentum sum).
29177 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
29178 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
29179 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
29180 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
29181 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
29182 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
29183 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
29184 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
29185 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
29186 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
29187 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
29188 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
29190 C...Threshold factors for c and b sea.
29191 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
29193 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29194 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29195 XCHM=XSEA*(1D0-(SCH/SLL)**3)
29198 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
29199 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
29200 XBOT=XSEA*(1D0-(SBT/SLL)**3)
29204 C...Add contribution of each valence flavour.
29205 XPGA(0)=XPGA(0)+FAC*XGLU
29206 XPGA(1)=XPGA(1)+FAC*XSEA
29207 XPGA(2)=XPGA(2)+FAC*XSEA
29208 XPGA(3)=XPGA(3)+FAC*XSEA
29209 XPGA(4)=XPGA(4)+FAC*XCHM
29210 XPGA(5)=XPGA(5)+FAC*XBOT
29211 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
29212 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
29215 XPGA(-KFL)=XPGA(KFL)
29216 VXPGA(-KFL)=VXPGA(KFL)
29222 C*********************************************************************
29225 C...Evaluates the Bethe-Heitler cross section for heavy flavour
29227 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
29229 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
29231 C...Double precision and integer declarations.
29232 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29233 IMPLICIT INTEGER(I-N)
29234 INTEGER PYK,PYCHGE,PYCOMP
29237 DATA AEM2PI/0.0011614D0/
29243 C...Check kinematics limits.
29244 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
29246 BETA2=1D0-4D0*PM2/W2
29247 IF(BETA2.LT.1D-10) RETURN
29251 C...Simple case: P2 = 0.
29252 IF(P2.LT.1D-4) THEN
29253 IF(BETA.LT.0.99D0) THEN
29254 XBL=LOG((1D0+BETA)/(1D0-BETA))
29256 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
29258 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
29259 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
29261 C...Complicated case: P2 > 0, based on approximation of
29262 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
29264 RPQ=1D0-4D0*X**2*P2/Q2
29265 IF(RPQ.GT.1D-10) THEN
29266 RPBE=SQRT(RPQ*BETA2)
29267 IF(RPBE.LT.0.99D0) THEN
29268 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
29269 XBI=2D0*RPBE/(1D0-RPBE**2)
29271 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
29272 XBL=LOG((1D0+RPBE)**2/RPBESN)
29273 XBI=2D0*RPBE/RPBESN
29275 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
29276 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
29277 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
29281 C...Multiply by charge-squared etc. to get parton distribution.
29283 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
29284 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
29289 C*********************************************************************
29292 C...Evaluates the direct contribution, i.e. the C^gamma term,
29293 C...as needed in MSbar parametrizations.
29294 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
29296 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
29298 C...Double precision and integer declarations.
29299 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29300 IMPLICIT INTEGER(I-N)
29301 INTEGER PYK,PYCHGE,PYCOMP
29302 C...Local array and data.
29303 DIMENSION XPGA(-6:6)
29304 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
29311 C...Evaluate common x-dependent expression.
29312 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
29313 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
29315 C...d, u, s part by simple charge factor.
29316 XPGA(1)=(1D0/9D0)*CGAM
29317 XPGA(2)=(4D0/9D0)*CGAM
29318 XPGA(3)=(1D0/9D0)*CGAM
29320 C...Also fill for antiquarks.
29328 C*********************************************************************
29331 C...Gives pi+ parton distribution according to two different
29332 C...parametrizations.
29334 SUBROUTINE PYPDPI(X,Q2,XPPI)
29336 C...Double precision and integer declarations.
29337 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29338 IMPLICIT INTEGER(I-N)
29339 INTEGER PYK,PYCHGE,PYCOMP
29341 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29342 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29343 COMMON/PYINT1/MINT(400),VINT(400)
29344 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
29346 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
29348 C...The following data lines are coefficients needed in the
29349 C...Owens pion parton distribution parametrizations, see below.
29350 C...Expansion coefficients for up and down valence quark distributions.
29351 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
29352 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29353 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29354 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
29355 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
29356 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29357 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
29358 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
29359 C...Expansion coefficients for gluon distribution.
29360 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
29361 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
29362 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
29363 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
29364 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
29365 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
29366 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
29367 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
29368 C...Expansion coefficients for (up+down+strange) quark sea distribution.
29369 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
29370 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
29371 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
29372 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
29373 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
29374 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
29375 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
29376 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
29377 C...Expansion coefficients for charm quark sea distribution.
29378 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
29379 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
29380 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
29381 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
29382 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
29383 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
29384 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
29385 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
29387 C...Euler's beta function, requires ordinary Gamma function
29388 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
29390 C...Reset output array.
29395 IF(MSTP(53).LE.2) THEN
29396 C...Pion parton distributions from Owens.
29397 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
29399 C...Determine set, Lambda and s expansion variable.
29401 IF(NSET.EQ.1) ALAM=0.2D0
29402 IF(NSET.EQ.2) ALAM=0.4D0
29404 IF(MSTP(57).LE.0) THEN
29407 Q2IN=MIN(2D3,MAX(4D0,Q2))
29408 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
29411 C...Calculate parton distributions.
29414 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
29415 & COW(3,IS,KFL,NSET)*SD**2
29418 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
29420 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
29425 C...Put into output array.
29428 XPPI(2)=XQ(1)+XQ(3)/6D0
29431 XPPI(-1)=XQ(1)+XQ(3)/6D0
29436 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
29437 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
29441 C...Determine s expansion variable and some x expressions.
29443 IF(MSTP(57).LE.0) THEN
29446 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
29447 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
29453 C...Evaluate valence, gluon and sea distributions.
29454 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
29455 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
29456 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
29458 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
29459 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
29461 & (1D0-X)**(0.390D0+1.053D0*SD)
29462 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
29464 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
29466 & XL**(2.538D0-0.763D0*SD)
29467 IF(SD.LE.0.888D0) THEN
29470 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
29472 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
29475 IF(SD.LE.1.351D0) THEN
29478 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
29479 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
29483 C...Put into output array.
29491 XPPI(-KFL)=XPPI(KFL)
29493 XPPI(2)=XPPI(2)+XFVAL
29494 XPPI(-1)=XPPI(-1)+XFVAL
29500 C*********************************************************************
29503 C...Gives proton parton distributions according to a few different
29504 C...parametrizations.
29506 SUBROUTINE PYPDPR(X,Q2,XPPR)
29508 C...Double precision and integer declarations.
29509 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29510 IMPLICIT INTEGER(I-N)
29511 INTEGER PYK,PYCHGE,PYCOMP
29513 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29514 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29515 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29516 COMMON/PYINT1/MINT(400),VINT(400)
29517 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
29518 C...Arrays and data.
29519 DIMENSION XPPR(-6:6),Q2MIN(16)
29520 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
29521 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
29523 C...Reset output array.
29528 C...Common preliminaries.
29529 NSET=MAX(1,MIN(16,MSTP(51)))
29530 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
29531 VINT(231)=Q2MIN(NSET)
29532 IF(MSTP(57).EQ.0) THEN
29535 Q2L=MAX(Q2MIN(NSET),Q2)
29538 IF(NSET.GE.1.AND.NSET.LE.3) THEN
29539 C...Interface to the CTEQ 3 parton distributions.
29540 QRT=SQRT(MAX(1D0,Q2L))
29542 C...Loop over flavours.
29545 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
29546 ELSEIF(I.LE.2) THEN
29547 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
29553 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
29554 C...Interface to the GRV 94 distributions.
29556 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29557 ELSEIF(NSET.EQ.5) THEN
29558 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29560 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29563 C...Put into output array.
29565 XPPR(-1)=0.5D0*(UDB+DEL)
29566 XPPR(-2)=0.5D0*(UDB-DEL)
29570 XPPR(1)=DV+XPPR(-1)
29571 XPPR(2)=UV+XPPR(-2)
29576 ELSEIF(NSET.EQ.7) THEN
29577 C...Interface to the CTEQ 5L parton distributions.
29578 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
29579 C...freezing x*f(x,Q2) at borders.
29580 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
29581 XIN=MAX(1D-6,MIN(1D0,X))
29583 C...Loop over flavours (with u <-> d notation mismatch).
29584 SUMUDB=PYCT5L(-1,XIN,QRT)
29585 RATUDB=PYCT5L(-2,XIN,QRT)
29588 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
29589 ELSEIF(I.EQ.2) THEN
29590 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
29591 ELSEIF(I.EQ.-1) THEN
29592 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
29593 ELSEIF(I.EQ.-2) THEN
29594 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
29596 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
29597 IF(I.LT.0) XPPR(-I)=XPPR(I)
29601 ELSEIF(NSET.EQ.8) THEN
29602 C...Interface to the CTEQ 5M1 parton distributions.
29603 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
29604 XIN=MAX(1D-6,MIN(1D0,X))
29606 C...Loop over flavours (with u <-> d notation mismatch).
29607 SUMUDB=PYCT5M(-1,XIN,QRT)
29608 RATUDB=PYCT5M(-2,XIN,QRT)
29611 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
29612 ELSEIF(I.EQ.2) THEN
29613 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
29614 ELSEIF(I.EQ.-1) THEN
29615 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
29616 ELSEIF(I.EQ.-2) THEN
29617 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
29619 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
29620 IF(I.LT.0) XPPR(-I)=XPPR(I)
29624 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
29625 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
29626 C...obsolete but offers backwards compatibility.
29627 CALL PYPDPO(X,Q2L,XPPR)
29629 C...Symmetric choice for debugging only
29630 ELSEIF(NSET.EQ.16) THEN
29648 C*********************************************************************
29651 C...Gives the CTEQ 3 parton distribution function sets in
29652 C...parametrized form, of October 24, 1994.
29653 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
29654 C...J. Qiu, W.K. Tung and H. Weerts.
29656 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
29658 C...Double precision declaration.
29659 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29660 IMPLICIT INTEGER(I-N)
29662 C...Data on Lambda values of fits, minimum Q and quark masses.
29663 DIMENSION ALM(3), QMS(4:6)
29664 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
29665 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
29667 C....Check flavour thresholds. Set up QI for SB.
29670 IF(Q .LE. QMS(IP)) THEN
29679 C...Use "standard lambda" of parametrization program for expansion.
29681 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
29686 C...Expansion for CTEQ3L.
29687 IF(ISET .EQ. 1) THEN
29688 IF(IPRT .EQ. 2) THEN
29689 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
29691 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
29692 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
29693 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
29694 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
29695 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
29696 ELSEIF(IPRT .EQ. 1) THEN
29697 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
29699 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
29700 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
29701 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
29702 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
29703 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
29704 ELSEIF(IPRT .EQ. 0) THEN
29705 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
29707 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
29708 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
29709 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
29710 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
29711 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
29712 ELSEIF(IPRT .EQ. -1) THEN
29713 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
29715 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
29716 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
29717 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
29718 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
29719 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
29720 ELSEIF(IPRT .EQ. -2) THEN
29721 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
29723 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
29724 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
29725 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
29726 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
29727 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
29728 ELSEIF(IPRT .EQ. -3) THEN
29729 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
29731 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
29732 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
29733 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
29734 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
29735 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
29736 ELSEIF(IPRT .EQ. -4) THEN
29737 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
29739 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
29740 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
29741 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
29742 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
29743 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
29744 ELSEIF(IPRT .EQ. -5) THEN
29745 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
29747 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
29748 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
29749 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
29750 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
29751 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
29752 ELSEIF(IPRT .EQ. -6) THEN
29753 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
29755 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
29756 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
29757 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
29758 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
29759 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
29762 C...Expansion for CTEQ3M.
29763 ELSEIF(ISET .EQ. 2) THEN
29764 IF(IPRT .EQ. 2) THEN
29765 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
29767 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
29768 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
29769 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
29770 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
29771 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
29772 ELSEIF(IPRT .EQ. 1) THEN
29773 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
29775 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
29776 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
29777 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
29778 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
29779 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
29780 ELSEIF(IPRT .EQ. 0) THEN
29781 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
29783 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
29784 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
29785 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
29786 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
29787 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
29788 ELSEIF(IPRT .EQ. -1) THEN
29789 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
29791 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
29792 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
29793 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
29794 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
29795 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
29796 ELSEIF(IPRT .EQ. -2) THEN
29797 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
29799 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
29800 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
29801 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
29802 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
29803 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
29804 ELSEIF(IPRT .EQ. -3) THEN
29805 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
29807 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
29808 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
29809 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
29810 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
29811 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
29812 ELSEIF(IPRT .EQ. -4) THEN
29813 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
29815 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
29816 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
29817 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
29818 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
29819 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
29820 ELSEIF(IPRT .EQ. -5) THEN
29821 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
29823 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
29824 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
29825 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
29826 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
29827 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
29828 ELSEIF(IPRT .EQ. -6) THEN
29829 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
29831 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
29832 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
29833 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
29834 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
29835 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
29838 C...Expansion for CTEQ3D.
29839 ELSEIF(ISET .EQ. 3) THEN
29840 IF(IPRT .EQ. 2) THEN
29841 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
29843 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
29844 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
29845 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
29846 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
29847 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
29848 ELSEIF(IPRT .EQ. 1) THEN
29849 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
29851 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
29852 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
29853 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
29854 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
29855 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
29856 ELSEIF(IPRT .EQ. 0) THEN
29857 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
29859 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
29860 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
29861 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
29862 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
29863 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
29864 ELSEIF(IPRT .EQ. -1) THEN
29865 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
29867 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
29868 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
29869 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
29870 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
29871 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
29872 ELSEIF(IPRT .EQ. -2) THEN
29873 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
29875 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
29876 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
29877 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
29878 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
29879 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
29880 ELSEIF(IPRT .EQ. -3) THEN
29881 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
29883 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
29884 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
29885 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
29886 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
29887 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
29888 ELSEIF(IPRT .EQ. -4) THEN
29889 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
29891 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
29892 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
29893 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
29894 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
29895 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
29896 ELSEIF(IPRT .EQ. -5) THEN
29897 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
29899 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
29900 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
29901 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
29902 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
29903 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
29904 ELSEIF(IPRT .EQ. -6) THEN
29905 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
29907 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
29908 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
29909 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
29910 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
29911 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
29915 C...Calculation of x * f(x, Q).
29916 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
29917 & *(LOG(1D0+1D0/X))**A5 )
29922 C*********************************************************************
29925 C...Gives the GRV 94 L (leading order) parton distribution function set
29926 C...in parametrized form.
29927 C...Authors: M. Glueck, E. Reya and A. Vogt.
29929 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
29931 C...Double precision declaration.
29932 IMPLICIT DOUBLE PRECISION (A - Z)
29934 C...Common expressions.
29936 LAM2 = 0.2322D0 * 0.2322D0
29937 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
29943 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
29944 AKU = 0.590D0 - 0.024D0 * S
29945 BKU = 0.131D0 + 0.063D0 * S
29946 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
29947 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
29948 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
29949 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
29950 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
29953 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
29955 BKD = 0.486D0 + 0.062D0 * S
29956 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
29957 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
29958 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
29959 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
29960 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
29963 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
29964 AKE = 0.409D0 - 0.005D0 * S
29965 BKE = 0.799D0 + 0.071D0 * S
29966 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
29967 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
29969 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
29970 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
29975 AKX = 0.410D0 - 0.232D0 * S
29976 BKX = 0.534D0 - 0.457D0 * S
29977 AGX = 0.890D0 - 0.140D0 * S
29979 CX = 0.320D0 + 0.683D0 * S
29980 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
29981 EX = 4.119D0 + 1.713D0 * S
29982 ESX = 0.682D0 + 2.978D0 * S
29983 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
29990 AKS = 1.798D0 - 0.596D0 * S
29991 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
29992 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
29993 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
29994 EST = 3.981D0 + 1.638D0 * S
29996 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
30004 BC = 4.24D0 - 0.804D0 * S
30005 DCT = 3.46D0 - 1.076D0 * S
30006 ECT = 4.61D0 + 1.49D0 * S
30007 ESC = 2.555D0 + 1.961D0 * S
30008 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
30017 DBT = 2.929D0 + 1.396D0 * S
30018 EBT = 4.71D0 + 1.514D0 * S
30019 ESB = 4.02D0 + 1.239D0 * S
30020 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
30025 AKG = 1.742D0 - 0.930D0 * S
30026 BKG = - 0.399D0 * S2
30027 AG = 7.486D0 - 2.185D0 * S
30028 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
30029 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
30030 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
30031 EG = 0.807D0 + 2.005D0 * S
30032 ESG = 3.841D0 + 0.316D0 * S
30033 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
30039 C*********************************************************************
30042 C...Gives the GRV 94 M (MSbar) parton distribution function set
30043 C...in parametrized form.
30044 C...Authors: M. Glueck, E. Reya and A. Vogt.
30046 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
30048 C...Double precision declaration.
30049 IMPLICIT DOUBLE PRECISION (A - Z)
30051 C...Common expressions.
30053 LAM2 = 0.248D0 * 0.248D0
30054 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
30060 NU = 1.304D0 + 0.863D0 * S
30061 AKU = 0.558D0 - 0.020D0 * S
30063 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
30064 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
30065 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
30066 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
30067 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
30070 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
30071 AKD = 0.270D0 - 0.019D0 * S
30073 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
30074 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
30075 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
30076 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
30077 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
30080 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
30081 AKE = 0.409D0 - 0.007D0 * S
30082 BKE = 0.782D0 + 0.082D0 * S
30083 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
30084 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
30086 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
30087 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
30095 BGX = 3.210D0 - 1.866D0 * S
30097 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
30098 EX = 3.077D0 + 1.446D0 * S
30099 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
30100 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
30107 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
30108 AS = -4.329D0 + 1.131D0 * S
30109 BS = 9.568D0 - 1.744D0 * S
30110 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
30111 EST = 3.031D0 + 1.639D0 * S
30112 ESS = 5.837D0 + 0.815D0 * S
30113 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
30119 AKC = -0.625D0 - 0.523D0 * S
30121 BC = 1.896D0 + 1.616D0 * S
30122 DCT = 4.12D0 + 0.683D0 * S
30123 ECT = 4.36D0 + 1.328D0 * S
30124 ESC = 0.677D0 + 0.679D0 * S
30125 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
30131 AKB = - 0.193D0 * S
30134 DBT = 3.447D0 + 0.927D0 * S
30135 EBT = 4.68D0 + 1.259D0 * S
30136 ESB = 1.892D0 + 2.199D0 * S
30137 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
30142 AKG = 1.724D0 + 0.157D0 * S
30143 BKG = 0.800D0 + 1.016D0 * S
30144 AG = 7.517D0 - 2.547D0 * S
30145 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
30146 CG = 4.039D0 + 1.491D0 * S
30147 DG = 3.404D0 + 0.830D0 * S
30148 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
30149 ESG = 3.256D0 - 0.436D0 * S
30150 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
30155 C*********************************************************************
30158 C...Gives the GRV 94 D (DIS) parton distribution function set
30159 C...in parametrized form.
30160 C...Authors: M. Glueck, E. Reya and A. Vogt.
30162 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
30164 C...Double precision declaration.
30165 IMPLICIT DOUBLE PRECISION (A - Z)
30167 C...Common expressions.
30169 LAM2 = 0.248D0 * 0.248D0
30170 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
30176 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
30177 AKU = 0.563D0 - 0.025D0 * S
30178 BKU = 0.054D0 + 0.154D0 * S
30179 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
30180 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
30181 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
30182 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
30183 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
30186 ND = 0.156D0 - 0.017D0 * S
30187 AKD = 0.299D0 - 0.022D0 * S
30188 BKD = 0.259D0 - 0.015D0 * S
30189 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
30190 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
30191 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
30192 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
30193 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
30196 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
30197 AKE = 0.419D0 - 0.013D0 * S
30198 BKE = 1.064D0 - 0.038D0 * S
30199 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
30200 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
30201 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
30202 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
30203 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
30208 AKX = 0.326D0 + 0.150D0 * S
30209 BKX = 0.956D0 + 0.405D0 * S
30211 BGX = 3.794D0 - 2.359D0 * DS
30213 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
30214 EX = 3.049D0 + 1.597D0 * S
30215 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
30216 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
30223 AKS = 1.415D0 - 0.641D0 * DS
30224 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
30225 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
30226 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
30227 EST = 4.546D0 + 0.372D0 * S2
30228 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
30229 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
30235 AKC = -0.625D0 - 0.523D0 * S
30237 BC = 1.896D0 + 1.616D0 * S
30238 DCT = 4.12D0 + 0.683D0 * S
30239 ECT = 4.36D0 + 1.328D0 * S
30240 ESC = 0.677D0 + 0.679D0 * S
30241 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
30247 AKB = - 0.193D0 * S
30250 DBT = 3.447D0 + 0.927D0 * S
30251 EBT = 4.68D0 + 1.259D0 * S
30252 ESB = 1.892D0 + 2.199D0 * S
30253 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
30259 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
30260 AG = 25.09D0 - 7.935D0 * S
30261 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
30262 CG = 590.3D0 - 173.8D0 * S
30263 DG = 5.196D0 + 1.857D0 * S
30264 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
30265 ESG = 3.232D0 - 0.542D0 * S
30266 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
30271 C*********************************************************************
30274 C...Auxiliary for the GRV 94 parton distribution functions
30275 C...for u and d valence and d-u sea.
30276 C...Authors: M. Glueck, E. Reya and A. Vogt.
30278 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
30280 C...Double precision declaration.
30281 IMPLICIT DOUBLE PRECISION (A - Z)
30285 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
30291 C*********************************************************************
30294 C...Auxiliary for the GRV 94 parton distribution functions
30295 C...for d+u sea and gluon.
30296 C...Authors: M. Glueck, E. Reya and A. Vogt.
30298 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
30300 C...Double precision declaration.
30301 IMPLICIT DOUBLE PRECISION (A - Z)
30305 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
30306 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
30311 C*********************************************************************
30314 C...Auxiliary for the GRV 94 parton distribution functions
30315 C...for s, c and b sea.
30316 C...Authors: M. Glueck, E. Reya and A. Vogt.
30318 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
30320 C...Double precision declaration.
30321 IMPLICIT DOUBLE PRECISION (A - Z)
30329 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
30330 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
30336 C*********************************************************************
30339 C...Auxiliary function for parametrization of CTEQ5L.
30340 C...Author: J. Pumplin 9/99.
30342 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
30343 C...in Parametrized Form
30344 C... September 15, 1999
30346 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
30347 C... CTEQ5 PPARTON DISTRIBUTIONS"
30350 C...The CTEQ5M1 set given here is an updated version of the original
30351 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
30352 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
30353 C...almost all applications.
30354 C...The improvement is in the QCD evolution which is now more
30355 C...accurate, and which agrees completely with the benchmark work
30356 C...of the HERA 96/97 Workshop.
30357 C...The differences between the parametrized and the corresponding
30358 C...table versions (on which it is based) are of similar order as
30359 C...between the two version.
30361 C...!! Because accurate parametrizations over a wide range of (x,Q)
30362 C...is hard to obtain, only the most widely used sets CTEQ5M and
30363 C...CTEQ5L are available in parametrized form for now.
30365 C...These parametrizations were obtained by Jon Pumplin.
30367 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
30368 C -------------------------------------------------------------------
30369 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
30370 C 3 CTEQ5L Leading Order 0.127 192 146
30371 C -------------------------------------------------------------------
30372 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
30373 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
30376 C...The two Iset value are adopted to agree with the standard table
30379 C...Range of validity:
30380 C...The range of (x, Q) covered by this parametrization of the QCD
30381 C...evolved parton distributions is 1E-6 < x < 1 ;
30382 C...1.1 GeV < Q < 10 TeV. Of course, the PDF's are constrained by
30383 C...data only in a subset of that region; and the assumed DGLAP
30384 C...evolution is unlikely to be valid for all of it either.
30386 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
30387 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
30388 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
30389 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
30391 FUNCTION PYCT5L(IFL,X,Q)
30393 C...Double precision declaration.
30394 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30395 IMPLICIT INTEGER(I-N)
30397 PARAMETER (NEX=8, NLF=2)
30398 DIMENSION AM(0:NEX,0:NLF,-5:2)
30399 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
30400 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
30401 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
30402 DIMENSION AF(0:NEX)
30404 DATA MEXVEC( 2) / 8 /
30405 DATA MLFVEC( 2) / 2 /
30406 DATA UT1VEC( 2) / 0.4971265E+01 /
30407 DATA UT2VEC( 2) / -0.1105128E+01 /
30408 DATA ALFVEC( 2) / 0.2987216E+00 /
30409 DATA QMAVEC( 2) / 0.0000000E+00 /
30410 DATA (AM( 0,K, 2),K=0, 2)
30411 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
30412 DATA (AM( 1,K, 2),K=0, 2)
30413 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
30414 DATA (AM( 2,K, 2),K=0, 2)
30415 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
30416 DATA (AM( 3,K, 2),K=0, 2)
30417 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
30418 DATA (AM( 4,K, 2),K=0, 2)
30419 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
30420 DATA (AM( 5,K, 2),K=0, 2)
30421 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
30422 DATA (AM( 6,K, 2),K=0, 2)
30423 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
30424 DATA (AM( 7,K, 2),K=0, 2)
30425 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
30426 DATA (AM( 8,K, 2),K=0, 2)
30427 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
30429 DATA MEXVEC( 1) / 8 /
30430 DATA MLFVEC( 1) / 2 /
30431 DATA UT1VEC( 1) / 0.2612618E+01 /
30432 DATA UT2VEC( 1) / -0.1258304E+06 /
30433 DATA ALFVEC( 1) / 0.3407552E+00 /
30434 DATA QMAVEC( 1) / 0.0000000E+00 /
30435 DATA (AM( 0,K, 1),K=0, 2)
30436 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
30437 DATA (AM( 1,K, 1),K=0, 2)
30438 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
30439 DATA (AM( 2,K, 1),K=0, 2)
30440 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
30441 DATA (AM( 3,K, 1),K=0, 2)
30442 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
30443 DATA (AM( 4,K, 1),K=0, 2)
30444 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
30445 DATA (AM( 5,K, 1),K=0, 2)
30446 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
30447 DATA (AM( 6,K, 1),K=0, 2)
30448 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
30449 DATA (AM( 7,K, 1),K=0, 2)
30450 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
30451 DATA (AM( 8,K, 1),K=0, 2)
30452 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
30454 DATA MEXVEC( 0) / 8 /
30455 DATA MLFVEC( 0) / 2 /
30456 DATA UT1VEC( 0) / -0.4656819E+00 /
30457 DATA UT2VEC( 0) / -0.2742390E+03 /
30458 DATA ALFVEC( 0) / 0.4491863E+00 /
30459 DATA QMAVEC( 0) / 0.0000000E+00 /
30460 DATA (AM( 0,K, 0),K=0, 2)
30461 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
30462 DATA (AM( 1,K, 0),K=0, 2)
30463 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
30464 DATA (AM( 2,K, 0),K=0, 2)
30465 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
30466 DATA (AM( 3,K, 0),K=0, 2)
30467 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
30468 DATA (AM( 4,K, 0),K=0, 2)
30469 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
30470 DATA (AM( 5,K, 0),K=0, 2)
30471 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
30472 DATA (AM( 6,K, 0),K=0, 2)
30473 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
30474 DATA (AM( 7,K, 0),K=0, 2)
30475 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
30476 DATA (AM( 8,K, 0),K=0, 2)
30477 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
30479 DATA MEXVEC(-1) / 8 /
30480 DATA MLFVEC(-1) / 2 /
30481 DATA UT1VEC(-1) / 0.3862583E+01 /
30482 DATA UT2VEC(-1) / -0.1265969E+01 /
30483 DATA ALFVEC(-1) / 0.2457668E+00 /
30484 DATA QMAVEC(-1) / 0.0000000E+00 /
30485 DATA (AM( 0,K,-1),K=0, 2)
30486 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
30487 DATA (AM( 1,K,-1),K=0, 2)
30488 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
30489 DATA (AM( 2,K,-1),K=0, 2)
30490 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
30491 DATA (AM( 3,K,-1),K=0, 2)
30492 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
30493 DATA (AM( 4,K,-1),K=0, 2)
30494 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
30495 DATA (AM( 5,K,-1),K=0, 2)
30496 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
30497 DATA (AM( 6,K,-1),K=0, 2)
30498 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
30499 DATA (AM( 7,K,-1),K=0, 2)
30500 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
30501 DATA (AM( 8,K,-1),K=0, 2)
30502 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
30504 DATA MEXVEC(-2) / 7 /
30505 DATA MLFVEC(-2) / 2 /
30506 DATA UT1VEC(-2) / 0.1895615E+00 /
30507 DATA UT2VEC(-2) / -0.3069097E+01 /
30508 DATA ALFVEC(-2) / 0.5293999E+00 /
30509 DATA QMAVEC(-2) / 0.0000000E+00 /
30510 DATA (AM( 0,K,-2),K=0, 2)
30511 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
30512 DATA (AM( 1,K,-2),K=0, 2)
30513 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
30514 DATA (AM( 2,K,-2),K=0, 2)
30515 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
30516 DATA (AM( 3,K,-2),K=0, 2)
30517 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
30518 DATA (AM( 4,K,-2),K=0, 2)
30519 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
30520 DATA (AM( 5,K,-2),K=0, 2)
30521 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
30522 DATA (AM( 6,K,-2),K=0, 2)
30523 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
30524 DATA (AM( 7,K,-2),K=0, 2)
30525 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
30527 DATA MEXVEC(-3) / 7 /
30528 DATA MLFVEC(-3) / 2 /
30529 DATA UT1VEC(-3) / 0.3753257E+01 /
30530 DATA UT2VEC(-3) / -0.1113085E+01 /
30531 DATA ALFVEC(-3) / 0.3713141E+00 /
30532 DATA QMAVEC(-3) / 0.0000000E+00 /
30533 DATA (AM( 0,K,-3),K=0, 2)
30534 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
30535 DATA (AM( 1,K,-3),K=0, 2)
30536 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
30537 DATA (AM( 2,K,-3),K=0, 2)
30538 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
30539 DATA (AM( 3,K,-3),K=0, 2)
30540 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
30541 DATA (AM( 4,K,-3),K=0, 2)
30542 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
30543 DATA (AM( 5,K,-3),K=0, 2)
30544 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
30545 DATA (AM( 6,K,-3),K=0, 2)
30546 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
30547 DATA (AM( 7,K,-3),K=0, 2)
30548 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
30550 DATA MEXVEC(-4) / 7 /
30551 DATA MLFVEC(-4) / 2 /
30552 DATA UT1VEC(-4) / 0.4400772E+01 /
30553 DATA UT2VEC(-4) / -0.1356116E+01 /
30554 DATA ALFVEC(-4) / 0.3712017E-01 /
30555 DATA QMAVEC(-4) / 0.1300000E+01 /
30556 DATA (AM( 0,K,-4),K=0, 2)
30557 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
30558 DATA (AM( 1,K,-4),K=0, 2)
30559 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
30560 DATA (AM( 2,K,-4),K=0, 2)
30561 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
30562 DATA (AM( 3,K,-4),K=0, 2)
30563 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
30564 DATA (AM( 4,K,-4),K=0, 2)
30565 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
30566 DATA (AM( 5,K,-4),K=0, 2)
30567 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
30568 DATA (AM( 6,K,-4),K=0, 2)
30569 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
30570 DATA (AM( 7,K,-4),K=0, 2)
30571 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
30573 DATA MEXVEC(-5) / 6 /
30574 DATA MLFVEC(-5) / 2 /
30575 DATA UT1VEC(-5) / 0.5562568E+01 /
30576 DATA UT2VEC(-5) / -0.1801317E+01 /
30577 DATA ALFVEC(-5) / 0.4952010E-02 /
30578 DATA QMAVEC(-5) / 0.4500000E+01 /
30579 DATA (AM( 0,K,-5),K=0, 2)
30580 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
30581 DATA (AM( 1,K,-5),K=0, 2)
30582 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
30583 DATA (AM( 2,K,-5),K=0, 2)
30584 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
30585 DATA (AM( 3,K,-5),K=0, 2)
30586 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
30587 DATA (AM( 4,K,-5),K=0, 2)
30588 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
30589 DATA (AM( 5,K,-5),K=0, 2)
30590 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
30591 DATA (AM( 6,K,-5),K=0, 2)
30592 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
30594 IF(Q .LE. QMAVEC(IFL)) THEN
30599 IF(X .GE. 1.D0) THEN
30604 TMP = LOG(Q/ALFVEC(IFL))
30605 IF(TMP .LE. 0.D0) THEN
30617 DO 100 K = 0, MLFVEC(IFL)
30618 AF(I) = AF(I) + SBX*AM(I,K,IFL)
30624 U = LOG(X/0.00001D0)
30626 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
30627 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
30628 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
30629 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
30630 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
30632 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
30634 C...Include threshold factor.
30635 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
30640 C*********************************************************************
30643 C...Auxiliary function for parametrization of CTEQ5M1.
30644 C...Author: J. Pumplin 9/99.
30646 FUNCTION PYCT5M(IFL,X,Q)
30648 C...Double precision declaration.
30649 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30650 IMPLICIT INTEGER(I-N)
30652 PARAMETER (NEX=8, NLF=2)
30653 DIMENSION AM(0:NEX,0:NLF,-5:2)
30654 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
30655 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
30656 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
30657 DIMENSION AF(0:NEX)
30659 DATA MEXVEC( 2) / 8 /
30660 DATA MLFVEC( 2) / 2 /
30661 DATA UT1VEC( 2) / 0.5141718E+01 /
30662 DATA UT2VEC( 2) / -0.1346944E+01 /
30663 DATA ALFVEC( 2) / 0.5260555E+00 /
30664 DATA QMAVEC( 2) / 0.0000000E+00 /
30665 DATA (AM( 0,K, 2),K=0, 2)
30666 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
30667 DATA (AM( 1,K, 2),K=0, 2)
30668 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
30669 DATA (AM( 2,K, 2),K=0, 2)
30670 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
30671 DATA (AM( 3,K, 2),K=0, 2)
30672 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
30673 DATA (AM( 4,K, 2),K=0, 2)
30674 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
30675 DATA (AM( 5,K, 2),K=0, 2)
30676 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
30677 DATA (AM( 6,K, 2),K=0, 2)
30678 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
30679 DATA (AM( 7,K, 2),K=0, 2)
30680 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
30681 DATA (AM( 8,K, 2),K=0, 2)
30682 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
30684 DATA MEXVEC( 1) / 8 /
30685 DATA MLFVEC( 1) / 2 /
30686 DATA UT1VEC( 1) / 0.4138426E+01 /
30687 DATA UT2VEC( 1) / -0.3221374E+01 /
30688 DATA ALFVEC( 1) / 0.4960962E+00 /
30689 DATA QMAVEC( 1) / 0.0000000E+00 /
30690 DATA (AM( 0,K, 1),K=0, 2)
30691 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
30692 DATA (AM( 1,K, 1),K=0, 2)
30693 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
30694 DATA (AM( 2,K, 1),K=0, 2)
30695 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
30696 DATA (AM( 3,K, 1),K=0, 2)
30697 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
30698 DATA (AM( 4,K, 1),K=0, 2)
30699 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
30700 DATA (AM( 5,K, 1),K=0, 2)
30701 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
30702 DATA (AM( 6,K, 1),K=0, 2)
30703 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
30704 DATA (AM( 7,K, 1),K=0, 2)
30705 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
30706 DATA (AM( 8,K, 1),K=0, 2)
30707 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
30709 DATA MEXVEC( 0) / 8 /
30710 DATA MLFVEC( 0) / 2 /
30711 DATA UT1VEC( 0) / -0.1026789E+01 /
30712 DATA UT2VEC( 0) / -0.9051707E+01 /
30713 DATA ALFVEC( 0) / 0.9462977E+00 /
30714 DATA QMAVEC( 0) / 0.0000000E+00 /
30715 DATA (AM( 0,K, 0),K=0, 2)
30716 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
30717 DATA (AM( 1,K, 0),K=0, 2)
30718 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
30719 DATA (AM( 2,K, 0),K=0, 2)
30720 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
30721 DATA (AM( 3,K, 0),K=0, 2)
30722 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
30723 DATA (AM( 4,K, 0),K=0, 2)
30724 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
30725 DATA (AM( 5,K, 0),K=0, 2)
30726 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
30727 DATA (AM( 6,K, 0),K=0, 2)
30728 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
30729 DATA (AM( 7,K, 0),K=0, 2)
30730 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
30731 DATA (AM( 8,K, 0),K=0, 2)
30732 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
30734 DATA MEXVEC(-1) / 8 /
30735 DATA MLFVEC(-1) / 2 /
30736 DATA UT1VEC(-1) / 0.5243571E+01 /
30737 DATA UT2VEC(-1) / -0.2870513E+01 /
30738 DATA ALFVEC(-1) / 0.6701448E+00 /
30739 DATA QMAVEC(-1) / 0.0000000E+00 /
30740 DATA (AM( 0,K,-1),K=0, 2)
30741 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
30742 DATA (AM( 1,K,-1),K=0, 2)
30743 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
30744 DATA (AM( 2,K,-1),K=0, 2)
30745 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
30746 DATA (AM( 3,K,-1),K=0, 2)
30747 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
30748 DATA (AM( 4,K,-1),K=0, 2)
30749 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
30750 DATA (AM( 5,K,-1),K=0, 2)
30751 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
30752 DATA (AM( 6,K,-1),K=0, 2)
30753 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
30754 DATA (AM( 7,K,-1),K=0, 2)
30755 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
30756 DATA (AM( 8,K,-1),K=0, 2)
30757 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
30759 DATA MEXVEC(-2) / 7 /
30760 DATA MLFVEC(-2) / 2 /
30761 DATA UT1VEC(-2) / 0.4782210E+01 /
30762 DATA UT2VEC(-2) / -0.1976856E+02 /
30763 DATA ALFVEC(-2) / 0.7558374E+00 /
30764 DATA QMAVEC(-2) / 0.0000000E+00 /
30765 DATA (AM( 0,K,-2),K=0, 2)
30766 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
30767 DATA (AM( 1,K,-2),K=0, 2)
30768 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
30769 DATA (AM( 2,K,-2),K=0, 2)
30770 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
30771 DATA (AM( 3,K,-2),K=0, 2)
30772 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
30773 DATA (AM( 4,K,-2),K=0, 2)
30774 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
30775 DATA (AM( 5,K,-2),K=0, 2)
30776 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
30777 DATA (AM( 6,K,-2),K=0, 2)
30778 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
30779 DATA (AM( 7,K,-2),K=0, 2)
30780 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
30782 DATA MEXVEC(-3) / 7 /
30783 DATA MLFVEC(-3) / 2 /
30784 DATA UT1VEC(-3) / 0.4518239E+01 /
30785 DATA UT2VEC(-3) / -0.2690590E+01 /
30786 DATA ALFVEC(-3) / 0.6124079E+00 /
30787 DATA QMAVEC(-3) / 0.0000000E+00 /
30788 DATA (AM( 0,K,-3),K=0, 2)
30789 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
30790 DATA (AM( 1,K,-3),K=0, 2)
30791 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
30792 DATA (AM( 2,K,-3),K=0, 2)
30793 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
30794 DATA (AM( 3,K,-3),K=0, 2)
30795 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
30796 DATA (AM( 4,K,-3),K=0, 2)
30797 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
30798 DATA (AM( 5,K,-3),K=0, 2)
30799 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
30800 DATA (AM( 6,K,-3),K=0, 2)
30801 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
30802 DATA (AM( 7,K,-3),K=0, 2)
30803 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
30805 DATA MEXVEC(-4) / 7 /
30806 DATA MLFVEC(-4) / 2 /
30807 DATA UT1VEC(-4) / 0.2783230E+01 /
30808 DATA UT2VEC(-4) / -0.1746328E+01 /
30809 DATA ALFVEC(-4) / 0.1115653E+01 /
30810 DATA QMAVEC(-4) / 0.1300000E+01 /
30811 DATA (AM( 0,K,-4),K=0, 2)
30812 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
30813 DATA (AM( 1,K,-4),K=0, 2)
30814 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
30815 DATA (AM( 2,K,-4),K=0, 2)
30816 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
30817 DATA (AM( 3,K,-4),K=0, 2)
30818 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
30819 DATA (AM( 4,K,-4),K=0, 2)
30820 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
30821 DATA (AM( 5,K,-4),K=0, 2)
30822 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
30823 DATA (AM( 6,K,-4),K=0, 2)
30824 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
30825 DATA (AM( 7,K,-4),K=0, 2)
30826 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
30828 DATA MEXVEC(-5) / 6 /
30829 DATA MLFVEC(-5) / 2 /
30830 DATA UT1VEC(-5) / 0.1619654E+02 /
30831 DATA UT2VEC(-5) / -0.3367346E+01 /
30832 DATA ALFVEC(-5) / 0.5109891E-02 /
30833 DATA QMAVEC(-5) / 0.4500000E+01 /
30834 DATA (AM( 0,K,-5),K=0, 2)
30835 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
30836 DATA (AM( 1,K,-5),K=0, 2)
30837 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
30838 DATA (AM( 2,K,-5),K=0, 2)
30839 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
30840 DATA (AM( 3,K,-5),K=0, 2)
30841 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
30842 DATA (AM( 4,K,-5),K=0, 2)
30843 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
30844 DATA (AM( 5,K,-5),K=0, 2)
30845 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
30846 DATA (AM( 6,K,-5),K=0, 2)
30847 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
30849 IF(Q .LE. QMAVEC(IFL)) THEN
30854 IF(X .GE. 1.D0) THEN
30859 TMP = LOG(Q/ALFVEC(IFL))
30860 IF(TMP .LE. 0.D0) THEN
30872 DO 100 K = 0, MLFVEC(IFL)
30873 AF(I) = AF(I) + SBX*AM(I,K,IFL)
30879 U = LOG(X/0.00001D0)
30881 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
30882 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
30883 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
30884 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
30885 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
30887 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
30889 C...Include threshold factor.
30890 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
30895 C*********************************************************************
30898 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
30899 C...a few older parametrizations, now obsolete but convenient for
30900 C...backwards checks.
30902 SUBROUTINE PYPDPO(X,Q2,XPPR)
30904 C...Double precision and integer declarations.
30905 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30906 IMPLICIT INTEGER(I-N)
30907 INTEGER PYK,PYCHGE,PYCOMP
30909 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30910 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30911 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30912 COMMON/PYINT1/MINT(400),VINT(400)
30913 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
30914 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
30915 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
30918 C...The following data lines are coefficients needed in the
30919 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
30920 C...parametrizations, see below.
30921 C...Powers of 1-x in different cases.
30922 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
30923 C...Expansion coefficients for up valence quark distribution.
30924 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
30925 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
30926 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
30927 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
30928 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
30929 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
30930 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
30931 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
30932 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
30933 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
30934 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
30935 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
30936 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
30937 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
30938 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
30939 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
30940 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
30941 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
30942 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
30943 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
30944 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
30945 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
30946 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
30947 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
30948 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
30949 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
30950 C...Expansion coefficients for down valence quark distribution.
30951 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
30952 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
30953 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
30954 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
30955 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
30956 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
30957 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
30958 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
30959 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
30960 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
30961 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
30962 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
30963 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
30964 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
30965 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
30966 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
30967 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
30968 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
30969 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
30970 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
30971 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
30972 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
30973 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
30974 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
30975 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
30976 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
30977 C...Expansion coefficients for up and down sea quark distributions.
30978 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
30979 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
30980 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
30981 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
30982 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
30983 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
30984 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
30985 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
30986 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
30987 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
30988 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
30989 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
30990 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
30991 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
30992 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
30993 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
30994 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
30995 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
30996 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
30997 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
30998 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
30999 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
31000 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
31001 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
31002 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
31003 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
31004 C...Expansion coefficients for gluon distribution.
31005 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
31006 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
31007 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
31008 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
31009 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
31010 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
31011 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
31012 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
31013 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
31014 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
31015 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
31016 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
31017 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
31018 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
31019 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
31020 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
31021 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
31022 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
31023 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
31024 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
31025 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
31026 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
31027 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
31028 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
31029 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
31030 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
31031 C...Expansion coefficients for strange sea quark distribution.
31032 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
31033 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
31034 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
31035 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
31036 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
31037 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
31038 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
31039 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
31040 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
31041 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
31042 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
31043 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
31044 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
31045 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
31046 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
31047 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
31048 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
31049 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
31050 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
31051 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
31052 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
31053 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
31054 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
31055 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
31056 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
31057 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
31058 C...Expansion coefficients for charm sea quark distribution.
31059 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
31060 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
31061 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
31062 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
31063 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
31064 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
31065 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
31066 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
31067 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
31068 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
31069 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
31070 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
31071 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
31072 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
31073 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
31074 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
31075 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
31076 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
31077 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
31078 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
31079 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
31080 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
31081 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
31082 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
31083 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
31084 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
31085 C...Expansion coefficients for bottom sea quark distribution.
31086 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
31087 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
31088 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
31089 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
31090 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
31091 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
31092 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
31093 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
31094 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
31095 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
31096 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
31097 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
31098 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
31099 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
31100 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
31101 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
31102 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
31103 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
31104 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
31105 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
31106 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
31107 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
31108 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
31109 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
31110 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
31111 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
31112 C...Expansion coefficients for top sea quark distribution.
31113 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
31114 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
31115 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
31116 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
31117 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
31118 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
31119 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
31120 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
31121 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
31122 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
31123 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
31124 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
31125 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
31126 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
31127 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
31128 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
31129 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
31130 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
31131 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
31132 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
31133 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
31134 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
31135 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
31136 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
31137 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
31138 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
31140 C...The following data lines are coefficients needed in the
31141 C...Duke, Owens proton structure function parametrizations, see below.
31142 C...Expansion coefficients for (up+down) valence quark distribution.
31143 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
31144 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31145 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31146 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
31147 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
31148 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31149 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31150 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
31151 C...Expansion coefficients for down valence quark distribution.
31152 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
31153 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31154 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
31155 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
31156 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
31157 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31158 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
31159 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
31160 C...Expansion coefficients for (up+down+strange) sea quark distribution.
31161 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
31162 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31163 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
31164 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
31165 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
31166 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31167 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
31168 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
31169 C...Expansion coefficients for charm sea quark distribution.
31170 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
31171 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31172 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
31173 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
31174 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
31175 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
31176 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
31177 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
31178 C...Expansion coefficients for gluon distribution.
31179 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
31180 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
31181 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
31182 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
31183 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
31184 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
31185 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
31186 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
31188 C...Euler's beta function, requires ordinary Gamma function
31189 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
31191 C...Leading order proton parton distributions from Glueck, Reya and
31192 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
31194 IF(MSTP(51).EQ.11) THEN
31196 C...Determine s expansion variable and some x expressions.
31197 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
31198 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
31203 C...Evaluate valence, gluon and sea distributions.
31204 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
31205 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
31206 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
31207 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
31208 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
31209 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
31210 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
31211 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
31212 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
31213 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
31214 & SQRT(4.066D0*SD**1.218D0*XL)))*
31215 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
31216 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
31217 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
31218 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
31219 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
31220 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
31221 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
31222 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
31223 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
31224 IF(SD.LE.0.888D0) THEN
31227 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
31228 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
31229 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
31231 IF(SD.LE.1.351D0) THEN
31234 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
31235 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
31236 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
31239 C...Put into output array.
31241 XPPR(1)=XFVDD+XFSEA
31242 XPPR(2)=XFVUD-XFVDD+XFSEA
31252 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
31253 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
31254 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
31256 C...Determine set, Lambda and x and t expansion variables.
31258 IF(NSET.EQ.1) ALAM=0.2D0
31259 IF(NSET.EQ.2) ALAM=0.29D0
31260 TMIN=LOG(5D0/ALAM**2)
31261 TMAX=LOG(1D8/ALAM**2)
31262 T=LOG(MAX(1D0,Q2/ALAM**2))
31263 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
31265 IF(X.LE.0.1D0) NX=2
31266 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
31267 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
31269 C...Chebyshev polynomials for x and t expansion.
31272 TX(3)=2D0*VX**2-1D0
31273 TX(4)=4D0*VX**3-3D0*VX
31274 TX(5)=8D0*VX**4-8D0*VX**2+1D0
31275 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
31278 TT(3)=2D0*VT**2-1D0
31279 TT(4)=4D0*VT**3-3D0*VT
31280 TT(5)=8D0*VT**4-8D0*VT**2+1D0
31281 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
31283 C...Calculate structure functions.
31288 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
31291 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
31294 C...Put into output array.
31296 XPPR(1)=XQ(2)+XQ(3)
31297 XPPR(2)=XQ(1)+XQ(3)
31305 C...Special expansion for bottom (threshold effects).
31306 IF(MSTP(58).GE.5) THEN
31307 IF(NSET.EQ.1) TMIN=8.1905D0
31308 IF(NSET.EQ.2) TMIN=7.4474D0
31310 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
31313 TT(3)=2D0*VT**2-1D0
31314 TT(4)=4D0*VT**3-3D0*VT
31315 TT(5)=8D0*VT**4-8D0*VT**2+1D0
31316 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
31320 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
31323 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
31328 C...Special expansion for top (threshold effects).
31329 IF(MSTP(58).GE.6) THEN
31330 IF(NSET.EQ.1) TMIN=11.5528D0
31331 IF(NSET.EQ.2) TMIN=10.8097D0
31332 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
31333 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
31335 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
31338 TT(3)=2D0*VT**2-1D0
31339 TT(4)=4D0*VT**3-3D0*VT
31340 TT(5)=8D0*VT**4-8D0*VT**2+1D0
31341 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
31345 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
31348 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
31353 C...Proton parton distributions from Duke, Owens.
31354 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
31355 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
31357 C...Determine set, Lambda and s expansion parameter.
31359 IF(NSET.EQ.1) ALAM=0.2D0
31360 IF(NSET.EQ.2) ALAM=0.4D0
31361 Q2IN=MIN(1D6,MAX(4D0,Q2))
31362 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
31364 C...Calculate structure functions.
31367 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
31368 & CDO(3,IS,KFL,NSET)*SD**2
31371 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
31372 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
31374 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
31375 & TS(5)*X**2+TS(6)*X**3)
31379 C...Put into output arrays.
31381 XPPR(1)=XQ(2)+XQ(3)/6D0
31382 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
31395 C*********************************************************************
31398 C...Gives threshold attractive/repulsive factor for heavy flavour
31401 FUNCTION PYHFTH(SH,SQM,FRATT)
31403 C...Double precision and integer declarations.
31404 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31405 IMPLICIT INTEGER(I-N)
31406 INTEGER PYK,PYCHGE,PYCOMP
31408 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31409 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31410 COMMON/PYINT1/MINT(400),VINT(400)
31411 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
31413 C...Value for alpha_strong.
31414 IF(MSTP(35).LE.1) THEN
31419 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
31425 C...Evaluate attractive and repulsive factors.
31426 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
31427 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
31428 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
31429 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
31430 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
31436 C*********************************************************************
31439 C...Splits a hadron remnant into two (partons or hadron + parton)
31440 C...in case it is more complicated than just a quark or a diquark.
31442 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
31444 C...Double precision and integer declarations.
31445 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31446 IMPLICIT INTEGER(I-N)
31447 INTEGER PYK,PYCHGE,PYCOMP
31448 C...Commonblocks. PYDAT1 temporary
31449 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31450 COMMON/PYINT1/MINT(400),VINT(400)
31451 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31452 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
31456 C...Preliminaries. Parton composition.
31459 KFL(1)=MOD(KFA/1000,10)
31460 KFL(2)=MOD(KFA/100,10)
31461 KFL(3)=MOD(KFA/10,10)
31462 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
31463 KFL(2)=INT(1.5D0+PYR(0))
31464 IF(MINT(105).EQ.333) KFL(2)=3
31465 IF(MINT(105).EQ.443) KFL(2)=4
31467 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
31470 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
31473 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
31474 KFL(2)=MOD(KFA/10,10)
31475 KFL(3)=MOD(KFA/100,10)
31477 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
31484 C...Subdivide lepton.
31485 IF(KFA.GE.11.AND.KFA.LE.18) THEN
31486 IF(KFLR.EQ.KFA) THEN
31488 ELSEIF(KFLR.EQ.22) THEN
31490 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
31492 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
31494 ELSEIF(KFLR.EQ.21) THEN
31502 C...Subdivide photon.
31503 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
31504 IF(KFLR.NE.21) THEN
31509 IF(RAGR.GT.0.125D0) KFLSP=2
31510 IF(RAGR.GT.0.625D0) KFLSP=3
31511 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
31515 C...Subdivide Reggeon or Pomeron.
31516 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
31517 IF(KFLIN.EQ.21) THEN
31523 C...Subdivide meson.
31524 ELSEIF(KFL(1).EQ.0) THEN
31525 KFL(2)=KFL(2)*(-1)**KFL(2)
31526 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
31527 IF(KFLR.EQ.KFL(2)) THEN
31529 ELSEIF(KFLR.EQ.KFL(3)) THEN
31531 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
31534 ELSEIF(KFLR.EQ.21) THEN
31537 ELSEIF(KFLR*KFL(2).GT.0) THEN
31540 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
31541 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31543 ELSEIF(KFLCH.EQ.0) THEN
31544 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31552 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
31553 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31555 ELSEIF(KFLCH.EQ.0) THEN
31556 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31563 C...Subdivide baryon.
31567 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
31570 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
31573 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
31574 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
31577 IAGR=1.00001D0+2.99998D0*PYR(0)
31580 IF(IAGR.EQ.1) ID1=2
31581 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
31584 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
31585 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
31586 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
31587 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
31588 ELSEIF(MOD(KFA,10).EQ.2) THEN
31589 IF(IAGR.EQ.1) KSP=1
31590 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
31592 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
31593 IF(KFLR.EQ.21) THEN
31595 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
31598 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
31599 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31601 ELSEIF(KFLCH.EQ.0) THEN
31602 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31606 ELSEIF(NAGR.EQ.0) THEN
31609 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
31610 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
31612 ELSEIF(KFLCH.EQ.0) THEN
31613 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
31621 C...Add on correct sign for result.
31628 C*********************************************************************
31631 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
31632 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
31633 C...(Dover, 1965) 6.1.36.
31637 C...Double precision and integer declarations.
31638 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31639 IMPLICIT INTEGER(I-N)
31640 INTEGER PYK,PYCHGE,PYCOMP
31641 C...Local array and data.
31643 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
31644 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
31653 PYGAMM=PYGAMM+B(I)*DXP
31659 PYGAMM=(X-IX)*PYGAMM
31666 C***********************************************************************
31669 C...Calculates real and imaginary parts of the auxiliary functions W1
31670 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
31671 C...der Bij, Nucl. Phys. B297 (1988) 221.
31673 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
31675 C...Double precision and integer declarations.
31676 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31677 IMPLICIT INTEGER(I-N)
31678 INTEGER PYK,PYCHGE,PYCOMP
31680 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31683 ASINH(X)=LOG(X+SQRT(X**2+1D0))
31684 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
31686 IF(EPS.LT.0D0) THEN
31687 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
31688 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
31690 ELSEIF(EPS.LT.1D0) THEN
31691 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
31692 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
31693 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
31694 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
31696 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
31697 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
31704 C***********************************************************************
31707 C...Calculates real and imaginary parts of the auxiliary function I3;
31708 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
31709 C...Nucl. Phys. B297 (1988) 221.
31711 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
31713 C...Double precision and integer declarations.
31714 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31715 IMPLICIT INTEGER(I-N)
31716 INTEGER PYK,PYCHGE,PYCOMP
31718 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31721 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
31722 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
31724 IF(EPS.LT.0D0) THEN
31725 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31726 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
31727 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
31728 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
31729 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
31730 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
31731 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
31732 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
31734 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
31735 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
31736 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
31737 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
31738 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
31739 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
31740 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
31741 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
31742 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31743 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
31744 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
31745 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
31746 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
31747 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
31748 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
31749 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
31751 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
31752 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
31753 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
31754 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
31755 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
31758 ELSEIF(EPS.LT.1D0) THEN
31759 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31760 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
31761 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
31762 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
31763 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
31764 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
31765 & (0.25D0*(RAT+1D0)*EPS))
31766 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
31767 & (0.25D0*(RAT+1D0)*EPS))
31768 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
31769 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
31770 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
31771 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
31772 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
31773 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
31774 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
31775 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
31776 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
31777 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
31778 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
31779 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
31780 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
31781 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
31782 & (1D0+0.25D0*RAT*EPS-GA))
31783 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
31784 & (1D0+0.25D0*RAT*EPS-GA))
31786 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
31787 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
31788 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
31789 & LOG((GA+BE-1D0)/(BE-GA))
31790 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
31793 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
31794 RCTHE=RSQ*(1D0-2D0*BE/EPS)
31795 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
31796 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
31797 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
31799 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
31800 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
31801 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
31802 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
31803 & (PHI-THE)*(PHI+THE-PARU(1))
31804 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
31805 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
31808 Y3RE=2D0/(2D0*BE-1D0)*F3RE
31809 Y3IM=2D0/(2D0*BE-1D0)*F3IM
31814 C***********************************************************************
31817 C...Calculates real and imaginary part of Spence function; see
31818 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
31820 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
31822 C...Double precision and integer declarations.
31823 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31824 IMPLICIT INTEGER(I-N)
31825 INTEGER PYK,PYCHGE,PYCOMP
31827 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31829 C...Local array and data.
31832 &1.000000D+00, -5.000000D-01, 1.666667D-01,
31833 &0.000000D+00, -3.333333D-02, 0.000000D+00,
31834 &2.380952D-02, 0.000000D+00, -3.333333D-02,
31835 &0.000000D+00, 7.575757D-02, 0.000000D+00,
31836 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
31840 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
31841 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
31842 IF(IREIM.EQ.2) PYSPEN=0D0
31846 XMOD=SQRT(XRE**2+XIM**2)
31847 IF(XMOD.LT.1D-6) THEN
31848 IF(IREIM.EQ.1) PYSPEN=0D0
31849 IF(IREIM.EQ.2) PYSPEN=0D0
31853 XARG=SIGN(ACOS(XRE/XMOD),XIM)
31857 IF(XMOD.GT.1D0) THEN
31859 ALGXIM=XARG-SIGN(PARU(1),XARG)
31860 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
31861 SP0IM=-ALGXRE*ALGXIM
31868 IF(XRE.GT.0.5D0) THEN
31873 XMOD=SQRT(XRE**2+XIM**2)
31874 XARG=SIGN(ACOS(XRE/XMOD),XIM)
31877 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
31878 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
31884 XMOD=SQRT(XRE**2+XIM**2)
31885 XARG=SIGN(ACOS(XRE/XMOD),XIM)
31894 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
31895 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
31896 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
31899 SPRE=SPRE+B(I)*TERMRE
31900 SPIM=SPIM+B(I)*TERMIM
31903 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
31904 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
31909 C***********************************************************************
31912 C...Calculates the matrix element for the processes
31913 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
31914 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
31915 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
31917 SUBROUTINE PYQQBH(WTQQBH)
31919 C...Double precision and integer declarations.
31920 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31921 IMPLICIT INTEGER(I-N)
31922 INTEGER PYK,PYCHGE,PYCOMP
31924 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31925 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31926 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31927 COMMON/PYINT1/MINT(400),VINT(400)
31928 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31929 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
31930 C...Local arrays and function.
31931 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
31932 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
31935 C...Mass parameters.
31938 SHPR=SQRT(VINT(26))*VINT(1)
31939 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
31940 PH=SQRT(VINT(21))*VINT(1)
31944 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
31946 PT=SQRT(MAX(0D0,VINT(197+5*I)))
31947 PP(I,1)=PT*COS(VINT(198+5*I))
31948 PP(I,2)=PT*SIN(VINT(198+5*I))
31950 PP(3,1)=-PP(1,1)-PP(2,1)
31951 PP(3,2)=-PP(1,2)-PP(2,2)
31952 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
31953 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
31954 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
31956 PP(3,3)=PMT3*SINH(VINT(211))
31957 PP(3,4)=PMT3*COSH(VINT(211))
31958 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
31959 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
31960 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
31961 PP(2,3)=-PP(1,3)-PP(3,3)
31962 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
31963 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
31965 C...Set up incoming kinematics and derived momentum combinations.
31969 PP(I,3)=-0.5D0*SHPR*(-1)**I
31970 PP(I,4)=-0.5D0*SHPR
31973 PP(6,J)=PP(1,J)+PP(2,J)
31974 PP(7,J)=PP(1,J)+PP(3,J)
31975 PP(8,J)=PP(1,J)+PP(4,J)
31976 PP(9,J)=PP(1,J)+PP(5,J)
31977 PP(10,J)=-PP(2,J)-PP(3,J)
31978 PP(11,J)=-PP(2,J)-PP(4,J)
31979 PP(12,J)=-PP(2,J)-PP(5,J)
31980 PP(13,J)=-PP(4,J)-PP(5,J)
31983 C...Derived kinematics invariants.
32012 C...Define colour coefficients for g + g -> Q + Qbar + H.
32013 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
32017 CLR(I+3,J+3)=16D0/3D0
32018 CLR(I,J+3)=-2D0/3D0
32019 CLR(I+3,J)=-2D0/3D0
32032 CLR(6+K1,6+K2)=12D0
32036 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
32037 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
32038 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
32039 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
32040 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
32041 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
32042 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
32044 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
32045 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
32046 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
32047 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
32048 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
32049 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
32050 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
32051 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
32052 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
32053 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
32054 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
32055 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
32056 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
32057 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
32058 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
32059 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
32060 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
32061 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
32063 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
32064 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
32065 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
32066 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
32067 & +X4*X9*X5+X4*X5**2)
32068 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
32069 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
32070 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
32071 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
32072 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
32073 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
32074 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
32075 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
32076 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
32077 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
32078 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
32079 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
32080 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
32081 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
32082 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
32083 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
32084 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
32085 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
32086 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
32087 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
32089 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
32090 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
32091 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
32092 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
32093 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
32094 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
32095 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
32097 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
32098 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
32099 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
32100 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
32101 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
32102 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
32104 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
32105 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
32106 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
32107 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
32108 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
32109 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
32110 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
32112 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
32113 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
32114 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
32115 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
32116 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
32117 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
32118 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
32119 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
32120 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
32121 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
32122 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
32123 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
32124 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
32125 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
32126 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
32127 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
32128 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
32129 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
32130 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
32131 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
32132 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
32133 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
32134 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
32135 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
32136 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
32137 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
32138 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
32139 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
32140 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
32141 & +X3*X8*X5+X3*X5**2)
32142 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
32143 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
32144 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
32145 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
32146 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
32147 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
32148 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
32150 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
32151 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
32152 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
32153 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
32154 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
32155 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
32156 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
32157 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
32158 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
32159 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
32160 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
32161 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
32162 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
32163 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
32164 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
32165 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
32166 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
32167 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
32168 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
32169 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
32170 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
32171 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
32172 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
32173 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
32174 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
32175 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
32177 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
32178 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
32179 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
32180 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
32181 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
32182 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
32183 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
32184 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
32185 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
32186 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
32187 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
32188 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
32189 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
32190 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
32191 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
32192 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
32193 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
32194 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
32195 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
32196 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
32197 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
32198 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
32199 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
32200 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
32201 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
32202 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
32204 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
32205 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
32206 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
32207 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
32208 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
32209 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
32210 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
32211 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
32212 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
32213 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
32214 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
32215 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
32216 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
32217 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
32218 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
32219 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
32220 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
32221 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
32222 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
32223 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
32224 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
32225 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
32226 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
32227 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
32228 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
32229 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
32230 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
32231 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
32232 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
32233 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
32234 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
32235 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
32236 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
32237 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
32238 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
32239 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
32240 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
32241 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
32242 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
32243 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
32244 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
32245 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
32246 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
32247 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
32249 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
32250 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
32251 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
32252 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
32253 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
32254 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
32255 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
32256 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
32257 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
32258 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
32259 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
32261 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
32262 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
32263 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
32264 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
32265 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
32266 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
32268 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
32269 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
32270 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
32272 FM(9,10)=0.5D0*(FMXX+FM(9,10))
32273 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
32274 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
32275 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
32277 C...Repackage matrix elements.
32283 RM(7,7)=FM(7,7)-2D0*FM(9,9)
32284 RM(7,8)=FM(7,8)-2D0*FM(9,10)
32285 RM(8,8)=FM(8,8)-2D0*FM(10,10)
32287 C...Produce final result: matrix elements * colours * propagators.
32292 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
32295 WTQQBH=-WTQQBH/256D0
32298 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
32299 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
32300 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
32302 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
32303 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
32304 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
32306 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
32307 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
32310 C...Produce final result: matrix elements * propagators.
32312 A12=A12/(DX(7)*DX(8))
32314 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
32320 C*********************************************************************
32323 C...Initializes supersymmetry: finds sparticle masses and
32324 C...branching ratios and stores this information.
32325 C...AUTHOR: STEPHEN MRENNA
32326 C...Baryon- and lepton-number violating parameters by P. Z. Skands.
32330 C...Double precision and integer declarations.
32331 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32332 IMPLICIT INTEGER(I-N)
32333 INTEGER PYK,PYCHGE,PYCOMP
32334 C...Parameter statement to help give large particle numbers.
32335 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32336 &KEXCIT=4000000,KDIMEN=5000000)
32338 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32339 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32340 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32341 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32342 COMMON/PYINT4/MWID(500),WIDS(500,5)
32343 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32344 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
32345 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32346 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
32347 COMMON/PYHTRI/HHH(7)
32348 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
32351 C...Local variables.
32352 DOUBLE PRECISION ALFA,BETA
32353 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
32354 INTEGER I,J,J1,I1,K1
32355 INTEGER KC,LKNT,IDLAM(400,3)
32356 DOUBLE PRECISION XLAM(0:400)
32357 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
32358 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
32359 DOUBLE PRECISION DELM,XMDIF
32360 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
32361 DOUBLE PRECISION ARG,SGNMU,R
32364 INTEGER KFSUSY(36),MWIDSU(36),MDCYSU(36)
32367 &1000001,2000001,1000002,2000002,1000003,2000003,
32368 &1000004,2000004,1000005,2000005,1000006,2000006,
32369 &1000011,2000011,1000012,2000012,1000013,2000013,
32370 &1000014,2000014,1000015,2000015,1000016,2000016,
32371 &1000021,1000022,1000023,1000025,1000035,1000024,
32372 &1000037,1000039, 25, 35, 36, 37/
32375 C...Do nothing if SUSY not requested.
32377 IF(IMSSM.EQ.0) RETURN
32379 C...Save copy of MWID(KC) and MDCY(KC,1) values before
32380 C...they are set to zero for the LSP.
32387 MDCYSU(I)=MDCY(KC,1)
32391 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
32395 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
32397 MDCY(KC,1)=MDCYSU(I)
32401 C...First part of routine: set masses and couplings.
32403 C...Reset mixing values in sfermion sector to pure left/right.
32411 C...Common couplings.
32416 COS2B=COS(2D0*BETA)
32422 C...Define sparticle masses for a general MSSM simulation.
32423 IF(IMSSM.EQ.1) THEN
32424 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
32426 KC=PYCOMP(KSUSY1+I)
32427 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
32428 KC=PYCOMP(KSUSY2+I)
32429 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
32430 KC=PYCOMP(KSUSY1+I+1)
32431 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
32432 KC=PYCOMP(KSUSY2+I+1)
32433 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
32435 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
32436 IF(XARG.LT.0D0) THEN
32437 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
32438 & ' FROM THE SUM RULE. '
32439 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
32445 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
32446 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
32447 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
32448 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
32450 IF(IMSS(8).EQ.1) THEN
32455 C...Alternatively derive masses from SUGRA relations.
32456 ELSEIF(IMSSM.EQ.2) THEN
32459 ELSEIF(IMSSM.EQ.12) THEN
32465 C...Add in extra D-term contributions.
32466 IF(IMSS(7).EQ.1) THEN
32471 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32472 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
32473 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
32474 WRITE(MSTU(11),*) 'C DX = ',DX
32475 WRITE(MSTU(11),*) 'C DY = ',DY
32476 WRITE(MSTU(11),*) 'C DS = ',DS
32477 WRITE(MSTU(11),*) 'C '
32478 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
32479 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
32480 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32481 DQ2=DY/6D0-DX/3D0-DS/3D0
32482 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
32483 DD2=DY/3D0+DX-2D0*DS/3D0
32484 DL2=-DY/2D0+DX-2D0*DS/3D0
32485 DE2=DY-DX/3D0-DS/3D0
32486 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
32487 DHD2=-DY/2D0-2D0*DX/3D0+DS
32488 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
32490 DMA2 = 2D0*DMU2+DHU2+DHD2
32492 KC=PYCOMP(KSUSY1+I)
32493 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
32494 KC=PYCOMP(KSUSY2+I)
32495 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
32496 KC=PYCOMP(KSUSY1+I+1)
32497 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
32498 KC=PYCOMP(KSUSY2+I+1)
32499 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
32502 KC=PYCOMP(KSUSY1+I)
32503 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
32504 KC=PYCOMP(KSUSY2+I)
32505 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
32506 KC=PYCOMP(KSUSY1+I+1)
32507 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
32509 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
32510 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
32513 SGNMU=SIGN(1D0,RMSS(4))
32514 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
32515 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
32516 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
32517 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
32518 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
32519 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
32520 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
32521 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
32522 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
32523 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
32524 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
32525 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
32526 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
32529 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
32530 RMSS(6)=SQRT(RMSS(6)**2+DL2)
32531 RMSS(7)=SQRT(RMSS(7)**2+DE2)
32532 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
32533 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
32534 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
32535 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
32536 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
32539 C...Fix the third generation sfermions.
32542 C...Fix the neutralino--chargino--gluino sector.
32545 C...Fix the Higgs sector.
32548 C...Choose the Gunion-Haber convention.
32552 C...Print information on mass parameters.
32553 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
32554 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32555 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
32556 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
32557 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
32558 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
32559 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
32560 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
32561 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
32562 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
32563 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32565 IF(IMSS(20).EQ.1) THEN
32566 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32567 WRITE(MSTU(11),*) ' DEBUG MODE '
32568 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
32569 & UMIX(2,1),UMIX(2,2)
32570 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
32571 & UMIXI(2,1),UMIXI(2,2)
32572 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
32573 & VMIX(2,1),VMIX(2,2)
32574 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
32575 & VMIXI(2,1),VMIXI(2,2)
32576 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
32577 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
32578 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
32579 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
32580 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
32581 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
32582 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
32583 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
32584 WRITE(MSTU(11),*) ' ALFA = ',ALFA
32585 WRITE(MSTU(11),*) ' BETA = ',BETA
32586 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
32587 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
32588 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
32591 C...Set up the Higgs couplings - needed here since initialization
32592 C...in PYINRE did not yet occur when PYWIDT is called below.
32604 C2B=COSB**2-SINB**2
32605 C...tanb (used for H+)
32609 C...Coupling to d-type quarks
32610 PARU(161)=SINA/COSB
32611 C...Coupling to u-type quarks
32612 PARU(162)=-COSA/SINB
32613 C...Coupling to leptons
32614 PARU(163)=PARU(161)
32618 PARU(165)=PARU(164)
32621 C...Coupling to d-type quarks
32622 PARU(171)=-COSA/COSB
32623 C...Coupling to u-type quarks
32624 PARU(172)=-SINA/SINB
32625 C...Coupling to leptons
32626 PARU(173)=PARU(171)
32630 PARU(175)=PARU(174)
32632 IF(IMSS(4).EQ.2) THEN
32633 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
32635 HHH(3)=HHH(3)+HHH(4)+HHH(5)
32636 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
32637 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
32638 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
32639 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
32643 IF(IMSS(4).EQ.2) THEN
32644 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
32646 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
32647 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
32648 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
32649 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
32652 IF(IMSS(4).EQ.2) THEN
32653 PARU(177)=COS(2D0*BE)*COS(BE+AL)
32655 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
32656 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
32657 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
32658 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
32661 IF(IMSS(4).EQ.2) THEN
32662 PARU(178)=PARU(177)
32664 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
32667 C...Coupling to d-type quarks
32669 C...Coupling to u-type quarks
32670 PARU(182)=1D0/PARU(181)
32671 C...Coupling to leptons
32672 PARU(183)=PARU(181)
32675 C...Coupling to Z h
32676 PARU(186)=COS(BE-AL)
32677 C...Coupling to Z H
32678 PARU(187)=SIN(BE-AL)
32684 C...Coupling to W h
32685 PARU(195)=COS(BE-AL)
32687 C...Tell that all Higgs couplings have been set.
32690 C...Set R-Violating couplings.
32691 C...Set lambda couplings to common value or "natural values".
32692 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
32693 VIR3=1D0/(126D0)**3
32697 IF (IRI.NE.IRJ) THEN
32698 IF (IRI.LT.IRJ) THEN
32699 RVLAM(IRI,IRJ,IRK)=RMSS(51)
32700 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
32701 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
32702 & PMAS(9+2*IRK,1)*VIR3)
32704 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
32707 RVLAM(IRI,IRJ,IRK)=0D0
32713 C...Set lambda' couplings to common value or "natural values".
32714 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
32715 VIR3=1D0/(126D0)**3
32719 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
32720 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
32721 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
32722 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
32727 C...Set lambda'' couplings to common value or "natural values".
32728 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
32729 VIR3=1D0/(126D0)**3
32733 IF (IRJ.NE.IRK) THEN
32734 IF (IRJ.LT.IRK) THEN
32735 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
32736 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
32737 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
32738 & PMAS(2*IRK-1,1)*VIR3)
32740 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
32743 RVLAMB(IRI,IRJ,IRK) = 0D0
32750 C...Antisymmetrize couplings set by user
32751 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
32755 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
32756 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
32757 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
32759 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
32760 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
32761 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
32768 C...Second part of routine: set decay modes and branching ratios.
32770 C...Allow chi10 -> gravitino + gamma or not.
32771 KC=PYCOMP(KSUSY1+39)
32772 IF( IMSS(11) .NE. 0 ) THEN
32773 PMAS(KC,1)=RMSS(21)/1000000000D0
32774 PMAS(KC,2)=0.0001D0
32776 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
32777 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
32779 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
32780 & ' ALLOWING SUSY LLE DECAYS'
32781 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
32782 & ' ALLOWING SUSY LQD DECAYS'
32783 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
32784 & ' ALLOWING SUSY UDD DECAYS'
32785 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
32786 & ' --- Warning: R-Violating couplings possibly',
32787 & ' incompatible with proton decay'
32793 C...Loop over sparticle and Higgs species.
32794 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
32795 C...Find the LSP or NLSP for a gravitino LSP
32800 IF(KF.EQ.1000039) GOTO 300
32802 IF(PMAS(KC,1).LT.PMLSP) THEN
32812 C...Sfermion decays.
32814 C...First check to see if sneutrino is lighter than chi10.
32815 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
32816 & PMAS(KC,1).LT.PMCHI1) THEN
32818 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
32822 ELSEIF(I.EQ.25) THEN
32823 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
32824 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
32826 C...Neutralino decays.
32827 ELSEIF(I.GE.26.AND.I.LE.29) THEN
32828 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
32829 C...chi10 stable or chi10 -> gravitino + gamma.
32830 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
32836 C...Chargino decays.
32837 ELSEIF(I.GE.30.AND.I.LE.31) THEN
32838 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
32840 C...Gravitino is stable.
32841 ELSEIF(I.EQ.32) THEN
32846 ELSEIF(I.GE.33.AND.I.LE.36) THEN
32847 C...Calculate decays to non-SUSY particles.
32848 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
32853 DO 330 I1=1,MDCY(KC,3)
32855 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
32856 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
32858 XLAM(0)=XLAM(0)+XLAM(I1)
32860 IDLAM(I1,J1)=KFDP(K1,J1)
32864 C...Add the decays to SUSY particles.
32865 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
32867 C...Zero the branching ratios for use in loop mode
32868 C...thanks to K. Matchev (FNAL)
32869 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
32873 C...Set stable particles.
32881 C...Store branching ratios in the standard tables.
32883 IDC=MDCY(KC,2)+MDCY(KC,3)-1
32889 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
32890 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
32891 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
32892 BRAT(IDC)=XLAM(IL)/XLAM(0)
32894 IF(MDME(IDC,1).GE.1) THEN
32895 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
32896 & PMAS(PYCOMP(KFDP(IDC,2)),1)
32897 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
32898 & PMAS(PYCOMP(KFDP(IDC,3)),1)
32901 IF(XMDIF.GE.0D0) THEN
32902 DELM=MIN(DELM,XMDIF)
32904 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
32905 WRITE(MSTU(11),*) ' KF = ',KF
32906 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
32910 ELSEIF(IDC.EQ.IDCSV) THEN
32911 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
32912 & 'channel not recognized:'
32913 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
32920 C...Store width, cutoff and lifetime.
32922 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
32923 PMAS(KC,3)=PMAS(KC,2)*10D0
32925 PMAS(KC,3)=0.95D0*DELM
32927 IF(PMAS(KC,2).NE.0D0) THEN
32928 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
32936 C*********************************************************************
32939 C...Uses approximate analytical formulae to determine the full set of
32940 C...MSSM parameters from SUGRA input.
32941 C...See M. Drees and S.P. Martin, hep-ph/9504124
32945 C...Double precision and integer declarations.
32946 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32947 IMPLICIT INTEGER(I-N)
32948 INTEGER PYK,PYCHGE,PYCOMP
32949 C...Parameter statement to help give large particle numbers.
32950 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32951 &KEXCIT=4000000,KDIMEN=5000000)
32953 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32954 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32955 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32956 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
32973 SINB=TANB/SQRT(TANB**2+1D0)
32976 DTERM=XMZ2*COS(2D0*BETA)
32977 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
32978 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
32981 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
32982 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
32983 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
32984 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
32986 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
32987 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
32988 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
32989 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
32991 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
32992 IF(XARG.LT.0D0) THEN
32993 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
32994 & ' FROM THE SUM RULE. '
32995 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
33001 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
33002 PMAS(PYCOMP(KSUSY2+I),1)=XMER
33003 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
33004 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
33006 RMT=PYMRUN(6,PMAS(6,1)**2)
33007 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
33008 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
33009 RMB=PYMRUN(5,PMAS(6,1)**2)
33010 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
33011 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
33012 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
33013 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
33016 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
33017 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
33018 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
33019 XMU=SIGN(SQRT(XMU2),RMSS(4))
33021 IF(XMA2.GT.0D0) THEN
33022 RMSS(19)=SQRT(XMA2)
33024 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
33027 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
33028 IF(ARG.GT.0D0) THEN
33031 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
33034 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
33035 IF(ARG.GT.0D0) THEN
33038 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
33041 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
33042 IF(ARG.GT.0D0) THEN
33045 RMSS(10)=-SQRT(-ARG)
33047 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
33048 IF(ARG.GT.0D0) THEN
33051 RMSS(12)=-SQRT(-ARG)
33053 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
33054 IF(ARG.GT.0D0) THEN
33057 RMSS(11)=-SQRT(-ARG)
33063 C*********************************************************************
33066 C...Interface to ISASUSY version 7.61.
33067 C...Warning: if you use earlier versions, change dimension to
33068 C...SUPER(66) in /SSPAR/ and remove MHPNEG and ASM3 from /SUGPAS/.
33069 C...Calls SUGRA (in ISAJET) to perform RGE evolution.
33070 C...Then converts to Gunion-Haber conventions.
33073 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33075 INTEGER PYK,PYCHGE,PYCOMP
33076 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33077 &KEXCIT=4000000,KDIMEN=5000000)
33081 PARAMETER (DOC='22 Nov 2002')
33083 C...ISASUGRA Input:
33084 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
33085 C...ISASUGRA Output
33086 CHARACTER*40 ISAVER,VISAJE
33088 COMMON /SSPAR/ SUPER(69)
33089 COMMON /SUGMG/ MSS(32),GSS(29),MGUTSS,GGUTSS,AGUTSS,FTGUT,
33090 $FBGUT,FTAGUT,FNGUT
33091 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
33092 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
33093 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
33094 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3
33095 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
33096 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
33098 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
33099 C SUPER: Filled by ISASUGRA.
33100 C SUPER(1) = mass of ~g
33101 C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
33102 C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
33103 C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
33105 C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
33106 C SUPER(29) = Higgsino mass = - mu
33107 C SUPER(30) = ratio v2/v1 of vev's
33108 C SUPER(31:34) = Signed neutralino masses
33109 C SUPER(35:50) = Neutralino mixing matrix
33110 C SUPER(51:52) = Signed chargino masses
33111 C SUPER(53:54) = Chargino left, right mixing angles
33112 C SUPER(55:58) = mass of h0, H0, A0, H+
33113 C SUPER(59) = Higgs mixing angle alpha
33114 C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
33115 C SUPER(66) = Gravitino mass
33116 C GSS: Filled by ISASUGRA
33117 C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
33118 C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
33119 C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
33120 C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
33121 C GSS(13) = M_h1^2 GSS(14) = M_h2^2 GSS(15) = M_er^2
33122 C GSS(16) = M_el^2 GSS(17) = M_dnr^2 GSS(18) = M_upr^2
33123 C GSS(19) = M_upl^2 GSS(20) = M_taur^2 GSS(21) = M_taul^2
33124 C GSS(22) = M_btr^2 GSS(23) = M_tpr^2 GSS(24) = M_tpl^2
33125 C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
33126 C GSS(28) = M_nr GSS(29) = A_n
33127 C MSS: Filled by ISASUGRA
33128 C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
33129 C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
33130 C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
33131 C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
33132 C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
33133 C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
33134 C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
33135 C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
33136 C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
33137 C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
33138 C MSS(31) = ha0 MSS(32) = h+
33139 C Unification, filled by ISASUGRA if applicable.
33140 C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
33141 C...SPYTHIA Input/Output:
33143 DOUBLE PRECISION RMSS
33144 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33145 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33146 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33147 SAVE /SUGMG/,/SSPAR/
33149 C...PYTHIA common blocks
33151 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33152 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33153 C...Particle properties + some flavour parameters.
33154 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33155 SAVE /PYDAT2/,/PYSSMT/
33157 C...Start by checking for incompatibilities/inconsistencies:
33159 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
33160 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
33161 & ,' option not used by PYSUGI'
33164 C...ISAJET works with REAL numbers.
33165 MZERO=REAL(RMSS(8))
33167 AZERO=REAL(RMSS(16))
33169 SGNMU=REAL(RMSS(4))
33170 MTOP=REAL(PMAS(6,1))
33171 C...Initialize MSSM parameter array
33176 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,1)
33177 C...Check whether ISASUSY thought the model was OK.
33178 IF (NOGOOD.NE.0) THEN
33179 IF (NOGOOD.EQ.1) CALL PYERRM(26
33180 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
33181 IF (NOGOOD.EQ.2) CALL PYERRM(26
33182 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
33183 IF (NOGOOD.EQ.3) CALL PYERRM(26
33184 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
33185 IF (NOGOOD.EQ.4) CALL PYERRM(26
33186 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
33187 IF (NOGOOD.EQ.7) CALL PYERRM(26
33188 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
33189 IF (NOGOOD.EQ.8) CALL PYERRM(26
33190 & ,'(PYSUGI:) SUSY parameters give m(h0)^2 < 0.')
33191 C...Give warning, but don't stop, if LSP not ~chi_10.
33192 IF (NOGOOD.EQ.5) CALL PYERRM(16
33193 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
33195 C...Warn about possible GUT scale tachyons.
33196 IF (ITACHY.NE.0) CALL PYERRM(16,
33197 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
33204 C...Mu = - Higgsino mass.
33207 C...Slepton and squark masses. 2 first generations.
33208 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
33209 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
33210 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
33211 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
33212 C...Third generation.
33213 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
33218 C...~b, ~t, and ~tau trilinear couplings and mixing angles.
33225 C...Higgs mixing angle alpha (Gunion-Haber convention).
33226 RMSS(18)=-SUPER(59)
33229 C...GUT scale coupling
33231 C...Gravitino mass (for future compatibility)
33234 C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
33236 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
33237 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
33238 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
33239 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
33241 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
33242 C...Squarks and Sleptons.
33245 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
33246 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
33247 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
33248 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
33249 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
33250 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
33251 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
33252 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
33253 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
33255 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
33256 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
33257 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
33259 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
33260 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
33261 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
33262 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
33263 C...Signed masses (extra minus from going to G-H convention).
33269 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
33270 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
33271 C...Signed masses (extra minus from going to G-H convention).
33275 C... Neutralino Mixing.
33277 ZMIX(IN,1)= SUPER(38+4*(IN-1))
33278 ZMIX(IN,2)= SUPER(37+4*(IN-1))
33279 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
33280 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
33282 C...Chargino Mixing (PYTHIA same angle as HERWIG).
33285 IF (SUPER(53).GT.0) THX=-1D0
33286 IF (SUPER(54).GT.0) THY=-1D0
33287 UMIX(1,1) = -SIN(SUPER(53))
33288 UMIX(1,2) = -COS(SUPER(53))
33289 UMIX(2,1) = -THX*COS(SUPER(53))
33290 UMIX(2,2) = THX*SIN(SUPER(53))
33291 VMIX(1,1) = -SIN(SUPER(54))
33292 VMIX(1,2) = -COS(SUPER(54))
33293 VMIX(2,1) = -THY*COS(SUPER(54))
33294 VMIX(2,2) = THY*SIN(SUPER(54))
33295 C...Sfermion mixing (PYTHIA same angle as ISAJET)
33296 SFMIX(5,1)=COS(SUPER(63))
33297 SFMIX(5,2)=SIN(SUPER(63))
33298 SFMIX(5,3)=-SIN(SUPER(63))
33299 SFMIX(5,4)=COS(SUPER(63))
33300 SFMIX(6,1)=COS(SUPER(61))
33301 SFMIX(6,2)=SIN(SUPER(61))
33302 SFMIX(6,3)=-SIN(SUPER(61))
33303 SFMIX(6,4)=COS(SUPER(61))
33304 SFMIX(15,1)=COS(SUPER(65))
33305 SFMIX(15,2)=SIN(SUPER(65))
33306 SFMIX(15,3)=-SIN(SUPER(65))
33307 SFMIX(15,4)=COS(SUPER(65))
33309 IF (MSTP(122).NE.0) THEN
33310 C...Print a few lines to make the user know what's happening
33312 WRITE(MSTU(11),5000) DOC, ISAVER
33313 WRITE(MSTU(11),5100)
33314 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU), MTOP
33315 WRITE(MSTU(11),5300)
33316 WRITE(MSTU(11),5500) 'EW scale masses'
33317 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
33318 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
33319 & ,(SUPER(IP),IP=19,25,2)
33320 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
33322 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
33323 WRITE(MSTU(11),5400)
33324 WRITE(MSTU(11),5500) 'Mixing structure'
33325 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
33326 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
33327 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
33328 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
33329 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
33330 & ),(SFMIX(15,J),J=3,4)
33331 WRITE(MSTU(11),5400)
33332 WRITE(MSTU(11),5500) 'Couplings'
33333 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
33334 WRITE(MSTU(11),5400)
33335 WRITE(MSTU(11),6500)
33338 C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
33339 C...output by ISASUGRA.
33342 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.1: PYTHIA/ISASUGRA '
33343 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
33344 & ,1x,'-',1x,'P.Z. Skands'/1x,'*',2x,A/1x,'*')
33345 5100 FORMAT(1x,'*',1x,'ISASUGRA Input:'/1x,'*',1x,'----------------')
33346 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
33347 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
33348 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUGRA Output:'/1x,'*',1x
33349 & ,'----------------')
33350 5400 FORMAT(1x,'*',1x,A)
33351 5500 FORMAT(1x,'*',1x,A,':')
33352 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
33353 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
33354 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
33355 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
33356 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
33358 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
33359 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
33360 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
33362 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
33363 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
33364 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
33365 6000 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
33366 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
33367 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
33368 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
33369 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
33370 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
33371 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
33372 & ,1x,F6.3,1x),'|')
33373 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
33374 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
33375 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
33376 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
33377 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
33378 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
33379 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
33380 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
33381 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
33382 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
33383 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
33384 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
33385 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
33386 & ,4x,'Alpha_GUT = ',F8.2)
33387 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
33390 C*********************************************************************
33393 C...Determines the running mass of Squarks.
33395 FUNCTION PYRNMQ(ID,DTERM)
33397 C...Double precision and integer declarations.
33398 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33399 IMPLICIT INTEGER(I-N)
33400 INTEGER PYK,PYCHGE,PYCOMP
33402 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33405 C...Local variables.
33406 DOUBLE PRECISION PI,R
33407 DOUBLE PRECISION TOL
33408 DOUBLE PRECISION CI(3)
33410 DOUBLE PRECISION PYALPS
33412 DATA PI,R/3.141592654D0,.61803399D0/
33413 DATA CI/0.47D0,0.07D0,0.02D0/
33417 AG=(0.71D0)**2/4D0/PI
33424 AS=PYALPS(XM02+6D0*XMG2)
33425 CG=8D0/9D0*((AS/AG)**2-1D0)
33426 BX=XM02+(CA+CG)*XMG2+DTERM
33427 AX=MIN(50D0**2,0.5D0*BX)
33428 CX=MAX(2000D0**2,2D0*BX)
33432 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
33440 CG=8D0/9D0*((AS1/AG)**2-1D0)
33441 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
33443 CG=8D0/9D0*((AS2/AG)**2-1D0)
33444 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
33445 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
33452 CG=8D0/9D0*((AS2/AG)**2-1D0)
33453 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
33460 CG=8D0/9D0*((AS1/AG)**2-1D0)
33461 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
33476 C*********************************************************************
33479 C...Calculates the mass eigenstates of the third generation sfermions.
33480 C...Created: 5-31-96
33484 C...Double precision and integer declarations.
33485 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33486 IMPLICIT INTEGER(I-N)
33487 INTEGER PYK,PYCHGE,PYCOMP
33488 C...Parameter statement to help give large particle numbers.
33489 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33490 &KEXCIT=4000000,KDIMEN=5000000)
33492 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33493 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33494 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33495 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33496 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33497 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
33499 C...Local variables.
33500 DOUBLE PRECISION BETA
33501 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
33502 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
33503 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
33504 DOUBLE PRECISION ATR,AMQR,AMQL
33505 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
33506 INTEGER IF,I,J,II,JJ,IT,L
33520 COS2B=COS(2D0*BETA)
33522 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
33532 XMQL2=CTT2*XM12+STT2*XM22
33533 XMQR2=STT2*XM12+CTT2*XM22
33534 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
33535 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
33537 C......SUBTRACT OUT D-TERM AND FERMION MASS
33538 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
33539 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
33540 IF(XMQL2.GE.0D0) THEN
33541 RMSS(10)=SQRT(XMQL2)
33543 RMSS(10)=-SQRT(-XMQL2)
33545 IF(XMQR2.GE.0D0) THEN
33546 RMSS(12)=SQRT(XMQR2)
33548 RMSS(12)=-SQRT(-XMQR2)
33551 C SAME FOR BOTTOM SQUARK
33557 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
33558 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
33559 IF(ABS(CTT).GE..9999D0) THEN
33562 ELSEIF(ABS(CTT).LE.1D-4) THEN
33566 XM12=(XMQL2-STT2*XM22)/CTT2
33567 XMQR2=STT2*XM12+CTT2*XM22
33568 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
33571 C......SUBTRACT OUT D-TERM AND FERMION MASS
33572 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
33573 IF(XMQR2.GE.0D0) THEN
33574 RMSS(11)=SQRT(XMQR2)
33576 RMSS(11)=-SQRT(-XMQR2)
33578 C SAME FOR TAU SLEPTON
33585 XMQL2=CTT2*XM12+STT2*XM22
33586 XMQR2=STT2*XM12+CTT2*XM22
33589 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
33591 C......SUBTRACT OUT D-TERM AND FERMION MASS
33592 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
33593 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
33594 IF(XMQL2.GE.0D0) THEN
33595 RMSS(13)=SQRT(XMQL2)
33597 RMSS(13)=-SQRT(-XMQL2)
33599 IF(XMQR2.GE.0D0) THEN
33600 RMSS(14)=SQRT(XMQR2)
33602 RMSS(14)=-SQRT(-XMQR2)
33607 IF(AMQL.LT.0D0) THEN
33614 IF(AMQR.LT.0D0) THEN
33620 XMF=PYMRUN(IF,PMAS(6,1)**2)
33622 AM2(1,1)=XMQL2+XMF2
33623 AM2(2,2)=XMQR2+XMF2
33624 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
33627 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
33628 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
33629 AM2(1,2)=XMF*(ATR+XMU*TANB)
33630 ELSEIF(L.EQ.2) THEN
33631 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
33632 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
33633 AM2(1,2)=XMF*(ATR+XMU/TANB)
33634 ELSEIF(L.EQ.3) THEN
33635 IF(IMSS(8).EQ.1) THEN
33636 AM2(1,1)=RMSS(6)**2
33637 AM2(2,2)=RMSS(7)**2
33642 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
33643 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
33644 AM2(1,2)=XMF*(ATR+XMU*TANB)
33649 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
33650 IF(DETM.LT.0D0) THEN
33651 WRITE(MSTU(11),*) ID2(L),DETM,AM2
33652 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
33654 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
33655 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
33659 IF(XMF22-XMF12.GT.0D0) THEN
33660 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
33662 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
33663 & AM2(1,2)/(XMF22-XMF12))
33679 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
33685 IF(DI(1,1).GT.DI(2,2)) THEN
33686 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
33687 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
33688 WRITE(MSTU(11),*) AM2
33689 WRITE(MSTU(11),*) DI
33690 WRITE(MSTU(11),*) RT
33701 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
33702 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
33703 & ' OFF DIAGONAL ELEMENTS '
33704 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
33705 WRITE(MSTU(11),*) DI
33706 WRITE(MSTU(11),*) ' ROTATION = ',RT
33708 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
33709 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
33710 & ' NEGATIVE MASSES '
33713 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
33714 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
33715 SFMIX(IF,1)=RT(1,1)
33716 SFMIX(IF,2)=RT(1,2)
33717 SFMIX(IF,3)=RT(2,1)
33718 SFMIX(IF,4)=RT(2,2)
33721 C.....TAU SNEUTRINO MASS...L=3
33723 XARG=AM2(1,1)+XMW2*COS2B
33724 IF(XARG.LT.0D0) THEN
33725 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
33726 & ' FROM THE SUM RULE. '
33727 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
33730 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
33736 C*********************************************************************
33739 C...Finds the mass eigenstates and mixing matrices for neutralinos
33744 C...Double precision and integer declarations.
33745 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33746 IMPLICIT INTEGER(I-N)
33748 C...Parameter statement to help give large particle numbers.
33749 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33750 &KEXCIT=4000000,KDIMEN=5000000)
33752 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33753 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33754 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33755 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33756 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33757 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
33759 C...Local variables.
33760 DOUBLE PRECISION XMW,XMZ,XM(4)
33761 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),AI(4,4)
33762 DOUBLE PRECISION WI(4),FV1(4),FV2(4),FV3(4)
33763 DOUBLE PRECISION COSW,SINW
33764 DOUBLE PRECISION XMU
33765 DOUBLE PRECISION TANB,COSB,SINB
33766 DOUBLE PRECISION XM1,XM2,XM3,BETA
33767 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
33768 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
33769 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
33770 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
33771 DOUBLE PRECISION PYALPS,PYALEM
33772 DOUBLE PRECISION PYRNM3
33773 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
33774 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
33775 DATA KFNCHI/1000022,1000023,1000025,1000035/
33778 IF(IMSS(1).EQ.2) THEN
33781 C...M1, M2, AND M3 ARE INDEPENDENT
33786 ELSEIF(IOPT.GE.1) THEN
33790 A1=AEM/(1D0-PARU(102))
33793 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
33795 XM2=XM1*A2/A1*3D0/5D0
33797 ELSEIF(IOPT.EQ.3) THEN
33798 XM1=XM2*5D0/3D0*A1/A2
33803 IF(XM3.LE.0D0) THEN
33804 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
33810 IF(IMSS(3).EQ.1) THEN
33811 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
33816 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
33817 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
33818 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
33824 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
33825 RM2=PMAS(I,1)**2/XM3**2
33826 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
33827 IF(ARG.GE.0D0) THEN
33828 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
33830 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
33835 ELSEIF(X0.EQ.0D0) THEN
33839 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
33840 & 0.5D0*X0**2*LOG(AX0)
33841 BT=(-1D0-2D0*X0)/4D0
33846 ELSEIF(X1.EQ.0D0) THEN
33850 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
33851 & X1**2*LOG(AX1)+AT
33852 BT=(-1D0-2D0*X1)/4D0+BT
33856 X0=0.5D0*(1D0+RM2-RM1)
33857 Y0=-0.5D0*SQRT(-ARG)
33858 AMGX0=SQRT(X0**2+Y0**2)
33859 AM1X0=SQRT((1D0-X0)**2+Y0**2)
33860 ARGX0=ATAN2(-X0,-Y0)
33861 AR1X0=ATAN2(1D0-X0,Y0)
33866 ARGX1=ATAN2(-X1,-Y1)
33867 AR1X1=ATAN2(1D0-X1,Y1)
33868 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
33869 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
33870 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
33871 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
33872 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
33873 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
33878 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
33879 & /(2D0*PARU(2))*(15D0+AQ))
33882 C...NEUTRALINO MASSES
33891 SINW=SQRT(PARU(102))
33892 COSW=SQRT(1D0-PARU(102))
33899 C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
33900 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
33901 AR(1,1) = XM1*COS(RMSS(30))
33902 AI(1,1) = XM1*SIN(RMSS(30))
33903 AR(2,2) = XM2*COS(RMSS(31))
33904 AI(2,2) = XM2*SIN(RMSS(31))
33909 AR(1,3) = -XMZ*SINW*COSB
33911 AR(1,4) = XMZ*SINW*SINB
33913 AR(2,3) = XMZ*COSW*COSB
33915 AR(2,4) = -XMZ*COSW*SINB
33917 AR(3,4) = -XMU*COS(RMSS(33))
33918 AI(3,4) = -XMU*SIN(RMSS(33))
33919 AR(4,3) = -XMU*COS(RMSS(33))
33920 AI(4,3) = -XMU*SIN(RMSS(33))
33921 C CALL PYEIG4(AR,WR,ZR)
33922 CALL PYEICG(4,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
33924 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
33933 IF(XM(K).LT.XM(J)) THEN
33951 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
33954 S=S+ZR(J,K)**2+ZI(J,K)**2
33957 ZMIX(I,J)=ZR(J,K)/SQRT(S)
33958 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
33959 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
33960 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
33964 C...CHARGINO MASSES
33965 C.....Find eigenvectors of X X^*
33968 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
33969 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
33970 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
33971 &XMU*COS(RMSS(33))*SINB)
33972 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
33973 &XMU*SIN(RMSS(33))*SINB)
33974 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
33975 &XMU*COS(RMSS(33))*SINB)
33976 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
33977 &XMU*SIN(RMSS(33))*SINB)
33978 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
33980 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
33984 IF(WR(2).LT.WR(1)) THEN
33994 S=S+ZR(J,K)**2+ZI(J,K)**2
33997 UMIX(I,J)=ZR(J,K)/SQRT(S)
33998 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
33999 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
34000 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
34003 IF(ABS(SMW(1)).LT.ABS(SMZ(1))) THEN
34004 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
34006 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
34007 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
34009 C.....Find eigenvectors of X^* X
34012 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
34013 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
34014 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
34015 &XMU*COS(RMSS(33))*COSB)
34016 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
34017 &XMU*SIN(RMSS(33))*COSB)
34018 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
34019 &XMU*COS(RMSS(33))*COSB)
34020 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
34021 &XMU*SIN(RMSS(33))*COSB)
34022 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
34024 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
34028 IF(WR(2).LT.WR(1)) THEN
34037 S=S+ZR(J,K)**2+ZI(J,K)**2
34040 VMIX(I,J)=ZR(J,K)/SQRT(S)
34041 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
34042 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
34043 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
34051 C*********************************************************************
34054 C...Calculates the running of M3, the SU(3) gluino mass parameter.
34056 FUNCTION PYRNM3(RGUT)
34058 C...Double precision and integer declarations.
34059 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34060 IMPLICIT INTEGER(I-N)
34061 INTEGER PYK,PYCHGE,PYCOMP
34063 C...Local variables.
34065 DOUBLE PRECISION TOL
34067 DOUBLE PRECISION PYALPS
34069 DATA R/0.61803399D0/
34073 BX=RGUT*PYALPS(RGUT**2)
34074 AX=MIN(50D0,BX*0.5D0)
34075 CX=MAX(2000D0,2D0*BX)
34079 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
34087 F1=ABS(X1-RGUT*AS1)
34089 F2=ABS(X2-RGUT*AS2)
34090 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
34097 F2=ABS(X2-RGUT*AS2)
34104 F1=ABS(X1-RGUT*AS1)
34119 C*********************************************************************
34122 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
34123 C...Specific application: mixing in neutralino sector.
34125 SUBROUTINE PYEIG4(A,W,Z)
34127 C...Double precision and integer declarations.
34128 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34129 IMPLICIT INTEGER(I-N)
34130 INTEGER PYK,PYCHGE,PYCOMP
34132 C...Arrays: in call and local.
34133 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
34135 C...Coefficients of fourth-degree equation from matrix.
34136 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
34137 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
34141 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
34150 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
34151 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
34152 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
34153 B0=B0+(-1D0)**(I+1)*A(1,I)*(
34154 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
34155 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
34156 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
34159 C...Coefficients of third-degree equation needed for
34160 C...separation into two second-degree equations.
34161 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
34164 C0=-B1**2-B0*B3**2+4D0*B0*B2
34165 CQ=C1/3D0-C2**2/9D0
34166 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
34169 C...Cases with one or three real roots.
34170 IF(CQR.GE.0D0) THEN
34171 S1=(CR+SQRT(CQR))**(1D0/3D0)
34172 S2=(CR-SQRT(CQR))**(1D0/3D0)
34176 THE=ACOS(CR/SABS**3)/3D0
34181 C...Find and solve two second-degree equations.
34182 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
34183 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
34184 Q1=U/2D0+SQRT(U**2/4D0-B0)
34185 Q2=U/2D0-SQRT(U**2/4D0-B0)
34186 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
34191 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
34192 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
34193 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
34194 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
34196 C...Order eigenvalues in asceding mass.
34199 DO 130 I2=I1-1,1,-1
34200 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
34206 C...Find equation system for eigenvectors.
34209 D(J1,J1)=A(J1,J1)-W(I)
34216 C...Find largest element in matrix.
34220 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
34223 DAMAX=ABS(D(J1,J2))
34227 C...Subtract others by multiple of row selected above.
34229 DO 210 J3=JA+1,JA+3
34231 RL=D(J1,JB)/D(JA,JB)
34233 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
34234 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
34237 DAMAX=ABS(D(J1,J2))
34241 C...Do one more subtraction of a row.
34243 DO 230 J3=JC+1,JC+3
34245 IF(J1.EQ.JA) GOTO 230
34246 RL=D(J1,JD)/D(JC,JD)
34248 IF(J2.EQ.JB) GOTO 220
34249 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
34250 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
34252 DAMAX=ABS(D(J1,J2))
34256 C...Construct unnormalized eigenvector.
34258 JF2=JD+2-4*((JD+1)/4)
34259 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
34260 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
34263 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
34264 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
34267 C...Normalize and fill in final array.
34268 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
34269 SGN=(-1D0)**INT(PYR(0)+0.5D0)
34278 C*********************************************************************
34281 C...Determines the Higgs boson mass spectrum using several inputs.
34283 SUBROUTINE PYHGGM(ALPHA)
34285 C...Double precision and integer declarations.
34286 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34287 IMPLICIT INTEGER(I-N)
34288 INTEGER PYK,PYCHGE,PYCOMP
34289 C...Parameter statement to help give large particle numbers.
34290 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34291 &KEXCIT=4000000,KDIMEN=5000000)
34293 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34294 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34295 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34296 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34297 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
34299 C...Local variables.
34300 DOUBLE PRECISION AT,AB,XMU,TANB
34301 DOUBLE PRECISION ALPHA
34303 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
34304 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
34305 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
34306 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
34309 IF(IHOPT.EQ.2) THEN
34325 DMC=PMAS(PYCOMP(KSUSY1+37),1)
34332 IF(IHOPT.EQ.0) THEN
34333 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
34334 & DMHCH,DSA,DCA,DTANBA)
34335 ELSEIF(IHOPT.EQ.1) THEN
34336 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
34337 & DMHCH,DSA,DCA,DTANBA)
34338 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
34339 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
34340 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
34346 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
34347 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
34348 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
34349 & PMAS(PYCOMP(1000006),1),DSTOP2
34351 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
34352 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
34353 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
34354 & PMAS(PYCOMP(2000006),1),DSTOP1
34356 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
34357 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
34358 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
34359 & PMAS(PYCOMP(1000005),1),DSBOT2
34361 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
34362 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
34363 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
34364 & PMAS(PYCOMP(2000005),1),DSBOT1
34379 C*********************************************************************
34382 C...This routine computes the renormalization group improved
34383 C...values of Higgs masses and couplings in the MSSM.
34385 C...Program based on the work by M. Carena, J.R. Espinosa,
34386 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
34388 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
34389 C...All masses in GeV units. MA is the CP-odd Higgs mass,
34390 C...MTOP is the physical top mass, MQ and MUR are the soft
34391 C...supersymmetry breaking mass parameters of left handed
34392 C...and right handed stops respectively, AU and AD are the
34393 C...stop and sbottom trilinear soft breaking terms,
34394 C...respectively, and MU is the supersymmetric
34395 C...Higgs mass parameter. We use the conventions from
34396 C...the physics report of Haber and Kane: left right
34397 C...stop mixing term proportional to (AU - MU/TANB)
34398 C...We use as input TANB defined at the scale MTOP
34400 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
34401 C...where MH and HM are the lightest and heaviest CP-even
34402 C...Higgs masses, MHCH is the charged Higgs mass and
34403 C...ALPHA is the Higgs mixing angle
34404 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
34406 C...Range of validity:
34407 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
34408 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
34409 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
34410 C...are the sbottom mass eigenvalues, respectively. This
34411 C...range automatically excludes the existence of tachyons.
34412 C...For the charged Higgs mass computation, the method is
34414 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
34415 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
34416 C...where M_SUSY**2 is the average of the squared stop mass
34417 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
34418 C...masses have been assumed to be of order of the stop ones
34419 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
34421 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
34422 &XMHCH,SA,CA,TANBA)
34424 C...Double precision and integer declarations.
34425 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34426 IMPLICIT INTEGER(I-N)
34427 INTEGER PYK,PYCHGE,PYCOMP
34428 C...Parameter statement to help give large particle numbers.
34429 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34430 &KEXCIT=4000000,KDIMEN=5000000)
34432 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34433 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34434 COMMON/PYHTRI/HHH(7)
34435 SAVE /PYDAT1/,/PYDAT2/
34437 C...Local variables.
34438 DOUBLE PRECISION PYALEM,PYALPS
34439 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
34440 DOUBLE PRECISION XMHCH,SA,CA
34441 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
34442 DOUBLE PRECISION Q02
34443 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
34444 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
34445 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
34446 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
34447 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
34448 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
34449 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
34450 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
34455 ALP1=AEM/(1D0-PARU(102))
34468 C...MBOTTOM(MTOP) = 3. GEV
34469 XMB = PYMRUN(5,XMTOP**2)
34470 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
34471 &LOG(XMTOP**2/XMZ**2))
34473 C...RMTOP= RUNNING TOP QUARK MASS
34474 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
34475 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
34476 T = LOG(XMS**2/XMTOP**2)
34477 SINB = TANB/((1D0 + TANB**2)**0.5D0)
34479 C...IF(MA.LE.XMTOP) TANBA = TANBT
34481 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
34482 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
34483 &LOG(XMA**2/XMTOP**2))
34485 SINBT = TANBT/SQRT(1D0 + TANBT**2)
34486 COSBT = 1D0/SQRT(1D0 + TANBT**2)
34487 C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
34488 G1 = SQRT(ALP1*4D0*PI)
34489 G2 = SQRT(ALP2*4D0*PI)
34490 G3 = SQRT(ALP3*4D0*PI)
34505 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
34506 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
34507 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
34508 &+ 3D0*(AU + AD)**2/XMS2)/6D0
34509 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
34510 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
34511 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
34512 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
34513 &- 16D0*G3**2) *T/16D0/PI2)
34514 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
34515 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
34516 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
34517 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
34518 &- 16D0*G3**2) *T/16D0/PI2)
34519 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
34520 &(HU2 + HD2)*T/16D0/PI2)
34521 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
34522 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
34523 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
34524 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
34525 &- 16D0*G3**2) *T/16D0/PI2)
34526 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
34527 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
34528 &- 16D0*G3**2) *T/16D0/PI2)
34529 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
34530 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
34531 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
34532 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
34534 &(1+ (6D0*HU2 -2D0* HD2
34535 &- 16D0*G3**2) *T/16D0/PI2)
34536 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
34538 &(1+ (6D0*HD2 -2D0* HU2/2D0
34539 &- 16D0*G3**2) *T/16D0/PI2)
34540 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
34541 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
34542 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
34543 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
34544 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
34545 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34546 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
34547 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34548 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
34549 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34550 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
34551 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
34559 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
34560 &2D0* XLAM6*SINBT*COSBT
34561 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
34563 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
34565 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
34566 &2D0* XLAM6* COSBT*SINBT
34567 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
34568 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
34569 &((XLAM1* COSBT**2 +2D0*
34570 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
34571 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
34573 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
34574 &+ XLAM4) + XLAM6*COSBT**2
34575 &+ XLAM7* SINBT**2))
34577 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
34578 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
34581 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
34582 XMHCH = SQRT(XMHCH2)
34584 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
34585 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
34586 &XLAM6* COSBT*SINBT
34587 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
34588 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
34589 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
34590 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
34592 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
34593 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
34594 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
34595 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
34596 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
34597 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
34598 &XLAM6* COSBT*SINBT
34599 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
34600 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
34601 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
34611 C*********************************************************************
34614 C...This subroutine computes the CP-even higgs and CP-odd pole
34615 c...Higgs masses and mixing angles.
34617 C...Program based on the work by M. Carena, M. Quiros
34618 C...and C.E.M. Wagner, "Effective potential methods and
34619 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
34621 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
34623 C...where MCHI is the largest chargino mass, MA is the running
34624 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
34625 C...expectaion values at the scale MTOP, MQ is the third generation
34626 C...left handed squark mass parameter, MUR is the third generation
34627 C...right handed stop mass parameter, MDR is the third generation
34628 C...right handed sbottom mass parameter, MTOP is the pole top quark
34629 C...mass; AT,AB are the soft supersymmetry breaking trilinear
34630 C...couplings of the stop and sbottoms, respectively, and MU is the
34631 C...supersymmetric mass parameter
34633 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
34634 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
34635 C...masses are given, what makes the running of the program
34636 c...much faster and it is quite generally a good approximation
34637 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
34638 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
34639 c...and if IHIGGS=3, then h,H,A polarizations are computed
34641 C...Output: MH and MHP which are the lightest CP-even Higgs running
34642 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
34643 C...Higgs running and pole masses, repectively; SA and CA are the
34644 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
34645 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
34646 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
34647 C...the value of TANB at the CP-odd Higgs mass scale
34649 C...This subroutine makes use of CERN library subroutine
34650 C...integration package, which makes the computation of the
34651 C...pole Higgs masses somewhat faster. We thank P. Janot for this
34652 C...improvement. Those who are not able to call the CERN
34653 C...libraries, please use the subroutine SUBHPOLE2.F, which
34654 C...although somewhat slower, gives identical results
34656 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
34657 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
34659 C...Double precision and integer declarations.
34660 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34661 IMPLICIT INTEGER(I-N)
34664 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34666 INTEGER PYK,PYCHGE,PYCOMP
34668 C...Local variables.
34669 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
34670 &SSBOT2(2),B(2,2),COUPB(2,2),
34671 &HCOUPT(2,2),HCOUPB(2,2),
34672 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
34681 RXMT=PYMRUN(6,XMT**2)
34682 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
34683 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
34685 SINB = TANB/(TANB**2+1D0)**0.5D0
34686 COSB = 1D0/(TANB**2+1D0)**0.5D0
34687 COS2B = SINB**2 - COSB**2
34688 SINBPA = SINB*CA + COSB*SA
34689 COSBPA = COSB*CA - SINB*SA
34690 RMBOT = PYMRUN(5,XMT**2)
34693 IF(XMUR.LT.0D0) XMUR2=-XMUR2
34695 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
34696 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
34697 IF(XMST11.LT.0D0) GOTO 500
34698 IF(XMST22.LT.0D0) GOTO 500
34699 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
34700 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
34701 IF(XMSB11.LT.0D0) GOTO 500
34702 IF(XMSB22.LT.0D0) GOTO 500
34703 C WMST11 = RXMT**2 + XMQ2
34704 C WMST22 = RXMT**2 + XMUR2
34705 XMST12 = RXMT*(AT - XMU/TANB)
34706 XMSB12 = RMBOT*(AB - XMU*TANB)
34708 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34709 C...STOP EIGENVALUES CALCULATION
34710 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34712 STOP12 = 0.5D0*(XMST11+XMST22) +
34713 &0.5D0*((XMST11+XMST22)**2 -
34714 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
34715 STOP22 = 0.5D0*(XMST11+XMST22) -
34716 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
34717 &XMST12**2))**0.5D0
34719 IF(STOP22.LT.0D0) GOTO 500
34722 STOP1 = STOP12**0.5D0
34723 STOP2 = STOP22**0.5D0
34727 IF(XMST12.EQ.0D0) XST11 = 1D0
34728 IF(XMST12.EQ.0D0) XST12 = 0D0
34729 IF(XMST12.EQ.0D0) XST21 = 0D0
34730 IF(XMST12.EQ.0D0) XST22 = 1D0
34732 IF(XMST12.EQ.0D0) GOTO 110
34734 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
34735 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
34736 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
34737 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
34744 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
34745 &0.5D0*((XMSB11+XMSB22)**2 -
34746 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
34747 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
34748 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
34749 &XMSB12**2))**0.5D0
34750 IF(SBOT22.LT.0D0) GOTO 500
34751 SBOT1 = SBOT12**0.5D0
34752 SBOT2 = SBOT22**0.5D0
34757 IF(XMSB12.EQ.0D0) XSB11 = 1D0
34758 IF(XMSB12.EQ.0D0) XSB12 = 0D0
34759 IF(XMSB12.EQ.0D0) XSB21 = 0D0
34760 IF(XMSB12.EQ.0D0) XSB22 = 1D0
34762 IF(XMSB12.EQ.0D0) GOTO 130
34764 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
34765 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
34766 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
34767 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
34779 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34780 C...STARTING OF LIGHT HIGGS
34781 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34783 IF(IHIGGS.EQ.0) GOTO 490
34788 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
34789 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
34790 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
34791 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
34800 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
34801 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
34802 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
34803 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
34811 180 ITER = ITER + 1
34814 PR(I3)=PRUN+(I3-2)*EPS/2
34819 POLT = POLT + COUPT(I,J)**2*3D0*
34820 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
34827 POLB = POLB + COUPB(I,J)**2*3D0*
34828 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
34835 & 3D0*RXMT**2/8D0/PI**2/ V **2*
34837 & (-2D0*XMT**2+0.5D0*P2)*
34838 & PYFINT(P2,XMT2,XMT2)
34840 POL = POLT + POLB + POLTT
34841 POLAR(I3) = P2 - XMH**2 - POL
34843 DERIV = (POLAR(3)-POLAR(1))/EPS
34844 DRUN = - POLAR(2)/DERIV
34847 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
34853 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34854 C...END OF LIGHT HIGGS
34855 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34857 250 IF(IHIGGS.EQ.1) GOTO 490
34859 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34860 C... STARTING OF HEAVY HIGGS
34861 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34866 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
34867 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
34868 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
34869 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
34877 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
34878 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
34879 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
34880 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
34889 300 ITER = ITER + 1
34891 PR(I3)=PRUN+(I3-2)*EPS/2
34897 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
34898 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
34905 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
34906 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
34914 & 3D0*RXMT**2/8D0/PI**2/ V **2*
34916 & (-2D0*XMT**2+0.5D0*HP2)*
34917 & PYFINT(HP2,XMT2,XMT2)
34919 HPOL = HPOLT + HPOLB + HPOLTT
34920 POLAR(I3) =HP2-HM**2-HPOL
34922 DERIV = (POLAR(3)-POLAR(1))/EPS
34923 DRUN = - POLAR(2)/DERIV
34926 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
34934 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34935 C... END OF HEAVY HIGGS
34936 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34938 IF(IHIGGS.EQ.2) GOTO 490
34940 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34941 C...BEGINNING OF PSEUDOSCALAR HIGGS
34942 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
34947 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
34948 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
34954 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
34955 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
34962 420 ITER = ITER + 1
34964 PR(I3)=PRUN+(I3-2)*EPS/2
34969 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
34970 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
34976 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
34977 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
34983 & 3D0*RXMT**2/8D0/PI**2/ V **2*
34984 & COSB**2/SINB**2 *
34986 & PYFINT(AP2,XMT2,XMT2)
34987 APOL = APOLT + APOLB + APOLTT
34988 POLAR(I3) = AP2 - XMA**2 -APOL
34990 DERIV = (POLAR(3)-POLAR(1))/EPS
34991 DRUN = - POLAR(2)/DERIV
34994 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
35000 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35001 C...END OF PSEUDOSCALAR HIGGS
35002 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35004 IF(IHIGGS.EQ.3) GOTO 490
35009 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
35010 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
35011 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
35012 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
35016 C*********************************************************************
35019 C...Auxiliary to PYPOLE.
35021 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
35022 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
35023 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
35024 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
35027 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35038 C MBOTTOM(MTOP) = 3. GEV
35039 MB = PYMRUN(5,MTOP**2)
35040 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
35041 *LOG(MTOP**2/MZ**2))
35042 C RMTOP= RUNNING TOP QUARK MASS
35043 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
35044 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
35045 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
35046 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
35047 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35049 C NEW DEFINITION, TGLU.
35051 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35052 TGLU = LOG(MGLU**2/MTOP**2)
35053 SINB = TANB/DSQRT(1D0 + TANB**2)
35056 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
35057 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
35058 *LOG(MA**2/MTOP**2))
35059 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
35060 SINB = TANBT/SQRT(1D0 + TANBT**2)
35061 COSB = 1D0/DSQRT(1D0 + TANBT**2)
35062 G1 = SQRT(ALPHA1*4D0*PI)
35063 G2 = SQRT(ALPHA2*4D0*PI)
35064 G3 = SQRT(ALPHA3*4D0*PI)
35067 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
35068 *SBOT1,SBOT2,DELTAMT,DELTAMB)
35069 IF(MQ.GT.MUR) TP = TQ - TU
35070 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
35071 IF(MQ.GT.MUR) TDP = TU
35072 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
35073 IF(MQ.GT.MD) TPD = TQ - TD
35074 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
35075 IF(MQ.GT.MD) TDPD = TD
35076 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
35078 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
35079 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
35080 * HD**2*(G1**2/3D0+G2**2)*TPD
35082 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
35083 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
35084 * HU**2*(-G1**2/3D0+G2**2)*TP
35086 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35088 C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
35089 C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
35090 C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
35094 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35097 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
35098 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
35099 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
35102 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
35103 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
35106 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
35107 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
35110 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
35111 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
35114 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
35115 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
35118 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
35119 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
35124 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
35125 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
35126 *(G2**2-G1**2/3D0)*TPD
35127 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
35128 *1D0/16D0/PI**2*G1**2*HU**2*TP
35129 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
35130 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
35131 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
35132 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
35134 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
35135 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
35136 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
35137 *+ (3D0*HD**2/2D0 + HU**2/2D0
35138 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
35139 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
35140 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
35141 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
35142 *(TP + TDP)/8D0/PI**2)
35143 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
35144 *+ (3D0*HU**2/2D0 + HD**2/2D0
35145 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
35146 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
35147 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
35148 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
35149 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
35150 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
35151 LAMBDA4 = (- G2**2/2D0)*(1D0
35152 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
35153 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
35159 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
35160 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
35162 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
35163 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
35164 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
35165 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
35168 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35169 CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
35170 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35172 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
35174 IF(MCHI.GT.MSSUSY) GOTO 100
35175 IF(MCHI.LT.MTOP) MCHI=MTOP
35177 TCHAR=LOG(MSSUSY**2/MCHI**2)
35179 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
35180 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
35181 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
35183 DELTAM112=2D0*DELTAL12*V**2*COSB**2
35184 DELTAM222=2D0*DELTAL12*V**2*SINB**2
35185 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
35187 M2(1,1)=M2(1,1)+DELTAM112
35188 M2(2,2)=M2(2,2)+DELTAM222
35189 M2(1,2)=M2(1,2)+DELTAM122
35190 M2(2,1)=M2(2,1)+DELTAM122
35194 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35195 CCC END OF CHARGINOS/NEUTRALINOS
35196 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35200 M2P(I,J) = M2(I,J) + VH(I,J)
35203 TRM2P = M2P(1,1) + M2P(2,2)
35204 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
35205 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
35206 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
35208 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
35210 IF(MH2P.LT.0.) GOTO 130
35212 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
35213 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
35214 IF(COS2ALPHA.GE.0.) THEN
35215 ALPHA = ASIN(SIN2ALPHA)/2D0
35217 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
35221 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35223 C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
35224 C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
35225 C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
35228 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35229 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
35230 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
35235 C*********************************************************************
35238 C...Auxiliary to PYRGHM.
35240 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
35241 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
35242 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
35243 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
35245 INTEGER MSTU,MSTJ,KCHG
35246 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35247 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35248 SAVE /PYDAT1/,/PYDAT2/
35250 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
35252 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
35253 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
35255 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
35260 SINBA = TANBA/DSQRT(TANBA**2+1D0)
35261 COSBA = SINBA/TANBA
35263 SINB = TANB/DSQRT(TANB**2+1D0)
35269 SW = 1D0-MW**2/MZ**2
35272 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
35273 G2 = DSQRT(0.0336D0*4D0*PI)
35274 G1 = DSQRT(0.0101D0*4D0*PI)
35276 IF(MQ.GT.MUR) MST = MQ
35277 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
35279 MSUSYT = DSQRT(MST**2 + MTOP**2)
35281 IF(MQ.GT.MD) MSB = MQ
35282 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
35284 MB = PYMRUN(5,MSB**2)
35285 MSUSYB = DSQRT(MSB**2 + MB**2)
35286 TT = LOG(MSUSYT**2/MTOP**2)
35287 TB = LOG(MSUSYB**2/MTOP**2)
35289 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
35290 HT = RMTOP/(V*SINB)
35293 G32 = ALPHA3*4D0*PI
35294 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
35295 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
35296 AL2 = 3D0/8D0/PI**2*HT**2
35297 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
35298 C ALST = 3./8./PI**2*HTST**2
35299 AL1 = 3D0/8D0/PI**2*HB**2
35302 AL(1,2) = (AL2+AL1)/2D0
35303 AL(2,1) = (AL2+AL1)/2D0
35306 IF(MA.GT.MTOP) THEN
35307 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
35308 * LOG(MTOP**2/MA**2))
35311 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
35312 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
35313 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
35314 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
35319 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
35320 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
35321 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
35322 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
35326 SINBT = TANBST/DSQRT(1D0+TANBST**2)
35329 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
35330 COSBB = SINBB/TANBSB
35335 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
35336 MTOP2 = DSQRT(MTOP4)
35337 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
35338 * /(1D0+DELTAMB)**4
35339 MBOT2 = DSQRT(MBOT4)
35341 STOP12 = (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 + MTOP2*(AT-XMU/TANBST)**2)
35345 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
35346 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35347 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35348 * MQ2 - MUR2)**2*0.25D0
35349 * + MTOP2*(AT-XMU/TANBST)**2)
35350 IF(STOP22.LT.0.) GOTO 120
35351 SBOT12 = (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 SBOT22 = (MQ2 + MD2)*.5D0
35356 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35357 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35358 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35359 IF(SBOT22.LT.0.) SBOT22 = 10000D0
35361 STOP1 = DSQRT(STOP12)
35362 STOP2 = DSQRT(STOP22)
35363 SBOT1 = DSQRT(SBOT12)
35364 SBOT2 = DSQRT(SBOT22)
35366 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35368 C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
35369 C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
35370 C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
35371 C INDUCED CORRECTIONS.
35373 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35378 IF(X.EQ.Y) X = X - 0.00001D0
35379 IF(X.EQ.Z) X = X - 0.00002D0
35380 IF(Y.EQ.Z) Y = Y - 0.00003D0
35386 IF(X.EQ.Y) X = X - 0.00001D0
35387 IF(X.EQ.Z) X = X - 0.00002D0
35388 IF(Y.EQ.Z) Y = Y - 0.00003D0
35390 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
35391 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
35395 IF(X.EQ.Y) X = X - 0.00001D0
35396 IF(X.EQ.Z) X = X - 0.00002D0
35397 IF(Y.EQ.Z) Y = Y - 0.00003D0
35399 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
35401 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35403 C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
35404 C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
35405 C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
35406 C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
35407 C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
35408 C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
35409 C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
35410 C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
35411 C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
35412 C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
35413 C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
35416 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35418 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
35419 MTOP2 = DSQRT(MTOP4)
35420 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
35421 * /(1D0+DELTAMB)**4
35422 MBOT2 = DSQRT(MBOT4)
35424 STOP12 = (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 + MTOP2*(AT-XMU/TANBST)**2)
35428 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
35429 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
35430 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
35431 * MQ2 - MUR2)**2*0.25D0
35432 * + MTOP2*(AT-XMU/TANBST)**2)
35434 IF(STOP22.LT.0.) GOTO 120
35435 SBOT12 = (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 SBOT22 = (MQ2 + MD2)*.5D0
35440 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
35441 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
35442 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
35443 IF(SBOT22.LT.0.) GOTO 120
35446 STOP1 = DSQRT(STOP12)
35447 STOP2 = DSQRT(STOP22)
35448 SBOT1 = DSQRT(SBOT12)
35449 SBOT2 = DSQRT(SBOT22)
35451 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35453 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
35456 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
35458 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
35459 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
35461 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
35463 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
35464 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
35466 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
35467 * (-.5D0*LOG(STOP12/STOP22)
35468 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
35469 * G(STOP12,STOP22))
35471 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
35472 * (.5D0*LOG(SBOT12/SBOT22)
35473 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
35474 * G(SBOT12,SBOT22))
35476 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
35477 * (MQ2+MBOT2)/(MD2+MBOT2))
35478 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
35479 * LOG(SBOT1**2/SBOT2**2)) +
35480 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
35481 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
35484 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
35485 * -STOP2**2))**2*G(STOP12,STOP22)
35487 VH3B(1,1)=VH3B(1,1)+
35488 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
35490 VH3T(1,1) = VH3T(1,1) +
35491 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
35493 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
35494 * (MQ2+MTOP2)/(MUR2+MTOP2))
35495 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
35496 * LOG(STOP1**2/STOP2**2)) +
35497 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
35498 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
35501 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
35502 * -SBOT2**2))**2*G(SBOT12,SBOT22)
35504 VH3T(2,2)=VH3T(2,2)+
35505 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
35506 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
35508 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
35509 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
35510 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
35513 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
35514 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
35515 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
35518 VH3T(1,2)=VH3T(1,2) +
35519 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
35521 VH3B(1,2)=VH3B(1,2) +
35522 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
35524 VH3T(2,1) = VH3T(1,2)
35525 VH3B(2,1) = VH3B(1,2)
35527 C TQ = LOG((MQ2 + MTOP2)/MTOP2)
35528 C TU = LOG((MUR2+MTOP2)/MTOP2)
35529 C TQD = LOG((MQ2 + MB**2)/MB**2)
35530 C TD = LOG((MD2+MB**2)/MB**2)
35535 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
35536 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
35537 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
35538 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
35557 C*********************************************************************
35560 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
35562 FUNCTION PYFINT(A,B,C)
35564 C...Double precision and integer declarations.
35565 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35566 IMPLICIT INTEGER(I-N)
35567 INTEGER PYK,PYCHGE,PYCOMP
35569 COMMON/PYINTS/XXM(20)
35572 C...Local variables.
35574 DOUBLE PRECISION PYFISB
35581 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
35586 C*********************************************************************
35589 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
35593 C...Double precision and integer declarations.
35594 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35595 IMPLICIT INTEGER(I-N)
35596 INTEGER PYK,PYCHGE,PYCOMP
35598 COMMON/PYINTS/XXM(20)
35601 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
35602 &(X*(XXM(2)-XXM(3))+XXM(3)))
35607 C*********************************************************************
35610 C...Calculates decays of sfermions.
35612 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
35614 C...Double precision and integer declarations.
35615 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35616 IMPLICIT INTEGER(I-N)
35617 INTEGER PYK,PYCHGE,PYCOMP
35618 C...Parameter statement to help give large particle numbers.
35619 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35620 &KEXCIT=4000000,KDIMEN=5000000)
35622 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35623 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35624 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35625 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35626 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35627 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
35629 C...Local variables.
35630 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
35631 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
35633 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
35634 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
35635 DOUBLE PRECISION PYLAMF,XL
35636 DOUBLE PRECISION TANW,XW,AEM,C1,AS
35637 DOUBLE PRECISION AL,AR,BL,BR
35638 DOUBLE PRECISION CH1,CH2,CH3,CH4
35639 DOUBLE PRECISION XMBOT,XMTOP
35640 DOUBLE PRECISION XLAM(0:400)
35641 INTEGER IDLAM(400,3)
35642 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
35643 DOUBLE PRECISION SR2
35644 DOUBLE PRECISION CBETA,SBETA
35645 DOUBLE PRECISION CW
35646 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
35647 DOUBLE PRECISION COSA,SINA,TANB
35648 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
35649 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
35651 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
35652 DATA IGG/23,25,35,36/
35653 DATA PI/3.141592654D0/
35654 DATA SR2/1.4142136D0/
35655 DATA KFNCHI/1000022,1000023,1000025,1000035/
35656 DATA KFCCHI/1000024,1000037/
35658 C...COUNT THE NUMBER OF DECAY MODES
35662 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
35663 &KFIN.EQ.KSUSY2+16) RETURN
35669 TANW = SQRT(XW/(1D0-XW))
35674 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
35679 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
35680 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
35686 C...ILR is 1 for left and 2 for right.
35688 C...IFL is matching non-SUSY flavour.
35689 IFL=MOD(KFIN,KSUSY1)
35690 C...IDU is weak isospin, 1 for down and 2 for up.
35701 XMBOT=PYMRUN(5,XMI2)
35702 XMTOP=PYMRUN(6,XMI2)
35716 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
35718 IF(IMSS(11).EQ.1) THEN
35721 XMGR=PMAS(PYCOMP(IDG),1)
35722 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
35725 ELSEIF(IFL.EQ.6) THEN
35730 IF(XMI.GT.XMGR+XMF) THEN
35735 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
35739 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
35741 C...CHARGED DECAYS:
35743 C...DI -> U CHI1-,CHI2-
35747 C...UI -> D CHI1+,CHI2+
35754 IF(XMI.GE.AXMJ+XMFP) THEN
35761 ELSEIF(IFL.LT.6) THEN
35766 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
35767 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
35773 ELSEIF(IFL.LT.5) THEN
35778 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
35779 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
35783 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
35784 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
35785 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
35786 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
35802 XL=PYLAMF(XMI2,XMA2,XMB2)
35803 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
35804 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
35805 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
35808 IDLAM(LKNT,1)=-KFCCHI(IX)
35809 IDLAM(LKNT,2)=IFL+1
35811 IDLAM(LKNT,1)=KFCCHI(IX)
35812 IDLAM(LKNT,2)=IFL-1
35823 IF(XMI.GE.AXMJ+XMF) THEN
35829 ELSEIF(IFL.LT.5) THEN
35832 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
35833 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
35834 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
35839 ELSEIF(IFL.LT.5) THEN
35842 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
35843 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
35844 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
35848 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
35849 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
35850 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
35851 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
35867 XL=PYLAMF(XMI2,XMA2,XMB2)
35868 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
35869 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
35870 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
35871 IDLAM(LKNT,1)=KFNCHI(IX)
35877 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
35881 IF(ILR.EQ.1) GOTO 160
35883 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
35884 IF(XMI.LT.XMSF1+XMB) GOTO 160
35886 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
35889 ELSEIF(IG.EQ.25) THEN
35892 ELSEIF(IFL.EQ.6) THEN
35894 ELSEIF(IFL.LT.5) THEN
35900 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
35901 & XMF**2/XMW*COSA/SBETA
35902 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
35903 & XMF**2/XMW*COSA/SBETA
35905 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
35906 & XMF**2/XMW*(-SINA)/CBETA
35907 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
35908 & XMF**2/XMW*(-SINA)/CBETA
35912 ELSEIF(IFL.EQ.6) THEN
35914 ELSEIF(IFL.EQ.15) THEN
35919 C.........need to complexify
35921 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
35924 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
35930 ELSEIF(IG.EQ.35) THEN
35933 ELSEIF(IFL.EQ.6) THEN
35935 ELSEIF(IFL.LT.5) THEN
35941 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
35942 & XMF**2/XMW*SINA/SBETA
35943 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
35944 & XMF**2/XMW*SINA/SBETA
35946 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
35947 & XMF**2/XMW*COSA/CBETA
35948 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
35949 & XMF**2/XMW*COSA/CBETA
35953 ELSEIF(IFL.EQ.6) THEN
35955 ELSEIF(IFL.EQ.15) THEN
35960 C.........Need to complexify
35962 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
35965 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
35971 ELSEIF(IG.EQ.36) THEN
35976 ELSEIF(IFL.EQ.6) THEN
35978 ELSEIF(IFL.LT.5) THEN
35985 ELSEIF(IFL.EQ.6) THEN
35987 ELSEIF(IFL.EQ.15) THEN
35992 C.........Need to complexify
35994 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
35996 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
36002 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
36003 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
36004 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
36005 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36008 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
36010 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
36013 IDLAM(LKNT,1)=KFIN-KSUSY1
36019 IF(MOD(IFL,2).EQ.0) THEN
36025 XMSF1=PMAS(PYCOMP(KF1),1)
36026 XMSF2=PMAS(PYCOMP(KF2),1)
36027 IF(XMI.GT.XMB+XMSF1) THEN
36028 IF(MOD(IFL,2).EQ.0) THEN
36030 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
36032 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
36036 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
36038 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
36041 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36043 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
36046 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
36048 IF(XMI.GT.XMB+XMSF2) THEN
36049 IF(MOD(IFL,2).EQ.0) THEN
36051 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
36053 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
36057 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
36059 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
36062 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
36064 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
36067 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
36072 IF(MOD(IFL,2).EQ.0) THEN
36078 XMSF1=PMAS(PYCOMP(KF1),1)
36079 XMSF2=PMAS(PYCOMP(KF2),1)
36080 IF(XMI.GT.XMB+XMSF1) THEN
36085 IF(MOD(IFL,2).EQ.0) THEN
36088 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
36089 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
36090 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
36091 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
36094 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
36095 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
36096 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
36097 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
36108 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
36109 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
36110 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
36111 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
36114 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
36115 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
36116 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
36117 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
36126 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36128 C.......Need to complexify
36129 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
36130 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
36131 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
36132 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
36135 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
36137 IF(XMI.GT.XMB+XMSF2) THEN
36142 IF(MOD(IFL,2).EQ.0) THEN
36145 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
36146 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
36147 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
36148 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
36151 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
36152 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
36153 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
36154 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
36165 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
36166 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
36167 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
36168 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
36171 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
36172 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
36173 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
36174 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
36183 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
36185 C.......Need to complexify
36186 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
36187 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
36188 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
36189 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
36192 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
36195 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
36200 IF(IFL.EQ.6) XMF=PMAS(6,1)
36201 IF(IFL.EQ.5) XMF=PMAS(5,1)
36202 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
36204 IF(XMI.GE.AXMJ+XMF) THEN
36221 XL=PYLAMF(XMI2,XMA2,XMB2)
36222 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
36223 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
36224 IDLAM(LKNT,1)=KSUSY1+21
36230 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
36231 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
36232 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
36233 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
36234 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
36235 C...M*M = C1**2 * G**2/(16PI**2)
36236 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
36238 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
36239 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
36240 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
36241 IDLAM(LKNT,1)=KSUSY1+22
36246 C...R-violating sfermion decays (SKANDS).
36247 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
36252 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
36253 XLAM(0)=XLAM(0)+XLAM(I)
36255 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
36260 C*********************************************************************
36263 C...Calculates gluino decay modes.
36265 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
36267 C...Double precision and integer declarations.
36268 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36269 IMPLICIT INTEGER(I-N)
36270 INTEGER PYK,PYCHGE,PYCOMP
36271 C...Parameter statement to help give large particle numbers.
36272 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36273 &KEXCIT=4000000,KDIMEN=5000000)
36275 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36276 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36277 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36278 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36279 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36281 C COMMON/PYINTS/XXM(20)
36283 COMMON/PYINTC/XXC(10),CXC(8)
36284 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
36286 C...Local variables
36287 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
36288 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
36289 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
36290 DOUBLE PRECISION PYLAMF,XL
36291 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
36292 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
36293 DOUBLE PRECISION XLAM(0:400)
36294 INTEGER IDLAM(400,3)
36295 INTEGER LKNT,IX,ILR,I,IKNT,IFL
36296 DOUBLE PRECISION SR2
36297 DOUBLE PRECISION GAM
36298 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
36299 EXTERNAL PYGAUS,PYXXZ6
36300 DOUBLE PRECISION PYGAUS,PYXXZ6
36301 DOUBLE PRECISION PREC
36302 INTEGER KFNCHI(4),KFCCHI(2)
36303 DATA PI/3.141592654D0/
36304 DATA SR2/1.4142136D0/
36306 DATA KFNCHI/1000022,1000023,1000025,1000035/
36307 DATA KFCCHI/1000024,1000037/
36309 C...COUNT THE NUMBER OF DECAY MODES
36311 IF(KFIN.NE.KSUSY1+21) RETURN
36315 TANW = SQRT(XW/(1D0-XW))
36325 XMI=SIGN(XMI,RMSS(3))
36327 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
36329 IF(IMSS(11).EQ.1) THEN
36332 XMGR=PMAS(PYCOMP(IDG),1)
36333 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
36334 IF(AXMI.GT.XMGR) THEN
36343 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
36347 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
36350 IF(AXMI.GE.AXMJ+XMF) THEN
36351 C...Minus sign difference from gluino-quark-squark feynman rules
36368 XL=PYLAMF(XMI2,XMA2,XMB2)
36369 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
36370 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
36371 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
36375 XLAM(LKNT)=XLAM(LKNT-1)
36376 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36377 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36383 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
36384 C...GLUINO -> NI Q QBAR
36388 IF(AXMI.GE.AXMJ) THEN
36390 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
36392 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
36399 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
36400 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
36406 T3I=SIGN(1D0,EI+1D-6)/2D0
36407 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36408 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36412 CXC(4)=DCONJG(GLIJ)
36416 CXC(8)=-DCONJG(GRIJ)
36418 S12MAX=(AXMI-AXMJ)**2
36419 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
36420 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
36422 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
36423 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
36424 IDLAM(LKNT,1)=KFNCHI(IX)
36428 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
36430 XLAM(LKNT)=XLAM(LKNT-1)
36431 IDLAM(LKNT,1)=KFNCHI(IX)
36436 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
36437 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
36438 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
36440 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
36441 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
36443 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
36446 IDLAM(LKNT,1)=KFNCHI(IX)
36449 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
36454 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
36455 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
36456 C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
36460 T3I=SIGN(1D0,EI+1D-6)/2D0
36461 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
36462 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
36464 CXC(4)=DCONJG(GLIJ)
36466 CXC(8)=-DCONJG(GRIJ)
36467 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
36468 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
36470 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
36471 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
36472 IDLAM(LKNT,1)=KFNCHI(IX)
36476 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
36478 XLAM(LKNT)=XLAM(LKNT-1)
36479 IDLAM(LKNT,1)=KFNCHI(IX)
36484 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
36485 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
36487 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
36488 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
36489 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
36491 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
36492 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
36494 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
36497 IDLAM(LKNT,1)=KFNCHI(IX)
36500 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
36506 C...GLUINO -> CI Q QBAR'
36510 IF(AXMI.GE.AXMJ) THEN
36512 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
36513 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
36516 S12MAX=(AXMI-AXMJ)**2
36521 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
36522 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
36525 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
36527 CXC(1)=DCMPLX(0D0,0D0)
36528 CXC(3)=DCMPLX(0D0,0D0)
36529 CXC(5)=DCMPLX(0D0,0D0)
36530 CXC(7)=DCMPLX(0D0,0D0)
36531 CXC(2)=UMIXC(IX,1)*OLPP/SR2
36532 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
36533 CXC(6)=DCMPLX(0D0,0D0)
36534 CXC(8)=DCMPLX(0D0,0D0)
36535 IF(XXC(5).LT.AXMI) THEN
36537 ELSEIF(XXC(6).LT.AXMI) THEN
36542 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
36543 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
36545 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
36546 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
36547 IDLAM(LKNT,1)=KFCCHI(IX)
36551 XLAM(LKNT)=XLAM(LKNT-1)
36552 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36553 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36554 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36556 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
36558 XLAM(LKNT)=XLAM(LKNT-1)
36559 IDLAM(LKNT,1)=KFCCHI(IX)
36563 XLAM(LKNT)=XLAM(LKNT-1)
36564 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36565 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36566 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36572 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
36573 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
36574 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
36575 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
36576 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
36577 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
36578 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
36579 IF(XMI.GT.PMOLT2+XMF) PMOLT2=100D0*AXMI
36580 IF(XMI.GT.PMOLT1+XMF) PMOLT1=100D0*AXMI
36581 IF(XMI.GT.PMOLB2+XMFP) PMOLB2=100D0*AXMI
36582 IF(XMI.GT.PMOLB1+XMFP) PMOLB1=100D0*AXMI
36583 CALL PYTBBC(IX,100,XMI,GAM)
36586 IDLAM(LKNT,1)=KFCCHI(IX)
36590 XLAM(LKNT)=XLAM(LKNT-1)
36591 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
36592 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
36593 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
36594 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
36595 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
36596 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
36597 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
36603 C...R-parity violating (3-body) decays.
36604 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
36609 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
36610 XLAM(0)=XLAM(0)+XLAM(I)
36612 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
36617 C*********************************************************************
36620 C...Calculates the three-body decay of gluinos into
36621 C...neutralinos and third generation fermions.
36623 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
36625 C...Double precision and integer declarations.
36626 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36627 IMPLICIT INTEGER(I-N)
36628 INTEGER PYK,PYCHGE,PYCOMP
36629 C...Parameter statement to help give large particle numbers.
36630 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36631 &KEXCIT=4000000,KDIMEN=5000000)
36633 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36634 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36635 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36636 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36637 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36638 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
36640 C...Local variables.
36641 EXTERNAL PYSIMP,PYLAMF
36642 DOUBLE PRECISION PYSIMP,PYLAMF
36644 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
36645 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
36646 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
36647 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
36648 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
36649 DOUBLE PRECISION XLN1,XLN2,B1,B2
36650 DOUBLE PRECISION E,XMGLU,GAM
36651 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
36652 SAVE HRB,HLB,FLB,FRB
36653 DOUBLE PRECISION ALPHAW,ALPHAS
36654 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
36655 SAVE HLT,HRT,FLT,FRT
36656 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
36658 DOUBLE PRECISION AMBOT,SINC,COSC
36659 DOUBLE PRECISION AMTOP,SINA,COSA
36660 DOUBLE PRECISION SINW,COSW,TANW
36661 DOUBLE PRECISION ROT1(4,4)
36664 DATA IFIRST/.TRUE./
36667 SINB=TANB/SQRT(1D0+TANB**2)
36678 AMBOT=PYMRUN(5,XMGLU**2)
36679 AMTOP=PYMRUN(6,XMGLU**2)
36681 FAKT1=AMBOT/W2/AMW/COSB
36682 FAKT2=AMTOP/W2/AMW/SINB
36693 ROT1(2,1)=-ROT1(1,2)
36694 ROT1(2,2)=ROT1(1,1)
36697 ROT1(4,3)=-ROT1(3,4)
36698 ROT1(4,4)=ROT1(3,3)
36702 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
36707 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
36708 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
36709 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
36711 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
36712 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
36713 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
36714 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
36717 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
36718 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
36719 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
36720 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
36721 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
36722 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
36723 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
36727 C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
36728 C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
36729 C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
36730 C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
36734 IF(NINT(3D0*E).EQ.2) THEN
36741 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
36742 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
36751 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
36752 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
36758 SIN2D=SIND*COSD*2D0
36772 ALPHAW=PYALEM(XMG2)
36773 ALPHAS=PYALPS(XMG2)
36777 XM24=(XMG2+XM2)*(XM2+XMR2)
36779 SMAX=(XMG-ABS(XMR))**2
36780 XMQA=XMG2+2D0*XM2+XMR2
36782 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
36784 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
36786 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
36787 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
36788 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
36789 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
36790 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
36791 & +2D0*(FF*SIND2-HH*COSD2))*W
36792 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
36793 & +4D0*HFL*XM*XMR)*XLN1
36794 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
36795 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
36796 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
36797 & +8D0*HFL*XMQ4*SIN2D)*B1
36798 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
36799 & +4D0*HFR*XMR*XM)*XLN2
36800 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
36801 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
36802 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
36803 & -8D0*HFR*XMQ4*SIN2D)*B2
36804 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
36805 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
36806 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
36807 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
36808 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
36809 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
36810 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
36811 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
36812 G(5)=(2D0*(HH*COSD2-FF*SIND2)
36813 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
36814 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
36815 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
36816 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
36817 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
36818 & +COS2D*XM*(SBAR+XMG2-XMR2))
36819 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
36820 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
36821 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
36822 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
36823 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
36824 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
36825 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
36828 SUMME(LIN)=SUMME(LIN)+G(J)
36833 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
36834 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
36839 C*********************************************************************
36842 C...Calculates the three-body decay of gluinos into
36843 C...charginos and third generation fermions.
36845 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
36847 C...Double precision and integer declarations.
36848 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36849 IMPLICIT INTEGER(I-N)
36850 INTEGER PYK,PYCHGE,PYCOMP
36851 C...Parameter statement to help give large particle numbers.
36852 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36853 &KEXCIT=4000000,KDIMEN=5000000)
36855 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36856 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36857 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
36858 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
36859 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
36860 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
36862 C...Local variables.
36863 EXTERNAL PYSIMP,PYLAMF
36864 DOUBLE PRECISION PYSIMP,PYLAMF
36866 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
36867 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
36868 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
36869 DOUBLE PRECISION SUMME(0:100),A(4,8)
36870 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
36871 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
36872 DOUBLE PRECISION XMGLU,GAM
36873 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
36874 &DDD(2),EEE(2),FFF(2)
36875 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
36876 DOUBLE PRECISION ALPHAW,ALPHAS
36877 DOUBLE PRECISION AMC(2)
36879 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
36880 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
36884 DATA IFIRST/.TRUE./
36887 SINB=TANB/SQRT(1D0+TANB**2)
36895 AMBOT=PYMRUN(5,XMGLU**2)
36896 AMTOP=PYMRUN(6,XMGLU**2)
36899 FAKT1=AMBOT/W2/AMW/COSB
36900 FAKT2=AMTOP/W2/AMW/SINB
36905 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
36906 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
36907 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
36908 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
36909 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
36910 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
36911 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
36912 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
36914 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
36915 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
36916 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
36917 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
36921 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
36922 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
36923 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
36924 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
36926 COS2A=COSA**2-SINA**2
36927 SIN2A=SINA*COSA*2D0
36928 COS2C=COSC**2-SINC**2
36929 SIN2C=SINC*COSC*2D0
36936 ALPHAW=PYALEM(XMG2)
36937 ALPHAS=PYALPS(XMG2)
36941 XMQ2=XMG2+XMT2+XMB2+XMR2
36942 XMQ4=XMG*XMT*XMB*XMR
36943 XMQ3=XMG2*XMR2+XMT2*XMB2
36944 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
36945 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
36947 XMST(1)=AMST(1)*AMST(1)
36948 XMST(2)=AMST(1)*AMST(1)
36949 XMST(3)=AMST(2)*AMST(2)
36950 XMST(4)=AMST(2)*AMST(2)
36951 XMSB(1)=AMSB(1)*AMSB(1)
36952 XMSB(2)=AMSB(2)*AMSB(2)
36953 XMSB(3)=AMSB(1)*AMSB(1)
36954 XMSB(4)=AMSB(2)*AMSB(2)
36956 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
36957 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
36958 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
36959 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
36960 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
36961 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
36962 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
36963 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
36965 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
36966 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
36967 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
36968 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
36969 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
36970 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
36971 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
36972 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
36974 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
36975 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
36976 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
36977 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
36978 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
36979 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
36980 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
36981 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
36983 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
36984 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
36985 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
36986 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
36987 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
36988 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
36989 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
36990 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
36992 SMAX=(XMG-ABS(XMR))**2
36993 SMIN=(XMB+XMT)**2+0.1D0
36996 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
36997 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
36999 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
37000 W=DSQRT(W)/2D0/SBAR
37001 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
37002 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
37003 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
37004 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
37005 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
37006 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
37007 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
37008 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
37009 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
37010 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
37011 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
37012 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
37013 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
37014 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
37015 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
37016 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
37017 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
37018 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
37019 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
37020 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
37021 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
37022 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
37023 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
37024 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
37025 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
37026 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
37027 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
37028 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
37029 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
37030 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
37031 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
37032 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
37033 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
37034 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
37035 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
37036 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
37037 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
37038 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
37039 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
37040 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
37041 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
37042 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
37043 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
37045 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
37046 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
37047 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
37048 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
37049 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
37050 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
37051 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
37052 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
37053 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
37054 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
37055 & -A(J,6)*(XMG2+XMR2-SBAR)
37056 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
37057 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
37058 & /(GRS+XMSB(J)+XMST(J))
37062 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
37063 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
37068 C*********************************************************************
37071 C...Calculates decay widths for the neutralinos (admixtures of
37072 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
37074 C...Input: KCIN = KF code for particle
37075 C...Output: XLAM = widths
37076 C... IDLAM = KF codes for decay particles
37077 C... IKNT = number of decay channels defined
37078 C...AUTHOR: STEPHEN MRENNA
37080 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
37081 C...when CHIGAMMA .NE. 0
37082 C...10 FEB 96: Calculate this decay for small tan(beta)
37084 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
37086 C...Double precision and integer declarations.
37087 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37088 IMPLICIT INTEGER(I-N)
37089 INTEGER PYK,PYCHGE,PYCOMP
37090 C...Parameter statement to help give large particle numbers.
37091 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37092 &KEXCIT=4000000,KDIMEN=5000000)
37094 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37095 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37096 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
37097 c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37099 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37100 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
37101 C COMMON/PYINTS/XXM(20)
37103 COMMON/PYINTC/XXC(10),CXC(8)
37104 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
37106 C...Local variables.
37107 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
37108 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
37110 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
37111 &XMZ,XMZ2,AXMJ,AXMI
37112 DOUBLE PRECISION S12MIN,S12MAX
37113 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
37114 DOUBLE PRECISION PYLAMF,XL
37115 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
37116 DOUBLE PRECISION PYX2XH,PYX2XG
37117 DOUBLE PRECISION XLAM(0:400)
37118 INTEGER IDLAM(400,3)
37119 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
37120 INTEGER ITH(3),KF1,KF2
37122 DOUBLE PRECISION DH(3),EH(3)
37123 DOUBLE PRECISION SR2
37124 DOUBLE PRECISION CBETA,SBETA
37125 DOUBLE PRECISION GAMCON,XMT1,XMT2
37126 DOUBLE PRECISION PYALEM,PI,PYALPS
37127 DOUBLE PRECISION RAT1,RAT2
37128 DOUBLE PRECISION T3T,FCOL
37129 DOUBLE PRECISION ALFA,BETA,TANB
37130 DOUBLE PRECISION PYXXGA
37131 EXTERNAL PYGAUS,PYXXZ6
37132 DOUBLE PRECISION PYGAUS,PYXXZ6
37133 DOUBLE PRECISION PREC
37134 INTEGER KFNCHI(4),KFCCHI(2)
37138 DATA PI/3.141592654D0/
37139 DATA SR2/1.4142136D0/
37140 DATA KFNCHI/1000022,1000023,1000025,1000035/
37141 DATA KFCCHI/1000024,1000037/
37143 C...COUNT THE NUMBER OF DECAY MODES
37152 TANW = SQRT(XW/XW1)
37154 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
37156 IF(KFIN.EQ.KFNCHI(2)) IX=2
37157 IF(KFIN.EQ.KFNCHI(3)) IX=3
37158 IF(KFIN.EQ.KFNCHI(4)) IX=4
37178 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
37183 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
37184 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
37188 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
37189 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
37191 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
37192 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
37196 GAMCON=AEM**3/8D0/PI/XMW2/XW
37197 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
37198 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
37199 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
37200 IDLAM(LKNT,1)=KSUSY1+22
37203 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
37207 C...GRAVITINO DECAY MODES
37209 IF(IMSS(11).EQ.1) THEN
37212 XMGR=PMAS(PYCOMP(IDG),1)
37215 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
37216 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
37221 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
37223 IF(AXMI.GT.XMGR+XMZ) THEN
37228 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
37229 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
37230 & (1D0-XMZ2/XMI2)**4
37232 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
37237 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
37238 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
37240 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
37245 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
37246 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
37248 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
37253 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
37254 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
37256 IF(IX.EQ.1) GOTO 300
37264 C...CHI0_I -> CHI0_J + GAMMA
37265 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
37266 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
37267 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
37268 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
37269 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
37270 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
37271 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
37273 IDLAM(LKNT,1)=KFNCHI(IJ)
37276 GAMCON=AEM**3/8D0/PI/XMW2/XW
37277 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
37278 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
37279 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
37283 C...CHI0_I -> CHI0_J + Z0
37284 IF(AXMI.GE.AXMJ+XMZ) THEN
37286 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
37287 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
37289 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37290 GLR=DBLE(OLPP*DCONJG(ORPP))
37291 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
37292 IDLAM(LKNT,1)=KFNCHI(IJ)
37295 ELSEIF(AXMI.GE.AXMJ) THEN
37302 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
37303 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
37305 C...CHARGED LEPTONS
37307 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37308 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37310 T3I=SIGN(1D0,EI+1D-6)/2D0
37311 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37312 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37313 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37314 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37316 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37317 CXC(4)=DCONJG(GLIJ)
37318 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37320 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37321 CXC(8)=-DCONJG(GRIJ)
37323 S12MAX=(AXMI-AXMJ)**2
37324 IF( XXC(5).LT.AXMI ) THEN
37327 IF(XXC(6).LT.AXMI ) THEN
37333 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
37335 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37336 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37337 IDLAM(LKNT,1)=KFNCHI(IJ)
37340 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
37342 XLAM(LKNT)=XLAM(LKNT-1)
37343 IDLAM(LKNT,1)=KFNCHI(IJ)
37349 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
37350 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
37351 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
37353 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
37354 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
37356 IF( XXC(5).LT.AXMI ) THEN
37359 IF(XXC(6).LT.AXMI ) THEN
37365 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
37367 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37368 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37369 IDLAM(LKNT,1)=KFNCHI(IJ)
37377 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37378 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37380 T3I=SIGN(1D0,EI+1D-6)/2D0
37381 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37382 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37383 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37384 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37386 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37387 CXC(4)=DCONJG(GLIJ)
37388 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37390 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37391 CXC(8)=-DCONJG(GRIJ)
37393 S12MAX=(AXMI-AXMJ)**2
37394 IF( XXC(5).LT.AXMI ) THEN
37397 IF( XXC(6).LT.AXMI ) THEN
37404 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37405 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37406 IDLAM(LKNT,1)=KFNCHI(IJ)
37410 XLAM(LKNT)=XLAM(LKNT-1)
37411 IDLAM(LKNT,1)=KFNCHI(IJ)
37416 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
37418 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
37419 IF( XXC(5).LT.AXMI ) THEN
37424 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37425 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37428 XLAM(LKNT)=XLAM(LKNT-1)
37430 IDLAM(LKNT,1)=KFNCHI(IJ)
37436 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37437 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37439 T3I=SIGN(1D0,EI+1D-6)/2D0
37440 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37441 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37442 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37443 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37445 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37446 CXC(4)=DCONJG(GLIJ)
37447 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37449 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37450 CXC(8)=-DCONJG(GRIJ)
37452 S12MAX=(AXMI-AXMJ)**2
37453 IF( XXC(5).LT.AXMI ) THEN
37456 IF( XXC(6).LT.AXMI ) THEN
37462 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
37464 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37465 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
37466 IDLAM(LKNT,1)=KFNCHI(IJ)
37469 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
37471 XLAM(LKNT)=XLAM(LKNT-1)
37472 IDLAM(LKNT,1)=KFNCHI(IJ)
37478 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
37479 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
37480 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
37482 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
37483 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
37485 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
37486 IF(XXC(5).LT.AXMI) THEN
37488 ELSEIF(XXC(6).LT.AXMI) THEN
37493 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
37495 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37496 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
37497 IDLAM(LKNT,1)=KFNCHI(IJ)
37505 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37506 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37508 T3I=SIGN(1D0,EI+1D-6)/2D0
37509 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
37510 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
37511 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
37512 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
37514 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
37515 CXC(4)=DCONJG(GLIJ)
37516 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
37518 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
37519 CXC(8)=-DCONJG(GRIJ)
37521 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
37522 IF(XXC(5).LT.AXMI) THEN
37524 ELSEIF(XXC(6).LT.AXMI) THEN
37530 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
37532 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37533 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
37534 IDLAM(LKNT,1)=KFNCHI(IJ)
37537 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
37539 XLAM(LKNT)=XLAM(LKNT-1)
37540 IDLAM(LKNT,1)=KFNCHI(IJ)
37548 C...CHI0_I -> CHI0_J + H0_K
37555 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
37556 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
37557 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
37558 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
37559 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
37560 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
37561 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
37562 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
37564 XMH=PMAS(ITH(IH),1)
37566 IF(AXMI.GE.AXMJ+XMH) THEN
37568 XL=PYLAMF(XMI2,XMJ2,XMH2)
37569 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
37571 C...SIGN OF MASSES I,J
37573 IF(IH.EQ.3) XMK=-XMK
37574 GX2=ABS(F21K)**2+ABS(F12K)**2
37575 GLR=DBLE(F21K*DCONJG(F12K))
37576 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
37577 IDLAM(LKNT,1)=KFNCHI(IJ)
37578 IDLAM(LKNT,2)=ITH(IH)
37584 C...CHI0_I -> CHI+_J + W-
37589 IF(AXMI.GE.AXMJ+XMW) THEN
37591 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
37592 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
37593 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
37594 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
37595 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
37596 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
37597 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
37598 IDLAM(LKNT,1)=KFCCHI(IJ)
37602 XLAM(LKNT)=XLAM(LKNT-1)
37603 IDLAM(LKNT,1)=-KFCCHI(IJ)
37606 ELSEIF(AXMI.GE.AXMJ) THEN
37608 S12MAX=(AXMI-AXMJ)**2
37609 RT2I = 1D0/SQRT(2D0)
37610 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
37611 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
37612 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
37613 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
37614 CXC(5)=DCMPLX(0D0,0D0)
37615 CXC(7)=DCMPLX(0D0,0D0)
37619 T3I=SIGN(1D0,EI+1D-6)/2D0
37621 T3J=SIGN(1D0,EJ+1D-6)/2D0
37622 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
37623 & TANW+ZMIXC(IX,2)*T3J)*RT2I
37624 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
37625 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
37626 CXC(6)=DCMPLX(0D0,0D0)
37627 CXC(8)=DCMPLX(0D0,0D0)
37632 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
37633 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
37636 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
37637 IF(XXC(5).LT.AXMI) THEN
37639 ELSEIF(XXC(6).LT.AXMI) THEN
37644 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
37646 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37647 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37648 IDLAM(LKNT,1)=KFCCHI(IJ)
37652 XLAM(LKNT)=XLAM(LKNT-1)
37653 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37654 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37655 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37656 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
37658 XLAM(LKNT)=XLAM(LKNT-1)
37659 IDLAM(LKNT,1)=KFCCHI(IJ)
37663 XLAM(LKNT)=XLAM(LKNT-1)
37664 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37665 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37666 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37670 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
37671 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
37672 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
37674 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
37675 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
37677 IF(XXC(5).LT.AXMI) THEN
37680 IF(XXC(6).LT.AXMI) THEN
37685 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
37687 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
37688 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37689 XLAM(LKNT)=XLAM(LKNT-1)
37690 IDLAM(LKNT,1)=KFCCHI(IJ)
37694 XLAM(LKNT)=XLAM(LKNT-1)
37695 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37696 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37697 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37700 C...NOW, DO THE QUARKS
37705 T3I=SIGN(1D0,EI+1D-6)/2D0
37707 T3J=SIGN(1D0,EJ+1D-6)/2D0
37708 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
37709 & TANW+ZMIXC(IX,2)*T3J)
37710 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
37711 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
37712 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
37713 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
37714 IF(XXC(5).LT.AXMI) THEN
37717 IF(XXC(6).LT.AXMI) THEN
37722 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
37724 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
37725 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
37726 IDLAM(LKNT,1)=KFCCHI(IJ)
37730 XLAM(LKNT)=XLAM(LKNT-1)
37731 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37732 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37733 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37734 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
37736 XLAM(LKNT)=XLAM(LKNT-1)
37737 IDLAM(LKNT,1)=KFCCHI(IJ)
37741 XLAM(LKNT)=XLAM(LKNT-1)
37742 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37743 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37744 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37752 C...CHI0_I -> CHI+_I + H-
37758 IF(AXMI.GE.AXMJ+XMHP) THEN
37760 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
37761 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
37762 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
37763 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
37765 GX2=ABS(OLPP)**2+ABS(ORPP)**2
37766 GLR=DBLE(OLPP*DCONJG(ORPP))
37767 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
37768 IDLAM(LKNT,1)=KFCCHI(IJ)
37769 IDLAM(LKNT,2)=-ITHC
37772 XLAM(LKNT)=XLAM(LKNT-1)
37773 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37774 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37775 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
37781 C...2-BODY DECAYS TO FERMION SFERMION
37783 IF(J.GE.7.AND.J.LE.10) GOTO 290
37786 XMSF1=PMAS(PYCOMP(KF1),1)
37787 XMSF2=PMAS(PYCOMP(KF2),1)
37797 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
37798 IF(MOD(J,2).EQ.0) THEN
37799 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
37800 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
37801 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
37804 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
37805 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
37806 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
37811 IF(AXMI.GE.XMF+XMSF1) THEN
37815 XL=PYLAMF(XMI2,XMA2,XMB2)
37816 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
37817 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
37818 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37819 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37824 XLAM(LKNT)=XLAM(LKNT-1)
37825 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37826 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37831 IF(AXMI.GE.XMF+XMSF2) THEN
37835 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
37836 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
37837 XL=PYLAMF(XMI2,XMA2,XMB2)
37838 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
37839 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
37844 XLAM(LKNT)=XLAM(LKNT-1)
37845 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
37846 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
37851 C...3-BODY DECAY TO Q Q~ GLUINO
37852 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
37853 IF(AXMI.GE.XMJ) THEN
37854 RT2I = 1D0/SQRT(2D0)
37855 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
37863 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37864 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37865 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
37871 T3I=SIGN(1D0,EI+1D-6)/2D0
37872 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
37873 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
37877 CXC(4)=DCONJG(GLIJ)
37881 CXC(8)=-DCONJG(GRIJ)
37883 S12MAX=(AXMI-AXMJ)**2
37884 C...ALL QUARKS BUT T
37885 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
37887 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
37888 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37889 IDLAM(LKNT,1)=KSUSY1+21
37892 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
37894 XLAM(LKNT)=XLAM(LKNT-1)
37895 IDLAM(LKNT,1)=KSUSY1+21
37901 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
37902 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
37903 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
37905 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
37906 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
37908 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
37911 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
37913 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
37914 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37915 IDLAM(LKNT,1)=KSUSY1+21
37922 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
37923 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
37924 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
37928 T3I=SIGN(1D0,EI+1D-6)/2D0
37929 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
37930 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
37932 CXC(4)=DCONJG(GLIJ)
37934 CXC(8)=-DCONJG(GRIJ)
37935 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
37937 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
37938 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
37939 IDLAM(LKNT,1)=KSUSY1+21
37942 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
37944 XLAM(LKNT)=XLAM(LKNT-1)
37945 IDLAM(LKNT,1)=KSUSY1+21
37953 C...R-violating decay modes (SKANDS).
37954 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
37959 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
37960 XLAM(0)=XLAM(0)+XLAM(I)
37962 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
37967 C*********************************************************************
37970 C...Calculate decay widths for the charginos (admixtures of
37971 C...charged Wino and charged Higgsino.
37973 C...Input: KCIN = KF code for particle
37974 C...Output: XLAM = widths
37975 C... IDLAM = KF codes for decay particles
37976 C... IKNT = number of decay channels defined
37977 C...AUTHOR: STEPHEN MRENNA
37979 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
37980 C...when CHIENU .NE. 0
37982 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
37984 C...Double precision and integer declarations.
37985 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37986 IMPLICIT INTEGER(I-N)
37987 INTEGER PYK,PYCHGE,PYCOMP
37988 C...Parameter statement to help give large particle numbers.
37989 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37990 &KEXCIT=4000000,KDIMEN=5000000)
37992 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37993 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37994 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
37995 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
37996 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
37998 C COMMON/PYINTS/XXM(20)
38000 COMMON/PYINTC/XXC(10),CXC(8)
38001 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
38003 C...Local variables
38004 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
38005 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
38007 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
38008 &XMZ,XMZ2,AXMJ,AXMI
38009 DOUBLE PRECISION S12MIN,S12MAX
38010 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
38011 DOUBLE PRECISION PYLAMF,XL
38012 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
38013 DOUBLE PRECISION PYX2XH,PYX2XG
38014 DOUBLE PRECISION XLAM(0:400)
38015 INTEGER IDLAM(400,3)
38016 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
38019 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
38020 DOUBLE PRECISION SR2
38021 DOUBLE PRECISION CBETA,SBETA,TANB
38023 DOUBLE PRECISION PYALEM,PI,PYALPS
38024 DOUBLE PRECISION FCOL
38025 INTEGER KF1,KF2,ISF
38026 INTEGER KFNCHI(4),KFCCHI(2)
38028 DOUBLE PRECISION TEMP
38029 EXTERNAL PYGAUS,PYXXZ6
38030 DOUBLE PRECISION PYGAUS,PYXXZ6
38031 DOUBLE PRECISION PREC
38034 DATA ETAH/1D0,1D0,-1D0/
38035 DATA SR2/1.4142136D0/
38036 DATA PI/3.141592654D0/
38038 DATA KFNCHI/1000022,1000023,1000025,1000035/
38039 DATA KFCCHI/1000024,1000037/
38041 C...COUNT THE NUMBER OF DECAY MODES
38049 TANW = SQRT(XW/XW1)
38051 C...1 OR 2 DEPENDING ON CHARGINO TYPE
38053 IF(KFIN.EQ.KFCCHI(2)) IX=2
38071 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
38072 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
38076 C...GRAVITINO DECAY MODES
38078 IF(IMSS(11).EQ.1) THEN
38081 XMGR=PMAS(PYCOMP(IDG),1)
38083 C COSW=SQRT(1D0-XW)
38084 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
38085 IF(AXMI.GT.XMGR+XMW) THEN
38091 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
38092 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
38093 & (1D0-XMW2/XMI2)**4
38095 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
38100 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
38101 & (ABS(UMIXC(IX,2))*SBETA)**2))
38102 & *(1D0-PMAS(37,1)**2/XMI2)**4
38106 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
38107 IF(IX.EQ.1) GOTO 170
38112 C...CHI_2+ -> CHI_1+ + Z0
38113 IF(AXMI.GE.AXMJ+XMZ) THEN
38116 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
38117 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
38118 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
38119 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
38120 GX2=ABS(OLPP)**2+ABS(ORPP)**2
38121 GLR=DBLE(OLPP*DCONJG(ORPP))
38122 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
38123 IDLAM(LKNT,1)=KFCCHI(1)
38127 C...CHARGED LEPTONS
38128 ELSEIF(AXMI.GE.AXMJ) THEN
38130 S12MAX=(AXMI-AXMJ)**2
38133 EI=KCHG(IABS(IA),1)/3D0
38134 T3I=SIGN(1D0,EI+1D-6)/2D0
38139 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38144 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
38145 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
38146 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
38147 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
38148 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38149 CXC(2)=DCMPLX(0D0,0D0)
38150 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38151 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
38152 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38153 CXC(6)=DCMPLX(0D0,0D0)
38154 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38155 CXC(8)=DCMPLX(0D0,0D0)
38156 IF( XXC(5).LT.AXMI ) THEN
38161 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
38163 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
38164 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38165 IDLAM(LKNT,1)=KFCCHI(1)
38168 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
38170 XLAM(LKNT)=XLAM(LKNT-1)
38171 IDLAM(LKNT,1)=KFCCHI(1)
38175 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
38177 XLAM(LKNT)=XLAM(LKNT-1)
38178 IDLAM(LKNT,1)=KFCCHI(1)
38188 EI=KCHG(IABS(IA),1)/3D0
38189 T3I=SIGN(1D0,EI+1D-6)/2D0
38190 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38192 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38193 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38194 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
38195 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38196 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38197 IF( XXC(5).LT.AXMI ) THEN
38202 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
38204 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
38205 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38206 IDLAM(LKNT,1)=KFCCHI(1)
38210 XLAM(LKNT)=XLAM(LKNT-1)
38211 IDLAM(LKNT,1)=KFCCHI(1)
38215 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
38216 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
38217 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
38219 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
38221 IF( XXC(5).LT.AXMI ) THEN
38226 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
38227 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38228 IDLAM(LKNT,1)=KFCCHI(1)
38237 EI=KCHG(IABS(IA),1)/3D0
38238 T3I=SIGN(1D0,EI+1D-6)/2D0
38239 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38241 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38242 CXC(2)=DCMPLX(0D0,0D0)
38243 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38244 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
38245 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38246 CXC(6)=DCMPLX(0D0,0D0)
38247 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38248 CXC(8)=DCMPLX(0D0,0D0)
38249 IF( XXC(5).LT.AXMI ) THEN
38254 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
38256 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38257 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38258 IDLAM(LKNT,1)=KFCCHI(1)
38261 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
38263 XLAM(LKNT)=XLAM(LKNT-1)
38264 IDLAM(LKNT,1)=KFCCHI(1)
38269 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
38270 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
38271 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
38273 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
38275 IF( XXC(5).LT.AXMI ) THEN
38280 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38281 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38282 IDLAM(LKNT,1)=KFCCHI(1)
38291 EI=KCHG(IABS(IA),1)/3D0
38292 T3I=SIGN(1D0,EI+1D-6)/2D0
38293 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38295 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
38296 CXC(2)=DCMPLX(0D0,0D0)
38297 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
38298 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
38299 CXC(5)=-DCMPLX(EI/XW1)*ORPP
38300 CXC(6)=DCMPLX(0D0,0D0)
38301 CXC(7)=-DCMPLX(EI/XW1)*OLPP
38302 CXC(8)=DCMPLX(0D0,0D0)
38303 IF( XXC(5).LT.AXMI ) THEN
38308 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
38310 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38311 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38312 IDLAM(LKNT,1)=KFCCHI(1)
38315 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
38317 XLAM(LKNT)=XLAM(LKNT-1)
38318 IDLAM(LKNT,1)=KFCCHI(1)
38326 C...CHI_2+ -> CHI_1+ + H0_K
38334 XMH=PMAS(ITH(IH),1)
38336 C...NO 3-BODY OPTION
38337 IF(AXMI.GE.AXMJ+XMH) THEN
38339 XL=PYLAMF(XMI2,XMJ2,XMH2)
38340 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
38341 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
38342 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
38343 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
38345 GX2=ABS(OLPP)**2+ABS(ORPP)**2
38346 GLR=DBLE(OLPP*DCONJG(ORPP))
38347 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
38348 IDLAM(LKNT,1)=KFCCHI(1)
38349 IDLAM(LKNT,2)=ITH(IH)
38354 C...CHI1 JUMPS TO HERE
38357 C...CHI+_I -> CHI0_J + W+
38362 IF(AXMI.GE.AXMJ+XMW) THEN
38365 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
38367 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
38368 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
38369 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
38370 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
38371 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
38372 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
38373 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
38374 IDLAM(LKNT,1)=KFNCHI(IJ)
38378 ELSEIF(AXMI.GE.AXMJ) THEN
38380 S12MAX=(AXMI-AXMJ)**2
38382 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
38384 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
38385 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
38386 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
38387 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
38388 CXC(5)=DCMPLX(0D0,0D0)
38389 CXC(7)=DCMPLX(0D0,0D0)
38393 T3I=SIGN(1D0,EI+1D-6)/2D0
38395 T3J=SIGN(1D0,EJ+1D-6)/2D0
38396 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
38397 & TANW+ZMIXC(IJ,2)*T3J)/SR2
38398 CXC(4)=-DCONJG(UMIXC(IX,1))*(
38399 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
38400 CXC(6)=DCMPLX(0D0,0D0)
38401 CXC(8)=DCMPLX(0D0,0D0)
38406 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38407 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
38410 CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
38411 IF(XXC(5).LT.AXMI) THEN
38413 ELSEIF(XXC(6).LT.AXMI) THEN
38418 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
38419 C...--> 1/(16PI)/M**3*(AEM/XW)**2
38420 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
38422 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38423 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
38424 IDLAM(LKNT,1)=KFNCHI(IJ)
38427 C...ONLY DECAY CHI+1 -> E+ NU_E
38428 IF( IMSS(12).NE. 0 ) GOTO 260
38429 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
38431 XLAM(LKNT)=XLAM(LKNT-1)
38432 IDLAM(LKNT,1)=KFNCHI(IJ)
38437 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
38439 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
38440 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
38442 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
38444 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
38445 IF(XXC(5).LT.AXMI) THEN
38447 ELSEIF(XXC(6).LT.AXMI) THEN
38452 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38453 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
38454 IDLAM(LKNT,1)=KFNCHI(IJ)
38459 C...NOW, DO THE QUARKS
38464 T3I=SIGN(1D0,EI+1D-6)/2D0
38466 T3J=SIGN(1D0,EJ+1D-6)/2D0
38467 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
38468 & TANW+ZMIXC(IX,2)*T3J)
38469 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
38470 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
38471 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
38472 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
38473 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
38474 IF(XXC(5).LT.AXMI) THEN
38477 IF(XXC(6).LT.AXMI) THEN
38482 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
38484 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
38485 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38486 IDLAM(LKNT,1)=KFNCHI(IJ)
38489 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
38491 XLAM(LKNT)=XLAM(LKNT-1)
38492 IDLAM(LKNT,1)=KFNCHI(IJ)
38501 C...CHI+_I -> CHI0_J + H+
38507 IF(AXMI.GE.AXMJ+XMHP) THEN
38509 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
38510 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
38511 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
38512 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
38514 GX2=ABS(OLPP)**2+ABS(ORPP)**2
38515 GLR=DBLE(OLPP*DCONJG(ORPP))
38516 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
38517 IDLAM(LKNT,1)=KFNCHI(IJ)
38525 C...2-BODY DECAYS TO FERMION SFERMION
38527 IF(J.GE.7.AND.J.LE.10) GOTO 240
38528 IF(MOD(J,2).EQ.0) THEN
38534 XMSF1=PMAS(PYCOMP(KF1),1)
38535 XMSF2=PMAS(PYCOMP(KF2),1)
38544 IF(MOD(J,2).EQ.0) THEN
38547 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
38548 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
38554 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
38556 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
38561 IF(AXMI.GE.XMF+XMSF1) THEN
38565 XL=PYLAMF(XMI2,XMA2,XMB2)
38566 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
38567 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
38568 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
38569 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
38571 IF(MOD(J,2).EQ.0) THEN
38581 IF(AXMI.GE.XMF+XMSF2) THEN
38585 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
38586 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
38587 XL=PYLAMF(XMI2,XMA2,XMB2)
38588 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
38589 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
38591 IF(MOD(J,2).EQ.0) THEN
38601 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
38602 C...A 2-BODY -- 2-BODY CHAIN
38603 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
38604 IF(AXMI.GE.XMJ) THEN
38607 S12MAX=(AXMI-AXMJ)**2
38612 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
38613 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
38616 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
38618 CXC(1)=DCMPLX(0D0,0D0)
38619 CXC(3)=DCMPLX(0D0,0D0)
38620 CXC(5)=DCMPLX(0D0,0D0)
38621 CXC(7)=DCMPLX(0D0,0D0)
38622 CXC(2)=UMIXC(IX,1)*OLPP/SR2
38623 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
38624 CXC(6)=DCMPLX(0D0,0D0)
38625 CXC(8)=DCMPLX(0D0,0D0)
38626 IF(XXC(5).LT.AXMI) THEN
38628 ELSEIF(XXC(6).LT.AXMI) THEN
38633 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
38634 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
38636 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
38637 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
38638 IDLAM(LKNT,1)=KSUSY1+21
38641 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
38643 XLAM(LKNT)=XLAM(LKNT-1)
38644 IDLAM(LKNT,1)=KSUSY1+21
38652 C...R-violating decay modes (SKANDS).
38653 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
38658 XLAM(0)=XLAM(0)+XLAM(I)
38659 IF(XLAM(I).LT.0D0) THEN
38660 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
38661 & (IDLAM(I,J),J=1,3)
38665 IF(XLAM(0).EQ.0D0) THEN
38667 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
38668 WRITE(MSTU(11),*) LKNT
38669 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
38675 C*********************************************************************
38678 C...Used in the calculation of inoi -> inoj + f + ~f.
38682 C...Double precision and integer declarations.
38683 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38684 IMPLICIT INTEGER(I-N)
38685 INTEGER PYK,PYCHGE,PYCOMP
38686 C...Parameter statement to help give large particle numbers.
38687 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38688 &KEXCIT=4000000,KDIMEN=5000000)
38690 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38691 C COMMON/PYINTS/XXM(20)
38693 COMMON/PYINTC/XXC(10),CXC(8)
38694 SAVE /PYDAT1/,/PYINTC/
38696 C...Local variables.
38697 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
38698 DOUBLE PRECISION PYXXZ6,X
38699 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
38700 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
38701 DOUBLE PRECISION SIJ
38702 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
38703 DOUBLE PRECISION OL2
38704 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
38707 C...Statement functions.
38708 C...Integral from x to y of (t-a)(b-t) dt.
38709 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
38710 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
38711 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
38712 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
38713 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
38714 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
38715 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
38716 C...Integral from x to y of (t-a)/(b-t) dt.
38717 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
38718 C...Integral from x to y of 1/(t-a) dt.
38719 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
38727 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
38728 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
38729 &( (X-XM22-S)**2 -4D0*XM22*S ) )
38731 S23MIN=(S23AVE-S23DEL)
38732 S23MAX=(S23AVE+S23DEL)
38749 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
38750 SIJ=2D0*XXC(2)*XXC(4)*S13
38751 IF(XMV.LE.1000D0) THEN
38752 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
38753 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
38754 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
38755 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
38756 IF(XXC(5).LE.10000D0) THEN
38757 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
38758 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
38759 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
38760 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
38761 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
38762 & *(S13-XMV**2)/WPROP2
38767 IF(XXC(6).LE.10000D0) THEN
38768 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
38769 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
38770 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
38771 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
38772 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
38773 & *(S13-XMV**2)/WPROP2
38782 IF(XXC(5).LE.10000D0) THEN
38783 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
38784 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
38785 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
38786 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
38790 IF(XXC(6).LE.10000D0) THEN
38791 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
38792 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
38793 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
38794 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
38799 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
38801 IF(PYXXZ6.LT.0D0) THEN
38802 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
38803 WRITE(MSTU(11),*) XXc(1),XXc(2),XXc(3),XXc(4)
38804 WRITE(MSTU(11),*) (XXc(I),I=5,8)
38805 WRITE(MSTU(11),*) (XXc(I),I=9,12)
38806 WRITE(MSTU(11),*) (XXc(I),I=13,16)
38807 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
38808 WRITE(MSTU(11),*) S23MIN,S23MAX
38816 C*********************************************************************
38819 C...Calculates chi0_i -> chi0_j + gamma.
38821 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
38823 C...Double precision and integer declarations.
38824 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38825 IMPLICIT INTEGER(I-N)
38826 INTEGER PYK,PYCHGE,PYCOMP
38828 C...Local variables.
38829 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
38830 DOUBLE PRECISION F1,F2
38832 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
38833 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
38834 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
38835 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
38840 C*********************************************************************
38843 C...Calculates the decay rate for ino -> ino + gauge boson.
38845 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
38847 C...Double precision and integer declarations.
38848 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38849 IMPLICIT INTEGER(I-N)
38850 INTEGER PYK,PYCHGE,PYCOMP
38852 C...Local variables.
38853 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
38854 DOUBLE PRECISION XL,PYLAMF,C1
38855 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
38861 XL=PYLAMF(XMI2,XMJ2,XMV2)
38862 PYX2XG=C1/8D0/XMI3*SQRT(XL)
38863 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
38864 &12D0*GLR*XM1*XM2*XMV2)
38869 C*********************************************************************
38872 C...Calculates the decay rate for ino -> ino + H.
38874 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
38876 C...Double precision and integer declarations.
38877 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38878 IMPLICIT INTEGER(I-N)
38879 INTEGER PYK,PYCHGE,PYCOMP
38881 C...Local variables.
38882 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
38883 DOUBLE PRECISION XL,PYLAMF,C1
38884 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
38890 XL=PYLAMF(XMI2,XMJ2,XMV2)
38891 PYX2XH=C1/8D0/XMI3*SQRT(XL)
38892 &*(GX2*(XMI2+XMJ2-XMV2)+
38898 C*********************************************************************
38901 C...Calculates the non-standard decay modes of the Higgs boson.
38903 C...Author: Stephen Mrenna
38904 C...Last Update: April 2001
38905 C......Allow complex values for Z,U, and V
38907 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
38909 C...Double precision and integer declarations.
38910 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38911 IMPLICIT INTEGER(I-N)
38912 INTEGER PYK,PYCHGE,PYCOMP
38913 C...Parameter statement to help give large particle numbers.
38914 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38915 &KEXCIT=4000000,KDIMEN=5000000)
38917 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38918 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38919 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38920 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
38921 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
38922 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
38923 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
38925 C...Local variables.
38926 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
38927 COMPLEX*16 QIJ,RIJ,F21K,F12K
38929 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
38930 DOUBLE PRECISION XMI2,XMI3,XMJ2
38931 DOUBLE PRECISION PYLAMF,XL,CF,EI
38933 DOUBLE PRECISION TANW,XW,AEM,C1,AS
38934 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
38935 DOUBLE PRECISION XLAM(0:400)
38936 INTEGER IDLAM(400,3)
38937 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
38939 INTEGER KFNCHI(4),KFCCHI(2)
38940 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
38941 DOUBLE PRECISION SR2
38942 DOUBLE PRECISION BETA,ALFA
38943 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
38944 DOUBLE PRECISION PYALEM
38945 DOUBLE PRECISION AL,AR,ALR
38946 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
38947 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
38948 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
38949 DATA ITH/25,35,36,37/
38950 DATA ETAH/1D0,1D0,-1D0/
38951 DATA SR2/1.4142136D0/
38952 DATA KFNCHI/1000022,1000023,1000025,1000035/
38953 DATA KFCCHI/1000024,1000037/
38955 C...COUNT THE NUMBER OF DECAY MODES
38962 TANW = SQRT(XW/(1D0-XW))
38965 C...1 - 4 DEPENDING ON Higgs species.
38967 IF(KFIN.EQ.ITH(2)) IH=2
38968 IF(KFIN.EQ.ITH(3)) IH=3
38969 IF(KFIN.EQ.ITH(4)) IH=4
38992 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
38997 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
38998 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
39003 IF(IH.EQ.4) GOTO 220
39005 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
39006 C...H0_K -> CHI0_I + CHI0_J
39019 IF(AXMI.GE.AXMJ+AXMK) THEN
39021 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
39022 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
39023 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
39024 & ZMIXC(IJ,3)*ZMIXC(IK,1))
39025 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
39026 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
39027 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
39028 & ZMIXC(IJ,4)*ZMIXC(IK,1))
39029 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
39030 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
39031 C...SIGN OF MASSES I,J
39033 GX2=ABS(F12K)**2+ABS(F21K)**2
39034 GLR=DBLE(F12K*DCONJG(F21K))
39035 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
39036 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
39037 IDLAM(LKNT,1)=KFNCHI(IJ)
39038 IDLAM(LKNT,2)=KFNCHI(IK)
39044 C...H0_K -> CHI+_I CHI-_J
39051 IF(AXMI.GE.AXMJ+AXMK) THEN
39053 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
39054 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
39055 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
39056 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
39057 GX2=ABS(OLPP)**2+ABS(ORPP)**2
39058 GLR=DBLE(OLPP*DCONJG(ORPP))
39060 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
39061 IDLAM(LKNT,1)=KFCCHI(IJ)
39062 IDLAM(LKNT,2)=-KFCCHI(IK)
39068 C...HIGGS TO SFERMION SFERMION
39070 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
39072 XMJL=PMAS(PYCOMP(IJ),1)
39073 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
39074 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
39077 XL=PYLAMF(XMI2,XMJ2,XMJ2)
39084 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
39085 & XMF**2/XMW*SINA/CBETA
39086 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
39087 & XMF**2/XMW*SINA/CBETA
39089 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
39091 ELSEIF(IFL.EQ.15) THEN
39092 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
39098 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
39099 & XMF**2/XMW*COSA/SBETA
39100 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
39101 & XMF**2/XMW*COSA/SBETA
39103 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
39110 ELSEIF(IH.EQ.2) THEN
39112 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
39113 & XMF**2/XMW*COSA/CBETA
39114 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
39115 & XMF**2/XMW*COSA/CBETA
39117 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
39119 ELSEIF(IFL.EQ.15) THEN
39120 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
39126 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
39127 & XMF**2/XMW*SINA/SBETA
39128 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
39129 & XMF**2/XMW*SINA/SBETA
39131 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
39138 ELSEIF(IH.EQ.3) THEN
39144 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
39145 ELSEIF(IFL.EQ.15) THEN
39146 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
39150 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
39154 IF(IH.EQ.3) GOTO 180
39158 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
39165 IF(AXMI.GE.2D0*XMJ) THEN
39167 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39169 & +2D0*GHLR*ALR)**2
39175 IF(AXMI.GE.2D0*XMJR) THEN
39179 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
39182 XL=PYLAMF(XMI2,XMJ2,XMJ2)
39183 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39185 & +2D0*GHLR*ALR)**2
39186 IDLAM(LKNT,1)=IJ+KSUSY1
39187 IDLAM(LKNT,2)=-(IJ+KSUSY1)
39192 IF(AXMI.GE.XMJL+XMJR) THEN
39194 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
39195 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
39196 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
39199 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
39200 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39201 & (GHLL*AL+GHRR*AR)**2
39203 IDLAM(LKNT,2)=-(IJ+KSUSY1)
39207 IDLAM(LKNT,2)=IJ+KSUSY1
39209 XLAM(LKNT)=XLAM(LKNT-1)
39219 C...H+ -> CHI+_I + CHI0_J
39227 IF(AXMI.GE.AXMJ+AXMK) THEN
39229 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
39230 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
39231 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
39232 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
39233 GX2=ABS(OLPP)**2+ABS(ORPP)**2
39234 GLR=DBLE(OLPP*DCONJG(ORPP))
39235 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
39236 IDLAM(LKNT,1)=KFNCHI(IJ)
39237 IDLAM(LKNT,2)=KFCCHI(IK)
39243 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
39244 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
39250 XM1=PMAS(PYCOMP(KSUSY1+6),1)
39251 XM2=PMAS(PYCOMP(KSUSY1+5),1)
39252 IF(XMI.GE.XM1+XM2) THEN
39253 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39255 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39256 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
39257 IDLAM(LKNT,1)=KSUSY1+6
39258 IDLAM(LKNT,2)=-(KSUSY1+5)
39263 XM1=PMAS(PYCOMP(KSUSY2+6),1)
39264 XM2=PMAS(PYCOMP(KSUSY1+5),1)
39265 IF(XMI.GE.XM1+XM2) THEN
39266 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39268 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39269 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
39270 IDLAM(LKNT,1)=KSUSY2+6
39271 IDLAM(LKNT,2)=-(KSUSY1+5)
39276 XM1=PMAS(PYCOMP(KSUSY1+6),1)
39277 XM2=PMAS(PYCOMP(KSUSY2+5),1)
39278 IF(XMI.GE.XM1+XM2) THEN
39279 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39281 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39282 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
39283 IDLAM(LKNT,1)=KSUSY1+6
39284 IDLAM(LKNT,2)=-(KSUSY2+5)
39289 XM1=PMAS(PYCOMP(KSUSY2+6),1)
39290 XM2=PMAS(PYCOMP(KSUSY2+5),1)
39291 IF(XMI.GE.XM1+XM2) THEN
39292 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39294 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
39295 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
39296 IDLAM(LKNT,1)=KSUSY2+6
39297 IDLAM(LKNT,2)=-(KSUSY2+5)
39302 GL=-XMW/SR2*SIN(2D0*BETA)
39304 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
39305 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
39306 IF(XMI.GE.XM1+XM2) THEN
39307 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39309 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
39310 IDLAM(LKNT,1)=-(KSUSY1+IJ)
39311 IDLAM(LKNT,2)=KSUSY1+IJ+1
39319 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
39320 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
39321 IF(XMI.GE.XM1+XM2) THEN
39322 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39324 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
39325 IDLAM(LKNT,1)=-(KSUSY1+IJ)
39326 IDLAM(LKNT,2)=KSUSY1+IJ+1
39331 C...H+ -> TAU1 NUTAUL
39332 XM1=PMAS(PYCOMP(KSUSY1+15),1)
39333 XM2=PMAS(PYCOMP(KSUSY1+16),1)
39334 IF(XMI.GE.XM1+XM2) THEN
39335 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39337 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
39338 IDLAM(LKNT,1)=-(KSUSY1+15)
39339 IDLAM(LKNT,2)= KSUSY1+16
39343 C...H+ -> TAU2 NUTAUL
39344 XM1=PMAS(PYCOMP(KSUSY2+15),1)
39345 XM2=PMAS(PYCOMP(KSUSY1+16),1)
39346 IF(XMI.GE.XM1+XM2) THEN
39347 XL=PYLAMF(XMI2,XM1**2,XM2**2)
39349 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
39350 IDLAM(LKNT,1)=-(KSUSY2+15)
39351 IDLAM(LKNT,2)= KSUSY1+16
39359 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
39360 XLAM(0)=XLAM(0)+XLAM(I)
39362 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
39367 C*********************************************************************
39370 C...Calculates the decay rate for a Higgs to an ino pair.
39372 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
39374 C...Double precision and integer declarations.
39375 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39376 IMPLICIT INTEGER(I-N)
39377 INTEGER PYK,PYCHGE,PYCOMP
39379 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39382 C...Local variables.
39383 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
39384 DOUBLE PRECISION XL,PYLAMF,C1
39385 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
39391 XL=PYLAMF(XMI2,XMJ2,XMK2)
39392 PYH2XX=C1/4D0/XMI3*SQRT(XL)
39393 &*(GX2*(XMI2-XMJ2-XMK2)-
39395 IF(PYH2XX.LT.0D0) THEN
39396 WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
39397 WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GX2,GLR,XM1,XM2,XM3
39404 C*********************************************************************
39407 C...Integration by adaptive Gaussian quadrature.
39408 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
39410 FUNCTION PYGAUS(F, A, B, EPS)
39412 C...Double precision and integer declarations.
39413 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39414 IMPLICIT INTEGER(I-N)
39415 INTEGER PYK,PYCHGE,PYCOMP
39417 C...Local declarations.
39419 DOUBLE PRECISION F,W(12), X(12)
39420 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
39421 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
39422 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
39423 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
39424 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
39425 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
39426 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
39427 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
39428 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
39429 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
39430 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
39431 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
39433 C...The Gaussian quadrature algorithm.
39435 IF(B .EQ. A) GOTO 140
39436 CONST = 5D-3 / ABS(B-A)
39447 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
39452 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
39455 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
39457 IF(BB .NE. B) GOTO 100
39460 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
39462 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
39471 C*********************************************************************
39474 C...Integration by adaptive Gaussian quadrature.
39475 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
39476 C...Carbon copy of PYGAUS, but avoids having to use it recursively.
39478 FUNCTION PYGAU2(F, A, B, EPS)
39480 C...Double precision and integer declarations.
39481 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39482 IMPLICIT INTEGER(I-N)
39483 INTEGER PYK,PYCHGE,PYCOMP
39485 C...Local declarations.
39487 DOUBLE PRECISION F,W(12), X(12)
39488 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
39489 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
39490 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
39491 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
39492 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
39493 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
39494 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
39495 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
39496 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
39497 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
39498 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
39499 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
39501 C...The Gaussian quadrature algorithm.
39503 IF(B .EQ. A) GOTO 140
39504 CONST = 5D-3 / ABS(B-A)
39515 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
39520 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
39523 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
39525 IF(BB .NE. B) GOTO 100
39528 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
39530 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
39539 C*********************************************************************
39542 C...Simpson formula for an integral.
39544 FUNCTION PYSIMP(Y,X0,X1,N)
39546 C...Double precision and integer declarations.
39547 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39548 IMPLICIT INTEGER(I-N)
39549 INTEGER PYK,PYCHGE,PYCOMP
39551 C...Local variables.
39552 DOUBLE PRECISION Y,X0,X1,H,S
39558 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
39565 C*********************************************************************
39568 C...The standard lambda function.
39570 FUNCTION PYLAMF(X,Y,Z)
39572 C...Double precision and integer declarations.
39573 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39574 IMPLICIT INTEGER(I-N)
39575 INTEGER PYK,PYCHGE,PYCOMP
39577 C...Local variables.
39578 DOUBLE PRECISION PYLAMF,X,Y,Z
39580 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
39581 IF(PYLAMF.LT.0D0) PYLAMF=0D0
39586 C*********************************************************************
39589 C...Generates 3-body decays of gauginos.
39591 SUBROUTINE PYTBDY(IDIN)
39593 C...Double precision and integer declarations.
39594 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39595 IMPLICIT INTEGER(I-N)
39596 INTEGER PYK,PYCHGE,PYCOMP
39597 C...Parameter statement to help give large particle numbers.
39598 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
39599 &KEXCIT=4000000,KDIMEN=5000000)
39601 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39602 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39603 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39604 C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
39605 C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39606 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
39607 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
39608 C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
39609 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
39611 C...Local variables.
39612 DOUBLE PRECISION XM(5)
39613 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
39614 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
39615 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
39616 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
39617 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
39618 DOUBLE PRECISION CPHI1,SPHI1
39619 DOUBLE PRECISION S23DEL,EPS
39620 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
39621 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
39622 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
39624 DATA INOID/22,23,25,35/
39635 S12MIN=(XM(1)+XM(2))**2
39636 S12MAX=(XM(5)-XM(3))**2
39637 YJACO1=S12MAX-S12MIN
39639 C...Initialize some parameters
39648 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
39649 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
39651 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
39652 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
39653 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
39654 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
39659 EI=KCHG(IABS(IA),1)/3D0
39660 T3I=SIGN(1D0,EI+1D-6)/2D0
39661 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
39663 ELSEIF(IZID1*IZID2.NE.0) THEN
39665 GMMZ=PMAS(23,1)*PMAS(23,2)
39667 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
39668 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
39670 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
39671 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
39673 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
39675 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
39677 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
39678 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
39679 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
39680 XM1M2=SMZ(IZID1)*SMZ(IZID2)
39681 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
39683 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
39685 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
39687 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
39689 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
39690 IF(IZID1.NE.0) THEN
39691 XM1M2=SMZ(IZID1)*SMW(IWID2)
39695 XM1M2=SMZ(IZID2)*SMW(IWID1)
39698 RT2I = 1D0/SQRT(2D0)
39700 GMMZ=PMAS(24,1)*PMAS(24,2)
39702 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
39703 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
39706 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
39708 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
39709 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
39710 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
39711 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
39713 T3J=SIGN(1D0,EJ+1D-6)/2D0
39714 QRLS=DCMPLX(0D0,0D0)
39720 XLR2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
39721 XLL2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
39722 IF(MOD(IA,2).EQ.0) THEN
39723 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
39724 & TANW+ZMIXC(IZID2,2)*T3I)
39725 QLRT=-DCONJG(UMIXC(IZID1,1))*(
39726 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
39728 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
39729 & TANW+ZMIXC(IZID2,2)*T3J)
39730 QLRT=-DCONJG(UMIXC(IZID1,1))*(
39731 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
39733 ELSEIF(IWID1*IWID2.NE.0) THEN
39736 XM1M2=SMW(IWID1)*SMW(IWID2)
39738 GMMZ=PMAS(23,1)*PMAS(23,2)
39740 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
39741 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
39742 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
39743 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
39745 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
39746 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
39747 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
39748 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
39749 QRLS=-DCMPLX(EI/XW1)*ORPP
39750 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
39751 QRRS=-DCMPLX(EI/XW1)*OLPP
39752 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
39753 IF(MOD(IA,2).EQ.0) THEN
39754 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
39755 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
39757 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
39758 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
39760 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
39767 IF(ISKIP.NE.0) THEN
39770 S12=S12MIN+YJACO1*(KT-1)/99
39771 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
39772 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
39773 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
39774 & -(2D0*XM(1)*XM(2))**2
39775 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
39776 & -(2D0*XM(3)*XM(5))**2
39779 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
39781 S23MIN=S23AVE-S23DEL
39782 S23MAX=S23AVE+S23DEL
39783 YJACO2=S23MAX-S23MIN
39786 S23=S23MIN+YJACO2*(KS-1)/99
39789 WU2 = (UH-ZM12)*(UH-ZM22)
39790 WT2 = (TH-ZM12)*(TH-ZM22)
39792 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
39793 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
39794 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
39795 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
39796 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
39797 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
39798 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
39799 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
39800 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
39801 IF(WT0.GT.WTMAX) WTMAX=WT0
39811 BX=S12MIN+0.5D0*YJACO1
39814 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
39822 C...SOLVE FOR F1 AND F2
39823 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
39824 &-(2D0*XM(1)*XM(2))**2
39825 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
39826 &-(2D0*XM(3)*XM(5))**2
39829 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
39831 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
39832 &-(2D0*XM(1)*XM(2))**2
39833 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
39834 &-(2D0*XM(3)*XM(5))**2
39837 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
39840 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
39841 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
39847 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
39848 & -(2D0*XM(1)*XM(2))**2
39849 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
39850 & -(2D0*XM(3)*XM(5))**2
39853 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
39860 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
39861 & -(2D0*XM(1)*XM(2))**2
39862 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
39863 & -(2D0*XM(3)*XM(5))**2
39866 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
39871 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
39881 180 S12=S12MIN+PYR(0)*YJACO1
39884 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
39885 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
39886 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
39887 &-(2D0*XM(1)*XM(2))**2
39888 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
39889 &-(2D0*XM(3)*XM(5))**2
39892 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
39894 S23MIN=S23AVE-S23DEL
39895 S23MAX=S23AVE+S23DEL
39896 YJACO2=S23MAX-S23MIN
39897 S23=S23MIN+PYR(0)*YJACO2
39899 C...CHECK THE SAMPLING
39900 IF(IKNT.GT.100) THEN
39901 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
39904 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
39906 IF(ISKIP.EQ.0) GOTO 190
39912 WU2 = (UH-ZM12)*(UH-ZM22)
39913 WT2 = (TH-ZM12)*(TH-ZM22)
39915 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
39916 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
39918 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
39919 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
39920 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
39921 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
39922 c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
39923 c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
39924 c &/DCMPLX(TH-XML2)
39925 c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
39926 c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
39927 c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
39928 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
39929 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
39930 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
39932 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
39933 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
39935 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
39936 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
39938 P1=SQRT(D1*D1-XM(1)**2)
39939 P2=SQRT(D2*D2-XM(2)**2)
39940 P3=SQRT(D3*D3-XM(3)**2)
39941 CTHE1=2D0*PYR(0)-1D0
39942 ANG1=2D0*PYR(0)*PARU(1)
39946 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
39948 P(N+1,1)=P1*STHE1*CPHI1
39949 P(N+1,2)=P1*STHE1*SPHI1
39954 ANG3=2D0*PYR(0)*PARU(1)
39957 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
39959 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
39961 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
39962 &+P3*STHE3*SPHI3*SPHI1
39963 &+P3*CTHE3*STHE1*CPHI1
39964 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
39965 &-P3*STHE3*SPHI3*CPHI1
39966 &+P3*CTHE3*STHE1*SPHI1
39967 P(N+3,3)=P3*STHE3*CPHI3*STHE1
39972 P(N+2,I)=-P(N+1,I)-P(N+3,I)
39979 C*********************************************************************
39982 C...Finds the s-hat dependent eigenvalues of the inverse propagator
39983 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
39984 C...phase space generation.
39986 SUBROUTINE PYTECM(S1,S2)
39988 C...Double precision and integer declarations.
39989 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39990 IMPLICIT INTEGER(I-N)
39991 INTEGER PYK,PYCHGE,PYCOMP
39992 C...Parameter statement to help give large particle numbers.
39993 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
39994 &KEXCIT=4000000,KDIMEN=5000000)
39996 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39997 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39998 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39999 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
40000 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
40002 C...Local variables.
40003 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12),
40004 &AT(4,4),WI(4),FV1(4),FV2(4),FV3(4),sh,aem,tanw,ct2w,qupd,alprht,
40005 &far,fao,fzr,fzo,shr,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5)
40008 SH=PMAS(PYCOMP(KTECHN+113),1)**2
40011 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
40012 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
40013 QUPD=2D0*RTCM(2)-1D0
40015 ALPRHT=2.91D0*(3D0/DBLE(ITCM(1)))
40016 FAR=SQRT(AEM/ALPRHT)
40022 AR(2,2) = SH-PMAS(23,1)**2
40023 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
40024 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
40044 CALL PYWIDT(23,SH,WDTP,WDTE)
40045 AT(2,2) = WDTP(0)*SHR
40046 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
40047 AT(3,3) = WDTP(0)*SHR
40048 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
40049 AT(4,4) = WDTP(0)*SHR
40051 CALL PYEICG(4,4,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
40053 WI(I)=SQRT(ABS(SH-WR(I)))
40056 R1=MIN(WR(1),WR(2),WR(3),WR(4))
40061 IF(ABS(WR(I)-R1).LT.1D-6) THEN
40065 IF(WR(I).LE.R2) THEN
40075 C*********************************************************************
40078 C...Finds eigenvalues of a general complex matrix
40080 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
40081 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
40082 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
40083 C OF A COMPLEX GENERAL MATRIX.
40087 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
40088 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40089 C DIMENSION STATEMENT.
40091 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
40093 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
40094 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
40096 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
40097 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
40098 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
40102 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
40103 C RESPECTIVELY, OF THE EIGENVALUES.
40105 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
40106 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
40108 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
40109 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
40110 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
40112 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
40114 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40115 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40117 C THIS VERSION DATED AUGUST 1983.
40120 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
40122 INTEGER N,NM,IS1,IS2,IERR,MATZ
40123 DOUBLE PRECISION AR(4,4),AI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
40124 X FV1(4),FV2(4),FV3(4)
40125 IF (N .LE. NM) GOTO 100
40129 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
40130 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
40131 IF (MATZ .NE. 0) GOTO 110
40132 C .......... FIND EIGENVALUES ONLY ..........
40133 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
40135 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
40136 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
40137 IF (IERR .NE. 0) GOTO 120
40138 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
40142 C*********************************************************************
40145 C...Auxiliary to PYEICG.
40147 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
40148 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
40150 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
40151 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
40152 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
40154 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
40155 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
40159 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
40160 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40161 C DIMENSION STATEMENT.
40163 C N IS THE ORDER OF THE MATRIX.
40165 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
40166 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
40167 C SET LOW=1, IGH=N.
40169 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
40170 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
40171 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
40172 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
40173 C THE REDUCTION BY CORTH, IF PERFORMED.
40177 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
40178 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
40179 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
40180 C EIGENVECTORS IS TO BE PERFORMED.
40182 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
40183 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
40184 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
40185 C FOR INDICES IERR+1,...,N.
40188 C ZERO FOR NORMAL RETURN,
40189 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
40190 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
40192 C CALLS PYCDIV FOR COMPLEX DIVISION.
40193 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
40194 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
40196 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40197 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40199 C THIS VERSION DATED AUGUST 1983.
40202 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
40204 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
40205 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4)
40206 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
40210 IF (LOW .EQ. IGH) GOTO 130
40211 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
40216 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
40217 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
40218 YR = HR(I,I-1) / NORM
40219 YI = HI(I,I-1) / NORM
40224 SI = YR * HI(I,J) - YI * HR(I,J)
40225 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
40230 SI = YR * HI(J,I) + YI * HR(J,I)
40231 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
40236 C .......... STORE ROOTS ISOLATED BY CBAL ..........
40237 130 DO 140 I = 1, N
40238 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
40247 C .......... SEARCH FOR NEXT EIGENVALUE ..........
40248 150 IF (EN .LT. LOW) GOTO 320
40251 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
40252 C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
40253 160 DO 170 LL = LOW, EN
40255 IF (L .EQ. LOW) GOTO 180
40256 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
40257 X + DABS(HR(L,L)) + DABS(HI(L,L))
40258 TST2 = TST1 + DABS(HR(L,L-1))
40259 IF (TST2 .EQ. TST1) GOTO 180
40261 C .......... FORM SHIFT ..........
40262 180 IF (L .EQ. EN) GOTO 300
40263 IF (ITN .EQ. 0) GOTO 310
40264 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
40267 XR = HR(ENM1,EN) * HR(EN,ENM1)
40268 XI = HI(ENM1,EN) * HR(EN,ENM1)
40269 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
40270 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
40271 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
40272 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
40273 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
40276 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
40280 C .......... FORM EXCEPTIONAL SHIFT ..........
40281 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
40284 210 DO 220 I = LOW, EN
40285 HR(I,I) = HR(I,I) - SR
40286 HI(I,I) = HI(I,I) - SI
40293 C .......... REDUCE TO TRIANGLE (ROWS) ..........
40299 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
40300 XR = HR(I-1,I-1) / NORM
40302 XI = HI(I-1,I-1) / NORM
40305 HI(I-1,I-1) = 0.0D0
40306 HI(I,I-1) = SR / NORM
40313 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
40314 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
40315 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
40316 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
40322 IF (SI .EQ. 0.0D0) GOTO 250
40323 NORM = PYTHAG(HR(EN,EN),SI)
40324 SR = HR(EN,EN) / NORM
40328 C .......... INVERSE OPERATION (COLUMNS) ..........
40329 250 DO 280 J = LP1, EN
40338 IF (I .EQ. J) GOTO 260
40340 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
40341 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
40342 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
40343 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
40348 IF (SI .EQ. 0.0D0) GOTO 160
40353 HR(I,EN) = SR * YR - SI * YI
40354 HI(I,EN) = SR * YI + SI * YR
40358 C .......... A ROOT FOUND ..........
40359 300 WR(EN) = HR(EN,EN) + TR
40360 WI(EN) = HI(EN,EN) + TI
40363 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
40364 C CONVERGED AFTER 30*N ITERATIONS ..........
40369 C*********************************************************************
40372 C...Auxiliary to PYEICG.
40374 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
40375 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
40377 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
40378 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
40379 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
40381 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
40382 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
40383 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
40384 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
40385 C THIS GENERAL MATRIX TO HESSENBERG FORM.
40389 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
40390 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40391 C DIMENSION STATEMENT.
40393 C N IS THE ORDER OF THE MATRIX.
40395 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
40396 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
40397 C SET LOW=1, IGH=N.
40399 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
40400 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
40401 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
40402 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
40403 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
40405 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
40406 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
40407 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
40408 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
40409 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
40410 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
40415 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
40416 C HAVE BEEN DESTROYED.
40418 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
40419 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
40420 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
40421 C FOR INDICES IERR+1,...,N.
40423 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
40424 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
40425 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
40426 C THE EIGENVECTORS HAS BEEN FOUND.
40429 C ZERO FOR NORMAL RETURN,
40430 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
40431 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
40433 C CALLS PYCDIV FOR COMPLEX DIVISION.
40434 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
40435 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
40437 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40438 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40440 C THIS VERSION DATED OCTOBER 1989.
40442 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
40443 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
40446 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
40448 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
40449 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
40450 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
40452 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
40456 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
40465 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
40466 C FROM THE INFORMATION LEFT BY CORTH ..........
40467 IEND = IGH - LOW - 1
40468 IF (IEND.LT.0) GOTO 220
40469 IF (IEND.EQ.0) GOTO 170
40470 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
40471 DO 160 II = 1, IEND
40473 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
40474 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
40475 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
40476 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
40479 DO 120 K = IP1, IGH
40480 ORTR(K) = HR(K,I-1)
40481 ORTI(K) = HI(K,I-1)
40489 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
40490 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
40497 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
40498 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
40504 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
40509 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
40510 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
40511 YR = HR(I,I-1) / NORM
40512 YI = HI(I,I-1) / NORM
40517 SI = YR * HI(I,J) - YI * HR(I,J)
40518 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
40523 SI = YR * HI(J,I) + YI * HR(J,I)
40524 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
40528 DO 200 J = LOW, IGH
40529 SI = YR * ZI(J,I) + YI * ZR(J,I)
40530 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
40535 C .......... STORE ROOTS ISOLATED BY CBAL ..........
40536 220 DO 230 I = 1, N
40537 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
40546 C .......... SEARCH FOR NEXT EIGENVALUE ..........
40547 240 IF (EN .LT. LOW) GOTO 430
40550 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
40551 C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
40552 250 DO 260 LL = LOW, EN
40554 IF (L .EQ. LOW) GOTO 270
40555 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
40556 X + DABS(HR(L,L)) + DABS(HI(L,L))
40557 TST2 = TST1 + DABS(HR(L,L-1))
40558 IF (TST2 .EQ. TST1) GOTO 270
40560 C .......... FORM SHIFT ..........
40561 270 IF (L .EQ. EN) GOTO 420
40562 IF (ITN .EQ. 0) GOTO 550
40563 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
40566 XR = HR(ENM1,EN) * HR(EN,ENM1)
40567 XI = HI(ENM1,EN) * HR(EN,ENM1)
40568 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
40569 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
40570 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
40571 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
40572 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
40575 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
40579 C .......... FORM EXCEPTIONAL SHIFT ..........
40580 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
40583 300 DO 310 I = LOW, EN
40584 HR(I,I) = HR(I,I) - SR
40585 HI(I,I) = HI(I,I) - SI
40592 C .......... REDUCE TO TRIANGLE (ROWS) ..........
40598 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
40599 XR = HR(I-1,I-1) / NORM
40601 XI = HI(I-1,I-1) / NORM
40604 HI(I-1,I-1) = 0.0D0
40605 HI(I,I-1) = SR / NORM
40612 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
40613 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
40614 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
40615 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
40621 IF (SI .EQ. 0.0D0) GOTO 350
40622 NORM = PYTHAG(HR(EN,EN),SI)
40623 SR = HR(EN,EN) / NORM
40627 IF (EN .EQ. N) GOTO 350
40633 HR(EN,J) = SR * YR + SI * YI
40634 HI(EN,J) = SR * YI - SI * YR
40636 C .......... INVERSE OPERATION (COLUMNS) ..........
40637 350 DO 390 J = LP1, EN
40646 IF (I .EQ. J) GOTO 360
40648 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
40649 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
40650 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
40651 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
40654 DO 380 I = LOW, IGH
40659 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
40660 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
40661 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
40662 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
40667 IF (SI .EQ. 0.0D0) GOTO 250
40672 HR(I,EN) = SR * YR - SI * YI
40673 HI(I,EN) = SR * YI + SI * YR
40676 DO 410 I = LOW, IGH
40679 ZR(I,EN) = SR * YR - SI * YI
40680 ZI(I,EN) = SR * YI + SI * YR
40684 C .......... A ROOT FOUND ..........
40685 420 HR(EN,EN) = HR(EN,EN) + TR
40687 HI(EN,EN) = HI(EN,EN) + TI
40691 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
40692 C VECTORS OF UPPER TRIANGULAR FORM ..........
40698 TR = DABS(HR(I,J)) + DABS(HI(I,J))
40699 IF (TR .GT. NORM) NORM = TR
40702 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
40703 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
40711 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
40712 DO 490 II = 1, ENM1
40719 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
40720 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
40725 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
40728 460 YR = 0.01D0 * YR
40730 IF (TST2 .GT. TST1) GOTO 460
40732 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
40733 C .......... OVERFLOW CONTROL ..........
40734 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
40735 IF (TR .EQ. 0.0D0) GOTO 490
40737 TST2 = TST1 + 1.0D0/TST1
40738 IF (TST2 .GT. TST1) GOTO 490
40740 HR(J,EN) = HR(J,EN)/TR
40741 HI(J,EN) = HI(J,EN)/TR
40747 C .......... END BACKSUBSTITUTION ..........
40748 C .......... VECTORS OF ISOLATED ROOTS ..........
40750 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
40758 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
40759 C VECTORS OF ORIGINAL FULL MATRIX.
40760 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
40765 DO 540 I = LOW, IGH
40770 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
40771 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
40779 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
40780 C CONVERGED AFTER 30*N ITERATIONS ..........
40785 C*********************************************************************
40788 C...Auxiliary to PYCMQR
40790 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
40793 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
40795 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
40796 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
40798 S = DABS(BR) + DABS(BI)
40803 S = BRS**2 + BIS**2
40804 CR = (ARS*BRS + AIS*BIS)/S
40805 CI = (AIS*BRS - ARS*BIS)/S
40809 C*********************************************************************
40812 C...Auxiliary to PYCMQR
40814 C (YR,YI) = COMPLEX DSQRT(XR,XI)
40815 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
40818 SUBROUTINE PYCSRT(XR,XI,YR,YI)
40820 DOUBLE PRECISION XR,XI,YR,YI
40821 DOUBLE PRECISION S,TR,TI,PYTHAG
40825 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
40826 IF (TR .GE. 0.0D0) YR = S
40827 IF (TI .LT. 0.0D0) S = -S
40828 IF (TR .LE. 0.0D0) YI = S
40829 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
40830 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
40834 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
40835 DOUBLE PRECISION A,B
40837 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
40839 DOUBLE PRECISION P,R,S,T,U
40840 P = DMAX1(DABS(A),DABS(B))
40841 IF (P .EQ. 0.0D0) GOTO 110
40842 R = (DMIN1(DABS(A),DABS(B))/P)**2
40845 IF (T .EQ. 4.0D0) GOTO 110
40847 U = 1.0D0 + 2.0D0*S
40855 C*********************************************************************
40858 C...Auxiliary to PYEICG
40860 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
40861 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
40862 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
40863 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
40865 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
40866 C EIGENVALUES WHENEVER POSSIBLE.
40870 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
40871 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
40872 C DIMENSION STATEMENT.
40874 C N IS THE ORDER OF THE MATRIX.
40876 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
40877 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
40881 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
40882 C RESPECTIVELY, OF THE BALANCED MATRIX.
40884 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
40885 C ARE EQUAL TO ZERO IF
40886 C (1) I IS GREATER THAN J AND
40887 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
40889 C SCALE CONTAINS INFORMATION DETERMINING THE
40890 C PERMUTATIONS AND SCALING FACTORS USED.
40892 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
40893 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
40894 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
40895 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
40896 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
40897 C = D(J,J) J = LOW,...,IGH
40898 C = P(J) J = IGH+1,...,N.
40899 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
40902 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
40904 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
40905 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
40906 C K,L HAVE BEEN REVERSED.)
40908 C ARITHMETIC IS REAL THROUGHOUT.
40910 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
40911 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
40913 C THIS VERSION DATED AUGUST 1983.
40916 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
40918 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
40919 DOUBLE PRECISION AR(4,4),AI(4,4),SCALE(4)
40920 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
40929 C .......... IN-LINE PROCEDURE FOR ROW AND
40930 C COLUMN EXCHANGE ..........
40932 IF (J .EQ. M) GOTO 130
40952 130 IF(IEXC.EQ.1) GOTO 140
40953 IF(IEXC.EQ.2) GOTO 180
40954 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
40955 C AND PUSH THEM DOWN ..........
40956 140 IF (L .EQ. 1) GOTO 320
40958 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
40959 150 DO 170 JJ = 1, L
40963 IF (I .EQ. J) GOTO 160
40964 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
40973 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
40974 C AND PUSH THEM LEFT ..........
40977 190 DO 210 J = K, L
40980 IF (I .EQ. J) GOTO 200
40981 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
40988 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
40990 220 SCALE(I) = 1.0D0
40991 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
40992 230 NOCONV = .FALSE.
40999 IF (J .EQ. I) GOTO 240
41000 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
41001 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
41003 C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
41004 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
41008 250 IF (C .GE. G) GOTO 260
41013 270 IF (C .LT. G) GOTO 280
41017 C .......... NOW BALANCE ..........
41018 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
41020 SCALE(I) = SCALE(I) * F
41024 AR(I,J) = AR(I,J) * G
41025 AI(I,J) = AI(I,J) * G
41029 AR(J,I) = AR(J,I) * F
41030 AI(J,I) = AI(J,I) * F
41035 IF (NOCONV) GOTO 230
41042 C*********************************************************************
41045 C...Auxiliary to PYEICG.
41047 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
41048 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
41049 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
41050 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
41052 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
41053 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
41054 C BALANCED MATRIX DETERMINED BY CBAL.
41058 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
41059 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
41060 C DIMENSION STATEMENT.
41062 C N IS THE ORDER OF THE MATRIX.
41064 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
41066 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
41067 C AND SCALING FACTORS USED BY CBAL.
41069 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
41071 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
41072 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
41073 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
41077 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
41078 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
41079 C IN THEIR FIRST M COLUMNS.
41081 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
41082 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
41084 C THIS VERSION DATED AUGUST 1983.
41087 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
41089 INTEGER I,J,K,M,N,II,NM,IGH,LOW
41090 DOUBLE PRECISION SCALE(4),ZR(4,4),ZI(4,4)
41093 IF (M .EQ. 0) GOTO 150
41094 IF (IGH .EQ. LOW) GOTO 120
41096 DO 110 I = LOW, IGH
41098 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
41099 C IF THE FOREGOING STATEMENT IS REPLACED BY
41100 C S=1.0D0/SCALE(I). ..........
41102 ZR(I,J) = ZR(I,J) * S
41103 ZI(I,J) = ZI(I,J) * S
41107 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
41108 C IGH+1 STEP 1 UNTIL N DO -- ..........
41109 120 DO 140 II = 1, N
41111 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
41112 IF (I .LT. LOW) I = LOW - II
41114 IF (K .EQ. I) GOTO 140
41130 C*********************************************************************
41133 C...Auxiliary to PYEICG.
41135 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
41136 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
41137 C BY MARTIN AND WILKINSON.
41138 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
41140 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
41141 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
41142 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
41143 C UNITARY SIMILARITY TRANSFORMATIONS.
41147 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
41148 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
41149 C DIMENSION STATEMENT.
41151 C N IS THE ORDER OF THE MATRIX.
41153 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
41154 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
41155 C SET LOW=1, IGH=N.
41157 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
41158 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
41162 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
41163 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
41164 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
41165 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
41166 C HESSENBERG MATRIX.
41168 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
41169 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
41171 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
41173 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
41174 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
41176 C THIS VERSION DATED AUGUST 1983.
41179 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
41181 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
41182 DOUBLE PRECISION AR(4,4),AI(4,4),ORTR(4),ORTI(4)
41183 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
41187 IF (LA .LT. KP1) GOTO 210
41194 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
41196 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
41198 IF (SCALE .EQ. 0.0D0) GOTO 200
41200 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
41203 ORTR(I) = AR(I,M-1) / SCALE
41204 ORTI(I) = AI(I,M-1) / SCALE
41205 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
41209 F = PYTHAG(ORTR(M),ORTI(M))
41210 IF (F .EQ. 0.0D0) GOTO 120
41213 ORTR(M) = (1.0D0 + G) * ORTR(M)
41214 ORTI(M) = (1.0D0 + G) * ORTI(M)
41219 C .......... FORM (I-(U*UT)/H) * A ..........
41220 130 DO 160 J = M, N
41223 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
41226 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
41227 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
41234 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
41235 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
41239 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
41243 C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
41246 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
41247 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
41254 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
41255 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
41260 ORTR(M) = SCALE * ORTR(M)
41261 ORTI(M) = SCALE * ORTI(M)
41262 AR(M,M-1) = -G * AR(M,M-1)
41263 AI(M,M-1) = -G * AI(M,M-1)
41269 C*********************************************************************
41272 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
41275 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
41277 INTEGER N,NP,INDX(N)
41279 COMPLEX*16 A(NP,NP)
41280 PARAMETER (TINY=1.0D-20)
41282 REAL*8 AAMAX,VV(6),DUM
41283 COMPLEX*16 SUM,DUMC
41289 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
41291 IF (AAMAX.EQ.0D0) PAUSE 'SINGULAR MATRIX IN PYLDCM'
41298 SUM=SUM-A(I,K)*A(K,J)
41306 SUM=SUM-A(I,K)*A(K,J)
41310 IF (DUM.GE.AAMAX) THEN
41325 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
41328 A(I,J)=A(I,J)/A(J,J)
41336 C*********************************************************************
41339 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
41342 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
41344 INTEGER N,NP,INDX(N)
41345 COMPLEX*16 A(NP,NP),B(N)
41356 SUM=SUM-A(I,J)*B(J)
41358 ELSE IF (ABS(SUM).NE.0D0) THEN
41366 SUM=SUM-A(I,J)*B(J)
41373 C***********************************************************************
41376 C...Calculates full and partial widths of resonances.
41377 C....copy of PYWIDT, used for techniparticle widths
41379 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
41381 C...Double precision and integer declarations.
41382 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41383 IMPLICIT INTEGER(I-N)
41384 INTEGER PYK,PYCHGE,PYCOMP
41385 C...Parameter statement to help give large particle numbers.
41386 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
41387 &KEXCIT=4000000,KDIMEN=5000000)
41389 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41390 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41391 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
41392 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
41393 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41394 COMMON/PYINT1/MINT(400),VINT(400)
41395 COMMON/PYINT4/MWID(500),WIDS(500,5)
41396 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41397 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
41398 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
41399 &/PYINT4/,/PYMSSM/,/PYTCSM/
41400 C...Local arrays and saved variables.
41401 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
41403 SAVE MOFSV,WIDWSV,WID2SV
41404 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
41406 C...Compressed code and sign; mass.
41413 C...Reset width information.
41421 C...Common electroweak and strong constants.
41424 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
41427 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
41429 RADC=1D0+AS/PARU(1)
41431 IF(KFLA.EQ.23) THEN
41434 XWC=1D0/(16D0*XW*XW1)
41435 FAC=(AEM*XWC/3D0)*SHR
41437 DO 130 I=1,MDCY(KC,3)
41439 IF(MDME(IDC,1).LT.0) GOTO 130
41440 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
41441 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
41442 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
41447 AF=SIGN(1D0,EF+0.1D0)
41450 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
41451 IF(I.EQ.6) WID2=WIDS(6,1)
41452 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
41453 ELSEIF(I.LE.16) THEN
41454 C...Z0 -> l+ + l-, nu + nubar
41456 AF=SIGN(1D0,EF+0.1D0)
41459 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
41461 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
41462 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
41464 WDTP(0)=WDTP(0)+WDTP(I)
41465 IF(MDME(IDC,1).GT.0) THEN
41466 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
41467 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
41468 & WDTE(I,MDME(IDC,1))
41469 WDTE(I,0)=WDTE(I,MDME(IDC,1))
41470 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
41475 ELSEIF(KFLA.EQ.24) THEN
41477 FAC=(AEM/(24D0*XW))*SHR
41478 DO 140 I=1,MDCY(KC,3)
41480 IF(MDME(IDC,1).LT.0) GOTO 140
41481 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
41482 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
41483 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
41486 C...W+/- -> q + qbar'
41487 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
41489 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
41490 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
41491 IF(I.GE.13) WID2=WID2*WIDS(7,3)
41493 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
41494 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
41495 IF(I.GE.13) WID2=WID2*WIDS(7,2)
41497 ELSEIF(I.LE.20) THEN
41498 C...W+/- -> l+/- + nu
41501 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
41503 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
41506 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
41507 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
41508 WDTP(0)=WDTP(0)+WDTP(I)
41509 IF(MDME(IDC,1).GT.0) THEN
41510 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
41511 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
41512 WDTE(I,0)=WDTE(I,MDME(IDC,1))
41513 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
41517 C.....V8 -> quark anti-quark
41518 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
41521 IF(ITCM(2).EQ.0) THEN
41523 ELSEIF(ITCM(2).EQ.1) THEN
41526 DO 150 I=1,MDCY(KC,3)
41528 IF(MDME(IDC,1).LT.0) GOTO 150
41529 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
41531 IF(RM1.GT.0.25D0) GOTO 150
41533 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
41538 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
41539 IF(I.EQ.6) WID2=WIDS(6,1)
41540 WDTP(0)=WDTP(0)+WDTP(I)
41541 IF(MDME(IDC,1).GT.0) THEN
41542 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
41543 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
41544 WDTE(I,0)=WDTE(I,MDME(IDC,1))
41545 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
41553 C*********************************************************************
41556 C...Calculates R-violating decays of sfermions.
41559 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
41561 C...Double precision and integer declarations.
41562 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41563 IMPLICIT INTEGER(I-N)
41564 C...Parameter statement to help give large particle numbers.
41565 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
41566 &KEXCIT=4000000,KDIMEN=5000000)
41568 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41569 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41570 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
41571 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
41572 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
41573 C...Local variables.
41574 DOUBLE PRECISION XLAM(0:400)
41575 INTEGER IDLAM(400,3), PYCOMP
41576 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
41578 C...IS R-VIOLATION ON ?
41579 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
41580 C...Mass eigenstate counter
41581 ICNT=INT(KFIN/KSUSY1)
41582 C...SM KF code of SUSY particle
41583 KFSM=KFIN-ICNT*KSUSY1
41584 C...Squared Sparticle Mass
41585 SM=PMAS(PYCOMP(KFIN),1)**2
41586 C... Squared mass of top quark
41587 SMT=PMAS(PYCOMP(6),1)**2
41588 C...IS L-VIOLATION ON ?
41589 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
41590 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
41591 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
41597 C...~e,~mu,~tau -> nu_I + lepton-_J
41599 IDLAM(LKNT,1)= 12 +2*(I-1)
41600 IDLAM(LKNT,2)= 11 +2*(J-1)
41603 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41604 IF (IMSS(51).NE.0) XLAM(LKNT) =
41605 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41606 C...KINEMATICS CHECK
41607 IF (XLAM(LKNT).EQ.0D0) THEN
41613 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
41619 IDLAM(LKNT,1)=-12 -2*(I-1)
41620 IDLAM(LKNT,2)= 11 +2*(K-1)
41623 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41624 IF (IMSS(51).NE.0) XLAM(LKNT) =
41625 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41626 C...KINEMATICS CHECK
41627 IF (XLAM(LKNT).EQ.0D0) THEN
41633 C...~e,~mu,~tau -> u_Jbar + d_K
41638 IDLAM(LKNT,1)=-2 -2*(J-1)
41639 IDLAM(LKNT,2)= 1 +2*(K-1)
41642 IF (IMSS(52).NE.0) THEN
41643 C...Use massive top quark
41644 IF (IDLAM(LKNT,1).EQ.-6) THEN
41645 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
41648 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
41649 C...If no top quark, all decay products massless
41651 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41653 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41655 C...KINEMATICS CHECK
41656 IF (XLAM(LKNT).EQ.0D0) THEN
41663 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
41664 C...No right-handed neutrinos
41666 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
41671 C...~nu_J -> lepton+_I + lepton-_K
41673 IDLAM(LKNT,1)=-11 -2*(I-1)
41674 IDLAM(LKNT,2)= 11 +2*(K-1)
41677 RM2=RVLAM(I,J,K)**2 * SM
41678 IF (IMSS(51).NE.0) XLAM(LKNT) =
41679 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41680 C...KINEMATICS CHECK
41681 IF (XLAM(LKNT).EQ.0D0) THEN
41687 C...~nu_I -> dbar_J + d_K
41692 IDLAM(LKNT,1)=-1 -2*(J-1)
41693 IDLAM(LKNT,2)= 1 +2*(K-1)
41696 RM2=3*RVLAMP(I,J,K)**2 * SM
41697 IF (IMSS(52).NE.0) XLAM(LKNT) =
41698 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41699 C...KINEMATICS CHECK
41700 IF (XLAM(LKNT).EQ.0D0) THEN
41707 C * SDOWN -> NU(BAR) + D and LEPTON- + U
41708 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
41712 C...~d_J -> nu_Ibar + d_K
41714 IDLAM(LKNT,1)=-12 -2*(I-1)
41715 IDLAM(LKNT,2)= 1 +2*(K-1)
41718 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41719 IF (IMSS(52).NE.0) XLAM(LKNT) =
41720 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41721 C...KINEMATICS CHECK
41722 IF (XLAM(LKNT).EQ.0D0) THEN
41730 C...~d_K -> nu_I + d_J
41732 IDLAM(LKNT,1)= 12 +2*(I-1)
41733 IDLAM(LKNT,2)= 1 +2*(J-1)
41736 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41737 IF (IMSS(52).NE.0) XLAM(LKNT) =
41738 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41739 C...KINEMATICS CHECK
41740 IF (XLAM(LKNT).EQ.0D0) THEN
41743 C...~d_K -> lepton_I- + u_J
41745 IDLAM(LKNT,1)= 11 +2*(I-1)
41746 IDLAM(LKNT,2)= 2 +2*(J-1)
41749 IF (IMSS(52).NE.0) THEN
41750 C...Use massive top quark
41751 IF (IDLAM(LKNT,2).EQ.6) THEN
41752 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
41754 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
41755 C...If no top quark, all decay products massless
41757 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41759 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41761 C...KINEMATICS CHECK
41762 IF (XLAM(LKNT).EQ.0D0) THEN
41769 C * SUP -> LEPTON+ + D
41770 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
41774 C...~u_J -> lepton_I+ + d_K
41776 IDLAM(LKNT,1)=-11 -2*(I-1)
41777 IDLAM(LKNT,2)= 1 +2*(K-1)
41780 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
41781 IF (IMSS(52).NE.0) XLAM(LKNT) =
41782 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41783 C...KINEMATICS CHECK
41784 IF (XLAM(LKNT).EQ.0D0) THEN
41791 C...BARYON NUMBER VIOLATING DECAYS
41792 IF (IMSS(53).GE.1) THEN
41793 C * SUP -> DBAR + DBAR
41794 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
41798 C...~u_I -> dbar_J + dbar_K
41800 C...(anti-) symmetry J <-> K.
41802 IDLAM(LKNT,1) = -1 -2*(J-1)
41803 IDLAM(LKNT,2) = -1 -2*(K-1)
41806 RM2 = 2.*(RVLAMB(I,J,K)**2)
41807 & * SFMIX(KFSM,2*ICNT)**2 * SM
41809 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41810 C...KINEMATICS CHECK
41811 IF (XLAM(LKNT).EQ.0D0) THEN
41818 C * SDOWN -> UBAR + DBAR
41819 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
41823 C...LAMB coupling antisymmetric in J and K.
41825 C...~d_K -> ubar_I + dbar_K
41827 IDLAM(LKNT,1)= -2 -2*(I-1)
41828 IDLAM(LKNT,2)= -1 -2*(J-1)
41831 C...Use massive top quark
41832 IF (IDLAM(LKNT,1).EQ.-6) THEN
41833 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
41836 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
41837 C...If no top quark, all decay products massless
41839 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
41841 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
41843 C...KINEMATICS CHECK
41844 IF (XLAM(LKNT).EQ.0D0) THEN
41857 C*********************************************************************
41860 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
41863 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
41865 C...Double precision and integer declarations.
41866 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41867 IMPLICIT INTEGER(I-N)
41868 C...Parameter statement to help give large particle numbers.
41869 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
41870 &KEXCIT=4000000,KDIMEN=5000000)
41872 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41873 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41874 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41875 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
41876 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
41877 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
41878 C...Local variables.
41879 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
41881 DOUBLE PRECISION XLAM(0:400)
41882 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
41883 INTEGER IDLAM(400,3), PYCOMP
41885 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
41887 C...R-VIOLATING DECAYS
41888 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
41890 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
41891 C...WHICH NEUTRALINO ?
41893 IF (KFSM.EQ.23) NCHI=2
41894 IF (KFSM.EQ.25) NCHI=3
41895 IF (KFSM.EQ.35) NCHI=4
41896 C...SIGN OF MASS (Opposite convention as HERWIG)
41898 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
41900 C...Useful parameters for the calculation of the A and B constants.
41901 WMASS = PMAS(PYCOMP(24),1)
41902 ECHG = 2*SQRT(PARU(103)*PARU(1))
41903 COSB=1/(SQRT(1+RMSS(5)**2))
41904 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
41905 COSW=SQRT(1-PARU(102))
41906 SINW=SQRT(PARU(102))
41907 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
41908 C...Run quark masses to neutralino mass squared (for Higgs-type
41910 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
41912 RMQ(I)=PYMRUN(I,SQMCHI)
41914 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
41916 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
41917 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
41918 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
41919 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
41921 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
41922 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
41923 C2=ECHG*ZPMIX(NCHI,1)
41924 C3=GW*ZPMIX(NCHI,2)/COSW
41928 C x=1-2 : Select A or B constant (1:A ; 2:B)
41929 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
41930 C 11-16:e,nu_e,mu,...)
41931 C z=1-2 : Mass eigenstate number
41932 C...CALCULATE COUPLINGS
41934 CMS=PMAS(PYCOMP(I),1)
41935 C...Intermediate sleptons
41936 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
41937 & *(C2-C3*SINW**2))
41938 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
41939 & *(C2-C3*SINW**2))
41940 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
41942 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
41944 C...Inermediate sneutrinos
41946 AB(2,I+1,1)=5D-1*C3
41949 C...Inermediate sdown
41952 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
41953 & *ED*(C2-C3*SINW**2))
41954 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
41955 & *ED*(C2-C3*SINW**2))
41956 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
41957 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
41958 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
41959 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
41960 C...Inermediate sup
41963 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
41964 & *EU*(C2-C3*SINW**2))
41965 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
41966 & *EU*(C2-C3*SINW**2))
41967 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
41968 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
41969 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
41970 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
41973 IF (IMSS(51).GE.1) THEN
41974 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
41975 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
41976 C...STEP IN I,J,K USING SINGLE COUNTER
41978 C...LAMBDA COUPLING ASYM IN I,J
41979 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
41981 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
41982 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
41983 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
41985 C...Set coupling, and decay product masses on/off
41986 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
41987 & ,MOD(ISC,3)+1)**2
41989 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
41991 C...Resonance KF codes (1=I,2=J,3=K)
41992 KFR(1)=-IDLAM(LKNT,1)
41993 KFR(2)=-IDLAM(LKNT,2)
41994 KFR(3)=-IDLAM(LKNT,3)
41995 C...Calculate width.
41996 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
41997 & IDLAM(LKNT,3),XLAM(LKNT))
41998 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
41999 C...Charge conjugate mode.
42001 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42002 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42003 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42004 XLAM(LKNT)=XLAM(LKNT-1)
42005 C...KINEMATICS CHECK
42006 IF (XLAM(LKNT).EQ.0D0) THEN
42013 IF (IMSS(52).GE.1) THEN
42014 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
42015 C * CHI0 -> NUBAR_I + DBAR_J + D_K
42018 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
42019 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42020 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42022 C...Set coupling, and decay product masses on/off
42023 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
42024 & ,MOD(ISC,3)+1)**2
42026 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
42028 C...Resonance KF codes (1=I,2=J,3=K)
42029 KFR(1)=-IDLAM(LKNT,1)
42030 KFR(2)=-IDLAM(LKNT,2)
42031 KFR(3)=-IDLAM(LKNT,3)
42032 C...Calculate width.
42033 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42035 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42036 C...Charge conjugate mode.
42038 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42039 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42040 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42041 XLAM(LKNT)=XLAM(LKNT-1)
42042 C...KINEMATICS CHECK
42043 IF (XLAM(LKNT).EQ.0D0) THEN
42047 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
42049 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42050 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
42051 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42053 C...Set coupling, and decay product masses on/off
42054 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
42055 & ,MOD(ISC,3)+1)**2
42057 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
42058 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
42059 C...Resonance KF codes (1=I,2=J,3=K)
42060 KFR(1)=-IDLAM(LKNT,1)
42061 KFR(2)=-IDLAM(LKNT,2)
42062 KFR(3)=-IDLAM(LKNT,3)
42063 C...Calculate width.
42064 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42066 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42067 C...Charge conjugate mode.
42069 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42070 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42071 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42072 XLAM(LKNT)=XLAM(LKNT-1)
42073 C...KINEMATICS CHECK
42074 IF (XLAM(LKNT).EQ.0D0) THEN
42080 IF (IMSS(53).GE.1) THEN
42081 C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
42082 C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
42084 C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
42085 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
42087 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
42088 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42089 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42091 C...Set coupling, and decay product masses on/off
42092 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
42093 & +1,MOD(ISC,3)+1)**2
42095 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
42096 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
42097 C...Resonance KF codes (1=I,2=J,3=K)
42098 KFR(1) = IDLAM(LKNT,1)
42099 KFR(2) = IDLAM(LKNT,2)
42100 KFR(3) = IDLAM(LKNT,3)
42101 C...Calculate width.
42102 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42103 & IDLAM(LKNT,3),XLAM(LKNT))
42104 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42105 C...Charge conjugate mode.
42107 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
42108 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
42109 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
42110 XLAM(LKNT)=XLAM(LKNT-1)
42111 C...KINEMATICS CHECK
42112 IF (XLAM(LKNT).EQ.0D0) THEN
42124 C*********************************************************************
42127 C...Calculates R-violating chargino decay widths.
42130 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
42132 C...Double precision and integer declarations.
42133 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42134 IMPLICIT INTEGER(I-N)
42135 C...Parameter statement to help give large particle numbers.
42136 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42137 &KEXCIT=4000000,KDIMEN=5000000)
42139 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42140 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42141 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42142 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42143 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42144 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
42145 C...Local variables.
42146 DOUBLE PRECISION XLAM(0:400)
42147 INTEGER IDLAM(400,3), PYCOMP
42148 C...Information from main routine to PYRVGW
42149 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
42151 C...Auxiliary variables needed for BV (RV Gauge STOre)
42152 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
42154 C...Running quark masses
42155 DOUBLE PRECISION RMQ(6)
42156 C...Decay product masses on/off
42158 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
42162 C...IF R-VIOLATION ON.
42163 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
42165 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
42166 C...WHICH CHARGINO ?
42168 IF (KFSM.EQ.37) NCHI = 2
42170 C...Useful parameters for calculating the A and B constants.
42171 C...SIGN OF MASS (Opposite convention as HERWIG)
42173 IF (SMW(NCHI).LT.0D0) ISM = -1
42174 WMASS = PMAS(PYCOMP(24),1)
42175 COSB = 1/(SQRT(1+RMSS(5)**2))
42176 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
42177 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
42178 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
42179 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
42182 C...Running masses at Q^2=MCHI^2.
42183 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
42185 RMQ(I)=PYMRUN(I,SQMCHI)
42188 C... AB(x,y,z) coefficients:
42189 C x=1-2 : A or B coefficient (1:A ; 2:B)
42190 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
42191 C 11-16:e,nu_e,mu,...)
42192 C z=1-2 : Mass eigenstate number
42194 C...Intermediate sleptons
42197 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
42199 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
42201 C...Intermediate sneutrinos
42202 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
42204 AB(2,I+1,1) = ISM*C3
42206 C...Intermediate sdown
42208 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
42209 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
42210 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
42211 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
42212 C...Intermediate sup
42214 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
42215 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
42216 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
42217 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
42220 C...LLE TYPE R-VIOLATION
42221 IF (IMSS(51).GE.1) THEN
42222 C...LOOP OVER DECAY MODES
42225 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
42226 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
42228 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
42229 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
42230 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
42232 C...Set coupling, and decay product masses on/off
42233 RVLAMC = GW2 * 5D-1 *
42234 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
42237 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
42238 C...Resonance KF codes (1=I,2=J,3=K).
42241 KFR(3) = -IDLAM(LKNT,3)+1
42242 C...Calculate width.
42243 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42244 & IDLAM(LKNT,3),XLAM(LKNT))
42245 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42246 C...KINEMATICS CHECK
42247 IF (XLAM(LKNT).EQ.0D0) THEN
42251 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
42252 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
42254 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
42255 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
42256 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
42258 C...Set coupling, and decay product masses on/off
42259 RVLAMC = GW2 * 5D-1 *
42260 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42261 C...I,J SYMMETRY => FACTOR 2
42264 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
42265 C...Resonance KF codes (1=I,2=J,3=K)
42266 KFR(1)=IDLAM(LKNT,1)-1
42267 KFR(2)=IDLAM(LKNT,2)-1
42269 C...Calculate width.
42270 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42271 & IDLAM(LKNT,3),XLAM(LKNT))
42272 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42273 C...KINEMATICS CHECK
42274 IF (XLAM(LKNT).EQ.0D0) THEN
42279 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
42281 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42282 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
42283 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
42285 C...Set coupling, and decay product masses on/off
42286 RVLAMC = GW2 * 5D-1 *
42287 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42288 C...I,J SYMMETRY => FACTOR 2
42291 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
42292 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
42293 C...Resonance KF codes (1=I,2=J,3=K)
42294 KFR(1) =-IDLAM(LKNT,1)+1
42295 KFR(2) =-IDLAM(LKNT,2)+1
42297 C...Calculate width.
42298 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42299 & IDLAM(LKNT,3),XLAM(LKNT))
42300 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42301 C...KINEMATICS CHECK
42302 IF (XLAM(LKNT).EQ.0D0) THEN
42309 C...LQD TYPE R-VIOLATION
42310 IF (IMSS(52).GE.1) THEN
42311 C...LOOP OVER DECAY MODES
42314 C...CHI+ -> NUBAR_I + DBAR_J + U_K
42316 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
42317 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42318 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
42320 C...Set coupling, and decay product masses on/off
42321 RVLAMC = 3. * GW2 * 5D-1 *
42322 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42324 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
42326 C...Resonance KF codes (1=I,2=J,3=K)
42329 KFR(3)=-IDLAM(LKNT,3)+1
42330 C...Calculate width.
42331 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42333 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42334 C...KINEMATICS CHECK
42335 IF (XLAM(LKNT).EQ.0D0) THEN
42339 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
42341 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42342 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
42343 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
42345 C...Set coupling, and decay product masses on/off
42346 RVLAMC = 3. * GW2 * 5D-1 *
42347 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42349 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
42350 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
42351 C...Resonance KF codes (1=I,2=J,3=K)
42354 KFR(3)=-IDLAM(LKNT,3)+1
42355 C...Calculate width.
42356 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42358 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42359 C...KINEMATICS CHECK
42360 IF (XLAM(LKNT).EQ.0D0) THEN
42364 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
42366 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42367 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42368 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42370 C...Set coupling, and decay product masses on/off
42371 RVLAMC = 3. * GW2 * 5D-1 *
42372 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42374 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
42375 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
42376 C...Resonance KF codes (1=I,2=J,3=K)
42377 KFR(1)=-IDLAM(LKNT,1)+1
42378 KFR(2)=-IDLAM(LKNT,2)+1
42380 C...Calculate width.
42381 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42383 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42384 C...KINEMATICS CHECK
42385 IF (XLAM(LKNT).EQ.0D0) THEN
42389 C * CHI+ -> NU_I + U_J + DBAR_K.
42391 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
42392 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
42393 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42395 C...Set coupling, and decay product masses on/off
42397 RVLAMC = 3. * GW2 * 5D-1 *
42398 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42399 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
42401 C...Resonance KF codes (1=I,2=J,3=K)
42402 KFR(1)=IDLAM(LKNT,1)-1
42403 KFR(2)=IDLAM(LKNT,2)-1
42405 C...Calculate width.
42406 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42408 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42409 C...KINEMATICS CHECK
42410 IF (XLAM(LKNT).EQ.0D0) THEN
42417 C...UDD TYPE R-VIOLATION
42418 C...These decays need special treatment since more than one BV coupling
42419 C...contributes (with interference). Consider e.g. (symbolically)
42420 C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
42421 C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
42422 C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
42423 C...The problem is that a single call to PYRVGW would evaluate all
42424 C...these terms and sum them, but without the different couplings. The
42425 C...way out is to call PYRVGW three times, once for the first line, once
42426 C...for the second line, and then once for all the lines (it is
42427 C...impossible to get just the last line out) without multiplying by
42428 C...couplings. The last line is then obtained as the result of the third
42429 C...call minus the results of the two first calls. Each term is then
42430 C...multiplied by its respective coupling before the whole thing is
42431 C...summed up in XLAM.
42432 C...Note that with three interfering resonances, this procedure becomes
42433 C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
42435 IF (IMSS(53).GE.1) THEN
42436 C...LOOP OVER DECAY MODES
42439 C...CHI+ -> U_I + U_J + D_K
42440 C...Decay mode I<->J symmetric.
42441 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
42443 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
42444 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
42445 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42447 C...Set coupling, and decay product masses on/off
42448 RVLAMC= 6. * GW2 * 5D-1
42449 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
42451 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
42453 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
42456 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
42457 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
42458 C...Resonance KF codes (1=I,2=J,3=K)
42459 KFR(1) = -IDLAM(LKNT,1)+1
42462 C...Calculate width.
42463 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42464 & IDLAM(LKNT,3),XRESI)
42465 C...Resonance KF codes (1=I,2=J,3=K)
42467 KFR(2) = -IDLAM(LKNT,2)+1
42469 C...Calculate width.
42470 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42471 & IDLAM(LKNT,3),XRESJ)
42472 C...Resonance KF codes (1=I,2=J,3=K)
42473 KFR(1) = -IDLAM(LKNT,1)+1
42474 KFR(2) = -IDLAM(LKNT,2)+1
42476 C...Calculate width.
42477 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42478 & IDLAM(LKNT,3),XRESIJ)
42479 IF (ABS((XRESI+XRESJ)/XRESIJ-1.).GT.1D-4) THEN
42480 XRESIJ = XRESIJ-XRESI-XRESJ
42484 C...CALCULATE TOTAL WIDTH
42485 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
42486 & + RVLJIK*RVLIJK * XRESIJ
42487 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42488 C...KINEMATICS CHECK
42489 IF (XLAM(LKNT).EQ.0D0) THEN
42493 C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
42494 C...Symmetry I<->J<->K.
42495 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
42496 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
42498 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
42499 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42500 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42502 C...Set coupling, and decay product masses on/off
42503 RVLAMC = 6. * GW2 * 5D-1
42504 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
42506 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
42508 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
42511 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
42512 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
42513 C...Collect symmetry factors
42514 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
42515 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
42516 & RVLAMC = 5D-1 * RVLAMC
42517 C...Resonance KF codes (1=I,2=J,3=K)
42518 KFR(1) = IDLAM(LKNT,1)-1
42521 C...Calculate width.
42522 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42523 & IDLAM(LKNT,3),XRESI)
42524 C...Resonance KF codes (1=I,2=J,3=K)
42526 KFR(2) = IDLAM(LKNT,2)-1
42528 C...Calculate width.
42529 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42530 & IDLAM(LKNT,3),XRESJ)
42531 C...Resonance KF codes (1=I,2=J,3=K)
42534 KFR(3) = IDLAM(LKNT,3)-1
42535 C...Calculate width.
42536 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42537 & IDLAM(LKNT,3),XRESK)
42538 C...Resonance KF codes (1=I,2=J,3=K)
42539 KFR(1) = IDLAM(LKNT,1)-1
42540 KFR(2) = IDLAM(LKNT,2)-1
42542 C...Calculate width.
42543 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42544 & IDLAM(LKNT,3),XRESIJ)
42545 IF (ABS(XRESIJ/(XRESI+XRESJ)-1.).GT.1D-4) THEN
42546 XRESIJ = XRESI+XRESJ-XRESIJ
42550 C...Resonance KF codes (1=I,2=J,3=K)
42552 KFR(2) = IDLAM(LKNT,2)-1
42553 KFR(3) = IDLAM(LKNT,3)-1
42554 C...Calculate width.
42555 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42556 & IDLAM(LKNT,3),XRESJK)
42557 IF (ABS(XRESJK/(XRESJ+XRESK)-1.).GT.1D-4) THEN
42558 XRESJK = XRESJ+XRESK-XRESJK
42562 C...Resonance KF codes (1=I,2=J,3=K)
42563 KFR(1) = IDLAM(LKNT,1)-1
42565 KFR(3) = IDLAM(LKNT,3)-1
42566 C...Calculate width.
42567 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
42568 & IDLAM(LKNT,3),XRESIK)
42569 IF (ABS(XRESIK/(XRESI+XRESK)-1.).GT.1D-4) THEN
42570 XRESIK = XRESI+XRESK-XRESIK
42574 C...CALCULATE TOTAL WIDTH
42576 & RVLIJK**2 * XRESI
42577 & + RVLJKI**2 * XRESJ
42578 & + RVLKIJ**2 * XRESK
42579 & + RVLIJK*RVLJKI * XRESIJ
42580 & + RVLIJK*RVLKIJ * XRESIK
42581 & + RVLJKI*RVLKIJ * XRESJK
42582 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
42583 C...KINEMATICS CHECK
42584 IF (XLAM(LKNT).EQ.0D0) THEN
42596 C*********************************************************************
42599 C...Calculates R-violating gluino decay widths.
42600 C...See BV part of PYRVCH for comments about the way the BV decay width
42601 C...is calculated. Same comments apply here.
42604 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
42606 C...Double precision and integer declarations.
42607 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42608 IMPLICIT INTEGER(I-N)
42609 C...Parameter statement to help give large particle numbers.
42610 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42611 &KEXCIT=4000000,KDIMEN=5000000)
42613 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42614 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42615 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42616 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42617 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42618 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
42619 C...Local variables.
42620 DOUBLE PRECISION XLAM(0:400)
42621 INTEGER IDLAM(400,3), PYCOMP
42622 C...Information from main routine to PYRVGW
42623 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
42625 C...Auxiliary variables needed for BV (RV Gauge STOre)
42626 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
42628 C...Running quark masses
42629 DOUBLE PRECISION RMQ(6)
42630 C...Decay product masses on/off
42632 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
42635 C...IF LQD OR UDD TYPE R-VIOLATION ON.
42636 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
42640 C x=1-2 : Select A or B coupling (1:A ; 2:B)
42641 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
42642 C 11-16:e,nu_e,mu,... not used here)
42643 C z=1-2 : Mass eigenstate number
42646 AB(1,I,1) = SFMIX(I,2)
42647 AB(1,I,2) = SFMIX(I,4)
42649 AB(2,I,1) = -SFMIX(I,1)
42650 AB(2,I,2) = -SFMIX(I,3)
42652 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
42654 IF (IMSS(52).GE.1) THEN
42655 C...STEP IN I,J,K USING SINGLE COUNTER
42657 C * GLUINO -> NUBAR_I + DBAR_J + D_K.
42659 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
42660 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42661 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42663 C...Set coupling, and decay product masses on/off
42664 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
42667 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
42668 C...Resonance KF codes (1=I,2=J,3=K)
42670 KFR(2) = -IDLAM(LKNT,2)
42671 KFR(3) = -IDLAM(LKNT,3)
42672 C...Calculate width.
42673 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42676 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42677 C...Charge conjugate mode.
42679 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
42680 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
42681 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
42682 XLAM(LKNT) = XLAM(LKNT-1)
42683 C...KINEMATICS CHECK
42684 IF (XLAM(LKNT).EQ.0D0) THEN
42688 C * GLUINO -> LEPTON+_I + UBAR_J + D_K
42690 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
42691 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
42692 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
42694 C...Set coupling, and decay product masses on/off
42695 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
42696 & **2* 5D-1 * GSTR2
42698 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
42699 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
42700 C...Resonance KF codes (1=I,2=J,3=K)
42702 KFR(2) = -IDLAM(LKNT,2)
42703 KFR(3) = -IDLAM(LKNT,3)
42704 C...Calculate width.
42705 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42707 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42708 C...Charge conjugate mode.
42710 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
42711 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
42712 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
42713 XLAM(LKNT) = XLAM(LKNT-1)
42714 C...KINEMATICS CHECK
42715 IF (XLAM(LKNT).EQ.0D0) THEN
42723 IF (IMSS(53).GE.1) THEN
42724 C...STEP IN I,J,K USING SINGLE COUNTER
42726 C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
42727 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
42729 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
42730 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
42731 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
42733 C...Set coupling, and decay product masses on/off. A factor of 2 for
42734 C...(N_C-1) has been used to cancel a factor 0.5.
42735 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
42738 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
42739 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
42740 C...Resonance KF codes (1=I,2=J,3=K)
42741 KFR(1) = IDLAM(LKNT,1)
42744 C...Calculate width.
42745 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42747 C...Resonance KF codes (1=I,2=J,3=K)
42749 KFR(2) = IDLAM(LKNT,2)
42751 C...Calculate width.
42752 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42754 C...Resonance KF codes (1=I,2=J,3=K)
42757 KFR(3) = IDLAM(LKNT,3)
42758 C...Calculate width.
42759 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42761 C...Resonance KF codes (1=I,2=J,3=K)
42762 KFR(1) = IDLAM(LKNT,1)
42763 KFR(2) = IDLAM(LKNT,2)
42765 C...Calculate width.
42766 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42768 C...Calculate interference function. (Factor -1/2 to make up for factor
42770 IF (ABS((XRESI+XRESJ)/XRESIJ-1D0).GT.1D-4) THEN
42771 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
42775 C...Resonance KF codes (1=I,2=J,3=K)
42777 KFR(2) = IDLAM(LKNT,2)
42778 KFR(3) = IDLAM(LKNT,3)
42779 C...Calculate width.
42780 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42782 IF (ABS((XRESJ+XRESK)/XRESJK-1).GT.1D-4) THEN
42783 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
42787 C...Resonance KF codes (1=I,2=J,3=K)
42788 KFR(1) = IDLAM(LKNT,1)
42790 KFR(3) = IDLAM(LKNT,3)
42791 C...Calculate width.
42792 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
42794 IF (ABS((XRESI+XRESK)/XRESIK-1).GT.1D-4) THEN
42795 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
42799 C...Calculate total width (factor 1/2 from 1/(N_C-1))
42800 XLAM(LKNT) = XRESI + XRESJ + XRESK
42801 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
42803 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
42804 C...Charge conjugate mode.
42806 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
42807 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
42808 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
42809 XLAM(LKNT) = XLAM(LKNT-1)
42810 C...KINEMATICS CHECK
42811 IF (XLAM(LKNT).EQ.0D0) THEN
42821 C*********************************************************************
42824 C...Auxiliary function to PYRVSF for calculating R-Violating
42825 C...sfermion widths. Though the decay products are most often treated
42826 C...as massless in the calculation, the kinematical boundary of phase
42827 C...space is tested using the true masses.
42828 C...MODE = 1: All decay products massive
42829 C...MODE = 2: Decay product 1 massless
42830 C...MODE = 3: Decay product 2 massless
42831 C...MODE = 4: All decay products massless
42833 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
42835 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42836 IMPLICIT INTEGER (I-N)
42837 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42838 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42839 SAVE /PYDAT1/,/PYDAT2/
42840 DOUBLE PRECISION SM(3)
42841 INTEGER PYCOMP, KC(3)
42845 SM(1)=PMAS(KC(1),1)**2
42846 SM(2)=PMAS(KC(2),1)**2
42847 SM(3)=PMAS(KC(3),1)**2
42848 C...Kinematics check
42849 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
42853 C...CM momenta squared
42854 IF (MODE.EQ.1) THEN
42855 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
42856 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
42857 ELSE IF (MODE.EQ.2) THEN
42858 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
42859 ELSE IF (MODE.EQ.3) THEN
42860 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
42864 C...Calculate Width
42865 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
42869 C*********************************************************************
42872 C...Generalized Matrix Element for R-Violating 3-body widths.
42874 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
42876 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42877 IMPLICIT INTEGER (I-N)
42878 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42879 &KEXCIT=4000000,KDIMEN=5000000)
42880 PARAMETER (EPS=1D-4)
42881 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42882 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
42884 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42885 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42886 DOUBLE PRECISION XLIM(3,3)
42887 INTEGER KC(0:3), PYCOMP
42888 LOGICAL DCMASS, DCHECK(6)
42889 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
42893 KC(0) = PYCOMP(KFIN)
42894 KC(1) = PYCOMP(ID1)
42895 KC(2) = PYCOMP(ID2)
42896 KC(3) = PYCOMP(ID3)
42897 RMS(0) = PMAS(KC(0),1)
42898 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
42899 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
42900 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
42901 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
42902 XLIM(1,1)=(RMS(1)+RMS(2))**2
42903 XLIM(1,2)=(RMS(0)-RMS(3))**2
42904 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
42905 XLIM(2,1)=(RMS(2)+RMS(3))**2
42906 XLIM(2,2)=(RMS(0)-RMS(1))**2
42907 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
42908 XLIM(3,1)=(RMS(1)+RMS(3))**2
42909 XLIM(3,2)=(RMS(0)-RMS(2))**2
42910 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
42911 C...Check Phase Space
42912 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
42916 C...INITIALIZE RESONANCE INFORMATION
42919 IRES = 2*(JRES-1)+IMASS
42921 DCHECK(IRES) =.FALSE.
42922 C...NO RIGHT-HANDED NEUTRINOS
42923 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
42924 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
42925 & .KFR(JRES).EQ.0) GOTO 100
42926 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
42927 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
42928 INTRES(IRES,1) = IABS(KFR(JRES))
42929 INTRES(IRES,2) = IMASS
42930 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
42931 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
42935 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
42937 C...RESONANCE CONTRIBUTIONS
42938 C...(Only sum contributions where the resonance is off shell).
42939 C...Store whether diagram on/off in DCHECK.
42940 C...LOOP OVER MASS STATES
42943 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
42944 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
42945 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
42946 DCHECK(IDR) =.TRUE.
42947 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
42951 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
42952 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
42953 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
42954 DCHECK(IDR) =.TRUE.
42955 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
42959 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
42960 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
42961 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
42962 DCHECK(IDR) =.TRUE.
42963 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
42966 C... L-R INTERFERENCES
42967 C... (Only add contributions where both contributing diagrams
42968 C... are non-resonant).
42970 IF (DCHECK(1).AND.DCHECK(2)) THEN
42971 C...Bug corrected 11/12 2001. Skands.
42972 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
42973 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
42974 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
42978 IF (DCHECK(3).AND.DCHECK(4)) THEN
42979 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
42980 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
42981 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
42985 IF (DCHECK(5).AND.DCHECK(6)) THEN
42986 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
42987 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
42988 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
42990 C... TRUE INTERFERENCES
42991 C... (Only add contributions where both contributing diagrams
42992 C... are non-resonant).
42994 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
42999 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
43000 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
43001 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
43002 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
43007 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
43008 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
43009 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
43010 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
43015 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
43016 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
43017 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
43018 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
43026 C*********************************************************************
43029 C...Function to integrate resonance contributions
43031 FUNCTION PYRVI1(ID1,ID2,ID3)
43034 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
43035 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
43036 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
43037 LOGICAL MFLAG,DCMASS
43038 EXTERNAL PYRVG1,PYGAUS
43039 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
43041 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43042 SAVE/PYRVNV/,/PYRVPM/
43043 C...Initialize mass and width information
43049 RESM(1)= RES(IDR,1)
43050 RESW(1)= RES(IDR,2)
43051 C...A->B and B->A for antisparticles
43052 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43053 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43054 C...Integration boundaries and mass flag
43055 LO = (RM(1)+RM(2))**2
43056 HI = (RM(0)-RM(3))**2
43058 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
43062 C*********************************************************************
43065 C...Function to integrate L-R interference contributions
43067 FUNCTION PYRVI2(ID1,ID2,ID3)
43070 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
43071 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
43072 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
43073 LOGICAL MFLAG,DCMASS
43074 EXTERNAL PYRVG2,PYGAUS
43075 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
43077 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43078 SAVE/PYRVNV/,/PYRVPM/
43079 C...Initialize mass and width information
43085 RESM(1)= RES(IDR,1)
43086 RESW(1)= RES(IDR,2)
43087 RESM(2)= RES(IDR+1,1)
43088 RESW(2)= RES(IDR+1,2)
43089 C...A->B and B->A for antisparticles
43090 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43091 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43092 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
43093 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
43094 C...Boundaries and mass flag
43095 LO = (RM(1)+RM(2))**2
43096 HI = (RM(0)-RM(3))**2
43098 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
43102 C*********************************************************************
43105 C...Function to integrate true interference contributions
43107 FUNCTION PYRVI3(ID1,ID2,ID3)
43110 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
43111 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
43112 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
43113 LOGICAL MFLAG,DCMASS
43114 EXTERNAL PYRVG3,PYGAUS
43115 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
43117 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43118 SAVE/PYRVNV/,/PYRVPM/
43119 C...Initialize mass and width information
43125 RESM(1)= RES(IDR,1)
43126 RESW(1)= RES(IDR,2)
43127 RESM(2)= RES(IDR2,1)
43128 RESW(2)= RES(IDR2,2)
43129 C...A -> B and B -> A for antisparticles
43130 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43131 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
43132 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
43133 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
43134 C...Boundaries and mass flag
43135 LO = (RM(1)+RM(2))**2
43136 HI = (RM(0)-RM(3))**2
43138 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
43142 C*********************************************************************
43145 C...Integrand for resonance contributions
43150 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43151 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
43152 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
43155 RVR = PYRVR(X,RESM(1),RESW(1))
43156 C1 = 2D0*SQRT(MAX(0D0,X))
43157 IF (.NOT.MFLAG) THEN
43159 E3 = (RM(0)**2-X)/C1
43161 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
43163 E2 = (X-RM(1)**2+RM(2)**2)/C1
43164 E3 = (RM(0)**2-X-RM(3)**2)/C1
43165 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
43166 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
43167 DELTAY = 4D0*SR1*SR2
43168 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
43169 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
43170 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
43175 C*********************************************************************
43178 C...Integrand for L-R interference contributions
43183 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43184 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
43185 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
43188 C1 = 2D0*SQRT(MAX(0D0,X))
43189 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
43190 IF (.NOT.MFLAG) THEN
43192 E3 = (RM(0)**2-X)/C1
43194 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
43196 E2 = (X-RM(1)**2+RM(2)**2)/C1
43197 E3 = (RM(0)**2-X-RM(3)**2)/C1
43198 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
43199 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
43200 DELTAY = 4D0*SR1*SR2
43201 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
43202 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
43203 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
43208 C*********************************************************************
43211 C...Function to do Y integration over true interference contributions
43216 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43217 C...Second Dalitz variable for PYRVG4
43219 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
43220 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
43221 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
43223 EXTERNAL PYGAU2,PYRVG4
43224 SAVE/PYRVPM/,/PYG2DX/
43226 C1=2D0*SQRT(MAX(1D-9,X))
43228 IF (.NOT.MFLAG) THEN
43230 E3 = (RM(0)**2-X)/C1
43234 E2 = (X-RM(1)**2+RM(2)**2)/C1
43235 E3 = (RM(0)**2-X-RM(3)**2)/C1
43237 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
43238 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
43239 YMIN = SQ1-(SR1+SR2)**2
43240 YMAX = SQ1-(SR1-SR2)**2
43242 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
43246 C*********************************************************************
43249 C...Integrand for true intereference contributions
43254 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
43256 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
43258 SAVE /PYRVPM/,/PYG2DX/
43260 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
43261 IF (.NOT.MFLAG) THEN
43262 PYRVG4 = RVS*B(1)*B(2)*X*Y
43264 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
43265 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
43266 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
43267 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
43272 C*********************************************************************
43275 C...Breit-Wigner for resonance contributions
43277 FUNCTION PYRVR(Mab2,RM,RW)
43280 DOUBLE PRECISION Mab2,RM,RW,PYRVR
43281 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
43285 C*********************************************************************
43288 C...Interference function
43290 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
43293 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
43294 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
43299 C*********************************************************************
43302 C...Stores one parton/particle in commonblock PYJETS.
43304 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
43306 C...Double precision and integer declarations.
43307 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43308 IMPLICIT INTEGER(I-N)
43309 INTEGER PYK,PYCHGE,PYCOMP
43311 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43312 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43313 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43314 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43316 C...Standard checks.
43318 IF(MSTU(12).GE.1) CALL PYLIST(0)
43319 IPA=MAX(1,IABS(IP))
43320 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
43321 &'(PY1ENT:) writing outside PYJETS memory')
43323 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
43325 C...Find mass. Reset K, P and V vectors.
43327 IF(MSTU(10).EQ.1) PM=P(IPA,5)
43328 IF(MSTU(10).GE.2) PM=PYMASS(KF)
43335 C...Store parton/particle in K and P vectors.
43337 IF(IP.LT.0) K(IPA,1)=2
43340 P(IPA,4)=MAX(PE,PM)
43341 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
43342 P(IPA,1)=PA*SIN(THE)*COS(PHI)
43343 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
43344 P(IPA,3)=PA*COS(THE)
43346 C...Set N. Optionally fragment/decay.
43348 IF(IP.EQ.0) CALL PYEXEC
43353 C*********************************************************************
43356 C...Stores two partons/particles in their CM frame,
43357 C...with the first along the +z axis.
43359 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
43361 C...Double precision and integer declarations.
43362 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43363 IMPLICIT INTEGER(I-N)
43364 INTEGER PYK,PYCHGE,PYCOMP
43366 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43367 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43368 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43369 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43371 C...Standard checks.
43373 IF(MSTU(12).GE.1) CALL PYLIST(0)
43374 IPA=MAX(1,IABS(IP))
43375 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
43376 &'(PY2ENT:) writing outside PYJETS memory')
43379 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
43380 &'(PY2ENT:) unknown flavour code')
43382 C...Find masses. Reset K, P and V vectors.
43384 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
43385 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
43387 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
43388 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
43397 C...Check flavours.
43398 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
43399 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
43400 IF(MSTU(19).EQ.1) THEN
43403 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
43404 & '(PY2ENT:) unphysical flavour combination')
43409 C...Store partons/particles in K vectors for normal case.
43412 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
43415 C...Store partons in K vectors for parton shower evolution.
43419 K(IPA,4)=MSTU(5)*(IPA+1)
43421 K(IPA+1,4)=MSTU(5)*IPA
43422 K(IPA+1,5)=K(IPA+1,4)
43425 C...Check kinematics and store partons/particles in P vectors.
43426 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
43427 &'(PY2ENT:) energy smaller than sum of masses')
43428 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
43431 P(IPA,4)=SQRT(PM1**2+PA**2)
43434 P(IPA+1,4)=SQRT(PM2**2+PA**2)
43437 C...Set N. Optionally fragment/decay.
43439 IF(IP.EQ.0) CALL PYEXEC
43444 C*********************************************************************
43447 C...Stores three partons or particles in their CM frame,
43448 C...with the first along the +z axis and the third in the (x,z)
43449 C...plane with x > 0.
43451 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
43453 C...Double precision and integer declarations.
43454 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43455 IMPLICIT INTEGER(I-N)
43456 INTEGER PYK,PYCHGE,PYCOMP
43458 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43459 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43460 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43461 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43463 C...Standard checks.
43465 IF(MSTU(12).GE.1) CALL PYLIST(0)
43466 IPA=MAX(1,IABS(IP))
43467 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
43468 &'(PY3ENT:) writing outside PYJETS memory')
43472 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
43473 &'(PY3ENT:) unknown flavour code')
43475 C...Find masses. Reset K, P and V vectors.
43477 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
43478 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
43480 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
43481 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
43483 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
43484 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
43493 C...Check flavours.
43494 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
43495 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
43496 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
43497 IF(MSTU(19).EQ.1) THEN
43499 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
43500 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
43501 & KQ1+KQ3.EQ.4)) THEN
43503 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
43509 C...Store partons/particles in K vectors for normal case.
43512 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
43514 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
43517 C...Store partons in K vectors for parton shower evolution.
43523 IF(KQ1.EQ.-1) KCS=5
43524 K(IPA,KCS)=MSTU(5)*(IPA+1)
43525 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
43526 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
43527 K(IPA+1,9-KCS)=MSTU(5)*IPA
43528 K(IPA+2,KCS)=MSTU(5)*IPA
43529 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
43532 C...Check kinematics.
43534 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
43535 &0.5D0*X3*PECM.LE.PM3) MKERR=1
43536 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
43537 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
43538 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
43539 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
43540 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
43541 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
43542 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
43543 IF(MKERR.NE.0) CALL PYERRM(13,
43544 &'(PY3ENT:) unphysical kinematical variable setup')
43546 C...Store partons/particles in P vectors.
43548 P(IPA,4)=SQRT(PA1**2+PM1**2)
43550 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
43551 P(IPA+2,3)=PA3*CTHE3
43552 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
43554 P(IPA+1,1)=-P(IPA+2,1)
43555 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
43556 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
43559 C...Set N. Optionally fragment/decay.
43561 IF(IP.EQ.0) CALL PYEXEC
43566 C*********************************************************************
43569 C...Stores four partons or particles in their CM frame, with
43570 C...the first along the +z axis, the last in the xz plane with x > 0
43571 C...and the second having y < 0 and y > 0 with equal probability.
43573 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
43575 C...Double precision and integer declarations.
43576 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43577 IMPLICIT INTEGER(I-N)
43578 INTEGER PYK,PYCHGE,PYCOMP
43580 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43581 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43582 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43583 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
43585 C...Standard checks.
43587 IF(MSTU(12).GE.1) CALL PYLIST(0)
43588 IPA=MAX(1,IABS(IP))
43589 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
43590 &'(PY4ENT:) writing outside PYJETS momory')
43595 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
43596 &'(PY4ENT:) unknown flavour code')
43598 C...Find masses. Reset K, P and V vectors.
43600 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
43601 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
43603 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
43604 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
43606 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
43607 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
43609 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
43610 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
43619 C...Check flavours.
43620 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
43621 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
43622 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
43623 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
43624 IF(MSTU(19).EQ.1) THEN
43626 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
43627 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
43628 & KQ1+KQ4.EQ.4)) THEN
43629 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
43632 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
43639 C...Store partons/particles in K vectors for normal case.
43642 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
43644 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
43647 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
43650 C...Store partons for parton shower evolution from q-g-g-qbar or
43652 ELSEIF(KQ1+KQ2.NE.0) THEN
43658 IF(KQ1.EQ.-1) KCS=5
43659 K(IPA,KCS)=MSTU(5)*(IPA+1)
43660 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
43661 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
43662 K(IPA+1,9-KCS)=MSTU(5)*IPA
43663 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
43664 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
43665 K(IPA+3,KCS)=MSTU(5)*IPA
43666 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
43668 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
43674 K(IPA,4)=MSTU(5)*(IPA+1)
43676 K(IPA+1,4)=MSTU(5)*IPA
43677 K(IPA+1,5)=K(IPA+1,4)
43678 K(IPA+2,4)=MSTU(5)*(IPA+3)
43679 K(IPA+2,5)=K(IPA+2,4)
43680 K(IPA+3,4)=MSTU(5)*(IPA+2)
43681 K(IPA+3,5)=K(IPA+3,4)
43684 C...Check kinematics.
43686 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
43687 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
43689 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
43690 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
43691 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
43692 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
43693 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
43694 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
43695 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
43696 STHE4=SQRT(1D0-CTHE4**2)
43697 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
43698 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
43699 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
43700 STHE2=SQRT(1D0-CTHE2**2)
43701 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
43702 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
43703 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
43704 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
43705 IF(MKERR.EQ.1) CALL PYERRM(13,
43706 &'(PY4ENT:) unphysical kinematical variable setup')
43708 C...Store partons/particles in P vectors.
43710 P(IPA,4)=SQRT(PA1**2+PM1**2)
43712 P(IPA+3,1)=PA4*STHE4
43713 P(IPA+3,3)=PA4*CTHE4
43714 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
43716 P(IPA+1,1)=PA2*STHE2*CPHI2
43717 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
43718 P(IPA+1,3)=PA2*CTHE2
43719 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
43721 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
43722 P(IPA+2,2)=-P(IPA+1,2)
43723 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
43724 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
43727 C...Set N. Optionally fragment/decay.
43729 IF(IP.EQ.0) CALL PYEXEC
43734 C*********************************************************************
43737 C...An interface from a two-fermion generator to include
43738 C...parton showers and hadronization.
43740 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
43742 C...Double precision and integer declarations.
43743 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43744 IMPLICIT INTEGER(I-N)
43745 INTEGER PYK,PYCHGE,PYCOMP
43747 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43748 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43749 SAVE /PYJETS/,/PYDAT1/
43751 DIMENSION IJOIN(2),INTAU(2)
43753 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
43759 C...Loop through entries and pick up all final fermions/antifermions.
43763 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
43765 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
43766 IF(K(I,2).GT.0) THEN
43770 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
43776 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
43782 C...Check that event is arranged according to conventions.
43783 IF(I1.EQ.0.OR.I2.EQ.0) THEN
43784 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
43787 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
43790 C...Check whether fermion pair is quarks or leptons.
43791 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
43793 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
43796 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
43799 C...Decide whether to allow or not photon radiation in showers.
43801 IF(IRAD.EQ.0) MSTJ(41)=1
43803 C...Do colour joining and parton showers.
43806 IF(IQL12.EQ.1) THEN
43809 CALL PYJOIN(2,IJOIN)
43811 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
43812 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
43813 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
43814 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
43817 C...Do fragmentation and decays. Possibly except tau decay.
43821 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
43835 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
43843 C*********************************************************************
43846 C...An interface from a four-fermion generator to include
43847 C...parton showers and hadronization.
43849 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
43851 C...Double precision and integer declarations.
43852 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43853 IMPLICIT INTEGER(I-N)
43854 INTEGER PYK,PYCHGE,PYCOMP
43856 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43857 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43858 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43859 COMMON/PYINT1/MINT(400),VINT(400)
43860 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
43862 DIMENSION IJOIN(2),INTAU(4)
43864 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
43870 C...Loop through entries and pick up all final fermions/antifermions.
43876 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
43878 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
43879 IF(K(I,2).GT.0) THEN
43882 ELSEIF(I3.EQ.0) THEN
43885 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
43890 ELSEIF(I4.EQ.0) THEN
43893 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
43899 C...Check that event is arranged according to conventions.
43900 IF(I3.EQ.0.OR.I4.EQ.0) THEN
43901 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
43903 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
43904 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
43907 C...Check which fermion pairs are quarks and which leptons.
43908 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
43910 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
43913 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
43915 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
43917 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
43920 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
43923 C...Decide whether to allow or not photon radiation in showers.
43925 IF(IRAD.EQ.0) MSTJ(41)=1
43927 C...Decide on dipole pairing.
43932 IF(IQL12.EQ.IQL34) THEN
43935 DELTA=ATOTSQ-A1SQ-A2SQ
43936 IF(ISTRAT.EQ.1) THEN
43937 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
43938 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
43939 ELSEIF(ISTRAT.EQ.2) THEN
43940 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
43941 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
43943 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
43949 C...If colour reconnection then bookkeep W+W- or Z0Z0
43950 C...and copy q qbar q qbar consecutively.
43951 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
43960 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
43964 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
43978 P(N+1,J)=P(IP1,J)+P(IP2,J)
43979 P(N+2,J)=P(IP3,J)+P(IP4,J)
43991 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
43993 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
43999 C...Remove original q qbar q qbar and update counters.
44000 K(IP1,1)=K(IP1,1)+10
44001 K(IP2,1)=K(IP2,1)+10
44002 K(IP3,1)=K(IP3,1)+10
44003 K(IP4,1)=K(IP4,1)+10
44014 C...Do colour joinings and parton showers.
44015 IF(IQL12.EQ.1) THEN
44018 CALL PYJOIN(2,IJOIN)
44020 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
44021 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
44022 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
44023 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
44026 IF(IQL34.EQ.1) THEN
44029 CALL PYJOIN(2,IJOIN)
44031 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
44032 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
44033 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
44034 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
44037 C...Optionally do colour reconnection.
44040 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
44041 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
44045 C...Do fragmentation and decays. Possibly except tau decay.
44049 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
44063 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
44071 C*********************************************************************
44074 C...An interface from a six-fermion generator to include
44075 C...parton showers and hadronization.
44077 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
44079 C...Double precision and integer declarations.
44080 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44081 IMPLICIT INTEGER(I-N)
44082 INTEGER PYK,PYCHGE,PYCOMP
44084 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44085 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44086 SAVE /PYJETS/,/PYDAT1/
44088 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
44090 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
44096 C...Loop through entries and pick up all final fermions/antifermions.
44104 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
44106 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
44107 IF(K(I,2).GT.0) THEN
44110 ELSEIF(I3.EQ.0) THEN
44112 ELSEIF(I5.EQ.0) THEN
44115 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
44120 ELSEIF(I4.EQ.0) THEN
44122 ELSEIF(I6.EQ.0) THEN
44125 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
44131 C...Check that event is arranged according to conventions.
44132 IF(I5.EQ.0.OR.I6.EQ.0) THEN
44133 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
44135 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
44136 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
44139 C...Check which fermion pairs are quarks and which leptons.
44140 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
44142 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
44145 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
44147 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
44149 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
44152 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
44154 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
44156 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
44159 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
44162 C...Decide whether to allow or not photon radiation in showers.
44164 IF(IRAD.EQ.0) MSTJ(41)=1
44166 C...Allow dipole pairings only among leptons and quarks separately.
44169 IF(IQL34.EQ.IQL56) P13D=P13
44171 IF(IQL12.EQ.IQL34) P21D=P21
44173 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
44175 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
44177 IF(IQL12.EQ.IQL56) P32D=P32
44179 C...Decide whether t+tbar.
44181 IF(PYR(0).LT.PTOP) THEN
44184 C...If t+tbar: reconstruct t's.
44190 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
44191 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
44199 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
44201 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
44205 C...If t+tbar: colour join t's and let them shower.
44208 CALL PYJOIN(2,IJOIN)
44209 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
44210 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
44211 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
44213 C...If t+tbar: pick up the t's after shower.
44217 IF(K(I,2).EQ.6) ITNEW=I
44218 IF(K(I,2).EQ.-6) ITBNEW=I
44221 C...If t+tbar: loop over two top systems.
44236 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
44237 & '(PY6FRM:) not b in t decay')
44239 C...If t+tbar: find boost from original to new top frame.
44241 BETAO(J)=P(ITO,J)/P(ITO,4)
44242 BETAN(J)=P(ITN,J)/P(ITN,4)
44245 C...If t+tbar: boost copy of b by t shower and connect it in colour.
44255 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
44256 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
44257 K(IB,4)=MSTU(5)*ITN
44258 K(IB,5)=MSTU(5)*ITN
44259 K(ITN,4)=K(ITN,4)+IB
44260 K(ITN,5)=K(ITN,5)+IB
44261 K(ITN,1)=K(ITN,1)+10
44262 K(IBO,1)=K(IBO,1)+10
44264 C...If t+tbar: construct W recoiling against b.
44272 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
44273 IF(IABS(KCHW).EQ.3) THEN
44274 K(IW,2)=ISIGN(24,KCHW)
44276 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
44280 C...If t+tbar: construct W momentum, including boost by t shower.
44282 P(IW,J)=P(IW1,J)+P(IW2,J)
44284 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
44286 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
44287 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
44289 C...If t+tbar: boost b and W to top rest frame.
44291 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
44293 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44294 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44296 C...If t+tbar: let b shower and pick up modified W.
44297 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
44298 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
44299 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
44301 IF(IABS(K(I,2)).EQ.24) IWM=I
44304 C...If t+tbar: take copy of W decay products.
44313 K(IW1,1)=K(IW1,1)+10
44314 K(IW2,1)=K(IW2,1)+10
44315 K(IWM,1)=K(IWM,1)+10
44329 C...If t+tbar: boost W decay products, first by effects of t shower,
44330 C...then by those of b shower. b and its shower simple boost back.
44331 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
44332 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
44333 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44334 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
44335 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
44336 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
44337 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
44338 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
44339 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
44343 C...Decide on dipole pairing.
44347 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
44348 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
44352 ELSEIF(PRN.LT.P12D+P13D) THEN
44356 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
44360 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
44364 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
44374 C...Do colour joinings and parton showers
44375 C...(except ones already made for t+tbar).
44377 IF(IQL12.EQ.1) THEN
44380 CALL PYJOIN(2,IJOIN)
44382 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
44383 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
44384 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
44385 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
44388 IF(IQL34.EQ.1) THEN
44391 CALL PYJOIN(2,IJOIN)
44393 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
44394 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
44395 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
44396 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
44398 IF(IQL56.EQ.1) THEN
44401 CALL PYJOIN(2,IJOIN)
44403 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
44404 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
44405 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
44406 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
44409 C...Do fragmentation and decays. Possibly except tau decay.
44413 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
44427 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
44435 C*********************************************************************
44438 C...An interface from a four-parton generator to include
44439 C...parton showers and hadronization.
44441 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
44443 C...Double precision and integer declarations.
44444 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44445 IMPLICIT INTEGER(I-N)
44446 INTEGER PYK,PYCHGE,PYCOMP
44448 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44449 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44450 SAVE /PYJETS/,/PYDAT1/
44452 DIMENSION IJOIN(2),PTOT(4),BETA(3)
44454 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
44460 C...Loop through entries and pick up all final partons.
44466 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
44468 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
44469 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
44472 ELSEIF(I3.EQ.0) THEN
44475 CALL PYERRM(16,'(PY4JET:) more than two quarks')
44477 ELSEIF(K(I,2).LT.0) THEN
44480 ELSEIF(I4.EQ.0) THEN
44483 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
44488 ELSEIF(I4.EQ.0) THEN
44491 CALL PYERRM(16,'(PY4JET:) more than two gluons')
44497 C...Check that event is arranged according to conventions.
44498 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
44499 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
44501 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
44502 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
44505 C...Check whether second pair are quarks or gluons.
44506 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
44508 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
44511 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
44514 C...Boost partons to their cm frame.
44516 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
44518 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
44520 BETA(J)=PTOT(J)/PTOT(4)
44522 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44523 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44524 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44525 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
44528 C...Decide and set up shower history for q qbar q' qbar' events.
44529 IF(IQG34.EQ.1) THEN
44530 W1=PY4JTW(0,I1,I3,I4)
44531 W2=PY4JTW(0,I2,I3,I4)
44532 IF(W1.GT.PYR(0)*(W1+W2)) THEN
44533 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
44535 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
44538 C...Decide and set up shower history for q qbar g g events.
44540 W1=PY4JTW(I1,I3,I2,I4)
44541 W2=PY4JTW(I1,I4,I2,I3)
44542 W3=PY4JTW(0,I3,I1,I4)
44543 W4=PY4JTW(0,I4,I1,I3)
44544 W5=PY4JTW(0,I3,I2,I4)
44545 W6=PY4JTW(0,I4,I2,I3)
44546 W7=PY4JTW(0,I1,I3,I4)
44547 W8=PY4JTW(0,I2,I3,I4)
44548 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
44550 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
44551 ELSEIF(W1+W2.GT.WR) THEN
44552 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
44553 ELSEIF(W1+W2+W3.GT.WR) THEN
44554 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
44555 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
44556 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
44557 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
44558 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
44559 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
44560 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
44561 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
44562 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
44564 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
44568 C...Boost back original partons and mark them as deleted.
44569 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
44570 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
44571 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
44572 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
44578 C...Rotate shower initiating partons to be along z axis.
44579 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
44580 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
44581 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
44582 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
44584 C...Set up copy of shower initiating partons as on mass shell.
44594 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
44605 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
44606 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
44608 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
44610 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
44613 C...Decide whether to allow or not photon radiation in showers.
44614 C...Connect up colours.
44616 IF(IRAD.EQ.0) MSTJ(41)=1
44619 CALL PYJOIN(2,IJOIN)
44621 C...Decide on maximum virtuality and do parton shower.
44622 IF(PMAX.LT.PARJ(82)) THEN
44627 CALL PYSHOW(NSAV+1,-8,PQMAX)
44629 C...Rotate and boost back system.
44630 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
44632 C...Do fragmentation and decays.
44635 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
44644 C*********************************************************************
44647 C...Auxiliary to PY4JET, to evaluate weight of configuration.
44649 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
44651 C...Double precision and integer declarations.
44652 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44653 IMPLICIT INTEGER(I-N)
44654 INTEGER PYK,PYCHGE,PYCOMP
44656 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44659 C...First case: when both original partons radiate.
44660 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
44663 P(N+1,J)=P(IA1,J)+P(IA2,J)
44664 P(N+2,J)=P(IA3,J)+P(IA4,J)
44666 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44668 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44670 Z1=P(IA1,4)/P(N+1,4)
44671 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
44672 Z2=P(IA3,4)/P(N+2,4)
44673 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
44675 C...Second case: when one original parton radiates to three.
44676 C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
44679 P(N+2,J)=P(IA3,J)+P(IA4,J)
44680 P(N+1,J)=P(N+2,J)+P(IA2,J)
44682 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44684 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44686 IF(K(IA2,2).EQ.21) THEN
44687 Z1=P(N+2,4)/P(N+1,4)
44688 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
44691 Z1=P(IA2,4)/P(N+1,4)
44692 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
44695 Z2=P(IA3,4)/P(N+2,4)
44696 IF(K(IA2,2).EQ.21) THEN
44697 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
44699 ELSEIF(K(IA3,2).EQ.21) THEN
44700 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
44702 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
44712 C*********************************************************************
44715 C...Auxiliary to PY4JET, to set up chosen configuration.
44717 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
44719 C...Double precision and integer declarations.
44720 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44721 IMPLICIT INTEGER(I-N)
44722 INTEGER PYK,PYCHGE,PYCOMP
44724 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44736 C...First case: when both original partons radiate.
44737 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
44740 C...Set up flavour and history pointers for new partons.
44758 C...Set up momenta for new partons.
44760 P(N+1,J)=P(IA1,J)+P(IA2,J)
44761 P(N+2,J)=P(IA3,J)+P(IA4,J)
44767 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44769 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
44771 QMAX=MIN(P(N+1,5),P(N+2,5))
44773 C...Second case: q radiates twice.
44774 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
44775 C...IA5=N+2 does not radiate.
44776 ELSEIF(K(IA2,2).EQ.21) THEN
44778 C...Set up flavour and history pointers for new partons.
44796 C...Set up momenta for new partons.
44798 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
44800 P(N+3,J)=P(IA3,J)+P(IA4,J)
44805 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44807 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
44811 C...Third case: q radiates g, g branches.
44812 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
44813 C...IA5=N+2 does not radiate.
44816 C...Set up flavour and history pointers for new partons.
44834 C...Set up momenta for new partons.
44836 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
44839 P(N+4,J)=P(IA3,J)+P(IA4,J)
44843 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
44845 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
44855 C*********************************************************************
44858 C...Connects a sequence of partons with colour flow indices,
44859 C...as required for subsequent shower evolution (or other operations).
44861 SUBROUTINE PYJOIN(NJOIN,IJOIN)
44863 C...Double precision and integer declarations.
44864 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44865 IMPLICIT INTEGER(I-N)
44866 INTEGER PYK,PYCHGE,PYCOMP
44868 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44869 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44870 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44871 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
44875 C...Check that partons are of right types to be connected.
44876 IF(NJOIN.LT.2) GOTO 120
44880 IF(I.LE.0.OR.I.GT.N) GOTO 120
44881 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
44883 IF(KC.EQ.0) GOTO 120
44884 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
44885 IF(KQ.EQ.0) GOTO 120
44886 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
44887 IF(KQ.NE.2) KQSUM=KQSUM+KQ
44888 IF(IJN.EQ.1) KQS=KQ
44890 IF(KQSUM.NE.0) GOTO 120
44892 C...Connect the partons sequentially (closing for gluon loop).
44894 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
44898 IF(IJN.NE.1) IP=IJOIN(IJN-1)
44899 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
44900 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
44901 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
44902 K(I,KCS)=MSTU(5)*IN
44903 K(I,9-KCS)=MSTU(5)*IP
44904 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
44905 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
44908 C...Error exit: no action taken.
44910 120 CALL PYERRM(12,
44911 &'(PYJOIN:) given entries can not be joined by one string')
44916 C*********************************************************************
44919 C...Sets values of commonblock variables.
44921 SUBROUTINE PYGIVE(CHIN)
44923 C...Double precision and integer declarations.
44924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44925 IMPLICIT INTEGER(I-N)
44926 INTEGER PYK,PYCHGE,PYCOMP
44928 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
44929 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44930 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44931 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44932 COMMON/PYDAT4/CHAF(500,2)
44934 COMMON/PYDATR/MRPY(6),RRPY(100)
44935 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
44936 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44937 COMMON/PYINT1/MINT(400),VINT(400)
44938 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
44939 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
44940 COMMON/PYINT4/MWID(500),WIDS(500,5)
44941 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
44942 COMMON/PYINT6/PROC(0:500)
44944 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
44945 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
44947 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44948 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44949 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
44950 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
44951 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
44952 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/
44953 C...Local arrays and character variables.
44954 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
44955 &CHNEW2*28,CHNAM*6,CHVAR(54)*6,CHALP(2)*26,CHIND*8,CHINI*10,
44957 DIMENSION MSVAR(54,8)
44959 C...For each variable to be translated give: name,
44960 C...integer/real/character, no. of indices, lower&upper index bounds.
44961 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
44962 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
44963 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
44964 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
44965 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
44966 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
44968 DATA ((MSVAR(I,J),J=1,8),I=1,54)/ 1,7*0, 1,2,1,4000,1,5,2*0,
44969 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
44970 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
44971 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
44972 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
44973 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
44974 &1,1,1,6,4*0, 2,1,1,100,4*0,
44975 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
44976 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
44977 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
44978 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
44979 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
44980 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
44981 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
44982 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
44983 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
44984 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
44985 &1,1,0,99,4*0, 2,1,0,99,4*0/
44986 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
44987 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
44989 C...Length of character variable. Subdivide it into instructions.
44990 IF(MSTU(12).GE.1) CALL PYLIST(0)
44994 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
44997 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
44999 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
45004 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
45006 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
45008 C...Peel off any text following exclamation mark.
45010 DO 140 LLOW2=LHIG2,1,-1
45011 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
45013 IF(LBIT.EQ.0) RETURN
45015 C...Identify commonblock variable.
45018 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
45019 &LNAM.LE.6) GOTO 150
45020 CHNAM=CHBIT(1:LNAM-1)//' '
45021 DO 170 LCOM=1,LNAM-1
45023 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
45024 & CHALP(2)(LALP:LALP)
45029 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
45032 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
45034 IF(LLOW.LT.LTOT) GOTO 120
45038 C...Identify any indices.
45043 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
45046 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
45048 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
45049 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
45050 & IVAR.EQ.37)) THEN
45051 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
45052 READ(CHIND,'(I8)') KF
45054 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
45056 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
45059 IF(LLOW.LT.LTOT) GOTO 120
45062 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
45063 READ(CHIND,'(I8)') I1
45066 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
45069 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
45072 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
45074 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
45075 READ(CHIND,'(I8)') I2
45077 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
45080 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
45083 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
45085 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
45086 READ(CHIND,'(I8)') I3
45091 C...Check that indices allowed.
45093 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
45094 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
45096 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
45098 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
45100 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
45102 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
45105 IF(LLOW.LT.LTOT) GOTO 120
45109 C...Save old value of variable.
45112 ELSEIF(IVAR.EQ.2) THEN
45114 ELSEIF(IVAR.EQ.3) THEN
45116 ELSEIF(IVAR.EQ.4) THEN
45118 ELSEIF(IVAR.EQ.5) THEN
45120 ELSEIF(IVAR.EQ.6) THEN
45122 ELSEIF(IVAR.EQ.7) THEN
45124 ELSEIF(IVAR.EQ.8) THEN
45126 ELSEIF(IVAR.EQ.9) THEN
45128 ELSEIF(IVAR.EQ.10) THEN
45130 ELSEIF(IVAR.EQ.11) THEN
45132 ELSEIF(IVAR.EQ.12) THEN
45134 ELSEIF(IVAR.EQ.13) THEN
45136 ELSEIF(IVAR.EQ.14) THEN
45138 ELSEIF(IVAR.EQ.15) THEN
45140 ELSEIF(IVAR.EQ.16) THEN
45142 ELSEIF(IVAR.EQ.17) THEN
45144 ELSEIF(IVAR.EQ.18) THEN
45146 ELSEIF(IVAR.EQ.19) THEN
45148 ELSEIF(IVAR.EQ.20) THEN
45150 ELSEIF(IVAR.EQ.21) THEN
45152 ELSEIF(IVAR.EQ.22) THEN
45154 ELSEIF(IVAR.EQ.23) THEN
45156 ELSEIF(IVAR.EQ.24) THEN
45158 ELSEIF(IVAR.EQ.25) THEN
45160 ELSEIF(IVAR.EQ.26) THEN
45162 ELSEIF(IVAR.EQ.27) THEN
45164 ELSEIF(IVAR.EQ.28) THEN
45166 ELSEIF(IVAR.EQ.29) THEN
45168 ELSEIF(IVAR.EQ.30) THEN
45170 ELSEIF(IVAR.EQ.31) THEN
45172 ELSEIF(IVAR.EQ.32) THEN
45174 ELSEIF(IVAR.EQ.33) THEN
45175 IOLD=ICOL(I1,I2,I3)
45176 ELSEIF(IVAR.EQ.34) THEN
45178 ELSEIF(IVAR.EQ.35) THEN
45180 ELSEIF(IVAR.EQ.36) THEN
45182 ELSEIF(IVAR.EQ.37) THEN
45184 ELSEIF(IVAR.EQ.38) THEN
45186 ELSEIF(IVAR.EQ.39) THEN
45188 ELSEIF(IVAR.EQ.40) THEN
45190 ELSEIF(IVAR.EQ.41) THEN
45192 ELSEIF(IVAR.EQ.42) THEN
45193 ROLD=SIGT(I1,I2,I3)
45194 ELSEIF(IVAR.EQ.43) THEN
45196 ELSEIF(IVAR.EQ.44) THEN
45198 ELSEIF(IVAR.EQ.45) THEN
45200 ELSEIF(IVAR.EQ.46) THEN
45202 ELSEIF(IVAR.EQ.47) THEN
45204 ELSEIF(IVAR.EQ.48) THEN
45206 ELSEIF(IVAR.EQ.49) THEN
45208 ELSEIF(IVAR.EQ.50) THEN
45209 ROLD=RVLAM(I1,I2,I3)
45210 ELSEIF(IVAR.EQ.51) THEN
45211 ROLD=RVLAMP(I1,I2,I3)
45212 ELSEIF(IVAR.EQ.52) THEN
45213 ROLD=RVLAMB(I1,I2,I3)
45214 ELSEIF(IVAR.EQ.53) THEN
45216 ELSEIF(IVAR.EQ.54) THEN
45220 C...Print current value of variable. Loop back.
45221 IF(LNAM.GE.LBIT) THEN
45223 CHBIT(15:60)=' has the value '
45224 IF(MSVAR(IVAR,1).EQ.1) THEN
45225 WRITE(CHBIT(51:60),'(I10)') IOLD
45226 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
45227 WRITE(CHBIT(47:60),'(F14.5)') ROLD
45228 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
45233 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45235 IF(LLOW.LT.LTOT) GOTO 120
45239 C...Read in new variable value.
45240 IF(MSVAR(IVAR,1).EQ.1) THEN
45242 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
45243 READ(CHINI,'(I10)') INEW
45244 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
45246 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
45248 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
45249 CHNEW=CHBIT(LNAM+1:LBIT)//' '
45251 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
45254 C...Store new variable value.
45257 ELSEIF(IVAR.EQ.2) THEN
45259 ELSEIF(IVAR.EQ.3) THEN
45261 ELSEIF(IVAR.EQ.4) THEN
45263 ELSEIF(IVAR.EQ.5) THEN
45265 ELSEIF(IVAR.EQ.6) THEN
45267 ELSEIF(IVAR.EQ.7) THEN
45269 ELSEIF(IVAR.EQ.8) THEN
45271 ELSEIF(IVAR.EQ.9) THEN
45273 ELSEIF(IVAR.EQ.10) THEN
45275 ELSEIF(IVAR.EQ.11) THEN
45277 ELSEIF(IVAR.EQ.12) THEN
45279 ELSEIF(IVAR.EQ.13) THEN
45281 ELSEIF(IVAR.EQ.14) THEN
45283 ELSEIF(IVAR.EQ.15) THEN
45285 ELSEIF(IVAR.EQ.16) THEN
45287 ELSEIF(IVAR.EQ.17) THEN
45289 ELSEIF(IVAR.EQ.18) THEN
45291 ELSEIF(IVAR.EQ.19) THEN
45293 ELSEIF(IVAR.EQ.20) THEN
45295 ELSEIF(IVAR.EQ.21) THEN
45297 ELSEIF(IVAR.EQ.22) THEN
45299 ELSEIF(IVAR.EQ.23) THEN
45301 ELSEIF(IVAR.EQ.24) THEN
45303 ELSEIF(IVAR.EQ.25) THEN
45305 ELSEIF(IVAR.EQ.26) THEN
45307 ELSEIF(IVAR.EQ.27) THEN
45309 ELSEIF(IVAR.EQ.28) THEN
45311 ELSEIF(IVAR.EQ.29) THEN
45313 ELSEIF(IVAR.EQ.30) THEN
45315 ELSEIF(IVAR.EQ.31) THEN
45317 ELSEIF(IVAR.EQ.32) THEN
45319 ELSEIF(IVAR.EQ.33) THEN
45320 ICOL(I1,I2,I3)=INEW
45321 ELSEIF(IVAR.EQ.34) THEN
45323 ELSEIF(IVAR.EQ.35) THEN
45325 ELSEIF(IVAR.EQ.36) THEN
45327 ELSEIF(IVAR.EQ.37) THEN
45329 ELSEIF(IVAR.EQ.38) THEN
45331 ELSEIF(IVAR.EQ.39) THEN
45333 ELSEIF(IVAR.EQ.40) THEN
45335 ELSEIF(IVAR.EQ.41) THEN
45337 ELSEIF(IVAR.EQ.42) THEN
45338 SIGT(I1,I2,I3)=RNEW
45339 ELSEIF(IVAR.EQ.43) THEN
45341 ELSEIF(IVAR.EQ.44) THEN
45343 ELSEIF(IVAR.EQ.45) THEN
45345 ELSEIF(IVAR.EQ.46) THEN
45347 ELSEIF(IVAR.EQ.47) THEN
45349 ELSEIF(IVAR.EQ.48) THEN
45351 ELSEIF(IVAR.EQ.49) THEN
45353 ELSEIF(IVAR.EQ.50) THEN
45354 RVLAM(I1,I2,I3)=RNEW
45355 ELSEIF(IVAR.EQ.51) THEN
45356 RVLAMP(I1,I2,I3)=RNEW
45357 ELSEIF(IVAR.EQ.52) THEN
45358 RVLAMB(I1,I2,I3)=RNEW
45359 ELSEIF(IVAR.EQ.53) THEN
45361 ELSEIF(IVAR.EQ.54) THEN
45365 C...Write old and new value. Loop back.
45367 CHBIT(15:60)=' changed from to '
45368 IF(MSVAR(IVAR,1).EQ.1) THEN
45369 WRITE(CHBIT(33:42),'(I10)') IOLD
45370 WRITE(CHBIT(51:60),'(I10)') INEW
45371 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45372 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
45373 WRITE(CHBIT(29:42),'(F14.5)') ROLD
45374 WRITE(CHBIT(47:60),'(F14.5)') RNEW
45375 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45376 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
45379 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
45381 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
45382 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
45385 IF(LLOW.LT.LTOT) GOTO 120
45387 C...Format statement for output on unit MSTU(11) (by default 6).
45388 5000 FORMAT(5X,A60)
45389 5100 FORMAT(5X,A88)
45394 C*********************************************************************
45397 C...Administrates the fragmentation and decay chain.
45401 C...Double precision and integer declarations.
45402 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45403 IMPLICIT INTEGER(I-N)
45404 INTEGER PYK,PYCHGE,PYCOMP
45406 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45407 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45408 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45409 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45410 COMMON/PYINT4/MWID(500),WIDS(500,5)
45411 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
45413 DIMENSION PS(2,6),IJOIN(100)
45414 C...Initialize and reset.
45416 IF(MSTU(12).GE.1) CALL PYLIST(0)
45418 MSTU(31)=MSTU(31)+1
45422 IF(MSTU(17).LE.0) MSTU(90)=0
45425 C...Sum up momentum, energy and charge for starting entries.
45433 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
45435 PS(1,J)=PS(1,J)+P(I,J)
45437 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
45441 C...Start by all decays of coloured resonances involved in shower.
45444 IF(K(I,1).EQ.3) THEN
45446 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
45450 C...Prepare system for subsequent fragmentation/decay.
45453 C...Loop through jet fragmentation and particle decays.
45459 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
45462 C...Deal with any remaining undecayed resonance
45463 C...(normally the task of PYEVNT, so seldom used).
45464 ELSEIF(MWID(KC).NE.0) THEN
45466 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
45469 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
45470 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
45473 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
45474 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
45477 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
45486 C...Particle decay if unstable and allowed. Save long-lived particle
45487 C...decays until second pass after Bose-Einstein effects.
45488 ELSEIF(KCHG(KC,2).EQ.0) THEN
45489 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
45490 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
45493 C...Decay products may develop a shower.
45494 IF(MSTJ(92).GT.0) THEN
45496 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
45497 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
45498 CALL PYSHOW(IP1,IP1+1,QMAX)
45501 ELSEIF(MSTJ(92).LT.0) THEN
45503 CALL PYSHOW(IP1,-3,P(IP,5))
45508 C...Jet fragmentation: string or independent fragmentation.
45509 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
45511 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
45512 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
45513 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
45514 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
45515 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
45518 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
45519 IF(MFRAG.EQ.2) CALL PYINDF(IP)
45520 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
45521 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
45524 C...Loop back if enough space left in PYJETS and no error abort.
45525 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
45526 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
45528 ELSEIF(IP.LT.N) THEN
45529 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
45532 C...Include simple Bose-Einstein effect parametrization if desired.
45533 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
45538 C...Check that momentum, energy and charge were conserved.
45540 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
45542 PS(2,J)=PS(2,J)+P(I,J)
45544 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
45546 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
45547 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
45548 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
45549 &'(PYEXEC:) four-momentum was not conserved')
45550 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
45551 &'(PYEXEC:) charge was not conserved')
45556 C*********************************************************************
45559 C...Rearranges partons along strings.
45560 C...Special considerations for systems with junctions, with
45561 C...possibility of junction-antijunction annihilation.
45562 C...Allows small systems to collapse into one or two particles.
45563 C...Checks flavours and colour singlet invariant masses.
45565 SUBROUTINE PYPREP(IP)
45567 C...Double precision and integer declarations.
45568 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45569 INTEGER PYK,PYCHGE,PYCOMP
45571 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
45572 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45573 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45574 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45575 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
45577 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
45578 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
45579 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
45580 &IJCP(0:6),TJUOLD(5)
45582 C...Function to give four-product.
45583 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)
45585 C...Rearrange parton shower product listing along strings: begin loop.
45593 DO 160 I=MAX(1,IP),N
45595 C...Special treatment for junctions
45596 IF(K(I,1).EQ.42) THEN
45597 C...First, just store positions
45598 IF (MQGST.EQ.1) THEN
45602 C...Then look for junction-junction strings (not detected in the
45603 C...main search below).
45604 ELSE IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
45605 IF (NJJSTR.EQ.0) THEN
45606 NJJSTR = (3*NJUNC-NPIECE)/2
45608 C...Check how many already identified strings end on this junction
45611 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
45613 C...If only 2, third one must be to another junction
45615 C...The colour information in the junction is unreadable for the
45616 C...colour space search further down in this routine, so we must
45617 C...start on the colour mother of this junction and then "artificially"
45618 C...prevent the colour mother from connecting here again.
45619 IA=MOD(K(I,4),MSTU(5))
45621 IF (MOD(MOD(K(I,4)/MSTU(5),MSTU(5)),2).EQ.1) KCS=5
45622 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
45623 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
45627 ELSE IF (ILC.NE.3) THEN
45628 C...This could happen if 2 legs of a junction connect to other
45631 & '(PYPREP:) Too many junction-junction strings.')
45636 C...Look for coloured string endpoint, or (later) leftover gluon.
45637 IF(K(I,1).NE.3) GOTO 160
45639 IF(KC.EQ.0) GOTO 160
45641 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 160
45643 C...Pick up loose string end.
45645 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
45651 IF(NSTP.GT.4*N) THEN
45652 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
45656 C...Copy undecayed parton. Finished if reached string endpoint.
45657 IF(K(IA,1).EQ.3) THEN
45658 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
45659 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
45664 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
45674 IF(K(I1,1).EQ.1) GOTO 160
45677 C...Also finished (for now) if reached junction; then copy to end.
45678 IF(K(IA,1).EQ.42) THEN
45680 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
45681 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
45684 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
45685 DO 140 ICOPY=1,NCOPY
45687 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
45688 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
45689 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
45695 IPIECE(NPIECE,1)=MSTU32+1
45696 IPIECE(NPIECE,2)=MSTU32+NCOPY
45697 IPIECE(NPIECE,3)=IB
45698 IPIECE(NPIECE,4)=IA
45699 MSTU32=MSTU32+NCOPY
45704 C...GOTO next parton in colour space.
45706 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
45708 IA=MOD(K(IB,KCS),MSTU(5))
45709 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
45712 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
45713 & MSTU(5)).EQ.0) KCS=9-KCS
45714 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
45715 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
45718 IF(IA.LE.0.OR.IA.GT.N) THEN
45719 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
45722 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
45723 & MSTU(5)).EQ.IB) THEN
45724 IF(MREV.EQ.1) KCS=9-KCS
45725 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
45726 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
45728 IF(MREV.EQ.0) KCS=9-KCS
45729 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
45730 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
45732 IF(IA.NE.I) GOTO 110
45737 C...Junction systems remain.
45743 180 IJUCNT=IJUCNT+1
45744 IF (IJUCNT.LE.NJUNC) THEN
45745 C...If we are not processing a j-j string, treat this junction as new.
45746 IF (IJJSTR.EQ.0) THEN
45747 IJU=IJUNC(IJUCNT,0)
45749 C...If junction has already been read, ignore it.
45750 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 180
45751 C...If we are on a j-j string, goto second j-j junction.
45756 C...Mark selected junction read.
45758 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
45761 C...Determine junction type
45762 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
45763 C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
45764 C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
45765 C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
45766 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
45769 C...Find which quarks belong to given junction.
45770 IF(IHK.EQ.1) IEND=MOD(K(IJU,5),MSTU(5))
45771 IF(IHK.EQ.2) IEND=MOD(K(IJU,5)/MSTU(5),MSTU(5))
45772 C...IHK = 3 is special. Either normal string piece, or j-j string.
45774 IEND=MOD(K(IJU,4),MSTU(5))
45775 IF (MREV.NE.1) THEN
45776 DO 210 IPC=1,NPIECE
45777 C...If there is a j-j string starting on the present junction which has
45778 C...zero length, insert next junction immediately.
45779 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
45780 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
45786 C...If MREV is 1 and IHK is 3 we are finished with this system.
45793 C...If we've gotten this far, then either IHK < 3, or
45794 C...an interjunction string exists, or just a third normal string.
45795 IJUNC(IJUCNT,IHK)=0
45797 C..Order pieces belonging to this junction. Also look for j-j.
45798 DO 220 IPC=1,NPIECE
45799 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
45800 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
45801 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
45802 IJUNC(IJUCNT,IHK)=IPC
45807 C...Copy back chains in proper order. MREV=0/1 : descending/ascending
45808 IPC=IJUNC(IJUCNT,IHK)
45809 DO 240 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
45812 K(I1,J)=K(MSTU(4)-ICP,J)
45813 P(I1,J)=P(MSTU(4)-ICP,J)
45814 V(I1,J)=V(MSTU(4)-ICP,J)
45818 C...Mark last quark.
45819 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
45820 C...Do not insert junctions at wrong places.
45821 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 270
45822 C...Insert junction.
45825 C...Shift to end junction if a j-j string has been processed.
45826 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
45836 K(IJUS,1)=K(IJUS,1)+10
45839 270 IF (IHK.LT.3) GOTO 200
45841 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
45843 IF (IJUCNT.NE.NJUNC) GOTO 180
45847 C...Rearrange three strings from junction, e.g. in case one has been
45848 C...shortened by shower, so the last is the largest-energy one.
45849 IF(NJUNC.GE.1) THEN
45850 C...Find systems with exactly one junction.
45854 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
45855 ELSEIF(K(I,1).EQ.41) THEN
45857 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
45862 C...Sum up energy-momentum in each junction string.
45869 DO 300 I1=NBEG,NEND
45870 IF(K(I1,2).NE.21) THEN
45875 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
45878 C...Find which of them has highest energy (minus mass) in rest frame.
45880 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
45882 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
45885 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
45886 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
45888 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
45889 C...Decide how to rearrange so that new last has highest energy.
45890 IF(PJU(1,6).LT.PJU(2,6)) THEN
45892 IRNG(1,2)=IJUR(2)-1
45894 IRNG(2,2)=IJUR(3)+1
45895 IRNG(4,1)=IJUR(3)-1
45899 IRNG(1,2)=IJUR(3)+1
45901 IRNG(2,2)=IJUR(3)-1
45902 IRNG(4,1)=IJUR(2)-1
45907 C...Copy in correct order below bottom of current event record.
45910 DO 340 I1=IRNG(II,1),IRNG(II,2),
45911 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
45918 IF(K(I2,1).EQ.1) K(I2,1)=2
45922 C...Copy back up, overwriting but now in correct order.
45923 DO 370 I1=NBEG,NEND
45937 C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
45938 C...to two q-qbar systems.
45939 C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
45940 IF (MSTJ(19).NE.1) THEN
45944 C...Force collapse when MSTJ(19)=2.
45945 IF (MSTJ(19).EQ.2) THEN
45949 C...Find systems with exactly two junctions.
45951 C...Count junctions
45952 IF (K(I,1).EQ.41) THEN
45954 C...Check for interjunction gluons
45955 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
45958 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
45959 C...If end of system reached with either zero or one junction, restart
45960 C...with next system.
45964 ELSEIF(K(I,1).EQ.1) THEN
45965 C...If end of system reached with exactly two junctions, compute string
45966 C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
45967 C...length measure for the (q-qbar)(q-qbar) topology.
45969 C...Loop down through chain.
45971 DO 390 I1=NBEG,NEND
45972 C...Store string piece division locations in event record
45973 IF (K(I1,2).NE.21) THEN
45978 C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
45980 IF (PYR(0).LT.0.5D0) ISW=1
45981 C...Randomly choose which qqbar string gets the jj gluons.
45983 IF (PYR(0).GT.0.5D0) IGS=2
45984 C...Only compute string lengths when no topology forced.
45985 IF (MSTJ(19).EQ.0) THEN
45986 C...Repeat following for each junction
45988 C...Initialize iterative procedure for finding JRF
45994 C...Start iteration. Sum up momenta in string pieces
45996 C...JD=-1 for first junction, +1 for second junction.
45997 C...Find out where piece starts and ends and which direction to go.
46000 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
46001 IB = IJCP((IJU-1)*7 - JD*IJS)
46002 ELSEIF (IJS.EQ.3) THEN
46004 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
46005 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
46007 C...Initialize junction pull 4-vector.
46011 C...Initialize weight
46014 C...Sum up (weighted) momenta along each string piece
46015 DO 440 ISP=IA,IB,JD
46016 C...If present parton not last in chain
46017 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
46018 C...If last parton was a junction, store present weight
46019 IF (K(ISP-JD,2).EQ.88) THEN
46021 C...If last parton was a quark, reset to stored weight.
46022 ELSEIF (K(ISP-JD,2).NE.21) THEN
46026 C...Skip next parton if weight already large
46027 IF (PWT.GT.10D0) GOTO 440
46028 C...Compute momentum in TJUOLD frame:
46029 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
46031 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
46033 TMP=P(ISP,J)+TJUOLD(J)*BFC
46034 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
46037 TMP=TJUOLD(4)*P(ISP,4)+TDP
46038 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
46040 PWT=PWT+TMP/PARJ(48)
46041 C...Put |p| rather than m in 5th slot
46042 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
46049 C...Combine new boost (T) with old boost (TJUOLD)
46050 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
46052 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
46055 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
46057 C...If last boost small, accept JRF, else iterate.
46058 C...Also prevent possibility of infinite loop.
46059 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
46060 & IJRFIT.LT.MSTJ(18))THEN
46062 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
46063 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
46065 C...Store final boost, with change of sign since TJJ motion vector.
46067 TJJ(IJU,IX)=-TJUOLD(IX)
46069 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
46072 C...String length measure for (q-qbar)(q-qbar) topology.
46073 C...Note only momenta of nearest partons used (since rest of system
46075 IF (JJGLUE.EQ.0) THEN
46076 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
46077 & -1,IJCP(5-ISW)+1)
46079 C...Put jj gluons on selected string (IGS selected randomly above).
46081 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
46082 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
46084 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
46085 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
46089 C...String length measure for q-q-j-j-q-q topology.
46098 C...Note only momenta of nearest partons used (since rest of system
46101 IF (IX.EQ.4) ISGN=1
46102 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
46103 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
46104 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
46105 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
46106 IF (JJGLUE.EQ.0) THEN
46107 C...Junction motion vector dot product gives length when inter-junction
46109 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
46111 C...Junction motion vector dot products with gluon momenta give length
46112 C...when inter-junction gluons present.
46113 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
46114 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
46117 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
46118 IF (JJGLUE.EQ.0) THEN
46119 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
46121 DELMJJ=DELMJJ*4D0*T1G1*T2G2
46124 C...If delmjj > delmqq collapse string system to q-qbar q-qbar
46125 C...(Always the case for MSTJ(19)=2 due to initialization above)
46126 IF (DELMJJ.GT.DELMQQ) THEN
46127 C...Put new system at end of event record
46130 DO 510 ICOP=IJCP(IST),IJCP(IST+1)-1
46133 P(NCOP,IX)=P(ICOP,IX)
46134 K(NCOP,IX)=K(ICOP,IX)
46137 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
46138 C...Insert inter-junction gluon string piece (reversed)
46140 DO 530 ICOP=IJCP(4)-1,IJCP(3)+1,-1
46144 P(NCOP,IX)=P(ICOP,IX)
46145 K(NCOP,IX)=K(ICOP,IX)
46150 DO 550 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
46153 P(NCOP,IX)=P(ICOP,IX)
46154 K(NCOP,IX)=K(ICOP,IX)
46159 C...Copy system back in right order
46160 DO 580 ICOP=NBEG,NEND-2
46162 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
46163 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
46166 C...Shift down rest of event record
46167 DO 600 ICOP=NEND+1,N
46169 P(ICOP-2,IX)=P(ICOP,IX)
46170 K(ICOP-2,IX)=K(ICOP,IX)
46173 C...Update length of event record.
46183 C...Done if no checks on small-mass systems.
46184 IF(MSTJ(14).LT.0) RETURN
46185 IF(MSTJ(14).EQ.0) GOTO 1050
46187 C...Find lowest-mass colour singlet jet system.
46192 DO 680 I=MAX(1,IP),N
46193 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
46194 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
46201 DPS(5)=PYMASS(K(I,2))
46202 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
46204 DPS(J)=DPS(J)+P(I,J)
46207 DPS(5)=DPS(5)+PYMASS(K(I,2))
46208 ELSEIF(K(I,1).EQ.2) THEN
46210 DPS(J)=DPS(J)+P(I,J)
46212 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
46214 DPS(J)=DPS(J)+P(I,J)
46217 DPS(5)=DPS(5)+PYMASS(K(I,2))
46218 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
46220 IF(PD.LT.PDMIN) THEN
46234 C...Done if lowest-mass system above threshold for string frag.
46235 IF(PDMIN.GE.PARJ(32)) GOTO 1050
46237 C...Fill small-mass system as cluster.
46239 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
46249 C...Set up history, assuming cluster -> 2 hadrons.
46255 IF(MSTU(16).NE.2) THEN
46270 C...Find total flavour content - complicated by presence of junctions.
46274 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
46277 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
46281 C...If several diquarks, split up one to give even number of flavours.
46282 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
46284 IF(IABS(KFQ(3)).LT.1000) I1=1
46285 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
46286 KFQ(I1)=KFQ(I1)/1000
46291 C...If four quark ends, join two to diquark.
46292 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
46295 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
46296 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
46297 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
46298 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
46299 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
46300 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
46306 C...If two quark ends, plus quark or diquark, join quarks to diquark.
46310 IF(IABS(KFQ(I1)).GT.1000) I1=3
46311 IF(IABS(KFQ(I2)).GT.1000) I2=3
46312 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
46313 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
46314 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
46315 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
46321 C...Form two particles from flavours of lowest-mass system, if feasible.
46323 700 NTRY = NTRY + 1
46325 C...Open string with two specified endpoint flavours.
46329 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1050
46330 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
46331 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
46332 IF(KQ1+KQ2.NE.0) GOTO 1050
46333 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
46335 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
46337 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
46338 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
46339 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 710
46341 C...Open string with four specified flavours.
46342 ELSEIF(NQ.EQ.4) THEN
46347 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1050
46348 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
46349 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
46350 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
46351 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
46352 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1050
46353 C...Combine flavours pairwise to form two hadrons.
46356 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
46357 & IABS(KFQ(2)).GT.1000)) I2=3
46358 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
46359 & IABS(KFQ(3)).GT.1000))) I2=4
46363 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
46364 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
46365 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 720
46369 IF(IABS(K(IC2,2)).NE.21) GOTO 1050
46370 C...No room for popcorn mesons in closed string -> 2 hadrons.
46372 730 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
46373 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
46374 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
46375 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 730
46377 P(N+2,5)=PYMASS(K(N+2,2))
46378 P(N+3,5)=PYMASS(K(N+3,2))
46380 C...If it does not work: try again (a number of times), give up (if no
46381 C...place to shuffle momentum or too many flavours), or form one hadron.
46382 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
46383 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
46385 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
46392 C...Perform two-particle decay of jet system.
46393 C...First step: find reference axis in decaying system rest frame.
46394 C...(Borrow slot N+2 for temporary direction.)
46398 DO 760 I=IC1+1,IC2-1
46399 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
46400 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
46401 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
46403 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
46407 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
46409 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
46410 PHI1=PYANGL(P(N+2,1),P(N+2,2))
46412 C...Second step: generate isotropic/anisotropic decay.
46413 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
46414 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
46416 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
46417 PT2=(1D0-UE(3)**2)*PA**2
46418 IF(MSTJ(16).LE.0) THEN
46421 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 770
46422 PR1=P(N+2,5)**2+PT2
46423 PR2=P(N+3,5)**2+PT2
46424 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
46426 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
46427 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
46429 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
46431 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
46432 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
46437 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
46438 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
46440 C...Third step: move back to event frame and set production vertex.
46441 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
46451 C...Else form one particle, if possible.
46459 C...Select hadron flavour from available quark flavours.
46460 820 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
46462 ELSEIF(NQ.EQ.2) THEN
46463 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
46465 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
46466 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
46468 IF(K(N+2,2).EQ.0) GOTO 820
46469 P(N+2,5)=PYMASS(K(N+2,2))
46471 C...Use old algorithm for E/p conservation? (EN)
46472 IF (MSTJ(16).LE.0) GOTO 990
46474 C...Find the string piece closest to the cluster by a loop
46475 C...over the undecayed partons not in present cluster. (EN)
46480 DO 850 I1=MAX(1,IP),N-1
46481 IF(K(I,1).EQ.1) NJUNC=0
46482 IF(K(I,1).EQ.41) NJUNC=NJUNC+1
46483 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
46485 ELSEIF(K(I1,1).EQ.2) THEN
46489 IF(K(I2,1).EQ.41) GOTO 850
46490 IF(K(I2,1).GT.10) GOTO 830
46491 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 830
46492 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
46493 & NJUNC.EQ.0) GOTO 850
46494 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 850
46496 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
46498 E1(J)=P(I1,J)/P(I1,4)
46499 E2(J)=P(I2,J)/P(I2,4)
46500 ECL(J)=P(N+1,J)/P(N+1,4)
46505 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
46506 E3S=E3(1)**2+E3(2)**2+E3(3)**2
46507 E4S=E4(1)**2+E4(2)**2+E4(3)**2
46508 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
46509 IF(E34.LE.0D0) THEN
46511 ELSEIF(E34.LT.E3S) THEN
46512 DDMIN=E4S-E34**2/E3S
46514 DDMIN=E4S-2D0*E34+E3S
46517 C...Is this the smallest so far?
46518 IF(DDMIN.LT.DGLOMI) THEN
46523 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
46528 C... Check if there are any strings to connect to the new gluon. (EN)
46529 IF (IBEG.EQ.0) GOTO 990
46531 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
46532 IF (P(N+1,5).GE.P(N+2,5)) THEN
46534 C...Construct 'gluon' that is needed to put hadron on the mass shell.
46535 FRAC=P(N+2,5)/P(N+1,5)
46537 P(N+2,J)=FRAC*P(N+1,J)
46538 PG(J)=(1D0-FRAC)*P(N+1,J)
46541 C... Copy string with new gluon put in.
46545 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 870
46546 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 870
46567 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 870
46570 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
46571 C...from string piece endpoints.
46574 C...Begin by copying string that should give energy to cluster.
46578 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 900
46579 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 900
46591 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 900
46594 C...Set initial Phad.
46596 P(NSAV+2,J)=P(NSAV+1,J)
46599 C...Calculate Pg, a part of which will be added to Phad later. (EN)
46600 930 IF(MSTJ(16).EQ.1) THEN
46604 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
46605 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
46608 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
46610 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
46612 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
46613 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
46615 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
46616 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
46617 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
46619 C...If all gluon energy eaten, zero it and take a step back.
46621 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3) THEN
46624 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
46630 IF(K(I1,1).EQ.41) ITER=-1
46632 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N) THEN
46635 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
46641 IF(K(I2,1).EQ.41) ITER=-1
46643 IF(ITER.EQ.1) GOTO 930
46645 C...If also all endpoint energy eaten, revert to old procedure.
46646 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
46647 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
46658 C... Construct the collapsed hadron and modified string partons.
46660 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
46661 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
46662 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
46664 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
46665 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
46667 C...Finished with string collapse in new scheme.
46671 C... Use old algorithm; by choice or when in trouble.
46673 C...Find parton/particle which combines to largest extra mass.
46678 IF(IR.NE.0) GOTO 1010
46679 DO 1000 I=MAX(1,IP),N
46680 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
46681 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1000
46682 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
46683 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1000
46684 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1000
46685 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
46687 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
46688 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
46689 IF(HSR.GT.HSM) THEN
46697 C...Shuffle energy and momentum to put new particle on mass shell.
46702 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
46703 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
46704 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
46706 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
46707 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
46711 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
46715 C...Mark collapsed system and store daughter pointers. Iterate.
46716 1030 DO 1040 I=IC1,IC2
46717 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
46718 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
46720 IF(MSTU(16).NE.2) THEN
46725 K(I,5)=NSAV+1+NBODY
46728 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
46730 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 620
46732 C...Check flavours and invariant masses in parton systems.
46740 DO 1090 I=MAX(1,IP),N
46741 IF(K(I,1).EQ.41) NJU=NJU+1
46742 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1090
46744 IF(KC.EQ.0) GOTO 1090
46745 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
46746 IF(KQ.EQ.0) GOTO 1090
46752 DPS(5)=DPS(5)+PYMASS(K(I,2))
46755 DPS(J)=DPS(J)+P(I,J)
46757 IF(K(I,1).EQ.1) THEN
46759 IF(NJU.EQ.0.AND.NP.NE.1) THEN
46760 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
46761 ELSEIF(NJU.EQ.1) THEN
46762 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
46763 ELSEIF(NJU.EQ.2) THEN
46764 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
46765 ELSEIF(NJU.GE.3) THEN
46768 IF(NFERR.EQ.1) CALL
46769 & PYERRM(2,'(PYPREP:) unphysical flavour combination')
46770 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
46771 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
46772 & '(PYPREP:) too small mass in jet system')
46786 C*********************************************************************
46789 C...Handles the fragmentation of an arbitrary colour singlet
46790 C...jet system according to the Lund string fragmentation model.
46792 SUBROUTINE PYSTRF(IP)
46794 C...Double precision and integer declarations.
46795 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46796 IMPLICIT INTEGER(I-N)
46797 INTEGER PYK,PYCHGE,PYCOMP
46799 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
46800 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46801 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46802 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
46803 C...Local arrays. All MOPS variables ends with MO
46804 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
46805 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
46806 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
46807 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
46808 &PBST(3,5),TJUOLD(5)
46810 C...Function: four-product of two vectors.
46811 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)
46812 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
46815 C...Reset counters.
46830 C...Identify parton system.
46833 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
46834 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
46835 IF(MSTU(21).GE.1) RETURN
46837 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
46839 IF(KC.EQ.0) GOTO 110
46840 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
46841 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
46842 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
46843 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
46844 IF(MSTU(21).GE.1) RETURN
46847 C...Take copy of partons to be considered. Check flavour sum.
46852 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
46854 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
46856 IF(KQ.NE.2) KQSUM=KQSUM+KQ
46857 IF(K(I,1).EQ.41) THEN
46858 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
46866 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
46867 IF(MOD(KQSUM,3).NE.0) THEN
46868 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
46869 IF(MSTU(21).GE.1) RETURN
46871 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
46873 C...Boost copied system to CM frame (for better numerical precision).
46874 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
46877 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
46881 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
46883 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
46884 IF(P(I,3).GT.0D0) THEN
46885 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
46886 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
46887 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
46889 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
46890 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
46891 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
46896 C...Search for very nearby partons that may be recombined.
46904 140 IF(NR.GE.3) THEN
46907 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
46909 IF(I.EQ.N+NR) I1=N+1
46910 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
46911 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
46913 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
46915 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
46916 & P(I1,2)**2+P(I1,3)**2))
46917 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
46918 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
46919 IF(PDR.LT.PDRMIN) THEN
46925 C...Recombine very nearby partons to avoid machine precision problems.
46926 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
46928 P(N+1,J)=P(N+1,J)+P(N+NR,J)
46930 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
46934 ELSEIF(PDRMIN.LT.PARU12) THEN
46936 P(IR,J)=P(IR,J)+P(IR+1,J)
46938 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
46940 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
46941 DO 190 I=IR+1,N+NR-1
46948 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
46950 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
46951 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
46957 C...Reset particle counter. Skip ahead if no junctions are present;
46958 C...this is usually the case!
46959 NRS=MAX(5*NR+11,NP)
46962 IF(NTRY.GT.100.AND.NTRYR.LE.8) THEN
46966 ELSEIF(NTRY.GT.100) THEN
46967 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
46968 IF(MSTU(21).GE.1) RETURN
46972 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 640
46973 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
46974 & ' junction strings not handled by MSTJ(12)>3 options')
46977 IF(MJU(JT).EQ.0) GOTO 630
46981 C...Find and sum up momentum on three sides of junction.
46982 C...Begin with previous boost = zero.
46989 C...Beginning and end of string system in event record.
46990 I1BEG=N+1+(JT-1)*(NR-1)
46991 I1END=N+NR+(JT-1)*(1-NR)
46992 C...Look for junction string piece end points
46993 DO 230 I1=I1BEG,I1END,JS
46994 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
46995 C...Store junction string piece end points.
46996 C 1-junction systems 2-junction systems
46997 C IU : 1 2 3 4 1 2 3 4 5 6
46998 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
47002 C...Sum over momenta, from junction outwards.
47006 C...Initialize junction drag and string piece 4-vectors.
47011 C...First two branches. Inwards out means opposite direction to JS.
47012 C...(JS is 1 for JT=1, -1 for JT=2)
47017 C...Last branch (gq or gjgqgq). Direction now reversed.
47023 DO 270 I1=I1A,I1B,IDIR
47024 C...Sum up momentum directions with exponential suppression
47025 C...for use in finding junction rest frame below.
47026 IF (K(I1,2).EQ.88) THEN
47027 C...gjgqgq type system encountered. Use current PWT as start
47028 C...for both strings.
47031 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
47032 C...Sum up string piece (boosted) 4-momenta.
47034 PJU(IU,J)=PJU(IU,J)+P(I1,J)
47036 C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
47037 C...boost is zero, see above). Skip parton if suppression factor large.
47038 IF (PWT.GT.10D0) GOTO 270
47039 C...Compute momentum in current frame:
47040 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
47041 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
47043 PTMP=P(I1,J)+TJUOLD(J)*BFC
47044 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
47047 PTMP=TJUOLD(4)*P(I1,4)+TDP
47048 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
47049 PWT=PWT+PTMP/PARJ(48)
47052 C...Put |p| rather than m in 5th slot.
47053 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
47054 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
47057 C...Calculate boost from present frame to next JRF candidate.
47059 CALL PYJURF(PBST,TJU)
47061 C...Combine new boost (TJU) with old boost (TJUOLD)
47062 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
47064 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
47066 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
47068 C...If last boost small, accept JRF, else iterate.
47069 C...Also prevent possibility of infinite loop.
47070 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
47071 & IJRFIT.LT.MSTJ(18)) THEN
47073 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
47074 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
47077 C...Now store total boost in TJU and change perception.
47078 C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
47079 C...TJU = junction motion vector in string CM, so the sign changes.
47083 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
47087 C...Calculate string piece energies in junction rest frame.
47089 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
47091 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
47092 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
47095 C...Start preparing for fragmentation of two strings from junction.
47098 320 NTRYER=NTRYER+1
47101 NS=IABS(IJU(IU+1)-IJU(IU))
47103 C...Junction strings: find longitudinal string directions.
47105 IS1=IJU(IU)+JS*(IS-1)
47108 DP(1,J)=0.5D0*P(IS1,J)
47109 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
47110 DP(2,J)=0.5D0*P(IS2,J)
47111 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
47112 & (PJU(IU,5)/PBST(IU,5))
47114 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
47115 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
47119 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
47120 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47121 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47126 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
47127 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
47128 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
47130 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
47132 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
47133 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
47137 C...Junction strings: initialize flavour, momentum and starting pos.
47141 IF(NTRY.GT.100.AND.NTRYR.LE.8) THEN
47145 ELSEIF(NTRY.GT.100) THEN
47146 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
47147 IF(MSTU(21).GE.1) RETURN
47152 IE(1)=K(N+1+(JT/2)*(NP-1),3)
47157 DO 370 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
47163 KFL(1)=K(IJU(IU),2)
47171 C...Junction strings: find initial transverse directions.
47174 DP(2,J)=P(IN(4)+1,J)
47178 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47179 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47180 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47181 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47182 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47183 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47184 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47185 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47186 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47188 DHCX1=DFOUR(3,1)/DHC12
47189 DHCX2=DFOUR(3,2)/DHC12
47190 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47191 DHCY1=DFOUR(4,1)/DHC12
47192 DHCY2=DFOUR(4,2)/DHC12
47193 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47194 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47196 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47198 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47202 C...Junction strings: produce new particle, origin.
47204 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
47205 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
47206 IF(MSTU(21).GE.1) RETURN
47214 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
47215 430 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
47216 IF(K(I,2).EQ.0) GOTO 360
47217 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
47218 & IABS(KFL(3)).GT.10) THEN
47219 IF(PYR(0).GT.PARJ(19)) GOTO 430
47221 P(I,5)=PYMASS(K(I,2))
47222 CALL PYPTDI(KFL(1),PX(3),PY(3))
47223 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
47224 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
47225 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
47226 & MSTU(90).LT.8) THEN
47227 MSTU(90)=MSTU(90)+1
47228 MSTU(90+MSTU(90))=I
47229 PARU(90+MSTU(90))=Z
47231 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
47236 C...Junction strings: stepping within 'low' string region.
47237 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
47238 & P(IN(1),5)**2.GE.PR(1)) THEN
47239 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
47240 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
47242 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
47245 C...Has used up energy of junction string, i.e. no more hadrons in it.
47246 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
47251 C...Stepping from 'low' string region
47252 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
47253 P(IN(2)+2,4)=P(IN(2)+2,3)
47256 IF(IN(2).GT.N+NR+4*NS) GOTO 360
47257 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47258 P(IN(1)+2,4)=P(IN(1)+2,3)
47264 C...Junction strings: find new transverse directions.
47265 470 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
47266 & IN(1).GT.IN(2)) GOTO 360
47267 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
47274 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47275 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47277 IF(DHC12.LE.1D-2) THEN
47278 P(IN(1)+2,4)=P(IN(1)+2,3)
47284 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47285 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47286 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47287 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47288 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47289 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47290 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47291 DHCX1=DFOUR(3,1)/DHC12
47292 DHCX2=DFOUR(3,2)/DHC12
47293 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47294 DHCY1=DFOUR(4,1)/DHC12
47295 DHCY2=DFOUR(4,2)/DHC12
47296 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47297 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47299 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47301 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47304 C...Express pT with respect to new axes, if sensible.
47305 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
47306 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
47307 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
47313 C...Junction strings: sum up known four-momentum, coefficients for m2.
47316 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
47317 & PY(3)*P(IN(3)+1,J)
47318 DO 500 IN1=IN(4),IN(1)-4,4
47319 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
47321 DO 510 IN2=IN(5),IN(2)-4,4
47322 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
47326 DHM(2)=2D0*FOUR(I,IN(1))
47327 DHM(3)=2D0*FOUR(I,IN(2))
47328 DHM(4)=2D0*FOUR(IN(1),IN(2))
47330 C...Junction strings: find coefficients for Gamma expression.
47331 DO 540 IN2=IN(1)+1,IN(2),4
47332 DO 530 IN1=IN(1),IN2-1,4
47333 DHC=2D0*FOUR(IN1,IN2)
47334 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
47335 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
47336 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
47337 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
47341 C...Junction strings: solve (m2, Gamma) equation system for energies.
47342 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
47343 IF(ABS(DHS1).LT.1D-4) GOTO 360
47344 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
47345 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
47346 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
47347 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
47348 & ABS(DHS1)-DHS2/DHS1)
47349 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
47350 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
47351 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
47353 C...Junction strings: step to new region if necessary.
47354 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
47355 P(IN(2)+2,4)=P(IN(2)+2,3)
47358 IF(IN(2).GT.N+NR+4*NS) GOTO 360
47359 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47360 P(IN(1)+2,4)=P(IN(1)+2,3)
47365 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
47366 P(IN(1)+2,4)=P(IN(1)+2,3)
47372 C...Junction strings: particle four-momentum, remainder, loop back.
47374 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
47375 & P(IN(2)+2,4)*P(IN(2),J)
47376 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
47378 IF(P(I,4).LT.P(I,5)) GOTO 360
47379 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
47380 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
47381 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
47386 IF(IN(3).NE.IN(6)) THEN
47388 P(IN(6),J)=P(IN(3),J)
47389 P(IN(6)+1,J)=P(IN(3)+1,J)
47394 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
47395 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
47400 C...Junction strings: save quantities left after each string.
47401 IF(IABS(KFL(1)).GT.10) GOTO 360
47405 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
47408 C...Junction strings: loopback if much unused energy in both strings.
47409 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
47410 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
47411 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
47413 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
47414 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
47415 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
47416 & .AND.NTRYER.LT.10) GOTO 320
47418 C...Junction strings: put together to new effective string endpoint.
47420 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
47421 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
47422 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
47423 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
47425 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
47426 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
47428 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
47433 C...Open versus closed strings. Choose breakup region for latter.
47434 640 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
47437 ELSEIF(MJU(1).NE.0) THEN
47440 ELSEIF(MJU(2).NE.0) THEN
47443 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
47450 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
47451 W2SUM=W2SUM+P(N+NR+IS,1)
47456 W2SUM=W2SUM-P(N+NR+NB,1)
47457 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 660
47460 C...Find longitudinal string directions (i.e. lightlike four-vectors).
47462 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
47463 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
47466 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
47467 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
47469 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
47470 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
47472 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
47473 & DP(1,2)**2-DP(1,3)**2))
47474 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
47475 & DP(2,2)**2-DP(2,3)**2))
47479 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
47480 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
47481 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
47482 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
47484 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
47486 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
47487 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
47491 C...Begin initialization: sum up energy, set starting position.
47495 IF(NTRY.GT.100.AND.NTRYR.LE.8) THEN
47499 ELSEIF(NTRY.GT.100) THEN
47500 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
47501 IF(MSTU(21).GE.1) RETURN
47508 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
47513 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
47514 IF(NS.GT.NR) IRANK(JT)=1
47516 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
47517 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
47518 IN(3*JT+2)=IN(3*JT+1)+1
47519 IN(3*JT+3)=N+NR+4*NS+2*JT-1
47520 DO 730 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
47527 C.. MOPS variables and switches
47533 C...Initialize flavour and pT variables for open string.
47537 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
47541 KFL(JT)=K(IE(JT),2)
47542 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
47543 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
47545 PMQ(JT)=PYMASS(KFL(JT))
47549 C...Closed string: random initial breakup flavour, pT and vertex.
47551 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
47553 760 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
47554 C.. Closed string: first vertex diq attempt => enforced second
47556 IF(IABS(KFL(1)).GT.10)THEN
47561 IF(IBMO.EQ.1) MSTU(121)=-1
47563 CALL PYPTDI(KFL(1),PX(1),PY(1))
47566 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
47567 770 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
47568 ZR=PR3/(Z*P(N+NR+1,5)**2)
47569 IF(ZR.GE.1D0) GOTO 770
47572 PMQ(JT)=PYMASS(KFL(JT))
47573 GAM(JT)=PR3*(1D0-Z)/Z
47574 IN1=N+NR+3+4*(JT/2)*(NS-1)
47577 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
47580 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
47586 PM2QMO(JT)=PMQ(JT)**2
47587 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
47590 C...Find initial transverse directions (i.e. spacelike four-vectors).
47592 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
47601 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47602 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47603 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47604 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47605 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47606 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47607 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47608 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47609 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47611 DHCX1=DFOUR(3,1)/DHC12
47612 DHCX2=DFOUR(3,2)/DHC12
47613 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47614 DHCY1=DFOUR(4,1)/DHC12
47615 DHCY2=DFOUR(4,2)/DHC12
47616 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47617 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47619 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47621 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47626 P(IN3+2,J)=P(IN3,J)
47627 P(IN3+3,J)=P(IN3+1,J)
47632 C...Remove energy used up in junction string fragmentation.
47633 IF(MJU(1)+MJU(2).GT.0) THEN
47635 IF(NJS(JT).EQ.0) GOTO 850
47637 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
47641 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
47642 WMIN=PARJST+PMQ(1)+PMQ(2)
47643 WREM2=FOUR(N+NRS,N+NRS)
47644 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
47646 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
47651 C...Produce new particle: side, origin.
47653 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
47654 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
47655 IF(MSTU(21).GE.1) RETURN
47657 C.. New side priority for popcorn systems
47658 IF(MSTU(121).LE.0)THEN
47660 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
47661 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
47665 IRANK(JT)=IRANK(JT)+1
47670 C...Generate flavour, hadron and pT.
47672 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
47673 IF(K(I,2).EQ.0) GOTO 700
47675 IF(MSTU(121).EQ.-1) GOTO 900
47676 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
47677 &IABS(KFL(3)).GT.10) THEN
47678 IF(PYR(0).GT.PARJ(19)) GOTO 870
47680 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47682 P(I,5)=PYMASS(K(I,2))
47683 CALL PYPTDI(KFL(JT),PX(3),PY(3))
47684 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
47686 C...Final hadrons for small invariant mass.
47688 PMQ(3)=PYMASS(KFL(3))
47690 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
47691 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
47692 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
47693 &WMIN-0.5D0*PARJ(36)*PMQ(3)
47694 WREM2=FOUR(N+NRS,N+NRS)
47695 IF(WREM2.LT.0.10D0) GOTO 700
47696 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
47697 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1070
47699 C...Choose z, which gives Gamma. Shift z for heavy flavours.
47700 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
47701 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
47702 &MSTU(90).LT.8) THEN
47703 MSTU(90)=MSTU(90)+1
47704 MSTU(90+MSTU(90))=I
47705 PARU(90+MSTU(90))=Z
47709 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
47710 &MOD(KFL2A/1000,10)).GE.4) THEN
47711 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
47712 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
47713 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
47714 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
47715 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1070
47717 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
47719 C.. MOPS baryon model modification
47720 XTMO3=(1D0-Z)*XTMO(JT)
47721 IF(IABS(KFL(3)).LE.10) NRVMO=0
47722 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
47726 IF(IABS(KFL(JT)).LE.10)THEN
47727 XBMO=MIN(XTMO3,1D0-(2D-10))
47730 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
47731 GTSTMO=1D0-PARF(192)**PGMO
47733 IF(IRANK(JT).EQ.1) THEN
47738 IF(XBMO.LT.1D0-(1D-10))THEN
47739 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
47740 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
47743 IF(MSTJ(12).GE.5)THEN
47744 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
47745 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
47746 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
47751 C.. MOPS Accepting popcorn system hadron.
47752 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
47753 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
47755 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
47757 & '(PYSTRF:) no more memory left in PYJETS')
47758 IF(MSTU(21).GE.1) RETURN
47770 DO 880 LINE=1,I-N-NR
47771 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
47772 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
47779 C..Reject popcorn system, flag=-1 if enforcing new one
47781 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
47786 C..Lift restoring string outside MOPS block
47787 900 IF(MSTU(121).LT.0) THEN
47788 IF(MSTU(121).EQ.-2) MSTU(121)=0
47791 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 870
47802 DO 910 LINE=1,I-N-NR
47803 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
47804 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
47812 C.. MOPS end of modification
47818 C...Stepping within or from 'low' string region easy.
47819 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
47820 &P(IN(1),5)**2.GE.PR(JT)) THEN
47821 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
47822 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
47824 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
47827 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
47828 P(IN(JR)+2,4)=P(IN(JR)+2,3)
47831 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 700
47832 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47833 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47839 C...Find new transverse directions (i.e. spacelike string vectors).
47840 950 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
47841 &IN(1).GT.IN(2)) GOTO 700
47842 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
47849 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
47850 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
47852 IF(DHC12.LE.1D-2) THEN
47853 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47859 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
47860 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
47861 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
47862 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
47863 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
47864 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
47865 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
47866 DHCX1=DFOUR(3,1)/DHC12
47867 DHCX2=DFOUR(3,2)/DHC12
47868 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
47869 DHCY1=DFOUR(4,1)/DHC12
47870 DHCY2=DFOUR(4,2)/DHC12
47871 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
47872 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
47874 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
47876 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
47879 C...Express pT with respect to new axes, if sensible.
47880 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
47881 & FOUR(IN(3*JT+3)+1,IN(3)))
47882 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
47883 & FOUR(IN(3*JT+3)+1,IN(3)+1))
47884 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
47890 C...Sum up known four-momentum. Gives coefficients for m2 expression.
47893 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
47894 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
47895 DO 980 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
47896 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
47898 DO 990 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
47899 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
47903 DHM(2)=2D0*FOUR(I,IN(1))
47904 DHM(3)=2D0*FOUR(I,IN(2))
47905 DHM(4)=2D0*FOUR(IN(1),IN(2))
47907 C...Find coefficients for Gamma expression.
47908 DO 1020 IN2=IN(1)+1,IN(2),4
47909 DO 1010 IN1=IN(1),IN2-1,4
47910 DHC=2D0*FOUR(IN1,IN2)
47911 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
47912 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
47913 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
47914 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
47918 C...Solve (m2, Gamma) equation system for energies taken.
47919 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
47920 IF(ABS(DHS1).LT.1D-4) GOTO 700
47921 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
47922 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
47923 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
47924 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
47925 &ABS(DHS1)-DHS2/DHS1)
47926 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 700
47927 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
47928 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
47930 C...Step to new region if necessary.
47931 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
47932 P(IN(JR)+2,4)=P(IN(JR)+2,3)
47935 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 700
47936 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
47937 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47942 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
47943 P(IN(JT)+2,4)=P(IN(JT)+2,3)
47949 C...Four-momentum of particle. Remaining quantities. Loop back.
47951 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
47952 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
47954 IF(P(I,4).LT.P(I,5)) GOTO 700
47960 IF(IN(3).NE.IN(3*JT+3)) THEN
47962 P(IN(3*JT+3),J)=P(IN(3),J)
47963 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
47968 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
47969 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
47971 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47975 C...Final hadron: side, flavour, hadron, mass.
47981 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
47982 IF(K(I,2).EQ.0) GOTO 700
47983 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
47985 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47987 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
47989 P(I,5)=PYMASS(K(I,2))
47990 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
47992 C...Final two hadrons: find common setup of four-vectors.
47994 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
47995 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
47996 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
47997 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
47998 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
47999 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
48000 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
48001 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
48002 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
48003 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
48006 C...Solve kinematics for final two hadrons, if possible.
48007 WREM2=2D0*DHR1*DHR2*DHC12
48008 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
48009 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
48010 IF(FD.GE.1D0) GOTO 700
48011 FA=WREM2+PR(JT)-PR(JR)
48012 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
48014 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
48015 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
48016 FB=SIGN(FB,JS*(PYR(0)-PREV))
48019 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
48020 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
48021 &4D0*WREM2*PR(JT))),DBLE(JS))
48023 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
48024 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
48025 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
48026 P(I,J)=P(N+NRS,J)-P(I-1,J)
48028 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 700
48029 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
48030 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
48031 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
48033 IF(NTRYFN.LT.100) GOTO 140
48034 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
48037 C...Mark jets as fragmented and give daughter pointers.
48039 DO 1090 I=NSAV+1,NSAV+NP
48042 IF(MSTU(16).NE.2) THEN
48051 C...Document string system. Move up particles.
48062 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
48066 K(I,J)=K(I+NRS-1,J)
48067 P(I,J)=P(I+NRS-1,J)
48072 DO 1130 IZ=MSTU90+1,MSTU91
48073 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
48074 PARU9T(IZ)=PARU(90+IZ)
48078 C...Order particles in rank along the chain. Update mother pointer.
48081 K(I-NSAV+N,J)=K(I,J)
48082 P(I-NSAV+N,J)=P(I,J)
48086 DO 1180 I=N+1,2*N-NSAV
48087 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1180
48093 IF(MSTU(16).NE.2) K(I1,3)=NSAV
48094 DO 1170 IZ=MSTU90+1,MSTU91
48095 IF(MSTU9T(IZ).EQ.I) THEN
48096 MSTU(90)=MSTU(90)+1
48097 MSTU(90+MSTU(90))=I1
48098 PARU(90+MSTU(90))=PARU9T(IZ)
48102 DO 1210 I=2*N-NSAV,N+1,-1
48103 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1210
48109 IF(MSTU(16).NE.2) K(I1,3)=NSAV
48110 DO 1200 IZ=MSTU90+1,MSTU91
48111 IF(MSTU9T(IZ).EQ.I) THEN
48112 MSTU(90)=MSTU(90)+1
48113 MSTU(90+MSTU(90))=I1
48114 PARU(90+MSTU(90))=PARU9T(IZ)
48119 C...Boost back particle system. Set production vertices.
48122 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
48126 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
48127 IF(P(I,3).GT.0D0) THEN
48128 HHPEZ=(P(I,4)+P(I,3))*HHBZ
48129 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
48130 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
48132 HHPEZ=(P(I,4)-P(I,3))/HHBZ
48133 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
48134 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
48147 C*********************************************************************
48150 C...From three given input vectors in PJU the boost VJU from
48151 C...the "lab frame" to the junction rest frame is constructed.
48153 SUBROUTINE PYJURF(PJU,VJU)
48155 C...Double precision and integer declarations.
48156 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48157 IMPLICIT INTEGER(I-N)
48159 C...Input, output and local arrays.
48160 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
48161 DATA TWOPI/6.283186D0/
48163 C...Calculate masses and other invariants.
48165 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
48167 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
48168 PSUM(5)=SQRT(PSUM2)
48171 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
48172 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
48176 C...Pick I to be most massive parton and J to be the one closest to I.
48179 IF(A(2,2).GT.A(1,1)) I=2
48180 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
48184 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
48195 C...Trivial find new parton energies if all three partons are massless.
48196 IF(PMI2.LT.1D-4) THEN
48197 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
48198 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
48199 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
48201 C...Else find momentum range for parton I and values at extremes.
48207 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
48208 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
48209 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
48210 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
48211 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
48212 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
48213 HI=PEIMAX**2-0.25D0*PAIMAX**2
48214 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
48215 & 0.5D0*PAIMAX*AIJ)/HI
48216 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
48217 & 0.5D0*PAIMAX*AIK)/HI
48218 PEJMAX=SQRT(PAJMAX**2+PMJ2)
48219 PEKMAX=SQRT(PAKMAX**2+PMK2)
48220 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
48222 C...If unexpected values at upper endpoint then pick another parton.
48223 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
48225 IF(A(I1,I1).GE.1D-4) THEN
48231 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
48237 C..Start binary + linear search to find solution inside range.
48241 PAI=0.5D0*(PAIMIN+PAIMAX)
48244 C...Derive momentum of other two partons and distance to root.
48245 PEI=SQRT(PAI**2+PMI2)
48246 HI=PEI**2-0.25D0*PAI**2
48247 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
48248 PEJ=SQRT(PAJ**2+PMJ2)
48249 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
48250 PEK=SQRT(PAK**2+PMK2)
48251 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
48253 C...Pick next I momentum to explore, hopefully closer to root.
48254 IF(FNOW.GT.0D0) THEN
48263 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
48265 PAI=0.5D0*(PAIMIN+PAIMAX)
48267 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
48268 & ABS(FNOW).GT.1D-12*PSUM2) THEN
48269 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
48274 C...Now know energies in junction rest frame.
48279 C...Boost (copy of) partons to their rest frame.
48280 VXCM=-PSUM(1)/PSUM(5)
48281 VYCM=-PSUM(2)/PSUM(5)
48282 VZCM=-PSUM(3)/PSUM(5)
48283 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
48285 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
48286 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
48287 PCM(I,1)=PJU(I,1)+FAC2*VXCM
48288 PCM(I,2)=PJU(I,2)+FAC2*VYCM
48289 PCM(I,3)=PJU(I,3)+FAC2*VZCM
48290 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
48291 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
48294 C...Construct difference vectors and boost to junction rest frame.
48296 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
48297 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
48299 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
48300 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
48301 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
48302 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
48303 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
48304 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
48305 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
48306 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
48307 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
48308 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
48309 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
48311 C...Add two boosts, giving final result.
48312 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
48313 VJU(1)=VXJU+FCM*VXCM
48314 VJU(2)=VYJU+FCM*VYCM
48315 VJU(3)=VZJU+FCM*VZCM
48316 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
48319 C...In case of error in reconstruction: revert to CM frame of system.
48320 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
48321 &(PCM(1,5)*PCM(2,5))
48322 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
48323 &(PCM(1,5)*PCM(3,5))
48324 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
48325 &(PCM(2,5)*PCM(3,5))
48326 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
48327 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
48329 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
48330 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
48331 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
48332 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
48333 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
48334 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
48335 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
48337 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
48338 &(PCM(1,5)*PCM(2,5))
48339 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
48340 &(PCM(1,5)*PCM(3,5))
48341 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
48342 &(PCM(2,5)*PCM(3,5))
48343 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
48344 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
48345 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
48355 C*********************************************************************
48358 C...Handles the fragmentation of a jet system (or a single
48359 C...jet) according to independent fragmentation models.
48361 SUBROUTINE PYINDF(IP)
48363 C...Double precision and integer declarations.
48364 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48365 IMPLICIT INTEGER(I-N)
48366 INTEGER PYK,PYCHGE,PYCOMP
48368 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48369 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48370 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48371 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
48373 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
48374 &KFLO(2),PXO(2),PYO(2),WO(2)
48376 C.. MOPS error message
48377 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
48378 &' are not treated as expected in independent fragmentation')
48380 C...Reset counters. Identify parton system and take copy. Check flavour.
48390 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
48391 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
48392 IF(MSTU(21).GE.1) RETURN
48394 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
48396 IF(KC.EQ.0) GOTO 110
48397 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
48398 IF(KQ.EQ.0) GOTO 110
48400 IF(KQ.NE.2) KQSUM=KQSUM+KQ
48402 K(NSAV+NJET,J)=K(I,J)
48403 P(NSAV+NJET,J)=P(I,J)
48404 DPS(J)=DPS(J)+P(I,J)
48407 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
48408 &K(I+1,1).EQ.2)) GOTO 110
48409 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
48410 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
48411 IF(MSTU(21).GE.1) RETURN
48414 C...Boost copied system to CM frame. Find CM energy and sum flavours.
48417 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
48418 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
48424 DO 140 I=NSAV+1,NSAV+NJET
48428 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
48429 ELSEIF(KFA.GT.1000) THEN
48430 KFLA=MOD(KFA/1000,10)
48431 KFLB=MOD(KFA/100,10)
48432 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
48433 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
48437 C...Loop over attempts made. Reset counters.
48440 IF(NTRY.GT.200) THEN
48441 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
48442 IF(MSTU(21).GE.1) RETURN
48452 C...Loop over jets to be fragmented.
48453 DO 230 IP1=NSAV+1,NSAV+NJET
48458 C...Initial flavour and momentum values. Jet along +z axis.
48459 KFLH=IABS(K(IP1,2))
48460 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
48462 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
48464 C...Initial values for quark or diquark jet.
48465 170 IF(IABS(K(IP1,2)).NE.21) THEN
48468 CALL PYPTDI(0,PXO(1),PYO(1))
48471 C...Initial values for gluon treated like random quark jet.
48472 ELSEIF(MSTJ(2).LE.2) THEN
48474 IF(MSTJ(2).EQ.2) MSTJ(91)=1
48475 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
48476 CALL PYPTDI(0,PXO(1),PYO(1))
48479 C...Initial values for gluon treated like quark-antiquark jet pair,
48480 C...sharing energy according to Altarelli-Parisi splitting function.
48483 IF(MSTJ(2).EQ.4) MSTJ(91)=1
48484 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
48486 CALL PYPTDI(0,PXO(1),PYO(1))
48489 WO(1)=WF*PYR(0)**(1D0/3D0)
48493 C...Initial values for rank, flavour, pT and W+.
48503 C...New hadron. Generate flavour and hadron species.
48505 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
48506 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
48507 IF(MSTU(21).GE.1) RETURN
48514 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
48515 IF(K(I,2).EQ.0) GOTO 180
48516 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
48517 IF(PYR(0).GT.PARJ(19)) GOTO 200
48520 C...Find hadron mass. Generate four-momentum.
48521 P(I,5)=PYMASS(K(I,2))
48522 CALL PYPTDI(KFL1,PX2,PY2)
48525 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
48526 CALL PYZDIS(KFL1,KFL2,PR,Z)
48528 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
48530 MSTU(90)=MSTU(90)+1
48531 MSTU(90+MSTU(90))=I
48532 PARU(90+MSTU(90))=Z
48534 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
48535 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
48536 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
48537 & P(I,3).LE.0.001D0) THEN
48538 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
48544 C...Remaining flavour and momentum.
48553 C...Check if pL acceptable. Go back for new hadron if enough energy.
48554 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
48556 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
48558 IF(W.GT.PARJ(31)) GOTO 190
48561 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
48562 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
48564 C...Rotate jet to new direction.
48565 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
48566 PHI=PYANGL(P(IP1,1),P(IP1,2))
48568 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
48569 K(K(IP1,3),4)=NSAV1+1
48572 C...End of jet generation loop. Skip conservation in some cases.
48574 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
48575 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
48577 C...Subtract off produced hadron flavours, finished if zero.
48578 DO 240 I=NSAV+NJET+1,N
48580 KFLA=MOD(KFA/1000,10)
48581 KFLB=MOD(KFA/100,10)
48582 KFLC=MOD(KFA/10,10)
48584 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
48585 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
48587 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
48588 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
48589 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
48592 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
48593 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
48594 IF(NREQ.EQ.0) GOTO 320
48596 C...Take away flavour of low-momentum particles until enough freedom.
48600 DO 260 I=NSAV+NJET+1,N
48601 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
48602 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
48603 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
48605 IF(IREM.EQ.0) GOTO 150
48607 KFA=IABS(K(IREM,2))
48608 KFLA=MOD(KFA/1000,10)
48609 KFLB=MOD(KFA/100,10)
48610 KFLC=MOD(KFA/10,10)
48611 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
48612 IF(K(IREM,1).EQ.8) GOTO 250
48614 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
48615 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
48616 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
48618 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
48619 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
48620 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
48623 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
48624 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
48625 IF(NREQ.GT.NREM) GOTO 250
48626 DO 270 I=NSAV+NJET+1,N
48627 IF(K(I,1).EQ.8) K(I,1)=1
48630 C...Find combination of existing and new flavours for hadron.
48632 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
48633 IF(NREQ.LT.NREM) NFET=1
48634 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
48636 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
48637 KFLF(J)=ISIGN(1,NFL(1))
48638 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
48639 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
48641 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
48643 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
48644 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
48645 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
48646 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
48647 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
48648 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
48649 IF(NFET.LE.2) KFLF(3)=0
48650 IF(KFLF(3).NE.0) THEN
48651 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
48652 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
48653 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
48654 & KFLFC=KFLFC+ISIGN(2,KFLFC)
48658 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
48659 IF(KF.EQ.0) GOTO 280
48660 DO 300 J=1,MAX(2,NFET)
48661 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
48664 C...Store hadron at random among free positions.
48665 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
48666 DO 310 I=NSAV+NJET+1,N
48667 IF(K(I,1).EQ.7) NPOS=NPOS-1
48668 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
48671 P(I,5)=PYMASS(K(I,2))
48672 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48675 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
48676 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
48677 IF(NREM.GT.0) GOTO 280
48679 C...Compensate for missing momentum in global scheme (3 options).
48680 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
48683 DO 330 I=NSAV+NJET+1,N
48684 PSI(J)=PSI(J)+P(I,J)
48687 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
48689 DO 350 I=NSAV+NJET+1,N
48690 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
48691 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
48692 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
48693 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
48695 DO 370 I=NSAV+NJET+1,N
48696 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
48697 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
48698 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
48699 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
48701 P(I,J)=P(I,J)-PSI(J)*PW/PWS
48703 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48706 C...Compensate for missing momentum withing each jet separately.
48707 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
48708 DO 390 I=N+1,N+NJET
48714 DO 410 I=NSAV+NJET+1,N
48717 K(IR2,1)=K(IR2,1)+1
48718 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
48719 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
48721 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
48723 P(IR2,4)=P(IR2,4)+P(I,4)
48724 P(IR2,5)=P(IR2,5)+PLS
48727 DO 420 I=N+1,N+NJET
48728 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
48730 DO 440 I=NSAV+NJET+1,N
48733 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
48734 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
48736 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
48739 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48743 C...Scale momenta for energy conservation.
48744 IF(MOD(MSTJ(3),5).NE.0) THEN
48748 DO 450 I=NSAV+NJET+1,N
48751 PQS=PQS+P(I,5)**2/P(I,4)
48753 IF(PMS.GE.PECM) GOTO 150
48756 PFAC=(PECM-PQS)/(PES-PQS)
48759 DO 480 I=NSAV+NJET+1,N
48763 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
48765 PQS=PQS+P(I,5)**2/P(I,4)
48767 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
48770 C...Origin of produced particles and parton daughter pointers.
48771 490 DO 500 I=NSAV+NJET+1,N
48772 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
48773 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
48775 DO 510 I=NSAV+1,NSAV+NJET
48778 IF(MSTU(16).NE.2) THEN
48782 K(I1,4)=K(I1,4)-NJET+1
48783 K(I1,5)=K(I1,5)-NJET+1
48784 IF(K(I1,5).LT.K(I1,4)) THEN
48791 C...Document independent fragmentation system. Remove copy of jets.
48802 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
48804 DO 540 I=NSAV+NJET,N
48806 K(I-NJET+1,J)=K(I,J)
48807 P(I-NJET+1,J)=P(I,J)
48808 V(I-NJET+1,J)=V(I,J)
48812 DO 550 IZ=MSTU90+1,MSTU(90)
48813 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
48816 C...Boost back particle system. Set production vertices.
48817 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
48818 &DPS(2)/DPS(4),DPS(3)/DPS(4))
48828 C*********************************************************************
48831 C...Handles the decay of unstable particles.
48833 SUBROUTINE PYDECY(IP)
48835 C...Double precision and integer declarations.
48836 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48837 IMPLICIT INTEGER(I-N)
48838 INTEGER PYK,PYCHGE,PYCOMP
48840 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
48841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48842 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48843 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
48844 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
48846 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
48847 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
48849 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
48851 C...Functions: momentum in two-particle decays and four-product.
48852 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
48853 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)
48855 C...Initial values.
48859 KFS=ISIGN(1,K(IP,2))
48863 C...Choose lifetime and determine decay vertex.
48864 IF(K(IP,1).EQ.5) THEN
48866 ELSEIF(K(IP,1).NE.4) THEN
48867 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
48870 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
48873 C...Determine whether decay allowed or not.
48875 IF(MSTJ(22).EQ.2) THEN
48876 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
48877 ELSEIF(MSTJ(22).EQ.3) THEN
48878 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
48879 ELSEIF(MSTJ(22).EQ.4) THEN
48880 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
48881 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
48883 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
48888 C...Interface to external tau decay library (for tau polarization).
48889 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
48891 C...Starting values for pointers and momenta.
48895 PCMTAU(J)=P(ITAU,J)
48898 C...Iterate to find position and code of mother of tau.
48900 120 IMTAU=K(IMTAU,3)
48902 IF(IMTAU.EQ.0) THEN
48903 C...If no known origin then impossible to do anything further.
48907 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
48908 C...If tau -> tau + gamma then add gamma energy and loop.
48909 IF(K(K(IMTAU,4),2).EQ.22) THEN
48911 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
48913 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
48915 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
48920 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
48921 C...If coming from weak decay of hadron then W is not stored in record,
48922 C...but can be reconstructed by adding neutrino momentum.
48923 KFORIG=-ISIGN(24,K(ITAU,2))
48925 DO 160 II=K(IMTAU,4),K(IMTAU,5)
48926 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
48928 PCMTAU(J)=PCMTAU(J)+P(II,J)
48934 C...If coming from resonance decay then find latest copy of this
48935 C...resonance (may not completely agree).
48938 DO 170 II=IMTAU+1,IP-1
48939 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
48940 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
48943 PCMTAU(J)=P(IORIG,J)
48947 C...Boost tau to rest frame of production process (where known)
48948 C...and rotate it to sit along +z axis.
48950 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
48952 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
48953 & -DBETAU(2),-DBETAU(3))
48954 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
48955 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
48956 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
48957 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
48959 C...Call tau decay routine (if meaningful) and fill extra info.
48960 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
48961 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
48962 DO 200 II=NSAV+1,NSAV+NDECAY
48971 C...Boost back decay tau and decay products.
48975 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
48976 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
48977 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
48978 & DBETAU(2),DBETAU(3))
48980 C...Skip past ordinary tau decay treatment.
48988 C...B-Bbar mixing: flip sign of meson appropriately.
48990 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
48992 IF(KFA.EQ.531) XBBMIX=PARJ(77)
48993 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
48994 IF(MMIX.EQ.1) KFS=-KFS
48997 C...Check existence of decay channels. Particle/antiparticle rules.
48999 IF(MDCY(KC,2).GT.0) THEN
49000 MDMDCY=MDME(MDCY(KC,2),2)
49001 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
49003 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
49004 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
49007 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
49008 IF(KCHG(KC,3).EQ.0) THEN
49011 IF(PYR(0).GT.0.5D0) KFS=-KFS
49012 ELSEIF(KFS.GT.0) THEN
49020 C...Sum branching ratios of allowed decay channels.
49023 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
49024 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
49025 & KFSN*MDME(IDL,1).NE.3) GOTO 230
49026 IF(MDME(IDL,2).GT.100) GOTO 230
49028 BRSU=BRSU+BRAT(IDL)
49031 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
49035 C...Select decay channel among allowed ones.
49036 240 RBR=BRSU*PYR(0)
49039 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
49040 &KFSN*MDME(IDL,1).NE.3) THEN
49041 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
49042 ELSEIF(MDME(IDL,2).GT.100) THEN
49043 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
49047 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
49050 C...Start readout of decay channel: matrix element, reset counters.
49053 IF(MOD(NTRY,200).EQ.0) THEN
49054 WRITE(CIDC,'(I4)') IDC
49055 C...Do not print warning for some well-known special cases.
49056 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
49057 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
49061 IF(NTRY.GT.1000) THEN
49062 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
49063 IF(MSTU(21).GE.1) RETURN
49069 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
49072 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
49074 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
49080 IF(KFA.GT.80) MHADDY=1
49081 C.. Random flavour and popcorn system memory.
49087 C...Read out decay products. Convert to standard flavour code.
49089 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
49091 IF(JT.LE.5) KP=KFDP(IDC,JT)
49092 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
49093 IF(KP.EQ.0) GOTO 280
49096 IF(KPA.GT.80) MHADDY=1
49097 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
49099 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
49101 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
49102 KFP=-KFS*MOD(KFA/10,10)
49103 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
49104 KFP=KFS*(100*MOD(KFA/10,100)+3)
49105 ELSEIF(KPA.EQ.81) THEN
49106 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
49107 ELSEIF(KP.EQ.82) THEN
49108 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
49109 IF(KFP.EQ.0) GOTO 260
49113 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
49114 ELSEIF(KP.EQ.-82) THEN
49117 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
49119 C...Add decay product to event record or to quark flavour list.
49122 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
49125 C...set rndmflav popcorn system pointer
49126 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
49128 PSQ=PSQ+PYMASS(KFLO(NQ))
49129 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
49130 & MOD(NQ,2).EQ.1) THEN
49135 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
49136 IF(K(I,2).EQ.0) GOTO 260
49138 P(I,5)=PYMASS(K(I,2))
49143 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
49144 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
49146 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
49147 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
49157 C...Check masses for resonance decays.
49158 IF(MHADDY.EQ.0) THEN
49159 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
49162 C...Choose decay multiplicity in phase space model.
49163 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
49165 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
49166 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
49168 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
49169 IF(IRNDMO.EQ.0) THEN
49172 ELSEIF(IRNDMO.EQ.1) THEN
49177 IF(NTRY.GT.1000) THEN
49178 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
49179 IF(MSTU(21).GE.1) RETURN
49181 IF(MMAT.LE.20) THEN
49182 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
49183 & SIN(PARU(2)*PYR(0))
49184 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
49185 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
49186 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
49187 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
49188 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
49192 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
49194 IF(MSTU(121).GT.MSTU(125)) GOTO 300
49196 C...Form hadrons from flavour content.
49200 IF(ND.EQ.NP+NQ/2) GOTO 330
49201 DO 320 I=N+NP+1,N+ND-NQ/2
49202 C.. Stick to started popcorn system, else pick side at random
49204 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
49205 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
49206 IF(K(I,2).EQ.0) GOTO 300
49207 MSTU(125)=MSTU(125)-1
49209 IF(MSTU(121).GT.0) JTMO=JT
49215 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
49216 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
49217 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
49220 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
49221 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
49222 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
49223 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
49225 C...Check that sum of decay product masses not too large.
49227 DO 340 I=N+NP+1,N+ND
49232 P(I,5)=PYMASS(K(I,2))
49235 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
49237 C...Rescale energy to subtract off spectator quark mass.
49238 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
49239 & .AND.NP.GE.3) THEN
49241 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
49243 P(N+NP,J)=PQT*PV(1,J)
49244 PV(1,J)=(1D0-PQT)*PV(1,J)
49246 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
49250 C...Fully specified final state: check mass broadening effects.
49252 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
49256 C...Determine position of grandmother, number of sisters.
49262 IF(IM.LT.0.OR.IM.GE.IP) IM=0
49263 IF(IM.NE.0) KFAM=IABS(K(IM,2))
49265 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
49266 IF(K(IL,3).EQ.IM) NM=NM+1
49267 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
49269 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
49270 & MOD(KFAM/1000,10).NE.0) NM=0
49272 KFAS=IABS(K(ISIS,2))
49273 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
49274 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
49279 C...Kinematics of one-particle decays.
49287 C...Calculate maximum weight ND-particle decay.
49290 WTMAX=1D0/WTCOR(ND-2)
49291 PMAX=PV(1,5)-PS+P(N+ND,5)
49293 DO 380 IL=ND-1,1,-1
49294 PMAX=PMAX+P(N+IL,5)
49295 PMIN=PMIN+P(N+IL+1,5)
49296 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
49300 C...Find virtual gamma mass in Dalitz decay.
49301 390 IF(ND.EQ.2) THEN
49302 ELSEIF(MMAT.EQ.2) THEN
49303 PMES=4D0*PMAS(11,1)**2
49304 PMRHO2=PMAS(131,1)**2
49305 PGRHO2=PMAS(131,2)**2
49306 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
49307 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
49308 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
49309 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
49310 IF(WT.LT.PYR(0)) GOTO 400
49311 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
49313 C...M-generator gives weight. If rejected, try again.
49318 DO 420 IL2=IL1-1,1,-1
49319 IF(RSAV.LE.RORD(IL2)) GOTO 430
49320 RORD(IL2+1)=RORD(IL2)
49322 430 RORD(IL2+1)=RSAV
49326 DO 450 IL=ND-1,1,-1
49327 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
49329 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
49331 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
49334 C...Perform two-particle decays in respective CM frame.
49335 460 DO 480 IL=1,ND-1
49336 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
49337 UE(3)=2D0*PYR(0)-1D0
49339 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
49340 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
49343 PV(IL+1,J)=-PA*UE(J)
49345 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
49346 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
49349 C...Lorentz transform decay products to lab frame.
49353 DO 530 IL=ND-1,1,-1
49355 BE(J)=PV(IL,J)/PV(IL,4)
49357 GA=PV(IL,4)/PV(IL,5)
49359 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
49361 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
49363 P(I,4)=GA*(P(I,4)+BEP)
49367 C...Check that no infinite loop in matrix element weight.
49369 IF(NTRY.GT.800) GOTO 560
49371 C...Matrix elements for omega and phi decays.
49373 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
49374 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
49375 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
49376 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
49378 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
49379 ELSEIF(MMAT.EQ.2) THEN
49380 FOUR12=FOUR(N+1,N+2)
49381 FOUR13=FOUR(N+1,N+3)
49382 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
49383 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
49384 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
49386 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
49387 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
49388 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
49389 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
49391 FOUR12=FOUR(IP,N+1)
49392 FOUR02=FOUR(IM,N+1)
49396 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
49397 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
49398 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
49399 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
49400 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
49401 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
49403 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
49404 ELSEIF(MMAT.EQ.4) THEN
49405 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
49406 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
49407 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
49408 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
49409 & ((1D0-HX3)/(HX1*HX2))**2
49410 IF(WT.LT.2D0*PYR(0)) GOTO 390
49411 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
49414 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
49415 ELSEIF(MMAT.EQ.41) THEN
49416 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
49417 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
49418 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
49420 C...Matrix elements for weak decays (only semileptonic for c and b)
49421 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
49422 & .AND.ND.EQ.3) THEN
49423 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
49424 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
49425 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
49426 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
49430 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
49433 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
49434 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
49435 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
49438 C...Scale back energy and reattach spectator.
49439 560 IF(MREM.EQ.1) THEN
49441 PV(1,J)=PV(1,J)/(1D0-PQT)
49447 C...Low invariant mass for system with spectator quark gives particle,
49448 C...not two jets. Readjust momenta accordingly.
49449 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
49451 PM2=PYMASS(K(N+2,2))
49453 PM3=PYMASS(K(N+3,2))
49454 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
49455 & (PARJ(32)+PM2+PM3)**2) GOTO 630
49458 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
49459 IF(K(N+2,2).EQ.0) GOTO 260
49460 P(N+2,5)=PYMASS(K(N+2,2))
49461 PS=P(N+1,5)+P(N+2,5)
49466 ELSEIF(MMAT.EQ.44) THEN
49468 PM3=PYMASS(K(N+3,2))
49470 PM4=PYMASS(K(N+4,2))
49471 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
49472 & (PARJ(32)+PM3+PM4)**2) GOTO 600
49475 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
49476 IF(K(N+3,2).EQ.0) GOTO 260
49477 P(N+3,5)=PYMASS(K(N+3,2))
49479 P(N+3,J)=P(N+3,J)+P(N+4,J)
49481 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)
49482 HA=P(N+1,4)**2-P(N+2,4)**2
49483 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
49484 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
49485 & (P(N+1,3)-P(N+2,3))**2
49486 HD=(PV(1,4)-P(N+3,4))**2
49487 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
49490 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
49492 PCOR=HH*(P(N+1,J)-P(N+2,J))
49493 P(N+1,J)=P(N+1,J)+PCOR
49494 P(N+2,J)=P(N+2,J)-PCOR
49496 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)
49497 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)
49501 C...Check invariant mass of W jets. May give one particle or start over.
49502 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
49503 &.AND.IABS(K(N+1,2)).LT.10) THEN
49504 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
49506 PM1=PYMASS(K(N+1,2))
49508 PM2=PYMASS(K(N+2,2))
49509 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
49510 KFLDUM=INT(1.5D0+PYR(0))
49511 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
49512 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
49513 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
49514 PSM=PYMASS(KF1)+PYMASS(KF2)
49515 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
49516 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
49517 IF(MMAT.EQ.48) GOTO 390
49518 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
49521 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
49522 IF(K(N+1,2).EQ.0) GOTO 260
49523 P(N+1,5)=PYMASS(K(N+1,2))
49526 PS=P(N+1,5)+P(N+2,5)
49527 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
49534 C...Phase space decay of partons from W decay.
49535 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
49541 PV(1,J)=P(N+1,J)+P(N+2,J)
49550 PSQ=PYMASS(KFLO(1))
49552 PSQ=PSQ+PYMASS(KFLO(2))
49557 C...Boost back for rapidly moving particle.
49561 BE(J)=P(IP,J)/P(IP,4)
49565 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
49567 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
49569 P(I,4)=GA*(P(I,4)+BEP)
49573 C...Fill in position of decay vertex.
49581 C...Set up for parton shower evolution from jets.
49582 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
49586 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
49587 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
49588 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
49589 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
49590 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
49591 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
49593 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
49596 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
49597 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
49598 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
49599 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
49601 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
49602 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
49605 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
49606 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
49607 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
49608 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
49610 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
49611 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
49613 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
49618 KCP=PYCOMP(K(NSAV+1,2))
49619 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
49621 IF(KQP.LT.0) JCON=5
49622 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
49623 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
49624 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
49625 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
49627 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
49630 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
49631 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
49632 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
49633 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
49637 C...Mark decayed particle; special option for B-Bbar mixing.
49638 IF(K(IP,1).EQ.5) K(IP,1)=15
49639 IF(K(IP,1).LE.10) K(IP,1)=11
49640 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
49648 C*********************************************************************
49651 C...Handles flavour production in the decay of unstable particles
49652 C...and small string clusters.
49654 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
49656 C...Double precision and integer declarations.
49657 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49658 IMPLICIT INTEGER(I-N)
49659 INTEGER PYK,PYCHGE,PYCOMP
49661 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49662 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49663 SAVE /PYDAT1/,/PYDAT2/
49666 C.. Call PYKFDI directly if no popcorn option is on
49667 IF(MSTJ(12).LT.2) THEN
49668 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
49675 IF(KFL1.EQ.0) RETURN
49680 NMAX=MIN(MSTU(125),10)
49682 C.. Identify rank 0 cluster qq
49684 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
49687 C.. Join jets: Fails if store not empty
49688 IF(MSTU(121).GT.0) THEN
49692 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
49693 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
49694 C.. Pick popcorn meson from store, return same qq, decrease store
49695 KF=MSTU(NSTO+MSTU(121))
49697 MSTU(121)=MSTU(121)-1
49699 C.. Generate new flavour. Then done if no diquark is generated
49700 100 CALL PYKFDI(KFL1,0,KFL3,KF)
49701 IF(MSTU(121).EQ.-1) GOTO 100
49703 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
49705 C.. Simple case if no dynamical popcorn suppressions are considered
49706 IF(MSTJ(12).LT.4) THEN
49707 IF(MSTU(121).EQ.0) RETURN
49710 CALL PYKFDI(KFPREV,0,KFL3,KFM)
49711 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
49712 IF(IABS(KFL3).LE.10)THEN
49719 C test output qq against fake Gamma, then return if no popcorn.
49722 CALL PYZDIS(1,2103,5D0,Z)
49724 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
49729 IF(MSTU(121).EQ.0) RETURN
49731 C..Set store size memory. Pick fake dynamical variables of qq.
49733 CALL PYPTDI(1,PX3,PY3)
49739 C.. Pick next popcorn meson, test with fake dynamical variables
49743 CALL PYKFDI(KFPREV,0,KFL3,KFM)
49744 IF(MSTU(121).EQ.-1) GOTO 100
49745 CALL PYPTDI(KFL3,PX3,PY3)
49746 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
49747 CALL PYZDIS(KFPREV,KFL3,PM,Z)
49754 IF(MSTJ(12).GT.4)THEN
49755 POPMN=SQRT((1D0-X)*(G/X-GB))
49756 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
49757 PTST=EXP((POPM-POPMN)*PARF(193))
49762 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
49765 IF(RTST.GT.PTST*GTST)THEN
49767 IF(RTST.GT.PTST) MSTU(121)=-1
49772 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
49773 IF(MSTU(121).GT.0) GOTO 110
49775 C.. Test accepted system size. If OK set global popcorn size variable.
49776 IF(NMES.GT.NMAX)THEN
49787 C********************************************************************
49790 C...Generates a new flavour pair and combines off a hadron
49792 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
49794 C...Double precision and integer declarations.
49795 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49796 IMPLICIT INTEGER(I-N)
49797 INTEGER PYK,PYCHGE,PYCOMP
49799 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49800 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49801 SAVE /PYDAT1/,/PYDAT2/
49805 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
49807 C...Default flavour values. Input consistency checks.
49812 IF(KF1A.EQ.0) RETURN
49814 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
49815 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
49816 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
49819 C...Check if tabulated flavour probabilities are to be used.
49820 IF(MSTJ(15).EQ.1) THEN
49821 IF(MSTJ(12).GE.5) CALL PYERRM(29,
49822 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
49823 & ' together with MSTJ(12)>=5 modification')
49825 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
49826 KFL1A=MOD(KF1A/1000,10)
49827 KFL1B=MOD(KF1A/100,10)
49829 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
49830 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
49831 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
49832 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
49836 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
49837 KFL2A=MOD(KF2A/1000,10)
49838 KFL2B=MOD(KF2A/100,10)
49840 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
49841 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
49842 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
49844 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
49847 C.. Recognize rank 0 diquark case
49849 KFDIQ=MAX(KF1A,KF2A)
49850 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
49852 C.. Join two flavours to meson or baryon. Test for popcorn.
49855 IF(KFDIQ.GT.10) THEN
49856 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
49857 & CALL PYNMES(KFDIQ)
49858 IF(MSTU(121).NE.0) THEN
49869 C.. Separate incoming flavours, curtain flavour consistency check
49875 KFL1A=MOD(KF1A/1000,10)
49876 KFL1B=MOD(KF1A/100,10)
49879 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
49880 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
49881 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
49883 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
49887 KFQOLD=KFL1A+KFL1B-KFQPOP
49890 C...Meson/baryon choice. Set number of mesons if starting a popcorn
49893 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
49894 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
49898 ELSEIF(KF1A.GT.10)THEN
49900 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
49901 IF(MSTU(121).GT.0) MBARY=-1
49904 C..x->H+q: Choose single vertex quark. Jump to form hadron.
49905 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
49906 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
49907 KFL3=ISIGN(KFQVER,-KFIN)
49911 C..x->H+qq: (IDW=proper PARF position for diquark weights)
49914 IF(MSTU(121).EQ.0) IDW=150
49916 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
49917 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
49918 C.. Shift to s-curtain parameters if needed
49919 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
49920 PARF(194)=PARF(138)*PARF(139)
49921 PARF(193)=PARJ(8)+PARJ(9)
49925 C.. x->H+qq: Get vertex quark
49926 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
49928 MSTU(121)=MSTU(121)-1
49929 IF(IDW.EQ.170) THEN
49930 IF(MSTU(121).EQ.0)THEN
49931 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
49933 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
49936 IF(MSTU(121).EQ.0)THEN
49937 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
49939 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
49945 RMES=PYR(0)*PARF(194)
49947 RMES=RMES-PARF(IPOS+IMES)
49948 IF(IMES.EQ.30) THEN
49953 IF(RMES.GT.0D0) GOTO 120
49956 IF(KMUL.EQ.2) KFJ=10003
49957 IF(KMUL.EQ.3) KFJ=10001
49958 IF(KMUL.EQ.4) KFJ=20003
49959 IF(KMUL.EQ.5) KFJ=5
49961 KFQVER=MOD(IMES,5)+1
49962 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
49963 IF(KFQVER.GT.3)THEN
49968 IF(MBARY.EQ.-1) IDW=170
49970 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
49971 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
49972 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
49973 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
49975 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
49979 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
49981 IF(KFQPOP.NE.KFQVER)THEN
49983 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
49984 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
49985 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
49987 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
49989 KFL3=ISIGN(KFDIQ,KFIN)
49991 C..x->M+y: flavour for meson.
49992 130 IF(MBARY.LE.0)THEN
49993 KFLA=MAX(KFQOLD,KFQVER)
49994 KFLB=MIN(KFQOLD,KFQVER)
49996 IF(KFLA.NE.KFQOLD) KFS=-KFS
49997 C... Form meson, with spin and flavour mixing for diagonal states.
49998 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
49999 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
50000 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
50003 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
50004 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
50005 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
50006 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
50007 IF(PYR(0).LT.PARJ(14)) KMUL=2
50008 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
50010 IF(RMUL.LT.PARJ(15)) KMUL=3
50011 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
50012 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
50015 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
50016 IF(KMUL.EQ.5) KFLS=5
50017 IF(KFLA.NE.KFLB)THEN
50018 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
50021 IMIX=2*KFLA+10*KMUL
50022 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
50023 & INT(RMIX+PARF(IMIX)))+KFLS
50024 IF(KFLA.GE.4) KF=110*KFLA+KFLS
50026 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
50027 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
50029 C..Optional extra suppression of eta and eta'.
50030 C..Allow shift to qq->B+q in old version (set IRANK to 0)
50031 IF(KF.EQ.221.OR.KF.EQ.331)THEN
50032 IF(PYR(0).GT.PARJ(25+KF/300))THEN
50033 IF(KF2A.GT.0) GOTO 130
50034 IF(MSTJ(12).LT.4) IRANK=0
50040 C.. x->B+y: Flavour for baryon
50043 IF(KF1A.LE.10) KFLA=KFQOLD
50044 KFLB=MOD(KFDIQ/1000,10)
50045 KFLC=MOD(KFDIQ/100,10)
50046 KFLDS=MOD(KFDIQ,10)
50047 KFLD=MAX(KFLA,KFLB,KFLC)
50048 KFLF=MIN(KFLA,KFLB,KFLC)
50049 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
50051 C... SU(6) factors for formation of baryon.
50055 IF(KFLB.NE.KFLC)THEN
50058 IF(KFLB.GT.2) KDMAX=KDMAX+2
50060 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
50065 SU6MAX=PARF(140+KDMAX)
50068 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
50073 SU6OCT=PARF(60+KBARY)
50074 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
50075 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
50076 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
50078 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
50080 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
50082 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
50083 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
50085 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
50089 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
50092 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
50093 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
50095 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
50097 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
50098 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
50100 C -------------------------------------------------------------------------
50101 C Extracted from a private e-mail exchange with Torbjorn Sjostrand
50103 C No, Lambda(1520) is not included and not foreseen.
50104 C So if you want it in Pythia, it would have to be a hack.
50105 C What you could do is:
50106 C 1) In PYKFDI, just before the RETURN above label 140, you could check if
50107 C a Lambda, Sigma0 or Sigma*0 has been produced, and with some small
50108 C probability switch such a particle to the Lambda(1520) code. That is,
50109 C if KF = 3122, 3212, or 3214 and a random number below some number, switch
50110 C to KF = 3124. (And correspondingly for anticparticles.)
50111 C 2) Use the PYUPDA routine (see manual) to include particle and decay data
50112 C for the Lambda(1520).
50113 C -------------------------------------------------------------------------
50115 C IF (IABS(KF).EQ.3122) THEN
50116 C Converting a fraction (0.20) of Lambda0 to Lambda(1520) + c.c.
50117 C This fraction is based on the experimental measurement at ISR
50118 C Bobbink 83, NP B217,11 (1983)
50119 C The region 0.5 < XF < 1.0 has been extrapolated to XF=0
50120 C IF(PYR(0).LE.0.20) KF=ISIGN(3124,KF)
50123 C IF(IABS(KF).EQ.3212) THEN
50124 C Converting a fraction (0.20) of Sigma0 to Lambda(1520) + c.c.
50125 C We suppose the same fraction as for Lambda0
50126 C IF(PYR(0).LE.0.20) KF=ISIGN(3124,KF)
50129 C IF (IABS(KF).EQ.3214) THEN
50130 C Converting a fraction (0.30) of Sigma0(1385) to Lambda(1520) + c.c.
50131 C This is conservative extimate supposing that the ratio
50132 C scales as (M_Sigma1385/M_Lambda0)^2 ~ 1.5
50133 C IF(PYR(0).LE.0.30) KF=ISIGN(3124,KF)
50137 C...Use tabulated probabilities to select new flavour and hadron.
50138 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
50141 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
50144 ELSEIF(KTAB2.EQ.0) THEN
50153 DO 150 KT3=KT3L,KT3U
50154 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
50160 DO 170 KT3=KT3L,KT3U
50162 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
50163 IF(RFL.LE.0D0) GOTO 190
50168 C...Reconstruct flavour of produced quark/diquark.
50169 IF(KTAB3.LE.6) THEN
50172 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
50175 IF(KTAB3.GE.8) KFL3A=2
50176 IF(KTAB3.GE.11) KFL3A=3
50177 IF(KTAB3.GE.16) KFL3A=4
50178 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
50179 KFL3=1000*KFL3A+100*KFL3B+1
50180 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
50182 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
50185 C...Reconstruct meson code.
50186 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
50188 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
50189 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
50191 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
50192 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
50193 & 25*KTABS)) KF=330+2*KTABS+1
50194 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
50195 KFLA=MAX(KTAB1,KTAB3)
50196 KFLB=MIN(KTAB1,KTAB3)
50198 IF(KFLA.NE.KF1A) KFS=-KFS
50199 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
50200 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
50202 IF(KFL1A.EQ.KFL3A) THEN
50203 KFLA=MAX(KFL1B,KFL3B)
50204 KFLB=MIN(KFL1B,KFL3B)
50205 IF(KFLA.NE.KFL1B) KFS=-KFS
50206 ELSEIF(KFL1A.EQ.KFL3B) THEN
50210 ELSEIF(KFL1B.EQ.KFL3A) THEN
50213 ELSEIF(KFL1B.EQ.KFL3B) THEN
50214 KFLA=MAX(KFL1A,KFL3A)
50215 KFLB=MIN(KFL1A,KFL3A)
50216 IF(KFLA.NE.KFL1A) KFS=-KFS
50218 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
50221 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
50223 C...Reconstruct baryon code.
50225 IF(KTAB1.GE.7) THEN
50234 KFLD=MAX(KFLA,KFLB,KFLC)
50235 KFLF=MIN(KFLA,KFLB,KFLC)
50236 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
50237 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
50238 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
50241 C...Check that constructed flavour code is an allowed one.
50242 IF(KFL2.NE.0) KFL3=0
50245 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
50253 C*********************************************************************
50256 C...Generates number of popcorn mesons and stores some relevant
50259 SUBROUTINE PYNMES(KFDIQ)
50261 C...Double precision and integer declarations.
50262 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50263 IMPLICIT INTEGER(I-N)
50264 INTEGER PYK,PYCHGE,PYCOMP
50266 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50267 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50268 SAVE /PYDAT1/,/PYDAT2/
50271 IF(MSTJ(12).LT.2) RETURN
50273 C..Old version: Get 1 or 0 popcorn mesons
50274 IF(MSTJ(12).LT.5)THEN
50276 IF(KFDIQ.NE.0) THEN
50278 KFA=MOD(KFDIQA/1000,10)
50279 KFB=MOD(KFDIQA/100,10)
50282 IF(KFA.EQ.3) POPWT=PARF(133)
50283 IF(KFB.EQ.3) POPWT=PARF(134)
50284 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
50286 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
50290 C..New version: Store popcorn- or rank 0 diquark parameters
50293 PARF(194)=PARF(139)
50294 IF(KFDIQ.NE.0) THEN
50297 PARF(194)=PARF(140)
50299 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
50300 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
50301 & '(PYNMES:) Neglecting too large popcorn possibility')
50305 C..New version: Get number of popcorn mesons
50308 110 MSTU(121)=MSTU(121)+1
50309 RTST=RTST/PARF(194)
50310 IF(RTST.LT.1D0) GOTO 110
50311 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
50312 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
50316 C***************************************************************
50319 C...Precalculates a set of diquark and popcorn weights.
50323 C...Double precision and integer declarations.
50324 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50325 IMPLICIT INTEGER(I-N)
50326 INTEGER PYK,PYCHGE,PYCOMP
50328 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50329 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50330 SAVE /PYDAT1/,/PYDAT2/
50332 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
50336 C..Diquark indices for dimensional variables
50345 C.. *** SU(6) factors **
50346 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
50348 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
50349 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
50350 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
50353 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
50355 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
50356 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
50358 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
50359 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
50362 C..SU(6)max q q' s,c,b
50363 SU6MUD =MAX(SU6(1) , SU6(8) )
50364 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
50365 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
50366 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
50367 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
50368 SU6M(IUS0)=SU6M(ISU0)
50369 SU6M(ISS1)=SU6M(IUU1)
50370 SU6M(IUS1)=SU6M(ISU1)
50372 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
50374 PARF(142)=SU6M(IUD1)
50375 PARF(143)=SU6M(ISU0)
50376 PARF(144)=SU6M(ISU1)
50377 PARF(145)=SU6M(ISS1)
50379 C..diquark SU(6) survival =
50380 C..sum over quark (quark tunnel weight)*(SU(6)).
50381 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
50382 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
50383 DMB(IUS0)=DMB(ISU0)
50384 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
50385 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
50386 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
50387 DMB(IUS1)=DMB(ISU1)
50388 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
50390 C.. *** Tunneling factors for Diquark production***
50391 C.. T: half a curtain pair = sqrt(curtain pair factor)
50392 IF(MSTJ(12).GE.5) THEN
50394 PMUD1=PYMASS(2103)-PMUD0
50395 PMUS0=PYMASS(3201)-PMUD0
50396 PMUS1=PYMASS(3203)-PMUS0-PMUD0
50397 PMSS1=PYMASS(3303)-PMUS0-PMUD0
50398 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
50399 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
50400 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
50401 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
50402 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
50403 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
50404 QBB(IUD1)=QBB(IUU1)
50406 PAR2M=SQRT(PARJ(2))
50407 PAR3M=SQRT(PARJ(3))
50408 PAR4M=SQRT(PARJ(4))
50409 QBB(ISU0)=PAR2M*PAR3M
50411 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
50413 QBB(ISU1)=PAR4M*QBB(ISU0)
50414 QBB(IUS1)=PAR4M*QBB(IUS0)
50418 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
50419 QBM(ISU0)=QBB(ISU0)
50420 QBM(IUS0)=PARJ(2)*QBB(IUS0)
50421 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
50422 QBM(IUU1)=6D0*QBB(IUU1)
50423 QBM(ISU1)=3D0*QBB(ISU1)
50424 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
50425 QBM(IUD1)=3D0*QBB(IUD1)
50427 C.. Combine T and tau to diquark weight for q-> B+B+..
50429 QBB(I)=QBB(I)*QBM(I)
50432 IF(MSTJ(12).GE.5)THEN
50433 C..New version: tau for rank 0 diquark.
50434 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
50435 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
50436 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
50437 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
50438 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
50439 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
50440 DMB(7+IUD1)=DMB(7+IUU1)/2D0
50442 C..New version: curtain flavour ratios.
50443 C.. s/u for q->B+M+...
50444 C.. s/u for rank 0 diquark: su -> ...M+B+...
50445 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
50446 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
50447 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
50448 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
50449 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
50450 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
50451 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
50453 C..Old version: reset unused rank 0 diquark weights and
50454 C.. unused diquark SU(6) survival weights
50456 IF(MSTJ(12).LT.3) DMB(I)=1D0
50460 C..Old version: Shuffle PARJ(7) into tau
50461 QBM(IUS0)=QBM(IUS0)*PARJ(7)
50462 QBM(ISS1)=QBM(ISS1)*PARJ(7)
50463 QBM(IUS1)=QBM(IUS1)*PARJ(7)
50465 C..Old version: curtain flavour ratios.
50466 C.. s/u for q->B+M+...
50467 C.. s/u for rank 0 diquark: su -> ...M+B+...
50468 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
50469 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
50470 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
50471 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
50472 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
50475 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
50476 C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
50478 DMB(7+I)=DMB(7+I)*DMB(I)
50479 DMB(I)=DMB(I)*QBM(I)
50480 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
50481 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
50484 C.. *** Popcorn factors ***
50486 IF(MSTJ(12).LT.5)THEN
50487 C.. Old version: Resulting popcorn weights.
50489 WS=PARF(135)*PARF(138)
50491 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
50493 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
50494 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
50495 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
50496 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
50497 & (1D0+QBB(IUD1)+QBB(IUU1)+
50498 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
50500 C..New version: Store weights for popcorn mesons,
50501 C..get prel. popcorn weights.
50502 DO 150 IPOS=201,1400
50511 IF(MR.EQ.7) PARF(193)=PARJ(10)
50512 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
50513 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
50514 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
50516 IF(NMES.EQ.1) SQWT=PARJ(2)
50518 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
50519 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
50520 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
50522 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
50523 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
50526 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
50528 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
50529 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
50535 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
50536 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
50537 IF(PJWT.LE.0D0) GOTO 190
50538 IF(PJWT.GT.1D0) PJWT=1D0
50540 IMIX=2*KFQOLD+10*KMUL
50542 IF(KMUL.EQ.2) KFJ=10003
50543 IF(KMUL.EQ.3) KFJ=10001
50544 IF(KMUL.EQ.4) KFJ=20003
50545 IF(KMUL.EQ.5) KFJ=5
50547 KFLA=MAX(KFQOLD,KFQVER)
50548 KFLB=MIN(KFQOLD,KFQVER)
50549 SWT=PARJ(11+KFLA/3+KFLA/4)
50550 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
50552 QWT=SQWT/(2D0+SQWT)
50553 IF(KFQVER.LT.3)THEN
50554 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
50555 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
50557 IF(KFQVER.NE.KFQOLD)THEN
50559 KFM=100*KFLA+10*KFLB+KFJ
50560 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
50561 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
50562 WTTOT=WTTOT+PARF(IPOS+IMES)
50565 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
50566 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
50567 IF(ID.EQ.5) DWT=PARF(IMIX)
50569 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
50570 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
50571 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
50572 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
50573 PARF(IPOS+5*KMUL+ID)=
50574 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
50576 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
50582 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
50584 IF(MR.EQ.7) PARF(140)=
50585 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
50586 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
50587 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
50593 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
50598 C..Recombine diquark weights to flavour and spin ratios
50599 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
50600 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
50601 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
50602 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
50603 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
50604 PARF(155)=QBB(ISU1)/QBB(ISU0)
50605 PARF(156)=QBB(IUS1)/QBB(IUS0)
50606 PARF(157)=QBB(IUD1)
50608 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
50609 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
50610 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
50611 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
50612 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
50613 PARF(165)=QBM(ISU1)/QBM(ISU0)
50614 PARF(166)=QBM(IUS1)/QBM(IUS0)
50615 PARF(167)=QBM(IUD1)
50617 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
50618 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
50619 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
50620 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
50621 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
50622 PARF(175)=DMB(ISU1)/DMB(ISU0)
50623 PARF(176)=DMB(IUS1)/DMB(IUS0)
50624 PARF(177)=DMB(IUD1)
50626 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
50627 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
50628 PARF(187)=DMB(7+IUD1)
50634 C*********************************************************************
50637 C...Generates transverse momentum according to a Gaussian.
50639 SUBROUTINE PYPTDI(KFL,PX,PY)
50641 C...Double precision and integer declarations.
50642 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50643 IMPLICIT INTEGER(I-N)
50644 INTEGER PYK,PYCHGE,PYCOMP
50646 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50649 C...Generate p_T and azimuthal angle, gives p_x and p_y.
50651 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
50652 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
50653 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
50654 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
50662 C*********************************************************************
50665 C...Generates the longitudinal splitting variable z.
50667 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
50669 C...Double precision and integer declarations.
50670 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50671 IMPLICIT INTEGER(I-N)
50672 INTEGER PYK,PYCHGE,PYCOMP
50674 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50675 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50676 SAVE /PYDAT1/,/PYDAT2/
50678 C...Check if heavy flavour fragmentation.
50682 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
50684 C...Lund symmetric scaling function: determine parameters of shape.
50685 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
50686 &MSTJ(11).GE.4) THEN
50688 IF(MSTJ(91).EQ.1) FA=PARJ(43)
50689 IF(KFLB.GE.10) FA=FA+PARJ(45)
50691 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
50694 IF(KFLA.GE.10) FC=FC-PARJ(45)
50695 IF(KFLB.GE.10) FC=FC+PARJ(45)
50696 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
50698 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
50699 FC=FC+FRED*FBB*PARF(100+KFLH)**2
50702 IF(ABS(FC-1D0).GT.0.01D0) MC=2
50704 C...Determine position of maximum. Special cases for a = 0 or a = c.
50705 IF(FA.LT.0.02D0) THEN
50708 IF(FC.GT.FB) ZMAX=FB/FC
50709 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
50714 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
50715 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
50718 C...Subdivide z range if distribution very peaked near endpoint.
50720 IF(ZMAX.LT.0.1D0) THEN
50726 ZDIVC=ZDIV**(1D0-FC)
50727 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
50729 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
50731 FSCB=SQRT(4D0+(FC/FB)**2)
50732 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
50733 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
50734 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
50735 FINT=1D0+FB*(1D0-ZDIV)
50738 C...Choice of z, preweighted for peaks at low or high z.
50742 IF(FINT*PYR(0).LE.1D0) THEN
50744 ELSEIF(MC.EQ.1) THEN
50748 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
50751 ELSEIF(MMAX.EQ.3) THEN
50752 IF(FINT*PYR(0).LE.1D0) THEN
50754 FPRE=EXP(FB*(Z-ZDIV))
50756 Z=ZDIV+Z*(1D0-ZDIV)
50760 C...Weighting according to correct formula.
50761 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
50762 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
50763 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
50764 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
50765 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
50767 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
50769 FC=PARJ(50+MAX(1,KFLH))
50770 IF(MSTJ(91).EQ.1) FC=PARJ(59)
50772 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
50773 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
50774 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
50775 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
50778 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
50779 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
50786 C*********************************************************************
50789 C...Generates timelike parton showers from given partons.
50791 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
50793 C...Double precision and integer declarations.
50794 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50795 IMPLICIT INTEGER(I-N)
50796 INTEGER PYK,PYCHGE,PYCOMP
50797 C...Parameter statement to help give large particle numbers.
50798 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50799 &KEXCIT=4000000,KDIMEN=5000000)
50801 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
50802 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50803 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50804 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
50806 DIMENSION PMTH(5,50),PS(5),PMA(19),PMSD(10),IEP(10),IPA(10),
50807 &KFLA(10),KFLD(10),KFL(10),ITRY(10),ISI(10),ISL(10),DP(10),
50808 &DPT(5,4),KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
50809 &PHIIIS(2,2),ISII(2),ISSET(3),ISCOL(0:40),ISCHG(0:40),
50812 C...Check that QMAX not too low.
50813 IF(MSTJ(41).LE.0) THEN
50815 ELSEIF(MSTJ(41).EQ.1) THEN
50816 IF(QMAX.LE.PARJ(82).AND.IP2.GT.-8) RETURN
50818 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GT.-8)
50822 C...Initialization of cutoff masses etc.
50830 PMTH(1,21)=PYMASS(21)
50831 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
50832 PMTH(3,21)=2D0*PMTH(2,21)
50833 PMTH(4,21)=PMTH(3,21)
50834 PMTH(5,21)=PMTH(3,21)
50835 PMTH(1,22)=PYMASS(22)
50836 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
50837 PMTH(3,22)=2D0*PMTH(2,22)
50838 PMTH(4,22)=PMTH(3,22)
50839 PMTH(5,22)=PMTH(3,22)
50841 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
50842 PMQT1E=MIN(PMQTH1,PARJ(90))
50844 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
50845 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
50848 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
50850 PMTH(1,IFL)=PYMASS(IFL)
50851 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
50852 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
50853 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
50854 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
50857 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
50858 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
50859 PMTH(1,IFL)=PYMASS(IFL)
50860 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
50861 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
50862 PMTH(4,IFL)=PMTH(3,IFL)
50863 PMTH(5,IFL)=PMTH(3,IFL)
50865 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
50867 ALFM=LOG(PT2MIN/ALAMS)
50869 C...Store positions of shower initiating partons.
50871 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
50874 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
50879 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
50880 & .AND.IP2.GE.-7) THEN
50885 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
50893 & '(PYSHOW:) failed to reconstruct showering system')
50894 IF(MSTU(21).GE.1) RETURN
50897 C...Check on phase space available for emission.
50905 KFLA(I)=IABS(K(IPA(I),2))
50907 C...Special cutoff masses for initial partons (may be a heavy quark,
50908 C...squark, ..., and need not be on the mass shell).
50910 IF(NPA.LE.1) IREF(I)=IR
50911 IF(NPA.GE.2) IREF(I+1)=IR
50912 IF(KFLA(I).LE.8) THEN
50914 IF(MSTJ(41).GE.2) ISCHG(IR)=1
50915 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
50916 & KFLA(I).EQ.17) THEN
50917 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
50918 ELSEIF(KFLA(I).EQ.21) THEN
50920 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
50921 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
50923 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
50926 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
50928 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
50929 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
50930 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
50931 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
50932 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
50933 ELSEIF(ISCOL(IR).EQ.1) THEN
50934 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
50935 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
50936 PMTH(4,IR)=PMTH(3,IR)
50937 PMTH(5,IR)=PMTH(3,IR)
50938 ELSEIF(ISCHG(IR).EQ.1) THEN
50939 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
50940 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
50941 PMTH(4,IR)=PMTH(3,IR)
50942 PMTH(5,IR)=PMTH(3,IR)
50944 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
50946 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
50948 PS(J)=PS(J)+P(IPA(I),J)
50951 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
50952 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
50953 IF(NPA.EQ.1) PS(5)=PS(4)
50954 IF(PS(5).LE.PM+PMQT1E) RETURN
50956 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
50959 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
50960 KFSRCE=IABS(K(K(IP1,3),2))
50962 IPAR1=MAX(1,K(IP1,3))
50963 IPAR2=MAX(1,K(IP2,3))
50964 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
50965 & KFSRCE=IABS(K(K(IPAR1,3),2))
50968 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
50969 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
50970 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
50971 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
50972 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
50973 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
50974 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
50975 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
50977 C...Identify two primary showerers.
50979 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
50980 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
50981 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
50982 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
50983 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
50984 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
50985 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
50986 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
50988 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
50989 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
50990 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
50991 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
50992 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
50993 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
50994 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
50995 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
50997 C...Order of showerers. Presence of gluino.
50998 ITYPMN=MIN(ITYPE1,ITYPE2)
50999 ITYPMX=MAX(ITYPE1,ITYPE2)
51001 IF(ITYPE1.GT.ITYPE2) IORD=2
51003 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
51005 C...Check if 3-jet matrix elements to be used.
51008 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
51009 IF(MSTJ(38).NE.0) THEN
51013 ELSEIF(MSTJ(47).GE.6) THEN
51019 C...Vector/axial vector -> q + qbar; q -> q + V.
51020 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
51021 & ITYPES.EQ.3)) THEN
51023 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
51025 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
51026 & K(IP1,2)+K(IP2,2).EQ.0)) THEN
51027 C...gamma*/Z0: assume e+e- initial state if unknown.
51029 IF(KFSRCE.EQ.23) THEN
51030 IANNFL=K(K(IP1,3),3)
51031 IF(IANNFL.NE.0) THEN
51032 KANNFL=IABS(K(IANNFL,2))
51033 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
51036 AI=SIGN(1D0,EI+0.1D0)
51037 VI=AI-4D0*EI*PARU(102)
51038 EF=KCHG(KFLA(1),1)/3D0
51039 AF=SIGN(1D0,EF+0.1D0)
51040 VF=AF-4D0*EF*PARU(102)
51041 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
51044 SQWZ=PS(5)*PMAS(23,2)
51045 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
51046 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
51047 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
51048 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
51050 ALPHA=VECT/(VECT+AXIV)
51051 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
51054 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
51055 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
51057 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
51058 & ITYPES.EQ.1)) THEN
51061 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
51062 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
51064 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
51066 ELSEIF(KFSRCE.EQ.36) THEN
51069 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
51070 & ITYPES.EQ.1)) THEN
51073 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
51074 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
51075 & ITYPES.EQ.3)) THEN
51077 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
51078 & ITYPES.EQ.2)) THEN
51080 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
51082 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
51083 & ITYPES.EQ.2)) THEN
51086 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
51087 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
51088 & ITYPES.EQ.5)) THEN
51090 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
51091 & ITYPES.EQ.2)) THEN
51093 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
51094 & ITYPES.EQ.1)) THEN
51097 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
51098 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
51100 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
51101 & ITYPES.EQ.2)) THEN
51103 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
51104 & ITYPES.EQ.1)) THEN
51107 C...g -> ~g + ~g (eikonal approximation).
51108 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
51111 M3JC=5*ICLASS+ICOMBI
51115 C...Find if interference with initial state partons.
51117 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
51118 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
51119 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
51124 KCA=PYCOMP(KFLA(I))
51125 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
51127 IF(KCII(I).NE.0) THEN
51129 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
51130 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
51131 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
51133 IIIS(I,NIIS(I))=ICSI
51138 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
51141 C...Boost interfering initial partons to rest frame
51142 C...and reconstruct their polar and azimuthal angles.
51146 K(N+I,J)=K(IPA(I),J)
51147 P(N+I,J)=P(IPA(I),J)
51151 DO 220 I=3,2+NIIS(1)
51153 K(N+I,J)=K(IIIS(1,I-2),J)
51154 P(N+I,J)=P(IIIS(1,I-2),J)
51158 DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
51160 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
51161 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
51165 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
51166 & -PS(2)/PS(4),-PS(3)/PS(4))
51167 PHI=PYANGL(P(N+1,1),P(N+1,2))
51168 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
51169 THE=PYANGL(P(N+1,3),P(N+1,1))
51170 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
51171 DO 250 I=3,2+NIIS(1)
51172 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
51173 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
51175 DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
51176 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
51177 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
51178 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
51182 C...Boost 3 or more partons to their rest frame.
51183 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
51184 &-PS(2)/PS(4),-PS(3)/PS(4))
51186 C...Define imagined single initiator of shower for parton system.
51188 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
51189 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
51190 IF(MSTU(21).GE.1) RETURN
51209 C...Loop over partons that may branch.
51212 IF(NPA.EQ.1) IM=NS-1
51215 IF(IM.GT.N) GOTO 590
51218 IF(KSH(IR).EQ.0) GOTO 280
51219 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 280
51224 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
51225 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
51226 IF(MSTU(21).GE.1) RETURN
51229 C...Position of aunt (sister to branching parton).
51230 C...Origin and flavour of daughters.
51233 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
51234 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
51246 K(N+I,2)=K(IPA(I),2)
51248 ELSEIF(KFLM.NE.21) THEN
51251 IREF(N+1-NS)=IREF(IM-NS)
51252 IREF(N+2-NS)=IABS(K(N+2,2))
51253 ELSEIF(K(IM,5).EQ.21) THEN
51261 IREF(N+1-NS)=IABS(K(N+1,2))
51262 IREF(N+2-NS)=IABS(K(N+2,2))
51265 C...Reset flags on daughters and tries made.
51270 KFLD(IP)=IABS(K(N+IP,2))
51271 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
51275 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
51279 C...Maximum virtuality of daughters.
51282 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
51283 P(N+I,5)=MIN(QMAX,PS(5))
51285 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
51286 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
51289 IF(MSTJ(43).LE.2) PEM=V(IM,2)
51290 IF(MSTJ(43).GE.3) PEM=P(IM,4)
51291 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
51292 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
51293 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
51297 IF(ISI(I).EQ.1) THEN
51299 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
51301 V(N+I,5)=P(N+I,5)**2
51304 C...Choose one of the daughters for evolution.
51306 IF(NEP.EQ.1) INUM=1
51308 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
51311 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
51313 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
51319 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
51320 RPM=P(N+I,5)/PMSD(I)
51322 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
51330 C...Cancel choice of predetermined daughter already treated.
51333 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
51334 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
51335 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
51336 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
51337 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
51340 C...Store information on choice of evolving daughter.
51344 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
51347 KFL(I)=IABS(K(IEP(I),2))
51349 ITRY(INUM)=ITRY(INUM)+1
51350 IF(ITRY(INUM).GT.200) THEN
51351 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
51352 IF(MSTU(21).GE.1) RETURN
51356 IF(KSH(IR).EQ.0) GOTO 440
51357 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 440
51359 C...Check if evolution already predetermined for daughter.
51361 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
51362 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
51363 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
51364 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
51365 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
51368 IF(IPSPD.NE.0) ISSET(INUM)=1
51370 C...Select side for interference with initial state partons.
51371 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
51374 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
51376 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
51377 IF(PYR(0).GT.0.5D0) ISII(III)=1
51378 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
51380 IF(PYR(0).GT.0.5D0) ISII(III)=2
51384 C...Calculate allowed z range.
51387 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
51390 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
51391 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
51393 IF(MOD(MSTJ(43),2).EQ.1) THEN
51395 ZCE=PMTH(2,22)/PMED
51396 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
51398 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
51399 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
51401 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
51402 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
51403 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
51406 ZCE=MIN(ZCE,0.49991D0)
51407 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
51408 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
51409 P(IEP(1),5)=PMTH(1,IR)
51410 V(IEP(1),5)=P(IEP(1),5)**2
51414 C...Integral of Altarelli-Parisi z kernel for QCD.
51415 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
51418 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
51420 FBR=(1.D0+FMED)*6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
51421 ELSEIF(MSTJ(49).EQ.0) THEN
51423 FBR=(1.D0+FMED)*(8D0/3D0)*LOG((1D0-ZC)/ZC)
51424 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
51426 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
51427 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
51428 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
51429 ELSEIF(MSTJ(49).EQ.1) THEN
51430 FBR=(1D0-2D0*ZC)/3D0
51431 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
51433 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
51434 ELSEIF(KFL(1).EQ.21) THEN
51435 FBR=(1.D0+FMED)*6D0*MSTJ(45)*(0.5D0-ZC)
51437 FBR=(1.D0+FMED)*2D0*LOG((1D0-ZC)/ZC)
51440 C...Reset QCD probability for colourless.
51441 IF(ISCOL(IR).EQ.0) FBR=0D0
51443 C...Integral of Altarelli-Parisi kernel for photon emission.
51445 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
51446 IF(KFL(1).LE.18) THEN
51447 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
51449 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
51452 C...Inner veto algorithm starts. Find maximum mass for evolution.
51453 400 PMS=V(IEP(1),5)
51458 IRI=IREF(IEP(I)-NS)
51459 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
51462 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
51465 C...Select mass for daughter in QCD evolution.
51467 DO 420 IFF=4,MSTJ(45)
51468 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
51470 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
51471 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
51472 C...Already predetermined choice.
51473 IF(IPSPD.NE.0) THEN
51474 PMSQCD=P(IPSPD,5)**2
51475 ELSEIF(FBR.LT.1D-3) THEN
51477 ELSEIF(MSTJ(44).LE.0) THEN
51478 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
51479 ELSEIF(MSTJ(44).EQ.1) THEN
51480 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
51482 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
51484 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
51485 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
51486 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
51490 C...Select mass for daughter in QED evolution.
51491 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
51492 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
51493 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
51494 IF(FBRE.LT.1D-3) THEN
51497 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
51498 & (PARU(101)*FBRE)))
51500 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
51501 PMSQED=PMSQED+PMTH(1,IR)**2
51502 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
51504 IF(PMSQED.GT.PMSQCD) THEN
51510 C...Check whether daughter mass below cutoff.
51511 P(IEP(1),5)=SQRT(V(IEP(1),5))
51512 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
51513 P(IEP(1),5)=PMTH(1,IR)
51514 V(IEP(1),5)=P(IEP(1),5)**2
51518 C...Already predetermined choice of z, and flavour in g -> qqbar.
51519 IF(IPSPD.NE.0) THEN
51522 PMSGD1=P(IPSGD1,5)**2
51523 PMSGD2=P(IPSGD2,5)**2
51524 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
51525 & 4D0*PMSGD1*PMSGD2))
51526 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
51527 & PMSGD1+PMSGD2)/ALAMPS
51528 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
51529 IF(KFL(1).NE.21) THEN
51532 K(IEP(1),5)=IABS(K(IPSGD1,2))
51535 C...Select z value of branching: q -> qgamma.
51536 ELSEIF(MCE.EQ.2) THEN
51537 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
51538 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 400
51541 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
51542 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
51543 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
51544 C...Only do z weighting when no ME correction afterwards.
51545 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 400
51547 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
51548 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
51549 IF(PYR(0).GT.0.5D0) Z=1D0-Z
51550 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 400
51552 ELSEIF(MSTJ(49).NE.1) THEN
51554 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 400
51555 KFLB=1+INT(MSTJ(45)*PYR(0))
51556 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
51557 IF(PMQ.GE.1D0) GOTO 400
51558 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
51559 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 400
51560 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
51561 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
51562 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 400
51564 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 400
51568 C...Ditto for scalar gluon model.
51569 ELSEIF(KFL(1).NE.21) THEN
51570 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
51572 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
51573 Z=ZC+(1D0-2D0*ZC)*PYR(0)
51576 Z=ZC+(1D0-2D0*ZC)*PYR(0)
51577 KFLB=1+INT(MSTJ(45)*PYR(0))
51578 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
51579 IF(PMQ.GE.1D0) GOTO 400
51583 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
51584 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
51585 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
51586 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51587 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 400
51589 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
51590 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
51591 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
51592 IF(PT2APP.LT.PT2MIN) GOTO 400
51593 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 400
51597 C...Check if z consistent with chosen m.
51598 IF(KFL(1).EQ.21) THEN
51599 IRGD1=IABS(K(IEP(1),5))
51603 IRGD2=IABS(K(IEP(1),5))
51607 ELSEIF(NEP.GE.3) THEN
51609 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
51610 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
51612 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
51613 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
51615 IF(MOD(MSTJ(43),2).EQ.1) THEN
51616 PMQTH3=0.5D0*PARJ(82)
51617 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
51618 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
51619 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
51620 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
51621 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
51625 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
51628 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
51629 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51630 ELSEIF(IPSPD.NE.0) THEN
51634 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 400
51636 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
51638 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
51640 C...Width suppression for q -> q + g.
51641 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
51643 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
51647 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
51648 IF(MSTJ(40).EQ.1) THEN
51649 IF(CHI.LT.PYR(0)) GOTO 400
51650 ELSEIF(MSTJ(40).EQ.2) THEN
51651 IF(1D0-CHI.LT.PYR(0)) GOTO 400
51655 C...Three-jet matrix element correction.
51660 C...QED matrix elements: only for massless case so far.
51661 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
51662 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
51663 X2=1D0-V(IEP(1),5)/V(NS+1,5)
51664 X3=(1D0-X1)+(1D0-X2)
51666 KI2=K(IPA(3-INUM),2)
51667 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
51668 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
51669 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
51670 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
51671 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
51672 ELSEIF(MCE.EQ.2) THEN
51674 C...QCD matrix elements, including mass effects.
51675 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
51679 IF(IR.GE.31.AND.IGM.EQ.0) THEN
51680 C...QCD ME: original parton, first branching.
51681 PM2ME=PMTH(1,63-IR)
51683 ELSEIF(IR.GE.31) THEN
51684 C...QCD ME: original parton, subsequent branchings.
51685 PM2ME=PMTH(1,63-IR)
51686 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
51687 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
51688 ELSEIF(K(IM,2).EQ.21) THEN
51689 C...QCD ME: secondary partons, first branching.
51692 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
51693 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
51694 & 4D0*PS1ME*PM2ME**2))
51695 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
51697 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
51700 C...QCD ME: secondary partons, subsequent branchings.
51702 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
51703 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
51706 C...Construct ME variables.
51709 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
51710 X2=1D0+R2ME**2-PS1ME/ECMME**2
51711 C...Call ME, with right order important for two inequivalent showerers.
51712 IF(IR.EQ.IORD+30) THEN
51713 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
51715 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
51717 C...Split up total ME when two radiating partons.
51719 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
51720 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
51721 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
51722 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
51723 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
51724 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
51725 & MAX(1D-10,2D0-X1-X2)
51726 C...Evaluate shower rate to be compared with.
51727 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
51728 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
51729 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
51730 ELSEIF(MSTJ(49).NE.1) THEN
51732 C...Toy model scalar theory matrix elements; no mass effects.
51734 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
51735 X2=1D0-V(IEP(1),5)/V(NS+1,5)
51736 X3=(1D0-X1)+(1D0-X2)
51737 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
51739 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
51743 IF(WME.LT.PYR(0)*WSHOW) GOTO 400
51746 C...Impose angular ordering by rejection of nonordered emission.
51747 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
51748 PEMAO=V(IM,1)*P(IM,4)
51749 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
51750 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
51752 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
51753 & .OR.MSTJ(42).EQ.7)) THEN
51755 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
51756 & .OR.MSTJ(42).EQ.6)) THEN
51758 PMDAO=PMTH(2,K(IEP(1),5))
51759 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
51762 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
51763 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
51764 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
51768 430 IF(K(IAOM,5).EQ.22) THEN
51770 IF(K(IAOM,3).LE.NS) MAOM=0
51771 IF(MAOM.EQ.1) GOTO 430
51773 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
51774 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
51775 IF(THE2ID.LT.THE2IM) GOTO 400
51779 C...Impose user-defined maximum angle at first branching.
51780 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
51781 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
51782 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
51783 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400
51784 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
51785 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
51786 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400
51787 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
51788 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
51789 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 400
51793 C...Impose angular constraint in first branching from interference
51794 C...with initial state partons.
51795 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
51796 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
51797 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
51798 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 400
51799 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
51800 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 400
51804 C...End of inner veto algorithm. Check if only one leg evolved so far.
51808 IF(NEP.EQ.1) GOTO 480
51809 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 340
51812 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
51813 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 340
51817 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
51821 PMSUM=PMSUM+P(N+I,5)
51823 IF(PMSUM.GE.PS(5)) GOTO 340
51824 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
51827 IF(KSH(IRDA).EQ.0) GOTO 470
51828 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 470
51829 IF(IRDA.EQ.21) THEN
51830 IRGD1=IABS(K(I1,5))
51834 IRGD2=IABS(K(I1,5))
51837 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
51838 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
51840 IF(I1.EQ.N+1) ZM=V(IM,1)
51841 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
51842 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
51843 & 4D0*V(N+1,5)*V(N+2,5))
51844 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
51847 IF(MOD(MSTJ(43),2).EQ.1) THEN
51848 PMQTH3=0.5D0*PARJ(82)
51849 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
51850 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
51851 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
51852 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
51853 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
51857 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
51860 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
51861 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51865 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
51866 & ISSET(1).EQ.0) THEN
51868 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
51869 & ISSET(2).EQ.0) THEN
51873 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
51875 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
51877 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
51880 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
51881 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
51882 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
51883 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
51884 IF(ISL(1).EQ.1) ISL(2)=0
51885 IF(ISL(1).EQ.0) ISLM=1
51886 IF(ISL(2).EQ.0) ISLM=2
51888 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 340
51893 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
51894 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
51895 PMQ1=V(N+1,5)/V(IM,5)
51896 PMQ2=V(N+2,5)/V(IM,5)
51897 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
51902 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 340
51906 C...Accepted branch. Construct four-momentum for initial partons.
51912 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
51914 P(N+1,4)=P(IPA(1),4)
51916 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
51917 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
51920 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
51925 P(N+2,4)=P(IM,5)-PED1
51928 ELSEIF(NEP.GE.3) THEN
51929 C...Rescale all momenta for energy conservation.
51935 P(N+I,J)=P(IPA(I),J)
51938 PQS=PQS+P(N+I,5)**2/P(N+I,4)
51941 FAC=(PS(5)-PQS)/(PES-PQS)
51946 P(N+I,J)=FAC*P(N+I,J)
51948 P(N+I,4)=SQRT(P(N+I,5)**2+P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
51951 PQS=PQS+P(N+I,5)**2/P(N+I,4)
51953 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 510
51955 C...Construct transverse momentum for ordinary branching in shower.
51959 540 LOOPPT=LOOPPT+1
51960 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
51961 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
51962 IF(PZM.LE.0D0) THEN
51964 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
51965 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
51966 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
51967 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
51968 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
51969 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
51971 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
51973 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
51976 ELSEIF(PTS.LT.0D0) THEN
51979 PT=SQRT(MAX(0D0,PTS))
51981 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
51983 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
51984 & .AND.IAU.NE.0) THEN
51985 IF(K(IGM,3).NE.0) MAZIP=1
51987 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
51988 IF(MAZIP.EQ.0) ZAU=0D0
51989 IF(K(IGM,2).NE.21) THEN
51990 HAZIP=2D0*ZAU/(1D0+ZAU**2)
51992 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
51994 IF(K(N+1,2).NE.21) THEN
51995 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
51997 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
52001 C...Find coefficient of azimuthal asymmetry due to soft gluon
52004 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
52005 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
52006 IF(K(IGM,3).NE.0) MAZIC=N+1
52007 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
52008 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
52009 & ZM.GT.0.5D0) MAZIC=N+2
52010 IF(K(IAU,2).EQ.22) MAZIC=0
52012 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
52014 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
52015 IF(MAZIC.EQ.0) ZGM=1D0
52016 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
52017 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
52018 HAZIC=MIN(0.95D0,HAZIC)
52022 C...Construct energies for ordinary branching in shower.
52023 550 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
52024 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
52025 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
52026 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
52027 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
52028 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
52029 P(N+1,4)=PEM*V(IM,1)
52031 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
52032 & SQRT(PMLS)*ZM)/V(IM,5)
52035 C...Already predetermined choice of phi angle or not
52037 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
52039 IF(K(IPSPD,4).GT.0) THEN
52041 IF(IM.EQ.NS+2) THEN
52042 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
52044 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
52047 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
52049 IF(K(IPSPD,4).GT.0) THEN
52051 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
52052 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
52053 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
52054 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
52055 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
52056 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
52060 C...Construct momenta for ordinary branching in shower.
52061 P(N+1,1)=PT*COS(PHI)
52062 P(N+1,2)=PT*SIN(PHI)
52063 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
52064 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
52065 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
52066 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
52067 ELSEIF(PZM.GT.0D0) THEN
52068 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
52069 & 2D0*PEM*P(N+1,4))/PZM
52075 P(N+2,3)=PZM-P(N+1,3)
52076 P(N+2,4)=PEM-P(N+1,4)
52077 IF(MSTJ(43).LE.2) THEN
52078 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
52079 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
52083 C...Rotate and boost daughters.
52085 IF(MSTJ(43).LE.2) THEN
52086 BEX=P(IGM,1)/P(IGM,4)
52087 BEY=P(IGM,2)/P(IGM,4)
52088 BEZ=P(IGM,3)/P(IGM,4)
52089 GA=P(IGM,4)/P(IGM,5)
52090 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
52099 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
52100 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
52101 IF(PTIMB.GT.1D-4) THEN
52102 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
52107 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
52108 & SIN(THE)*COS(PHI)*P(I,3)
52109 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
52110 & SIN(THE)*SIN(PHI)*P(I,3)
52111 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
52113 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
52114 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
52115 P(I,1)=DP(1)+DGABP*BEX
52116 P(I,2)=DP(2)+DGABP*BEY
52117 P(I,3)=DP(3)+DGABP*BEZ
52118 P(I,4)=GA*(DP(4)+DBP)
52122 C...Weight with azimuthal distribution, if required.
52123 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
52129 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
52130 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
52131 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
52133 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
52134 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
52136 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
52137 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
52138 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
52139 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
52140 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
52141 IF(MAZIP.NE.0) THEN
52142 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
52145 IF(MAZIC.NE.0) THEN
52146 IF(MAZIC.EQ.N+2) CAD=-CAD
52147 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
52148 & .LT.PYR(0)) GOTO 550
52153 C...Azimuthal anisotropy due to interference with initial state partons.
52154 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
52155 &K(N+2,2).EQ.21)) THEN
52157 IF(ISII(III).GE.1) THEN
52159 IF(K(N+1,2).NE.21) IAZIID=N+2
52160 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
52161 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
52162 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
52163 IF(III.EQ.2) THEIID=PARU(1)-THEIID
52164 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
52165 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
52166 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
52167 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
52168 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
52169 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
52170 & .LT.PYR(0)) GOTO 550
52174 C...Continue loop over partons that may branch, until none left.
52175 IF(IGM.GE.0) K(IM,1)=14
52178 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
52179 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
52180 IF(MSTU(21).GE.1) N=NS
52181 IF(MSTU(21).GE.1) RETURN
52185 C...Set information on imagined shower initiator.
52186 590 IF(NPA.GE.2) THEN
52190 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
52198 C...Reconstruct string drawing information.
52199 DO 600 I=NS+1+IIM,N
52200 KQ=KCHG(PYCOMP(K(I,2)),2)
52201 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
52203 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
52204 & IABS(K(I,2)).LE.18) THEN
52206 ELSEIF(K(I,1).LE.10) THEN
52207 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
52208 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
52209 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
52210 ID1=MOD(K(I,4),MSTU(5))
52211 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
52212 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
52213 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
52214 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
52215 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
52216 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
52217 K(ID1,4)=K(ID1,4)+MSTU(5)*I
52218 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
52219 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
52220 K(ID2,5)=K(ID2,5)+MSTU(5)*I
52222 ID1=MOD(K(I,4),MSTU(5))
52224 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
52225 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
52226 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
52227 K(ID1,4)=K(ID1,4)+MSTU(5)*I
52228 K(ID1,5)=K(ID1,5)+MSTU(5)*I
52238 C...Transformation from CM frame.
52240 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
52241 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
52243 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
52244 ELSEIF(NPA.EQ.2) THEN
52249 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
52250 & /(1D0+GA)-P(IPA(1),4))
52251 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
52252 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
52253 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
52255 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
52257 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
52260 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
52263 C...Decay vertex of shower.
52270 C...Delete trivial shower, else connect initiators.
52271 IF(N.LE.NS+NPA+IIM) THEN
52276 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
52277 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
52278 K(NS+IIM+IP,3)=IPA(IP)
52279 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
52280 IF(K(NS+IIM+IP,1).NE.1) THEN
52281 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
52282 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
52290 C*********************************************************************
52293 C...Auxiliary to PYSHOW.
52294 C...Matrix elements for gluon (or photon) emission from
52295 C...a two-body state; to be used by the parton shower routine.
52296 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
52297 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
52298 C... = (alpha-strong/2 pi) * CF * PYMAEL,
52299 C...i.e. normalization is such that one recovers the familiar
52300 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
52301 C...Coupling structure:
52302 C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
52303 C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
52304 C... = 16-19 : q -> q V
52305 C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
52306 C... = 26-29 : q -> q S
52307 C... = 31-34 : V -> ~q ~qbar (~q = squark)
52308 C... = 36-39 : ~q -> ~q V
52309 C... = 41-44 : S -> ~q ~qbar
52310 C... = 46-49 : ~q -> ~q S
52311 C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
52312 C... = 56-59 : ~q -> q chi
52313 C... = 61-64 : q -> ~q chi
52314 C... = 66-69 : ~g -> q ~qbar
52315 C... = 71-74 : ~q -> q ~g
52316 C... = 76-79 : q -> ~q ~g
52317 C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
52318 C...Note that the order of the decay products is important.
52319 C...In each set of four, the variants are ordered as:
52320 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
52321 C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
52322 C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
52323 C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
52325 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
52327 C...Double precision and integer declarations.
52328 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52329 IMPLICIT INTEGER(I-N)
52331 C...Check input values. Return zero outside allowed phase space.
52333 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
52334 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
52335 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
52336 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
52337 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
52338 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
52340 C...Initial values and flags.
52348 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
52350 C...Eikonal expression; also acts as default.
52351 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
52353 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
52355 ELSEIF(ICOMBI.EQ.2) THEN
52356 ANUM=(2D0-X1-X2)**2
52357 ELSEIF(ICOMBI.EQ.3) THEN
52358 ANUM=ALPCOR*(2D0-X1-X2)**2
52360 ANUM=0.5D0*(2D0-X1-X2)**2
52362 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
52363 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
52364 & R1**2/(1D0+R2**2-R1**2-X2)**2-
52365 & R2**2/(1D0+R1**2-R2**2-X1)**2)
52368 C...V -> q qbar (V = gamma*/Z0/W+-/...).
52369 ELSEIF(ICLASS.EQ.2) THEN
52370 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52371 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
52372 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
52373 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
52374 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
52375 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
52376 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
52377 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
52378 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
52379 & (-1+R1**2-R2**2+X2)**2
52380 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
52381 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
52382 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
52383 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
52384 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
52385 & -X1-X2)**2+X1*(2-X1-X2)**2)/
52386 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52387 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
52388 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
52389 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
52390 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
52391 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
52395 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52396 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
52397 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
52398 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
52399 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
52400 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
52401 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
52402 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
52403 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
52404 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
52405 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
52406 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
52407 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
52408 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
52409 & -X1-X2)**2+X1*(2-X1-X2)**2)/
52410 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52411 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
52412 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
52413 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
52414 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
52415 & +X2)/(-1-R1**2+R2**2+X1)**2
52419 IF(ICOMBI.EQ.4) THEN
52420 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
52421 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
52422 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
52423 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
52424 & (-1-R1**2+R2**2+X1)**2
52426 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
52427 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
52428 & -R1**2*X2**2+X1*X2**2)/
52429 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52430 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
52431 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
52432 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
52433 & (-1+R1**2-R2**2+X2)**2
52439 ELSEIF(ICLASS.EQ.3) THEN
52440 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52441 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
52442 & +R1**2*R2**2-2D0*R2**4)
52443 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
52444 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
52445 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
52446 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
52447 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
52448 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
52449 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
52450 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
52451 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
52452 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
52453 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
52454 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
52455 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
52456 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
52457 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
52458 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
52459 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
52460 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
52461 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
52464 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52465 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
52466 & +R1**2*R2**2-2D0*R2**4)
52467 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
52468 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
52469 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
52470 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
52471 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
52472 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
52473 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52474 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
52475 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
52476 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
52477 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
52478 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
52479 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
52480 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
52481 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
52482 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
52483 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
52484 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
52485 & +X1*X2**2)/(-2+X1+X2)**2
52488 IF(ICOMBI.EQ.4) THEN
52489 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
52490 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
52491 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
52492 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
52493 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
52494 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52495 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
52496 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
52497 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
52498 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
52499 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
52500 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
52501 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
52502 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
52503 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
52504 & +X1*X2**2)/(2-X1-X2)**2
52508 C...S -> q qbar (S = h0/H0/A0/H+-/...).
52509 ELSEIF(ICLASS.EQ.4) THEN
52510 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52511 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
52512 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52513 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52514 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52515 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
52516 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
52517 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52518 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52519 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
52520 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52523 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52524 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
52525 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52526 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52527 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52528 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52529 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
52530 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52531 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
52532 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
52533 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
52534 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52537 IF(ICOMBI.EQ.4) THEN
52538 RLO4=PS*(1D0-R1**2-R2**2)
52539 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
52540 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52541 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
52542 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
52543 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52544 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
52545 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52550 ELSEIF(ICLASS.EQ.5) THEN
52551 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52552 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
52553 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
52554 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
52555 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
52556 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52557 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
52558 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
52559 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52560 & (-1+R1**2-R2**2+X2)**2
52563 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52564 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
52565 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
52566 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
52567 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
52568 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52569 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
52570 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
52571 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52572 & (-1+R1**2-R2**2+X2)**2
52575 IF(ICOMBI.EQ.4) THEN
52576 RLO4=PS*(1D0+R1**2-R2**2)
52577 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
52578 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
52579 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
52580 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
52581 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
52582 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
52586 C...V -> ~q ~qbar (~q = squark).
52587 ELSEIF(ICLASS.EQ.6) THEN
52588 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
52589 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
52590 & (-1-R1**2+R2**2+X1)**2
52591 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
52592 & (-1-R1**2+R2**2+X1)
52593 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
52594 & /(-1+R1**2-R2**2+X2)**2
52595 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
52596 & (-1+R1**2-R2**2+X2)
52597 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
52598 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
52599 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
52600 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52604 ELSEIF(ICLASS.EQ.7) THEN
52605 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
52606 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
52607 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
52608 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
52609 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
52610 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
52611 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
52612 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
52613 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
52614 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
52615 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
52621 ELSEIF(ICLASS.EQ.8) THEN
52623 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
52624 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
52625 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
52626 & -R1**2*X2**2+X1*X2**2)/
52627 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
52632 ELSEIF(ICLASS.EQ.9) THEN
52634 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
52635 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52636 & -(X1+X2)/(-2+X1+X2)**2
52639 C...chi -> q ~qbar (chi = neutralino/chargino).
52640 ELSEIF(ICLASS.EQ.10) THEN
52641 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52642 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
52643 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
52644 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
52645 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
52646 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52647 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
52648 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52649 & (-1+R1**2-R2**2+X2)**2
52652 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52653 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
52654 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
52655 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
52656 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
52657 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52658 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
52659 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52660 & (-1+R1**2-R2**2+X2)**2
52663 IF(ICOMBI.EQ.4) THEN
52664 RLO4=PS*(1+R1**2-R2**2)
52665 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
52666 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
52667 & +X2+R1**2*X2-X1*X2/2)/
52668 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
52669 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
52670 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
52675 ELSEIF(ICLASS.EQ.11) THEN
52676 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52677 RLO1=PS*(1D0-(R1+R2)**2)
52678 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
52679 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52680 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
52681 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52682 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
52683 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
52684 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52687 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52688 RLO2=PS*(1D0-(R1-R2)**2)
52689 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
52691 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52692 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
52693 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
52694 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
52695 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
52696 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
52699 IF(ICOMBI.EQ.4) THEN
52700 RLO4=PS*(1D0-R1**2-R2**2)
52701 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
52702 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
52703 & +3*R1**2*X2-R2**2*X2-X1*X2)/
52704 & (-1+R1**2-R2**2+X2)**2
52705 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
52706 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
52707 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52712 ELSEIF(ICLASS.EQ.12) THEN
52713 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52714 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
52715 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
52716 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
52717 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
52718 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
52719 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
52720 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52723 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52724 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
52725 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
52726 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
52727 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
52728 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
52729 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
52730 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52733 IF(ICOMBI.EQ.4) THEN
52734 RLO4=PS*(1D0-R1**2+R2**2)
52735 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
52736 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
52737 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
52738 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
52739 & +R1**2*X2-X1*X2/2-X2**2/2)/
52740 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
52745 ELSEIF(ICLASS.EQ.13) THEN
52746 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52747 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
52748 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
52749 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
52750 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
52751 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
52752 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
52753 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
52754 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
52755 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
52756 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
52757 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
52758 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
52759 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52760 & (3*(-1+R1**2-R2**2+X2)**2)
52764 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52765 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
52766 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
52767 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
52768 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
52769 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
52770 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
52771 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
52772 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
52773 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
52774 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
52775 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52776 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
52777 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
52778 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52779 & (3*(-1+R1**2-R2**2+X2)**2)
52783 IF(ICOMBI.EQ.4) THEN
52784 RLO4=PS*(1D0+R1**2-R2**2)
52785 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
52786 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
52787 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
52788 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
52789 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
52790 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52791 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
52792 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52793 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
52794 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
52795 & (3*(-1+R1**2-R2**2+X2)**2)
52801 ELSEIF(ICLASS.EQ.14) THEN
52802 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52803 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
52804 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
52805 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52806 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52807 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
52808 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
52809 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
52810 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
52811 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
52812 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
52813 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
52814 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
52815 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
52816 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
52818 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
52819 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
52820 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52824 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52825 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
52826 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
52827 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
52828 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
52829 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
52830 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
52831 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
52832 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
52833 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
52834 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
52835 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
52837 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
52838 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
52839 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
52840 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
52841 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
52842 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52846 IF(ICOMBI.EQ.4) THEN
52847 RLO4=PS*(1-R1**2-R2**2)
52848 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
52849 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
52850 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
52851 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
52852 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
52853 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
52854 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
52855 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
52856 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
52857 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
52858 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
52859 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
52860 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
52861 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
52862 RFO4=9D0*RFO4/128D0
52867 ELSEIF(ICLASS.EQ.15) THEN
52868 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
52869 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
52870 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
52871 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
52872 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
52873 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
52874 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
52875 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
52876 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
52877 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
52878 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
52879 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
52880 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
52881 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
52882 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
52883 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52887 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
52888 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
52889 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
52890 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
52891 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
52892 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
52893 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
52894 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
52895 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
52896 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
52897 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
52898 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
52899 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
52900 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
52901 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
52902 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52906 IF(ICOMBI.EQ.4) THEN
52907 RLO4=PS*(1D0-R1**2+R2**2)
52908 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
52909 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
52910 & -R2**2*X2/2-X1*X2/2)/
52911 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
52912 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
52913 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
52914 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
52915 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
52916 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
52917 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
52918 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
52919 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
52924 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
52925 ELSEIF(ICLASS.EQ.16) THEN
52927 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
52929 ELSEIF(ICOMBI.EQ.2) THEN
52930 ANUM=(2D0-X1-X2)**2
52931 ELSEIF(ICOMBI.EQ.3) THEN
52932 ANUM=ALPCOR*(2D0-X1-X2)**2
52934 ANUM=0.5D0*(2D0-X1-X2)**2
52936 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
52937 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
52938 & R1**2/(1D0+R2**2-R1**2-X2)**2-
52939 & R2**2/(1D0+R1**2-R2**2-X1)**2)
52944 C...Find relevant LO and FO expression.
52945 IF(ICOMBI.EQ.0) THEN
52946 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
52949 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
52952 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
52953 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
52954 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
52955 ELSEIF(ISSET4.EQ.1) THEN
52958 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
52959 RLO=0.5D0*(RLO1+RLO2)
52960 RFO=0.5D0*(RFO1+RFO2)
52961 ELSEIF(ISSET1.EQ.1) THEN
52965 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
52976 C*********************************************************************
52979 C...Modifies an event so as to approximately take into account
52980 C...Bose-Einstein effects according to a simple phenomenological
52981 C...parametrization.
52983 SUBROUTINE PYBOEI(NSAV)
52985 C...Double precision and integer declarations.
52986 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52987 IMPLICIT INTEGER(I-N)
52988 INTEGER PYK,PYCHGE,PYCOMP
52989 C...Parameter statement to help give large particle numbers.
52990 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52991 &KEXCIT=4000000,KDIMEN=5000000)
52993 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52994 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52995 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52996 COMMON/PYINT1/MINT(400),VINT(400)
52997 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
52998 C...Local arrays and data.
52999 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
53000 &BEIW(100),BEI3W(100)
53001 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
53002 C...Statement function: squared invariant mass.
53003 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
53004 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
53006 C...Boost event to overall CM frame. Calculate CM energy.
53007 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
53013 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
53014 & .AND.K(I,3).GT.0) THEN
53015 KFMA=IABS(K(K(I,3),2))
53016 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
53018 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
53020 DPS(J)=DPS(J)+P(I,J)
53023 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
53027 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
53030 C...Check if we have separated strings
53032 C...Reserve copy of particles by species at end of record.
53038 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
53039 NBE(IBE)=NBE(IBE-1)
53041 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
53042 DO 140 IIBE=1,IBE-1
53043 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
53046 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
53048 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
53049 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
53050 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
53053 NBE(IBE)=NBE(IBE)+1
53060 P(NBE(IBE),1)=0.0D0
53061 P(NBE(IBE),2)=0.0D0
53062 P(NBE(IBE),3)=0.0D0
53063 P(NBE(IBE),4)=0.0D0
53064 P(NBE(IBE),5)=0.0D0
53065 SMMIN=MIN(SMMIN,P(I,5))
53066 C...Check if particles comes from different W's or Z's
53067 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
53069 150 IF(K(IM,3).GT.0) THEN
53071 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
53073 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
53074 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
53075 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
53076 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
53079 C...Check if particles comes from different strings.
53080 IF(PARJ(94).GT.0.0D0) THEN
53082 160 IF(K(IM,3).GT.0) THEN
53084 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
53092 P(NBE(IBE),5)=-1.0D0
53095 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
53097 C...Calculate separation between W+ and W- or between two Z0's.
53098 C...No separation if there has been re-connections.
53100 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
53101 IF(K(IWP,2).EQ.23) THEN
53110 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
53111 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
53112 TAUP=-TAUPD*LOG(PYR(IDUM))
53113 TAUN=-TAUND*LOG(PYR(IDUM))
53114 DXP=TAUP*PYP(IWP,8)/DMP
53115 DXN=TAUN*PYP(IWN,8)/DMN
53117 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
53118 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
53121 C...Add separation between strings.
53122 IF(PARJ(94).GT.0.0D0) THEN
53123 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
53128 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
53129 DO 220 IBE=1,MIN(9,MSTJ(52))
53130 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
53133 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
53134 IF(I2M.EQ.I1M) GOTO 200
53136 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
53137 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
53138 & (P(I1,5)+P(I2,5))**2
53139 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
53148 C...Tabulate integral for subsequent momentum shift.
53149 DO 400 IBE=1,MIN(9,MSTJ(52))
53150 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
53151 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
53153 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
53154 & NBE(7)-NBE(6)).LE.1) GOTO 270
53155 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
53156 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
53157 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
53158 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
53159 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
53160 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
53161 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
53162 QDELW=0.1D0*MIN(PMHQ,SIGW)
53163 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
53164 IF(MSTJ(51).EQ.1) THEN
53165 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
53166 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
53167 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
53168 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
53169 BEEX=EXP(0.5D0*QDEL/PARJ(93))
53170 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
53171 BEEXW=EXP(0.5D0*QDELW/SIGW)
53172 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
53173 BERT=EXP(-QDEL/PARJ(93))
53174 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
53175 BERTW=EXP(-QDELW/SIGW)
53176 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
53178 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
53179 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
53180 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
53181 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
53184 QBIN=QDEL*(IBIN-0.5D0)
53185 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
53186 IF(MSTJ(51).EQ.1) THEN
53188 BEI(IBIN)=BEI(IBIN)*BEEX
53190 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
53192 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
53194 DO 240 IBIN=1,NBIN3
53195 QBIN=QDEL3*(IBIN-0.5D0)
53196 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
53197 IF(MSTJ(51).EQ.1) THEN
53199 BEI3(IBIN)=BEI3(IBIN)*BEEX3
53201 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
53203 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
53205 DO 250 IBIN=1,NBINW
53206 QBIN=QDELW*(IBIN-0.5D0)
53207 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
53208 IF(MSTJ(51).EQ.1) THEN
53210 BEIW(IBIN)=BEIW(IBIN)*BEEXW
53212 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
53214 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
53216 DO 260 IBIN=1,NBIN3W
53217 QBIN=QDEL3W*(IBIN-0.5D0)
53218 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
53219 & SQRT(QBIN**2+PMHQ**2)
53220 IF(MSTJ(51).EQ.1) THEN
53221 BEEX3W=BEEX3W*BERT3W
53222 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
53224 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
53226 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
53229 C...Loop through particle pairs and find old relative momentum.
53230 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
53232 DO 380 I2M=I1M+1,NBE(IBE)
53233 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
53234 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
53236 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
53237 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
53238 IF(Q2OLD.LE.0.0D0) GOTO 380
53241 C...Calculate new relative momentum.
53246 IF(QOLD.LT.1D-3*QDEL) THEN
53248 ELSEIF(QOLD.LE.QDEL) THEN
53250 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
53253 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
53254 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
53255 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
53257 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53259 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
53260 IF(QOLD.LT.1D-3*QDEL3) THEN
53262 ELSEIF(QOLD.LE.QDEL3) THEN
53264 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
53267 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
53268 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
53269 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
53271 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53273 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
53276 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
53277 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
53278 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
53280 IF(QOLD.LT.1D-3*QDELW) THEN
53282 ELSEIF(QOLD.LE.QDELW) THEN
53284 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
53287 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
53288 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
53289 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
53291 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53293 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
53294 IF(QOLD.LT.1D-3*QDEL3W) THEN
53296 ELSEIF(QOLD.LE.QDEL3W) THEN
53298 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
53301 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
53302 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
53303 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53305 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
53307 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
53309 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
53311 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
53313 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
53314 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
53316 IF(MSTJ(54).GE.1) THEN
53317 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
53319 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
53320 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
53322 ELSEIF(MSTJ(54).LE.-1) THEN
53323 EDEL=P(I1,4)+P(I2,4)-
53324 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
53325 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
53326 & (P(I1,3)-P(I2,3))**2
53331 SM1=(P(I1,5)+SMMIN)**2
53332 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
53333 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
53334 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
53335 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
53336 & K(I3M,5).NE.K(I1M,5)) GOTO 360
53338 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
53341 SM3=(P(I3,5)+SMMIN)**2
53342 IF(MSTJ(54).EQ.-2) THEN
53343 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
53344 & S23*MIN(SM1,SM3))*SM1)
53346 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
53347 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
53348 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
53349 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
53351 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
53352 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
53355 IF(WMAX*WI.GE.1.0) GOTO 360
53357 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
53358 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
53359 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
53360 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
53361 & K(I4M,5).NE.K(I1M,5)) GOTO 350
53363 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
53365 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
53366 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
53367 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
53369 IF(MSTJ(54).EQ.-2) THEN
53373 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
53374 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
53375 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
53376 W=MIN(W,MIN(S23,S24)*S13*S14)
53379 C...weight=1-cos(theta)/mtot2
53380 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
53381 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
53382 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
53383 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
53385 IF(W.LE.WMAX) GOTO 350
53387 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
53388 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
53389 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
53390 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
53391 IF(W.LE.WMAX) GOTO 350
53397 IF(MI4.EQ.0) GOTO 380
53400 EOLD=P(I3,4)+P(I4,4)
53402 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
53403 & (P(I3,3)+P(I4,3))**2
53404 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
53405 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
53406 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
53408 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
53409 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
53416 C...Shift momenta and recalculate energies.
53420 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
53424 P(I,J)=P(I,J)+P(IM,J)
53426 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53429 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
53434 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
53435 440 ALPHA=(ESUMP-ESUM)/PROD
53436 PARJ(96)=PARJ(96)+ALPHA
53439 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
53442 P(I,J)=P(I,J)+ALPHA*V(IM,J)
53444 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53447 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
53450 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
53454 C...Rescale all momenta for energy conservation.
53458 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
53460 PQS=PQS+P(I,5)**2/P(I,4)
53463 FAC=(PECM-PQS)/(PES-PQS)
53465 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
53469 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
53472 C...Boost back to correct reference frame.
53473 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
53475 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
53481 C*********************************************************************
53484 C...Calculates the momentum shift in a system of two particles assuming
53485 C...the relative momentum squared should be shifted to Q2NEW. NI is the
53486 C...last position occupied in /PYJETS/.
53488 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
53490 C...Double precision and integer declarations.
53491 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53492 IMPLICIT INTEGER(I-N)
53493 INTEGER PYK,PYCHGE,PYCOMP
53494 C...Parameter statement to help give large particle numbers.
53495 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53496 &KEXCIT=4000000,KDIMEN=5000000)
53498 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53499 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53500 SAVE /PYJETS/,/PYDAT1/
53501 C...Local arrays and data.
53505 IF(MSTJ(55).EQ.0) THEN
53507 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
53508 & (P(I1,3)-P(I2,3))**2
53509 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
53510 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
53514 DA=SE*DE*DP12-DP2*DQ2SE
53515 DB=DP2*DQ2SE-DP12**2
53516 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
53518 PD=HA*(P(I1,J)-P(I2,J))
53530 DP(J)=P(I1,J)+P(I2,J)
53533 C...Boost to cms and rotate first particle to z-axis
53534 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
53535 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
53536 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
53537 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
53538 S=Q2NEW+(P(I1,5)+P(I2,5))**2
53539 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
53543 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
53547 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
53548 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
53549 CALL PYROBO(NI+1,NI+2,THE,PHI,
53550 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
53553 P(NI+1,J)=P(NI+1,J)-P(I1,J)
53554 P(NI+2,J)=P(NI+2,J)-P(I2,J)
53560 C*********************************************************************
53563 C...Gives the mass of a particle/parton.
53565 FUNCTION PYMASS(KF)
53567 C...Double precision and integer declarations.
53568 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53569 IMPLICIT INTEGER(I-N)
53570 INTEGER PYK,PYCHGE,PYCOMP
53572 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53573 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53574 SAVE /PYDAT1/,/PYDAT2/
53576 C...Reset variables. Compressed code. Special case for popcorn diquarks.
53585 C...Guarantee use of constituent masses for internal checks.
53586 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
53587 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
53589 PYMASS=PARF(100+KFA)
53590 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
53591 ELSEIF(KFA.LE.10) THEN
53593 ELSEIF(MSTJ(93).EQ.1) THEN
53594 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
53596 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
53599 C...Other masses can be read directly off table.
53604 C...Optional mass broadening according to truncated Breit-Wigner
53605 C...(either in m or in m^2).
53606 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
53607 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
53608 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
53609 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
53612 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
53613 & (PM0*PMAS(KC,2)))
53614 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
53615 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
53616 & (PMUPP-PMLOW)*PYR(0))))
53624 C*********************************************************************
53627 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
53628 C...for Higgs couplings. Everything else sent on to PYMASS.
53630 FUNCTION PYMRUN(KF,Q2)
53632 C...Double precision and integer declarations.
53633 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53634 IMPLICIT INTEGER(I-N)
53635 INTEGER PYK,PYCHGE,PYCOMP
53637 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53638 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53639 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53640 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
53642 C...Most masses not handled here.
53644 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
53647 C...Current-algebra masses, but no Q2 dependence.
53648 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
53649 PYMRUN=PARF(90+KFA)
53651 C...Running current-algebra masses.
53654 PYMRUN=PARF(90+KFA)*
53655 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
53656 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
53662 C*********************************************************************
53665 C...Gives the particle/parton name as a character string.
53667 SUBROUTINE PYNAME(KF,CHAU)
53669 C...Double precision and integer declarations.
53670 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53671 IMPLICIT INTEGER(I-N)
53672 INTEGER PYK,PYCHGE,PYCOMP
53674 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53675 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53676 COMMON/PYDAT4/CHAF(500,2)
53678 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
53679 C...Local character variable.
53682 C...Read out code with distinction particle/antiparticle.
53685 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
53691 C*********************************************************************
53694 C...Gives three times the charge for a particle/parton.
53696 FUNCTION PYCHGE(KF)
53698 C...Double precision and integer declarations.
53699 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53700 IMPLICIT INTEGER(I-N)
53701 INTEGER PYK,PYCHGE,PYCOMP
53703 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53706 C...Read out charge and change sign for antiparticle.
53709 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
53714 C*********************************************************************
53717 C...Compress the standard KF codes for use in mass and decay arrays;
53718 C...also checks whether a given code actually is defined.
53720 FUNCTION PYCOMP(KF)
53722 C...Double precision and integer declarations.
53723 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53724 IMPLICIT INTEGER(I-N)
53725 INTEGER PYK,PYCHGE,PYCOMP
53727 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53728 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53729 SAVE /PYDAT1/,/PYDAT2/
53730 C...Local arrays and saved data.
53731 DIMENSION KFORD(100:500),KCORD(101:500)
53732 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
53734 C...Whenever necessary reorder codes for faster search.
53735 IF(MSTU(20).EQ.0) THEN
53740 IF(KFA.LE.100) GOTO 120
53742 DO 100 I1=NFORD-1,0,-1
53743 IF(KFA.GE.KFORD(I1)) GOTO 110
53744 KFORD(I1+1)=KFORD(I1)
53745 KCORD(I1+1)=KCORD(I1)
53747 110 KFORD(I1+1)=KFA
53755 C...Fast action if same code as in latest call.
53756 IF(KF.EQ.KFLAST) THEN
53761 C...Starting values. Remove internal diquark flags.
53764 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
53765 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
53767 C...Simple cases: direct translation.
53768 IF(KFA.GT.KFORD(NFORD)) THEN
53769 ELSEIF(KFA.LE.100) THEN
53772 C...Else binary search.
53776 130 IAVG=(IMIN+IMAX)/2
53777 IF(KFORD(IAVG).GT.KFA) THEN
53779 IF(IMAX.GT.IMIN+1) GOTO 130
53780 ELSEIF(KFORD(IAVG).LT.KFA) THEN
53782 IF(IMAX.GT.IMIN+1) GOTO 130
53788 C...Check if antiparticle allowed.
53789 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
53790 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
53793 C...Save codes for possible future fast action.
53800 C*********************************************************************
53803 C...Informs user of errors in program execution.
53805 SUBROUTINE PYERRM(MERR,CHMESS)
53807 C...Double precision and integer declarations.
53808 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53809 IMPLICIT INTEGER(I-N)
53810 INTEGER PYK,PYCHGE,PYCOMP
53812 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53813 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53814 SAVE /PYJETS/,/PYDAT1/
53815 C...Local character variable.
53816 CHARACTER CHMESS*(*)
53818 C...Write first few warnings, then be silent.
53819 IF(MERR.LE.10) THEN
53820 MSTU(27)=MSTU(27)+1
53822 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
53823 & MERR,MSTU(31),CHMESS
53825 C...Write first few errors, then be silent or stop program.
53826 ELSEIF(MERR.LE.20) THEN
53827 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
53829 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
53830 & MERR-10,MSTU(31),CHMESS
53831 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
53832 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
53833 WRITE(MSTU(11),5200)
53834 IF(MERR.NE.17) CALL PYLIST(2)
53838 C...Stop program in case of irreparable error.
53840 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
53844 C...Formats for output.
53845 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
53846 &' PYEXEC calls:'/5X,A)
53847 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
53848 &' PYEXEC calls:'/5X,A)
53849 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
53851 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
53852 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
53857 C*********************************************************************
53860 C...Calculates the running alpha_electromagnetic.
53862 FUNCTION PYALEM(Q2)
53864 C...Double precision and integer declarations.
53865 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53866 IMPLICIT INTEGER(I-N)
53867 INTEGER PYK,PYCHGE,PYCOMP
53869 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53872 C...Calculate real part of photon vacuum polarization.
53873 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
53874 C...For hadrons use parametrization of H. Burkhardt et al.
53875 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
53876 AEMPI=PARU(101)/(3D0*PARU(1))
53877 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
53879 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
53881 ELSEIF(MSTU(101).EQ.2) THEN
53882 RPIGG=1D0-PARU(101)/PARU(103)
53883 ELSEIF(Q2.LT.0.09D0) THEN
53884 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
53885 ELSEIF(Q2.LT.9D0) THEN
53886 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
53887 & 0.00238D0*LOG(1D0+3.927D0*Q2)
53888 ELSEIF(Q2.LT.1D4) THEN
53889 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
53890 & 0.00299D0*LOG(1D0+Q2)
53892 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
53893 & 0.00293D0*LOG(1D0+Q2)
53896 C...Calculate running alpha_em.
53897 PYALEM=PARU(101)/(1D0-RPIGG)
53903 C*********************************************************************
53906 C...Gives the value of alpha_strong.
53908 FUNCTION PYALPS(Q2)
53910 C...Double precision and integer declarations.
53911 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53912 IMPLICIT INTEGER(I-N)
53913 INTEGER PYK,PYCHGE,PYCOMP
53915 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53916 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53917 SAVE /PYDAT1/,/PYDAT2/
53919 C...Constant alpha_strong trivial. Pick artificial Lambda.
53920 IF(MSTU(111).LE.0) THEN
53922 MSTU(118)=MSTU(112)
53924 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
53925 & ((33D0-2D0*MSTU(112))*PARU(111)))
53926 PARU(118)=PARU(111)
53930 C...Find effective Q2, number of flavours and Lambda.
53932 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
53935 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
53936 Q2THR=PARU(113)*PMAS(NF,1)**2
53937 IF(Q2EFF.LT.Q2THR) THEN
53939 ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF))
53943 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
53944 Q2THR=PARU(113)*PMAS(NF+1,1)**2
53945 IF(Q2EFF.GT.Q2THR) THEN
53947 ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF))
53951 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
53952 PARU(117)=SQRT(ALAM2)
53954 C...Evaluate first or second order alpha_strong.
53955 B0=(33D0-2D0*NF)/6D0
53956 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
53957 IF(MSTU(111).EQ.1) THEN
53958 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
53960 B1=(153D0-19D0*NF)/6D0
53961 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
53970 C*********************************************************************
53973 C...Reconstructs an angle from given x and y coordinates.
53975 FUNCTION PYANGL(X,Y)
53977 C...Double precision and integer declarations.
53978 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53979 IMPLICIT INTEGER(I-N)
53980 INTEGER PYK,PYCHGE,PYCOMP
53982 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53987 IF(R.LT.1D-20) RETURN
53988 IF(ABS(X)/R.LT.0.8D0) THEN
53989 PYANGL=SIGN(ACOS(X/R),Y)
53992 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
53993 PYANGL=PARU(1)-PYANGL
53994 ELSEIF(X.LT.0D0) THEN
53995 PYANGL=-PARU(1)-PYANGL
54002 C*********************************************************************
54005 C...Performs rotations and boosts.
54007 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
54009 C...Double precision and integer declarations.
54010 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54011 IMPLICIT INTEGER(I-N)
54012 INTEGER PYK,PYCHGE,PYCOMP
54014 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54015 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54016 SAVE /PYJETS/,/PYDAT1/
54018 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
54020 C...Find and check range of rotation/boost.
54022 IF(IMIN.LE.0) IMIN=1
54023 IF(MSTU(1).GT.0) IMIN=MSTU(1)
54025 IF(IMAX.LE.0) IMAX=N
54026 IF(MSTU(2).GT.0) IMAX=MSTU(2)
54027 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
54028 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
54032 C...Optional resetting of V (when not set before.)
54033 IF(MSTU(33).NE.0) THEN
54034 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
54042 C...Rotate, typically from z axis to direction (theta,phi).
54043 IF(THE**2+PHI**2.GT.1D-20) THEN
54044 ROT(1,1)=COS(THE)*COS(PHI)
54046 ROT(1,3)=SIN(THE)*COS(PHI)
54047 ROT(2,1)=COS(THE)*SIN(PHI)
54049 ROT(2,3)=SIN(THE)*SIN(PHI)
54054 IF(K(I,1).LE.0) GOTO 140
54060 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
54061 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
54066 C...Boost, typically from rest to momentum/energy=beta.
54067 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
54071 DB=SQRT(DBX**2+DBY**2+DBZ**2)
54073 IF(DB.GT.EPS1) THEN
54074 C...Rescale boost vector if too close to unity.
54075 CALL PYERRM(3,'(PYROBO:) boost vector too large')
54081 DGA=1D0/SQRT(1D0-DB**2)
54083 IF(K(I,1).LE.0) GOTO 160
54088 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
54089 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
54090 P(I,1)=DP(1)+DGABP*DBX
54091 P(I,2)=DP(2)+DGABP*DBY
54092 P(I,3)=DP(3)+DGABP*DBZ
54093 P(I,4)=DGA*(DP(4)+DBP)
54094 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
54095 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
54096 V(I,1)=DV(1)+DGABV*DBX
54097 V(I,2)=DV(2)+DGABV*DBY
54098 V(I,3)=DV(3)+DGABV*DBZ
54099 V(I,4)=DGA*(DV(4)+DBV)
54106 C*********************************************************************
54109 C...Performs global manipulations on the event record, in particular
54110 C...to exclude unstable or undetectable partons/particles.
54112 SUBROUTINE PYEDIT(MEDIT)
54114 C...Double precision and integer declarations.
54115 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54116 IMPLICIT INTEGER(I-N)
54117 INTEGER PYK,PYCHGE,PYCOMP
54119 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54120 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54121 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54122 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
54124 DIMENSION NS(2),PTS(2),PLS(2)
54126 C...Remove unwanted partons/particles.
54127 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
54129 IF(MSTU(2).GT.0) IMAX=MSTU(2)
54130 I1=MAX(1,MSTU(1))-1
54131 DO 110 I=MAX(1,MSTU(1)),IMAX
54132 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
54133 IF(MEDIT.EQ.1) THEN
54134 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
54135 ELSEIF(MEDIT.EQ.2) THEN
54136 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
54138 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
54140 ELSEIF(MEDIT.EQ.3) THEN
54141 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
54143 IF(KC.EQ.0) GOTO 110
54144 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
54145 ELSEIF(MEDIT.EQ.5) THEN
54146 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
54148 IF(KC.EQ.0) GOTO 110
54149 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
54150 & KCHG(KC,2).EQ.0) GOTO 110
54153 C...Pack remaining partons/particles. Origin no longer known.
54162 IF(I1.LT.N) MSTU(3)=0
54163 IF(I1.LT.N) MSTU(70)=0
54166 C...Selective removal of class of entries. New position of retained.
54167 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
54170 K(I,3)=MOD(K(I,3),MSTU(5))
54171 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
54172 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
54173 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
54174 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
54175 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
54176 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
54177 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
54179 K(I,3)=K(I,3)+MSTU(5)*I1
54182 C...Find new event history information and replace old.
54184 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
54185 & K(I,3)/MSTU(5).EQ.0) GOTO 140
54187 130 IM=MOD(K(ID,3),MSTU(5))
54188 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
54189 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
54190 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
54194 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
54195 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
54196 & K(IM,2).EQ.94) THEN
54201 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
54202 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
54203 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
54204 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
54205 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
54206 & K(K(I,4),3)/MSTU(5)
54207 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
54208 & K(K(I,5),3)/MSTU(5)
54210 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
54211 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
54212 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
54213 KCD=MOD(K(I,4),MSTU(5))
54214 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
54215 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
54216 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
54217 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
54218 KCD=MOD(K(I,5),MSTU(5))
54219 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
54220 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
54224 C...Pack remaining entries.
54229 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
54236 K(I1,3)=MOD(K(I1,3),MSTU(5))
54238 IF(I.EQ.MSTU(90+IZ)) THEN
54239 MSTU(90)=MSTU(90)+1
54240 MSTU(90+MSTU(90))=I1
54241 PARU(90+MSTU(90))=PARU(90+IZ)
54245 IF(I1.LT.N) MSTU(3)=0
54246 IF(I1.LT.N) MSTU(70)=0
54249 C...Fill in some missing daughter pointers (lost in colour flow).
54250 ELSEIF(MEDIT.EQ.16) THEN
54252 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
54253 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
54254 C...Find daughters who point to mother.
54256 IF(K(I1,3).NE.I) THEN
54257 ELSEIF(K(I,4).EQ.0) THEN
54263 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
54264 IF(K(I,4).NE.0) GOTO 220
54265 C...Find daughters who point to documentation version of mother.
54267 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
54268 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
54269 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
54271 IF(K(I1,3).NE.IM) THEN
54272 ELSEIF(K(I,4).EQ.0) THEN
54278 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
54279 IF(K(I,4).NE.0) GOTO 220
54280 C...Find daughters who point to documentation daughters who,
54281 C...in their turn, point to documentation mother.
54285 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
54287 IF(ID1.EQ.IM) ID1=I1
54291 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
54292 ELSEIF(K(I,4).EQ.0) THEN
54298 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
54301 C...Save top entries at bottom of PYJETS commonblock.
54302 ELSEIF(MEDIT.EQ.21) THEN
54303 IF(2*N.GE.MSTU(4)) THEN
54304 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
54309 K(MSTU(4)-I,J)=K(I,J)
54310 P(MSTU(4)-I,J)=P(I,J)
54311 V(MSTU(4)-I,J)=V(I,J)
54316 C...Restore bottom entries of commonblock PYJETS to top.
54317 ELSEIF(MEDIT.EQ.22) THEN
54318 DO 260 I=1,MSTU(32)
54320 K(I,J)=K(MSTU(4)-I,J)
54321 P(I,J)=P(MSTU(4)-I,J)
54322 V(I,J)=V(MSTU(4)-I,J)
54327 C...Mark primary entries at top of commonblock PYJETS as untreated.
54328 ELSEIF(MEDIT.EQ.23) THEN
54333 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
54335 IF(KH.NE.0) GOTO 280
54337 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
54338 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
54342 C...Place largest axis along z axis and second largest in xy plane.
54343 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
54344 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
54345 & P(MSTU(61),2)),0D0,0D0,0D0)
54346 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
54347 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
54348 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
54349 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
54350 IF(MEDIT.EQ.31) RETURN
54352 C...Rotate to put slim jet along +z axis.
54359 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
54360 IF(MSTU(41).GE.2) THEN
54362 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
54363 & KC.EQ.18) GOTO 300
54364 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
54367 IS=2D0-SIGN(0.5D0,P(I,3))
54369 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
54371 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
54372 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
54374 C...Rotate to put second largest jet into -z,+x quadrant.
54376 IF(P(I,3).GE.0D0) GOTO 310
54377 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
54378 IF(MSTU(41).GE.2) THEN
54380 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
54381 & KC.EQ.18) GOTO 310
54382 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
54385 IS=2D0-SIGN(0.5D0,P(I,1))
54386 PLS(IS)=PLS(IS)-P(I,3)
54388 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
54395 C*********************************************************************
54398 C...Gives program heading, or lists an event, or particle
54399 C...data, or current parameter values.
54401 SUBROUTINE PYLIST(MLIST)
54403 C...Double precision and integer declarations.
54404 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54405 IMPLICIT INTEGER(I-N)
54406 INTEGER PYK,PYCHGE,PYCOMP
54407 C...Parameter statement to help give large particle numbers.
54408 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54409 &KEXCIT=4000000,KDIMEN=5000000)
54411 C...HEPEVT commonblock.
54412 PARAMETER (NMXHEP=4000)
54413 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
54414 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
54415 DOUBLE PRECISION PHEP,VHEP
54418 C...User process event common block.
54420 PARAMETER (MAXNUP=500)
54421 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
54422 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
54423 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
54424 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
54425 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
54429 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54430 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54431 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54432 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54433 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
54434 C...Local arrays, character variables and data.
54435 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
54437 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
54439 C...Initialization printout: version number and date of last change.
54440 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
54443 IF(MLIST.EQ.0) RETURN
54446 C...List event data, including additional lines after N.
54447 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
54448 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
54449 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
54450 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
54452 IF(MLIST.GE.2) LMX=16
54455 IF(MSTU(2).GT.0) IMAX=MSTU(2)
54456 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
54457 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
54458 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
54459 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
54461 C...Get particle name, pad it and check it is not too long.
54462 CALL PYNAME(K(I,2),CHAP)
54465 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
54469 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
54471 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
54474 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
54476 CHAC=CHDL(MDL)(1:2*LDL)//' '
54478 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
54479 & CHDL(MDL)(LDL+1:2*LDL)//' '
54480 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
54484 C...Add information on string connection.
54485 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
54489 IF(KC.NE.0) KCC=KCHG(KC,2)
54490 IF(IABS(K(I,2)).EQ.39) THEN
54491 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
54492 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
54494 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
54495 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
54496 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
54497 ELSEIF(KCC.NE.0) THEN
54499 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
54502 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
54503 & CHAC(LMX-1:LMX-1)='I'
54505 C...Write data for particle/jet.
54506 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
54507 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
54509 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
54510 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
54512 ELSEIF(MLIST.EQ.1) THEN
54513 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
54515 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
54516 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
54517 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
54518 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
54519 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
54522 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),
54525 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
54527 C...Insert extra separator lines specified by user.
54528 IF(MSTU(70).GE.1) THEN
54530 DO 110 J=1,MIN(10,MSTU(70))
54531 IF(I.EQ.MSTU(70+J)) ISEP=1
54533 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
54534 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
54538 C...Sum of charges and momenta.
54542 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
54543 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
54544 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
54545 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
54546 ELSEIF(MLIST.EQ.1) THEN
54547 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
54549 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
54552 C...Simple listing of HEPEVT entries (mainly for test purposes).
54553 ELSEIF(MLIST.EQ.5) THEN
54554 WRITE(MSTU(11),7500)
54556 IF(ISTHEP(I).EQ.0) GOTO 140
54557 WRITE(MSTU(11),7600) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
54558 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
54562 C...Simple listing of user-process entries (mainly for test purposes).
54563 ELSEIF(MLIST.EQ.7) THEN
54564 WRITE(MSTU(11),7300)
54566 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
54567 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
54570 C...Give simple list of KF codes defined in program.
54571 ELSEIF(MLIST.EQ.11) THEN
54572 WRITE(MSTU(11),6600)
54574 CALL PYNAME(KF,CHAP)
54575 CALL PYNAME(-KF,CHAN)
54576 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
54577 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54581 DO 170 KFLB=1,KFLA-(3-KFLS)/2
54582 KF=1000*KFLA+100*KFLB+KFLS
54583 CALL PYNAME(KF,CHAP)
54584 CALL PYNAME(-KF,CHAN)
54585 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54591 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
54592 IF(KMUL.EQ.5) KFLS=5
54594 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
54595 IF(KMUL.EQ.4) KFLR=2
54597 DO 200 KFLC=1,KFLB-1
54598 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
54599 CALL PYNAME(KF,CHAP)
54600 CALL PYNAME(-KF,CHAN)
54601 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54604 CALL PYNAME(KFK,CHAP)
54605 WRITE(MSTU(11),6700) KFK,CHAP
54607 CALL PYNAME(KFK,CHAP)
54608 WRITE(MSTU(11),6700) KFK,CHAP
54611 KF=10000*KFLR+110*KFLB+KFLS
54612 CALL PYNAME(KF,CHAP)
54613 WRITE(MSTU(11),6700) KF,CHAP
54617 CALL PYNAME(KF,CHAP)
54618 WRITE(MSTU(11),6700) KF,CHAP
54620 CALL PYNAME(KF,CHAP)
54621 WRITE(MSTU(11),6700) KF,CHAP
54627 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
54629 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
54630 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
54631 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
54632 CALL PYNAME(KF,CHAP)
54633 CALL PYNAME(-KF,CHAN)
54634 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54641 IF(KF.LT.1000000) GOTO 270
54642 CALL PYNAME(KF,CHAP)
54643 CALL PYNAME(-KF,CHAN)
54644 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
54645 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
54648 C...List parton/particle data table. Check whether to be listed.
54649 ELSEIF(MLIST.EQ.12) THEN
54650 WRITE(MSTU(11),6800)
54651 DO 300 KC=1,MSTU(6)
54653 IF(KF.EQ.0) GOTO 300
54654 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
54657 C...Find particle name and mass. Print information.
54658 CALL PYNAME(KF,CHAP)
54659 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
54660 CALL PYNAME(-KF,CHAN)
54661 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
54662 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
54664 C...Particle decay: channel number, branching ratios, matrix element,
54665 C...decay products.
54666 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
54668 CALL PYNAME(KFDP(IDC,J),CHAD(J))
54670 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
54675 C...List parameter value table.
54676 ELSEIF(MLIST.EQ.13) THEN
54677 WRITE(MSTU(11),7100)
54679 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
54683 C...Format statements for output on unit MSTU(11) (by default 6).
54684 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
54685 &5X,'KF orig p_x p_y p_z E m'/)
54686 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
54687 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
54688 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
54689 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
54690 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
54691 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
54692 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
54693 5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
54694 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
54695 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
54696 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
54697 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
54698 5900 FORMAT(66X,5(1X,F12.3))
54699 6000 FORMAT(1X,78('='))
54700 6100 FORMAT(1X,130('='))
54701 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
54702 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
54703 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
54704 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
54706 6600 FORMAT(///20X,'List of KF codes in program'/)
54707 6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
54708 6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
54709 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
54710 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
54711 &1X,'ME',3X,'Br.rat.',4X,'decay products')
54712 6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
54713 &1X,1P,E13.5,3X,I2)
54714 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
54715 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
54716 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
54717 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
54718 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
54719 &//' I IST ID Mothers Colours p_x p_y p_z',
54721 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
54722 7500 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
54723 &//' I IST ID Mothers Daughters p_x p_y p_z',
54725 7600 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
54730 C*********************************************************************
54733 C...Writes a logo for the program.
54737 C...Double precision and integer declarations.
54738 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54739 IMPLICIT INTEGER(I-N)
54740 INTEGER PYK,PYCHGE,PYCOMP
54741 C...Parameter for length of information block.
54742 PARAMETER (IREFER=24)
54744 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54745 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54746 SAVE /PYDAT1/,/PYPARS/
54747 C...Local arrays and character variables.
54749 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
54750 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
54752 C...Data on months, logo, titles, and references.
54753 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
54754 &'Oct','Nov','Dec'/
54755 DATA (LOGO(J),J=1,19)/
54757 &' *:::!!:::::::::::* ',
54758 &' *::::::!!::::::::::::::* ',
54759 &' *::::::::!!::::::::::::::::* ',
54760 &' *:::::::::!!:::::::::::::::::* ',
54761 &' *:::::::::!!:::::::::::::::::* ',
54762 &' *::::::::!!::::::::::::::::*! ',
54763 &' *::::::!!::::::::::::::* !! ',
54764 &' !! *:::!!:::::::::::* !! ',
54765 &' !! !* -><- * !! ',
54775 DATA (LOGO(J),J=20,38)/
54776 &'Welcome to the Lund Monte Carlo!',
54778 &'PPP Y Y TTTTT H H III A ',
54779 &'P P Y Y T H H I A A ',
54780 &'PPP Y T HHHHH I AAAAA',
54781 &'P Y T H H I A A',
54782 &'P Y T H H III A A',
54784 &'This is PYTHIA version x.xxx ',
54785 &'Last date of change: xx xxx 199x',
54787 &'Now is xx xxx 199x at xx:xx:xx ',
54789 &'Disclaimer: this program comes ',
54790 &'without any guarantees. Beware ',
54791 &'of errors and use common sense ',
54792 &'when interpreting results. ',
54794 &'Copyright T. Sjostrand (2003) '/
54795 DATA (REFER(J),J=1,18)/
54796 &'An archive of program versions and d',
54797 &'ocumentation is found on the web: ',
54798 &'http://www.thep.lu.se/~torbjorn/Pyth',
54802 &'When you cite this program, currentl',
54803 &'y the official reference is ',
54804 &'T. Sjostrand, P. Eden, C. Friberg, L',
54805 &'. Lonnblad, G. Miu, S. Mrenna and ',
54806 &'E. Norrbin, Computer Physics Commun.',
54807 &' 135 (2001) 238. ',
54808 &'The large manual is ',
54810 &'T. Sjostrand, L. Lonnblad and S. Mre',
54811 &'nna, LU TP 01-21 [hep-ph/0108264]. ',
54812 &'Also remember that the program, to a',
54813 &' large extent, represents original '/
54814 DATA (REFER(J),J=19,36)/
54815 &'physics research. Other publications',
54816 &' of special relevance to your ',
54817 &'studies may therefore deserve separa',
54821 &'Main author: Torbjorn Sjostrand; Dep',
54822 &'artment of Theoretical Physics 2, ',
54823 &' Lund University, Solvegatan 14A, S',
54824 &'-223 62 Lund, Sweden; ',
54825 &' phone: + 46 - 46 - 222 48 16; e-ma',
54826 &'il: torbjorn@thep.lu.se ',
54827 &'Author: Leif Lonnblad; Department of',
54828 &' Theoretical Physics 2, ',
54829 &' Lund University, Solvegatan 14A, S',
54830 &'-223 62 Lund, Sweden; ',
54831 &' phone: + 46 - 46 - 222 77 80; e-ma',
54832 &'il: leif@thep.lu.se '/
54833 DATA (REFER(J),J=37,2*IREFER)/
54834 &'Author: Stephen Mrenna; Computing Di',
54835 &'vision, Simulations Group, ',
54836 &' Fermi National Accelerator Laborat',
54837 &'ory, MS 234, Batavia, IL 60510, USA;',
54838 &' phone: + 1 - 630 - 840 - 2556; e-m',
54839 &'ail: mrenna@fnal.gov ',
54840 &'Author: Peter Skands; Department of ',
54841 &'Theoretical Physics 2, ',
54842 &' Lund University, Solvegatan 14A, S',
54843 &'-223 62 Lund, Sweden; ',
54844 &' phone: + 46 - 46 - 222 31 92; e-ma',
54845 &'il: zeiler@thep.lu.se '/
54847 C...Check that PYDATA linked.
54848 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
54850 & 'Error: PYDATA has not been linked.'
54851 WRITE(*,'(1X,A)') 'Execution stopped!'
54854 C...Write current version number and current date+time.
54856 WRITE(VERS,'(I1)') MSTP(181)
54857 LOGO(28)(24:24)=VERS
54858 WRITE(SUBV,'(I3)') MSTP(182)
54859 LOGO(28)(26:28)=SUBV
54860 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
54861 WRITE(DATE,'(I2)') MSTP(185)
54862 LOGO(29)(22:23)=DATE
54863 LOGO(29)(25:27)=MONTH(MSTP(184))
54864 WRITE(YEAR,'(I4)') MSTP(183)
54865 LOGO(29)(29:32)=YEAR
54867 IF(IDATI(1).LE.0) THEN
54870 WRITE(DATE,'(I2)') IDATI(3)
54872 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
54873 WRITE(YEAR,'(I4)') IDATI(1)
54874 LOGO(31)(15:18)=YEAR
54875 WRITE(HOUR,'(I2)') IDATI(4)
54876 LOGO(31)(23:24)=HOUR
54877 WRITE(MINU,'(I2)') IDATI(5)
54878 LOGO(31)(26:27)=MINU
54879 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
54880 WRITE(SECO,'(I2)') IDATI(6)
54881 LOGO(31)(29:30)=SECO
54882 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
54886 C...Loop over lines in header. Define page feed and side borders.
54887 DO 100 ILIN=1,29+IREFER
54896 C...Separator lines and logos.
54897 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
54898 LINE(4:77)='***********************************************'//
54899 & '***************************'
54900 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
54901 LINE(6:37)=LOGO(ILIN-5)
54902 LINE(44:75)=LOGO(ILIN+14)
54903 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
54904 LINE(5:40)=REFER(2*ILIN-51)
54905 LINE(41:76)=REFER(2*ILIN-50)
54908 C...Write lines to appropriate unit.
54909 WRITE(MSTU(11),'(A79)') LINE
54915 C*********************************************************************
54918 C...Facilitates the updating of particle and decay data
54919 C...by allowing it to be done in an external file.
54921 SUBROUTINE PYUPDA(MUPDA,LFN)
54923 C...Double precision and integer declarations.
54924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54925 IMPLICIT INTEGER(I-N)
54926 INTEGER PYK,PYCHGE,PYCOMP
54928 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54929 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54930 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54931 COMMON/PYDAT4/CHAF(500,2)
54933 COMMON/PYINT4/MWID(500),WIDS(500,5)
54934 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
54935 C...Local arrays, character variables and data.
54936 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
54937 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
54938 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
54939 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
54940 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
54941 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
54942 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
54944 C...Write header if not yet done.
54945 IF(MSTU(12).GE.1) CALL PYLIST(0)
54947 C...Write information on file for editing.
54948 IF(MUPDA.EQ.1) THEN
54950 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
54951 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
54952 & MWID(KC),MDCY(KC,1)
54953 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
54954 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
54955 & (KFDP(IDC,J),J=1,5)
54959 C...Read complete set of information from edited file or
54960 C...read partial set of new or updated information from edited file.
54961 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
54963 C...Reset counters.
54967 IF(MUPDA.EQ.2) THEN
54972 DO 130 KC=1,MSTU(6)
54973 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
54974 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
54978 C...Begin of loop: read new line; unknown whether particle or
54980 140 READ(LFN,5200,END=190) CHINL
54982 C...Identify particle code and whether already defined (for MUPDA=3).
54983 IF(CHINL(2:10).NE.' ') THEN
54986 IF(MUPDA.EQ.2) THEN
54999 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
55002 C...Remove duplicate old decay data.
55003 IF(KCREP.NE.0) THEN
55004 IF(MDCY(KCREP,3).GT.0) THEN
55005 IDCREP=MDCY(KCREP,2)
55006 NDCREP=MDCY(KCREP,3)
55008 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
55010 DO 180 I=IDCREP,NDC-NDCREP
55011 MDME(I,1)=MDME(I+NDCREP,1)
55012 MDME(I,2)=MDME(I+NDCREP,2)
55013 BRAT(I)=BRAT(I+NDCREP)
55015 KFDP(I,J)=KFDP(I+NDCREP,J)
55029 C...Study line with particle data.
55030 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
55031 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
55032 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
55033 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
55034 & MWID(KC),MDCY(KC,1)
55038 C...Study line with decay data.
55041 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
55042 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
55043 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
55044 MDCY(KC,3)=MDCY(KC,3)+1
55045 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
55046 & (KFDP(NDC,J),J=1,5)
55049 C...End of loop; ensure that PYCOMP tables are updated.
55054 C...Perform possible tests that new information is consistent.
55055 DO 220 KC=1,MSTU(6)
55057 IF(KF.EQ.0) GOTO 220
55058 WRITE(CHKF,5300) KF
55059 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
55060 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
55061 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
55063 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
55064 IF(MDME(IDC,2).GT.80) GOTO 210
55066 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
55070 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
55072 ELSEIF(PYCOMP(KP).EQ.0) THEN
55077 PMS=PMS-PMAS(KPC,1)
55078 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
55082 IF(KQ.NE.0) MERR=MAX(2,MERR)
55083 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
55085 IF(MERR.EQ.3) CALL PYERRM(17,
55086 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
55087 IF(MERR.EQ.2) CALL PYERRM(17,
55088 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
55089 IF(MERR.EQ.1) CALL PYERRM(7,
55090 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
55091 BRSUM=BRSUM+BRAT(IDC)
55093 WRITE(CHTMP,5500) BRSUM
55094 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
55095 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
55096 & CHTMP(9:16)//' for KF ='//CHKF)
55099 C...Write DATA statements for inclusion in program.
55100 ELSEIF(MUPDA.EQ.4) THEN
55102 C...Find out how many codes and decay channels are actually used.
55106 IF(KCHG(I,4).NE.0) THEN
55108 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
55112 C...Initialize writing of DATA statements for inclusion in program.
55115 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
55118 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
55122 C...Loop through variables for conversion to characters.
55124 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
55125 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
55126 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
55127 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
55128 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
55129 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
55130 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
55131 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
55132 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
55133 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
55134 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
55135 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
55136 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
55137 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
55138 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
55139 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
55140 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
55141 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
55142 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
55143 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
55144 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
55145 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
55147 C...Replace variables beyond what is properly defined.
55149 IF(IDIM.GT.KCC) CHTMP=' 0'
55150 ELSEIF(IVAR.LE.8) THEN
55151 IF(IDIM.GT.KCC) CHTMP=' 0.0'
55152 ELSEIF(IVAR.LE.11) THEN
55153 IF(IDIM.GT.KCC) CHTMP=' 0'
55154 ELSEIF(IVAR.LE.13) THEN
55155 IF(IDIM.GT.NDC) CHTMP=' 0'
55156 ELSEIF(IVAR.LE.14) THEN
55157 IF(IDIM.GT.NDC) CHTMP=' 0.0'
55158 ELSEIF(IVAR.LE.19) THEN
55159 IF(IDIM.GT.NDC) CHTMP=' 0'
55160 ELSEIF(IVAR.LE.21) THEN
55161 IF(IDIM.GT.KCC) CHTMP=' '
55163 IF(IDIM.GT.KCC) CHTMP=' 0'
55166 C...Length of variable, trailing decimal zeros, quotation marks.
55170 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
55171 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
55173 CHNEW=CHTMP(LLOW:LHIG)//' '
55175 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
55178 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
55179 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
55184 CHNEW(LNEW+1:LNEW+2)='D0'
55187 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
55188 DO 260 LL=LNEW,1,-1
55189 IF(CHNEW(LL:LL).EQ.'''') THEN
55191 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
55197 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
55201 C...Form composite character string, often including repetition counter.
55202 IF(CHNEW.NE.CHOLD) THEN
55209 IF(NRPT.GE.2) LRPT=LNEW+3
55210 IF(NRPT.GE.10) LRPT=LNEW+4
55211 IF(NRPT.GE.100) LRPT=LNEW+5
55212 IF(NRPT.GE.1000) LRPT=LNEW+6
55215 WRITE(CHTMP,5400) NRPT
55217 IF(NRPT.GE.10) LRPT=2
55218 IF(NRPT.GE.100) LRPT=3
55219 IF(NRPT.GE.1000) LRPT=4
55220 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
55224 C...Add characters to end of line, to new line (after storing old line),
55225 C...or to new block of lines (after writing old block).
55226 IF(LLIN+LCOM.LE.70) THEN
55227 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
55229 ELSEIF(NLIN.LE.19) THEN
55230 CHLIN(LLIN+1:72)=' '
55233 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
55236 CHLIN(LLIN:72)='/'//' '
55238 WRITE(CHTMP,5400) IDIM-NRPT
55239 CHBLK(1)(30:33)=CHTMP(13:16)
55241 WRITE(LFN,5700) CHBLK(ILIN)
55245 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
55246 & ',I= , )/'//CHCOM(1:LCOM)//','
55247 WRITE(CHTMP,5400) IDIM-NRPT+1
55248 CHLIN(25:28)=CHTMP(13:16)
55253 C...Write final block of lines.
55254 CHLIN(LLIN:72)='/'//' '
55256 WRITE(CHTMP,5400) NDIM
55257 CHBLK(1)(30:33)=CHTMP(13:16)
55259 WRITE(LFN,5700) CHBLK(ILIN)
55264 C...Formats for reading and writing particle data.
55265 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
55266 5100 FORMAT(10X,2I5,F12.6,5I10)
55277 C*********************************************************************
55280 C...Provides various integer-valued event related data.
55284 C...Double precision and integer declarations.
55285 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55286 IMPLICIT INTEGER(I-N)
55287 INTEGER PYK,PYCHGE,PYCOMP
55289 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55290 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55291 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55292 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55294 C...Default value. For I=0 number of entries, number of stable entries
55295 C...or 3 times total charge.
55297 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
55298 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
55300 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
55302 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
55303 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
55306 ELSEIF(I.EQ.0) THEN
55308 C...For I > 0 direct readout of K matrix or charge.
55309 ELSEIF(J.LE.5) THEN
55311 ELSEIF(J.EQ.6) THEN
55314 C...Status (existing/fragmented/decayed), parton/hadron separation.
55315 ELSEIF(J.LE.8) THEN
55316 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
55317 IF(J.EQ.8) PYK=PYK*K(I,2)
55318 ELSEIF(J.LE.12) THEN
55322 IF(KC.NE.0) KQ=KCHG(KC,2)
55323 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
55324 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
55326 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
55328 C...Heaviest flavour in hadron/diquark.
55329 ELSEIF(J.EQ.13) THEN
55331 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
55332 IF(KFA.LT.10) PYK=KFA
55333 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
55334 PYK=PYK*ISIGN(1,K(I,2))
55336 C...Particle history: generation, ancestor, rank.
55337 ELSEIF(J.LE.15) THEN
55344 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
55347 ELSEIF(J.EQ.16) THEN
55349 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
55350 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
55357 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
55358 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
55360 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
55361 IF(ILP.EQ.1) GOTO 120
55363 IF(K(I1,1).EQ.12) THEN
55365 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
55366 & .AND.K(I3,2).NE.93) PYK=PYK+1
55372 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
55376 C...Particle coming from collapsing jet system or not.
55377 ELSEIF(J.EQ.17) THEN
55384 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
55385 IF(PYK.EQ.1) PYK=-1
55389 IF(KCHG(KC,2).EQ.0) GOTO 150
55390 IF(K(I1,1).NE.12) PYK=0
55391 IF(K(I1,1).NE.12) RETURN
55394 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
55396 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
55398 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
55400 C...Number of decay products. Colour flow.
55401 ELSEIF(J.EQ.18) THEN
55402 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
55403 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
55404 ELSEIF(J.LE.22) THEN
55405 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
55406 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
55407 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
55408 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
55409 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
55416 C*********************************************************************
55419 C...Provides various real-valued event related data.
55423 C...Double precision and integer declarations.
55424 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55425 IMPLICIT INTEGER(I-N)
55426 INTEGER PYK,PYCHGE,PYCOMP
55428 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55429 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55430 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55431 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55435 C...Set default value. For I = 0 sum of momenta or charges,
55436 C...or invariant mass of system.
55438 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
55439 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
55441 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
55443 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
55447 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
55451 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
55452 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
55454 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
55456 ELSEIF(I.EQ.0) THEN
55458 C...Direct readout of P matrix.
55459 ELSEIF(J.LE.5) THEN
55462 C...Charge, total momentum, transverse momentum, transverse mass.
55463 ELSEIF(J.LE.12) THEN
55464 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
55465 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
55466 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
55467 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
55468 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
55470 C...Theta and phi angle in radians or degrees.
55471 ELSEIF(J.LE.16) THEN
55472 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
55473 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
55474 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
55476 C...True rapidity, rapidity with pion mass, pseudorapidity.
55477 ELSEIF(J.LE.19) THEN
55479 IF(J.EQ.17) PMR=P(I,5)
55480 IF(J.EQ.18) PMR=PYMASS(211)
55481 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
55482 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
55485 C...Energy and momentum fractions (only to be used in CM frame).
55486 ELSEIF(J.LE.25) THEN
55487 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
55488 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
55489 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
55490 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
55491 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
55492 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
55498 C*********************************************************************
55501 C...Performs sphericity tensor analysis to give sphericity,
55502 C...aplanarity and the related event axes.
55504 SUBROUTINE PYSPHE(SPH,APL)
55506 C...Double precision and integer declarations.
55507 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55508 IMPLICIT INTEGER(I-N)
55509 INTEGER PYK,PYCHGE,PYCOMP
55511 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55512 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55513 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55514 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55516 DIMENSION SM(3,3),SV(3,3)
55518 C...Calculate matrix to be diagonalized.
55527 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
55528 IF(MSTU(41).GE.2) THEN
55530 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
55531 & KC.EQ.18) GOTO 140
55532 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
55536 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55538 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
55539 & MAX(1D-10,PA)**(PARU(41)-2D0)
55542 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
55548 C...Very low multiplicities (0 or 1) not considered.
55550 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
55557 SM(J1,J2)=SM(J1,J2)/PS
55561 C...Find eigenvalues to matrix (third degree equation).
55562 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
55563 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
55564 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
55565 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
55566 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
55567 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
55568 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
55569 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
55570 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
55571 IF(P(N+2,4).LT.1D-5) THEN
55572 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
55578 C...Find first and last eigenvector by solving equation system.
55581 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
55583 SV(J1,J2)=SM(J1,J2)
55584 SV(J2,J1)=SM(J1,J2)
55590 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
55593 SMAX=ABS(SV(J1,J2))
55597 DO 220 J3=JA+1,JA+2
55599 RL=SV(J1,JB)/SV(JA,JB)
55601 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
55602 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
55604 SMAX=ABS(SV(J1,J2))
55608 JB2=JB+2-3*((JB+1)/3)
55609 P(N+I,JB1)=-SV(JC,JB2)
55610 P(N+I,JB2)=SV(JC,JB1)
55611 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
55613 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
55614 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55616 P(N+I,J)=SGN*P(N+I,J)/PA
55620 C...Middle axis orthogonal to other two. Fill other codes.
55621 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55622 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
55623 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
55624 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
55637 C...Calculate sphericity and aplanarity. Select storing option.
55638 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
55642 IF(MSTU(43).LE.1) MSTU(3)=3
55643 IF(MSTU(43).GE.2) N=N+3
55648 C*********************************************************************
55651 C...Performs thrust analysis to give thrust, oblateness
55652 C...and the related event axes.
55654 SUBROUTINE PYTHRU(THR,OBL)
55656 C...Double precision and integer declarations.
55657 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55658 IMPLICIT INTEGER(I-N)
55659 INTEGER PYK,PYCHGE,PYCOMP
55661 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55662 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55663 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55664 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55666 DIMENSION TDI(3),TPR(3)
55668 C...Take copy of particles that are to be considered in thrust analysis.
55672 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
55673 IF(MSTU(41).GE.2) THEN
55675 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
55676 & KC.EQ.18) GOTO 100
55677 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
55680 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
55681 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
55691 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55693 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
55694 & P(N+NP,4)**(PARU(42)-1D0)
55695 PS=PS+P(N+NP,4)*P(N+NP,5)
55698 C...Very low multiplicities (0 or 1) not considered.
55700 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
55706 C...Loop over thrust and major. T axis along z direction in latter case.
55710 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
55712 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
55713 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
55714 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
55717 C...Find and order particles with highest p (pT for major).
55718 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
55722 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
55723 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
55724 IF(P(I,4).LE.P(ILF,4)) GOTO 140
55726 P(ILF+1,J)=P(ILF,J)
55735 C...Find and order initial axes with highest thrust (major).
55736 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
55739 NC=2**(MIN(MSTU(44),NP)-1)
55744 DO 200 ILF=1,MIN(MSTU(44),NP)
55745 SGN=P(N+NP+ILF+3,5)
55746 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
55748 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
55751 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
55752 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
55753 IF(TDS.LE.P(ILG,4)) GOTO 230
55755 P(ILG+1,J)=P(ILG,J)
55758 ILG=N+NP+MSTU(44)+4
55765 C...Iterate direction of axis until stable maximum.
55772 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
55773 IF(THP.GT.1D-10) TDI(J)=TPR(J)
55777 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
55779 TPR(J)=TPR(J)+SGN*P(I,J)
55782 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
55783 IF(THP.GE.THPS+PARU(48)) GOTO 270
55785 C...Save good axis. Try new initial axis until a number of tries agree.
55786 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
55787 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
55789 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55791 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
55797 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
55800 C...Find minor axis and value by orthogonality.
55801 SGN=(-1D0)**INT(PYR(0)+0.5D0)
55802 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
55803 P(N+NP+3,2)=SGN*P(N+NP+2,1)
55807 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
55812 C...Fill axis information. Rotate back to original coordinate system.
55820 P(N+ILD,J)=P(N+NP+ILD,J)
55824 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
55826 C...Calculate thrust and oblateness. Select storing option.
55828 OBL=P(N+2,4)-P(N+3,4)
55831 IF(MSTU(43).LE.1) MSTU(3)=3
55832 IF(MSTU(43).GE.2) N=N+3
55837 C*********************************************************************
55840 C...Subdivides the particle content of an event into jets/clusters.
55842 SUBROUTINE PYCLUS(NJET)
55844 C...Double precision and integer declarations.
55845 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55846 IMPLICIT INTEGER(I-N)
55847 INTEGER PYK,PYCHGE,PYCOMP
55849 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55850 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55851 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55852 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55853 C...Local arrays and saved variables.
55855 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
55857 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
55858 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
55859 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
55860 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
55861 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
55862 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
55863 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
55865 C...If first time, reset. If reentering, skip preliminaries.
55866 IF(MSTU(48).LE.0) THEN
55872 PIMASS=PMAS(PYCOMP(211),1)
55875 IF(MSTU(43).GE.2) N=N-NJET
55876 DO 110 I=N+1,N+NJET
55877 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55879 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
55882 R2ACC=PARU(45)*PS(5)**2
55888 C...Find which particles are to be considered in cluster search.
55890 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
55891 IF(MSTU(41).GE.2) THEN
55893 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
55894 & KC.EQ.18) GOTO 140
55895 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
55898 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
55899 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
55904 C...Take copy of these particles, with space left for jets later on.
55910 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
55911 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
55912 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
55913 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
55915 PS(J)=PS(J)+P(N+NP,J)
55925 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
55927 C...Very low multiplicities not considered.
55928 IF(NP.LT.MSTU(47)) THEN
55929 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
55934 C...Find precluster configuration. If too few jets, make harder cuts.
55936 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
55939 R2ACC=PARU(45)*PS(5)**2
55941 RINIT=1.25D0*PARU(43)
55942 IF(NP.LE.MSTU(47)+2) RINIT=0D0
55943 170 RINIT=0.8D0*RINIT
55946 DO 180 I=N+NP+1,N+2*NP
55950 C...Sum up small momentum region. Jet if enough absolute momentum.
55951 IF(MSTU(46).LE.2) THEN
55955 DO 210 I=N+NP+1,N+2*NP
55956 IF(P(I,5).GT.2D0*RINIT) GOTO 210
55960 P(N+1,J)=P(N+1,J)+P(I,J)
55963 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
55964 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
55965 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
55966 IF(NREM.EQ.0) GOTO 170
55969 C...Find fastest remaining particle.
55972 DO 230 I=N+NP+1,N+2*NP
55973 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
55978 P(N+NPRE,J)=P(IMAX,J)
55983 C...Sum up precluster around it according to pT separation.
55984 IF(MSTU(46).LE.2) THEN
55985 DO 260 I=N+NP+1,N+2*NP
55986 IF(K(I,4).NE.0) GOTO 260
55988 IF(R2.GT.RINIT**2) GOTO 260
55992 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
55995 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
55997 C...Sum up precluster around it according to mass or
55998 C...Durham pT separation.
56002 DO 280 I=N+NP+1,N+2*NP
56003 IF(K(I,4).NE.0) GOTO 280
56004 IF(MSTU(46).LE.4) THEN
56009 IF(R2.GE.R2MIN) GOTO 280
56015 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
56017 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
56024 C...Check if more preclusters to be found. Start over if too few.
56025 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
56026 IF(NREM.GT.0) GOTO 220
56029 C...Reassign all particles to nearest jet. Sum up new jet momenta.
56032 310 IF(MSTU(46).LE.1) THEN
56033 DO 330 I=N+1,N+NJET
56038 DO 360 I=N+NP+1,N+2*NP
56040 DO 340 IJET=N+1,N+NJET
56041 IF(P(IJET,5).LT.RINIT) GOTO 340
56043 IF(R2.GE.R2MIN) GOTO 340
56049 V(IMIN,J)=V(IMIN,J)+P(I,J)
56053 DO 380 I=N+1,N+NJET
56057 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
56062 C...Find two closest jets.
56063 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
56064 DO 400 ITRY1=N+1,N+NJET-1
56065 DO 390 ITRY2=ITRY1+1,N+NJET
56066 IF(MSTU(46).LE.2) THEN
56067 R2=R2T(ITRY1,ITRY2)
56068 ELSEIF(MSTU(46).LE.4) THEN
56069 R2=R2M(ITRY1,ITRY2)
56071 R2=R2D(ITRY1,ITRY2)
56073 IF(R2.GE.R2MIN) GOTO 390
56080 C...If allowed, join two closest jets and start over.
56081 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
56082 IREC=MIN(IMIN1,IMIN2)
56083 IDEL=MAX(IMIN1,IMIN2)
56085 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
56087 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
56088 DO 430 I=IDEL+1,N+NJET
56093 IF(MSTU(46).GE.2) THEN
56094 DO 440 I=N+NP+1,N+2*NP
56096 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
56097 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
56103 C...Divide up broad jet if empty cluster in list of final ones.
56104 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
56105 DO 450 I=N+1,N+NJET
56108 DO 460 I=N+NP+1,N+2*NP
56109 K(N+K(I,4),5)=K(N+K(I,4),5)+1
56112 DO 470 I=N+1,N+NJET
56113 IF(K(I,5).EQ.0) IEMP=I
56119 DO 480 I=N+NP+1,N+2*NP
56120 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
56123 IF(R2.LE.R2MAX) GOTO 480
56130 P(IEMP,J)=P(ISPL,J)
56131 P(IJET,J)=P(IJET,J)-P(ISPL,J)
56133 P(IEMP,5)=P(ISPL,5)
56134 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
56135 IF(NLOOP.LE.2) GOTO 300
56140 C...If generalized thrust has not yet converged, continue iteration.
56141 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
56147 C...Reorder jets according to energy.
56148 DO 510 I=N+1,N+NJET
56153 DO 540 INEW=N+1,N+NJET
56155 DO 520 ITRY=N+1,N+NJET
56156 IF(V(ITRY,4).LE.PEMAX) GOTO 520
56165 P(INEW,J)=V(IMAX,J)
56171 C...Clean up particle-jet assignments and jet information.
56172 DO 550 I=N+NP+1,N+2*NP
56175 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
56176 K(IORI,4)=K(IORI,4)+1
56180 DO 570 I=N+1,N+NJET
56183 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
56187 IF(K(I,4).EQ.0) IEMP=I
56190 C...Select storing option. Output variables. Check for failure.
56196 PARU(63)=SQRT(R2MIN)
56197 IF(NJET.LE.1) PARU(63)=0D0
56199 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
56203 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
56204 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
56210 C*********************************************************************
56213 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
56214 C...as used for calorimeters at hadron colliders.
56216 SUBROUTINE PYCELL(NJET)
56218 C...Double precision and integer declarations.
56219 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56220 IMPLICIT INTEGER(I-N)
56221 INTEGER PYK,PYCHGE,PYCOMP
56223 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56224 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56225 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56226 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56228 C...Loop over all particles. Find cell that was hit by given particle.
56229 PTLRAT=1D0/SINH(PARU(51))**2
56233 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
56234 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
56235 IF(MSTU(41).GE.2) THEN
56237 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56238 & KC.EQ.18) GOTO 110
56239 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
56243 PT=SQRT(P(I,1)**2+P(I,2)**2)
56244 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
56245 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
56246 & (ETA/PARU(51)+1D0))))
56247 PHI=PYANGL(P(I,1),P(I,2))
56248 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
56249 & (PHI/PARU(1)+1D0))))
56250 IETPH=MSTU(52)*IETA+IPHI
56252 C...Add to cell already hit, or book new cell.
56254 IF(IETPH.EQ.K(IC,3)) THEN
56260 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
56261 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
56269 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
56270 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
56274 C...Smear true bin content by calorimeter resolution.
56275 IF(MSTU(53).GE.1) THEN
56278 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
56279 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
56280 & COS(PARU(2)*PYR(0))
56281 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
56283 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
56287 C...Remove cells below threshold.
56288 IF(PARU(58).GT.0D0) THEN
56292 IF(P(IC,5).GT.PARU(58)) THEN
56304 C...Find initiator cell: the one with highest pT of not yet used ones.
56308 IF(K(IC,5).NE.2) GOTO 160
56309 IF(P(IC,5).LE.ETMAX) GOTO 160
56315 IF(ETMAX.LT.PARU(52)) GOTO 220
56316 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
56317 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
56331 C...Sum up unused cells within required distance of initiator.
56333 IF(K(IC,5).EQ.0) GOTO 170
56334 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
56335 DPHIA=ABS(P(IC,2)-PHI)
56336 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
56338 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
56339 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
56341 K(NJ,4)=K(NJ,4)+K(IC,4)
56342 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
56343 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
56344 P(NJ,5)=P(NJ,5)+P(IC,5)
56347 C...Reject cluster below minimum ET, else accept.
56348 IF(P(NJ,5).LT.PARU(53)) THEN
56351 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
56353 ELSEIF(MSTU(54).LE.2) THEN
56354 P(NJ,3)=P(NJ,3)/P(NJ,5)
56355 P(NJ,4)=P(NJ,4)/P(NJ,5)
56356 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
56359 IF(K(IC,5).LT.0) K(IC,5)=0
56366 IF(K(IC,5).GE.0) GOTO 210
56367 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
56368 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
56369 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
56370 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
56376 C...Arrange clusters in falling ET sequence.
56377 220 DO 250 I=1,NJ-NC
56380 IF(K(IJ,5).EQ.0) GOTO 230
56381 IF(P(IJ,5).LT.ETMAX) GOTO 230
56389 K(N+I,4)=K(IJMAX,4)
56392 P(N+I,J)=P(IJMAX,J)
56398 C...Convert to massless or massive four-vectors.
56399 IF(MSTU(54).EQ.2) THEN
56400 DO 260 I=N+1,N+NJET
56402 P(I,1)=P(I,5)*COS(P(I,4))
56403 P(I,2)=P(I,5)*SIN(P(I,4))
56404 P(I,3)=P(I,5)*SINH(ETA)
56405 P(I,4)=P(I,5)*COSH(ETA)
56408 ELSEIF(MSTU(54).GE.3) THEN
56409 DO 270 I=N+1,N+NJET
56410 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
56414 C...Information about storage.
56418 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
56419 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
56424 C*********************************************************************
56427 C...Determines, approximately, the two jet masses that minimize
56428 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
56430 SUBROUTINE PYJMAS(PMH,PML)
56432 C...Double precision and integer declarations.
56433 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56434 IMPLICIT INTEGER(I-N)
56435 INTEGER PYK,PYCHGE,PYCOMP
56437 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56438 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56439 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56440 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56442 DIMENSION SM(3,3),SAX(3),PS(3,5)
56455 PIMASS=PMAS(PYCOMP(211),1)
56457 C...Take copy of particles that are to be considered in mass analysis.
56459 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
56460 IF(MSTU(41).GE.2) THEN
56462 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56463 & KC.EQ.18) GOTO 170
56464 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
56467 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
56468 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
56477 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
56478 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
56479 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
56481 C...Fill information in sphericity tensor and total momentum vector.
56484 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
56487 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
56489 PS(3,J)=PS(3,J)+P(N+NP,J)
56493 C...Very low multiplicities (0 or 1) not considered.
56495 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
56500 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
56503 C...Find largest eigenvalue to matrix (third degree equation).
56506 SM(J1,J2)=SM(J1,J2)/PSS
56509 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
56510 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
56511 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
56512 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
56513 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
56514 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
56515 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
56517 C...Find largest eigenvector by solving equation system.
56519 SM(J1,J1)=SM(J1,J1)-SMA
56521 SM(J2,J1)=SM(J1,J2)
56527 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
56530 SMAX=ABS(SM(J1,J2))
56534 DO 250 J3=JA+1,JA+2
56536 RL=SM(J1,JB)/SM(JA,JB)
56538 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
56539 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
56541 SMAX=ABS(SM(J1,J2))
56545 JB2=JB+2-3*((JB+1)/3)
56546 SAX(JB1)=-SM(JC,JB2)
56547 SAX(JB2)=SM(JC,JB1)
56548 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
56550 C...Divide particles into two initial clusters by hemisphere.
56552 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
56554 IF(PSAX.LT.0D0) IS=2
56557 PS(IS,J)=PS(IS,J)+P(I,J)
56560 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
56561 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
56563 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
56567 PS(3,J)=PS(1,J)-PS(2,J)
56570 PPS=P(I,4)*PS(3,4)-P(I,1)*PS(3,1)-P(I,2)*PS(3,2)-P(I,3)*PS(3,3)
56571 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
56572 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
56573 IF(PMDI.LT.PMD) THEN
56579 C...Loop back if significant reduction in sum of m^2.
56580 IF(PMD.LT.-PARU(48)*PMS) THEN
56584 PS(IS,J)=PS(IS,J)-P(IM,J)
56585 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
56591 C...Final masses and output.
56594 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
56595 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
56596 PMH=MAX(PS(1,5),PS(2,5))
56597 PML=MIN(PS(1,5),PS(2,5))
56602 C*********************************************************************
56605 C...Calculates the first few Fox-Wolfram moments.
56607 SUBROUTINE PYFOWO(H10,H20,H30,H40)
56609 C...Double precision and integer declarations.
56610 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56611 IMPLICIT INTEGER(I-N)
56612 INTEGER PYK,PYCHGE,PYCOMP
56614 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56615 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56616 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56617 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56619 C...Copy momenta for particles and calculate H0.
56624 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
56625 IF(MSTU(41).GE.2) THEN
56627 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56628 & KC.EQ.18) GOTO 110
56629 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
56632 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
56633 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
56644 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
56650 C...Very low multiplicities (0 or 1) not considered.
56652 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
56660 C...Calculate H1 - H4.
56666 DO 120 I2=I1+1,N+NP
56667 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
56668 & (P(I1,4)*P(I2,4))
56669 H10=H10+P(I1,4)*P(I2,4)*CTHE
56670 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
56671 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
56672 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
56677 C...Calculate H1/H0 - H4/H0. Output.
56680 H10=(HD+2D0*H10)/H0
56681 H20=(HD+2D0*H20)/H0
56682 H30=(HD+2D0*H30)/H0
56683 H40=(HD+2D0*H40)/H0
56688 C*********************************************************************
56691 C...Evaluates various properties of an event, with statistics
56692 C...accumulated during the course of the run and
56693 C...printed at the end.
56695 SUBROUTINE PYTABU(MTABU)
56697 C...Double precision and integer declarations.
56698 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56699 IMPLICIT INTEGER(I-N)
56700 INTEGER PYK,PYCHGE,PYCOMP
56702 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56703 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56704 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56705 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
56706 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
56707 C...Local arrays, character variables, saved variables and data.
56708 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
56709 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
56710 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
56711 &KFDM(8),KFDC(200,0:8),NPDC(200)
56712 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
56713 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
56714 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
56715 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
56716 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
56717 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
56718 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
56719 &NEVDC/0/,NKFDC/0/,NREDC/0/
56721 C...Reset statistics on initial parton state.
56722 IF(MTABU.EQ.10) THEN
56726 C...Identify and order flavour content of initial state.
56727 ELSEIF(MTABU.EQ.11) THEN
56729 KFM1=2*IABS(MSTU(161))
56730 IF(MSTU(161).GT.0) KFM1=KFM1-1
56731 KFM2=2*IABS(MSTU(162))
56732 IF(MSTU(162).GT.0) KFM2=KFM2-1
56733 KFMN=MIN(KFM1,KFM2)
56734 KFMX=MAX(KFM1,KFM2)
56736 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
56739 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
56740 & KFMX.LT.KFIS(I,2))) THEN
56746 110 IF(IKFIS.LT.0) THEN
56749 IF(NKFIS.GE.100) RETURN
56750 DO 130 I=NKFIS,IKFIS,-1
56751 KFIS(I+1,1)=KFIS(I,1)
56752 KFIS(I+1,2)=KFIS(I,2)
56754 NPIS(I+1,J)=NPIS(I,J)
56764 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
56766 C...Count number of partons in initial state.
56769 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
56770 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
56771 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
56776 IF(IM.LE.0.OR.IM.GT.N) THEN
56778 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
56780 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
56781 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
56791 IF(NP.GE.11) NPCO=8
56792 IF(NP.GE.16) NPCO=9
56793 IF(NP.GE.26) NPCO=10
56794 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
56797 C...Write statistics on initial parton state.
56798 ELSEIF(MTABU.EQ.12) THEN
56799 FAC=1D0/MAX(1,NEVIS)
56800 WRITE(MSTU(11),5000) NEVIS
56803 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
56805 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
56806 CALL PYNAME(KFM1,CHAU)
56808 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
56810 IF(KFIS(I,1).EQ.0) KFMX=0
56812 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
56813 CALL PYNAME(KFM2,CHAU)
56815 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
56816 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
56817 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
56820 C...Copy statistics on initial parton state into /PYJETS/.
56821 ELSEIF(MTABU.EQ.13) THEN
56822 FAC=1D0/MAX(1,NEVIS)
56825 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
56827 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
56829 IF(KFIS(I,1).EQ.0) KFMX=0
56831 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
56838 P(I,J)=FAC*NPIS(I,J)
56839 V(I,J)=FAC*NPIS(I,J+5)
56853 C...Reset statistics on number of particles/partons.
56854 ELSEIF(MTABU.EQ.20) THEN
56861 C...Identify whether particle/parton is primary or not.
56862 ELSEIF(MTABU.EQ.21) THEN
56866 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
56867 MSTU(62)=MSTU(62)+1
56870 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
56872 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
56874 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
56876 ELSEIF(KC.EQ.0) THEN
56877 ELSEIF(K(K(I,3),1).EQ.13) THEN
56879 IF(IM.LE.0.OR.IM.GT.N) THEN
56881 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
56884 ELSEIF(KCHG(KC,2).EQ.0) THEN
56885 KCM=PYCOMP(K(K(I,3),2))
56887 IF(KCHG(KCM,2).NE.0) MPRI=1
56890 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
56891 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
56893 IF(K(I,1).LE.10) THEN
56895 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
56898 C...Fill statistics on number of particles/partons in event.
56900 KFS=3-ISIGN(1,K(I,2))-MPRI
56902 IF(KFA.EQ.KFFS(IP)) THEN
56905 ELSEIF(KFA.LT.KFFS(IP)) THEN
56911 220 IF(IKFFS.LT.0) THEN
56914 IF(NKFFS.GE.400) RETURN
56915 DO 240 IP=NKFFS,IKFFS,-1
56916 KFFS(IP+1)=KFFS(IP)
56918 NPFS(IP+1,J)=NPFS(IP,J)
56927 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
56930 C...Write statistics on particle/parton composition of events.
56931 ELSEIF(MTABU.EQ.22) THEN
56932 FAC=1D0/MAX(1,NEVFS)
56933 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
56935 CALL PYNAME(KFFS(I),CHAU)
56938 IF(KC.NE.0) MDCYF=MDCY(KC,1)
56939 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
56940 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
56943 C...Copy particle/parton composition information into /PYJETS/.
56944 ELSEIF(MTABU.EQ.23) THEN
56945 FAC=1D0/MAX(1,NEVFS)
56951 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
56953 P(I,J)=FAC*NPFS(I,J)
56973 C...Reset factorial moments statistics.
56974 ELSEIF(MTABU.EQ.30) THEN
56980 FM1FM(IM,IB,IP)=0D0
56981 FM2FM(IM,IB,IP)=0D0
56986 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
56987 ELSEIF(MTABU.EQ.31) THEN
56992 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
56993 IF(MSTU(41).GE.2) THEN
56995 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
56996 & KC.EQ.18) GOTO 410
56997 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
56998 & PYCHGE(K(I,2)).EQ.0) GOTO 410
57001 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
57002 IF(MSTU(42).GE.2) PMR=P(I,5)
57003 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
57004 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
57006 IF(ABS(YETA).GT.PARU(57)) GOTO 410
57007 PHI=PYANGL(P(I,1),P(I,2))
57008 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
57009 IYETA=MAX(0,MIN(511,IYETA))
57010 IPHI=512D0*(PHI+PARU(1))/PARU(2)
57011 IPHI=MAX(0,MIN(511,IPHI))
57014 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
57017 C...Order particles in (pseudo)rapidity and/or azimuth.
57018 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
57019 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
57023 IF(NUPP.EQ.NLOW+1) THEN
57028 DO 350 I1=NUPP-1,NLOW+1,-1
57029 IF(IYETA.GE.K(I1,1)) GOTO 360
57032 360 K(I1+1,1)=IYETA
57033 DO 370 I1=NUPP-1,NLOW+1,-1
57034 IF(IPHI.GE.K(I1,2)) GOTO 380
57038 DO 390 I1=NUPP-1,NLOW+1,-1
57039 IF(IYEP.GE.K(I1,3)) GOTO 400
57049 C...Calculate sum of factorial moments in event.
57057 IF(IM.LE.2) IBIN=2**(10-IB)
57058 IF(IM.EQ.3) IBIN=4**(10-IB)
57059 IAGR=K(NLOW+1,IM)/IBIN
57061 DO 440 I=NLOW+2,NUPP+1
57063 IF(ICUT.EQ.IAGR) THEN
57067 ELSEIF(NAGR.EQ.2) THEN
57068 FEVFM(IB,1)=FEVFM(IB,1)+2D0
57069 ELSEIF(NAGR.EQ.3) THEN
57070 FEVFM(IB,1)=FEVFM(IB,1)+6D0
57071 FEVFM(IB,2)=FEVFM(IB,2)+6D0
57072 ELSEIF(NAGR.EQ.4) THEN
57073 FEVFM(IB,1)=FEVFM(IB,1)+12D0
57074 FEVFM(IB,2)=FEVFM(IB,2)+24D0
57075 FEVFM(IB,3)=FEVFM(IB,3)+24D0
57077 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
57078 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
57079 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
57081 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
57082 & (NAGR-3D0)*(NAGR-4D0)
57090 C...Add results to total statistics.
57093 IF(FEVFM(1,IP).LT.0.5D0) THEN
57095 ELSEIF(IM.LE.2) THEN
57096 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
57098 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
57100 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
57101 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
57105 NMUFM=NMUFM+(NUPP-NLOW)
57108 C...Write accumulated statistics on factorial moments.
57109 ELSEIF(MTABU.EQ.32) THEN
57110 FAC=1D0/MAX(1,NEVFM)
57111 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
57112 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
57113 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
57115 WRITE(MSTU(11),5500)
57118 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
57120 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
57121 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
57122 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
57124 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
57125 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
57128 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
57133 C...Copy statistics on factorial moments into /PYJETS/.
57134 ELSEIF(MTABU.EQ.33) THEN
57135 FAC=1D0/MAX(1,NEVFM)
57142 IF(IM.NE.2) K(I,3)=2**(IB-1)
57144 IF(IM.NE.1) K(I,4)=2**(IB-1)
57146 P(I,1)=2D0*PARU(57)/K(I,3)
57147 V(I,1)=PARU(2)/K(I,4)
57149 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
57150 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
57166 C...Reset statistics on Energy-Energy Correlation.
57167 ELSEIF(MTABU.EQ.40) THEN
57178 C...Find particles to include, with proper assumed mass.
57179 ELSEIF(MTABU.EQ.41) THEN
57185 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
57186 IF(MSTU(41).GE.2) THEN
57188 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
57189 & KC.EQ.18) GOTO 570
57190 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
57191 & PYCHGE(K(I,2)).EQ.0) GOTO 570
57194 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
57195 IF(MSTU(42).GE.2) PMR=P(I,5)
57196 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
57197 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
57204 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
57205 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
57208 IF(NUPP.EQ.NLOW) RETURN
57210 C...Analyze Energy-Energy Correlation in event.
57211 FAC=(2D0/ECM**2)*50D0/PARU(1)
57215 DO 600 I1=NLOW+2,NUPP
57216 DO 590 I2=NLOW+1,I1-1
57217 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
57218 & (P(I1,5)*P(I2,5))
57219 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
57220 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
57221 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
57225 FE1EC(J)=FE1EC(J)+FEVEE(J)
57226 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
57227 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
57228 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
57229 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
57230 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
57234 C...Write statistics on Energy-Energy Correlation.
57235 ELSEIF(MTABU.EQ.42) THEN
57236 FAC=1D0/MAX(1,NEVEE)
57237 WRITE(MSTU(11),5700) NEVEE
57240 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
57241 FEEC2=FAC*FE1EC(51-J)
57242 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
57244 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
57245 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
57246 & FEEC2,FEES2,FEECA,FEESA
57249 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
57250 ELSEIF(MTABU.EQ.43) THEN
57251 FAC=1D0/MAX(1,NEVEE)
57258 P(I,1)=FAC*FE1EC(I)
57259 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
57260 P(I,2)=FAC*FE1EC(51-I)
57261 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
57262 P(I,3)=FAC*FE1EA(I)
57263 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
57264 P(I,4)=PARU(1)*(I-1)/50D0
57265 P(I,5)=PARU(1)*I/50D0
57280 C...Reset statistics on decay channels.
57281 ELSEIF(MTABU.EQ.50) THEN
57286 C...Identify and order flavour content of final state.
57287 ELSEIF(MTABU.EQ.51) THEN
57291 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
57298 IF(K(I,2).LT.0) KFM=KFM-1
57299 DO 650 IDS=NDS-1,1,-1
57301 IF(KFM.LT.KFDM(IDS)) GOTO 660
57302 KFDM(IDS+1)=KFDM(IDS)
57308 C...Find whether old or new final state.
57310 IF(NDS.LT.KFDC(IDC,0)) THEN
57313 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
57315 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
57318 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
57327 700 IF(IKFDC.LT.0) THEN
57329 ELSEIF(NKFDC.GE.200) THEN
57333 DO 720 IDC=NKFDC,IKFDC,-1
57334 NPDC(IDC+1)=NPDC(IDC)
57336 KFDC(IDC+1,I)=KFDC(IDC,I)
57342 KFDC(IKFDC,I)=KFDM(I)
57346 NPDC(IKFDC)=NPDC(IKFDC)+1
57348 C...Write statistics on decay channels.
57349 ELSEIF(MTABU.EQ.52) THEN
57350 FAC=1D0/MAX(1,NEVDC)
57351 WRITE(MSTU(11),5900) NEVDC
57353 DO 740 I=1,KFDC(IDC,0)
57356 IF(2*KF.NE.KFM) KF=-KF
57357 CALL PYNAME(KF,CHAU)
57359 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
57361 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
57363 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
57365 C...Copy statistics on decay channels into /PYJETS/.
57366 ELSEIF(MTABU.EQ.53) THEN
57367 FAC=1D0/MAX(1,NEVDC)
57373 K(IDC,5)=KFDC(IDC,0)
57378 DO 770 I=1,KFDC(IDC,0)
57381 IF(2*KF.NE.KFM) KF=-KF
57382 IF(I.LE.5) P(IDC,I)=KF
57383 IF(I.GE.6) V(IDC,I-5)=KF
57385 V(IDC,5)=FAC*NPDC(IDC)
57400 C...Format statements for output on unit MSTU(11) (default 6).
57401 5000 FORMAT(///20X,'Event statistics - initial state'/
57402 &20X,'based on an analysis of ',I6,' events'//
57403 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
57404 &'according to fragmenting system multiplicity'/
57405 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
57406 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
57407 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
57408 5200 FORMAT(///20X,'Event statistics - final state'/
57409 &20X,'based on an analysis of ',I7,' events'//
57410 &5X,'Mean primary multiplicity =',F10.4/
57411 &5X,'Mean final multiplicity =',F10.4/
57412 &5X,'Mean charged multiplicity =',F10.4//
57413 &5X,'Number of particles produced per event (directly and via ',
57414 &'decays/branchings)'/
57415 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
57416 &8X,'Total'/35X,'prim seco prim seco'/)
57417 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
57418 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
57419 &20X,'based on an analysis of ',I6,' events'//
57420 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
57421 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
57423 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
57424 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
57425 &20X,'based on an analysis of ',I6,' events'//
57426 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
57427 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
57428 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
57429 5900 FORMAT(///20X,'Decay channel analysis - final state'/
57430 &20X,'based on an analysis of ',I6,' events'//
57431 &2X,'Probability',10X,'Complete final state'/)
57432 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
57433 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
57434 &'or table overflow)')
57439 C*********************************************************************
57442 C...Handles the generation of an e+e- annihilation jet event.
57444 SUBROUTINE PYEEVT(KFL,ECM)
57446 C...Double precision and integer declarations.
57447 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57448 IMPLICIT INTEGER(I-N)
57449 INTEGER PYK,PYCHGE,PYCOMP
57451 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57452 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57453 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57454 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
57456 C...Check input parameters.
57457 IF(MSTU(12).GE.1) CALL PYLIST(0)
57458 IF(KFL.LT.0.OR.KFL.GT.8) THEN
57459 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
57460 IF(MSTU(21).GE.1) RETURN
57462 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
57463 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
57464 IF(ECM.LT.ECMMIN) THEN
57465 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
57466 IF(MSTU(21).GE.1) RETURN
57469 C...Check consistency of MSTJ options set.
57470 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
57472 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
57475 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
57477 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
57481 C...Initialize alpha_strong and total cross-section.
57482 MSTU(111)=MSTJ(108)
57483 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
57485 PARU(112)=PARJ(121)
57486 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
57487 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
57488 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
57490 IF(MSTJ(116).GE.3) MSTJ(116)=1
57493 C...Add initial e+e- to event record (documentation only).
57496 IF(NTRY.GT.100) THEN
57497 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
57502 IF(MSTJ(115).GE.2) THEN
57504 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
57506 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
57510 C...Radiative photon (in initial state).
57513 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
57515 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
57516 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
57518 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
57519 K(NC,3)=MIN(MSTJ(115)/2,1)
57522 C...Virtual exchange boson (gamma or Z0).
57523 IF(MSTJ(115).GE.3) THEN
57526 IF(MSTJ(102).EQ.2) KF=23
57530 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
57536 C...Choice of flavour and jet configuration.
57537 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
57538 IF(KFLC.EQ.0) GOTO 100
57539 CALL PYXJET(ECMC,NJET,CUT)
57541 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
57543 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
57544 IF(NJET.EQ.2) MSTJ(120)=1
57546 C...Fill jet configuration and origin.
57547 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
57548 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
57550 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
57551 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
57552 &-KFLC,ECMC,X1,X2,X4,X12,X14)
57553 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
57554 &-KFLC,ECMC,X1,X2,X4,X12,X14)
57555 IF(MSTU(24).NE.0) GOTO 100
57557 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
57560 C...Angular orientation according to matrix element.
57561 IF(MSTJ(106).EQ.1) THEN
57562 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
57563 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
57564 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
57567 C...Rotation and boost from radiative photon.
57569 DBEK=-PAK/(ECM-PAK)
57570 NMIN=NC+1-MSTJ(115)/3
57571 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
57572 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
57573 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
57576 C...Generate parton shower. Rearrange along strings and check.
57577 IF(MSTJ(101).EQ.5) THEN
57578 CALL PYSHOW(N-1,N,ECMC)
57580 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
57581 IF(MSTJ(105).GE.0) MSTU(28)=0
57584 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
57587 C...Fragmentation/decay generation. Information for PYTABU.
57588 IF(MSTJ(105).EQ.1) CALL PYEXEC
57595 C*********************************************************************
57598 C...Calculates total cross-section, including initial state
57599 C...radiation effects.
57601 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
57603 C...Double precision and integer declarations.
57604 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57605 IMPLICIT INTEGER(I-N)
57606 INTEGER PYK,PYCHGE,PYCOMP
57608 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57609 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57610 SAVE /PYDAT1/,/PYDAT2/
57612 C...Status, (optimized) Q^2 scale, alpha_strong.
57614 MSTJ(119)=10*MSTJ(102)+KFL
57615 IF(MSTJ(111).EQ.0) THEN
57617 ELSEIF(MSTU(111).EQ.0) THEN
57618 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
57619 & ((33D0-2D0*MSTU(112))*PARU(111)))))
57620 Q2R=PARJ(168)*ECM**2
57622 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
57623 & (2D0*PARU(112)/ECM)**2))
57624 Q2R=PARJ(168)*ECM**2
57626 ALSPI=PYALPS(Q2R)/PARU(1)
57628 C...QCD corrections factor in R.
57629 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
57631 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
57633 ELSEIF(MSTJ(109).EQ.0) THEN
57634 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
57635 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
57636 & LOG(PARJ(168))*ALSPI**2)
57637 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
57638 RQCD=1D0+(3D0/4D0)*ALSPI
57640 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
57643 C...Calculate Z0 width if default value not acceptable.
57644 IF(MSTJ(102).GE.3) THEN
57645 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
57646 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
57649 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
57650 & (2D0*PYMASS(KFLC)/ ECM)**2))
57651 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
57652 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
57653 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
57655 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
57659 C...Calculate propagator and related constants for QFD case.
57660 POLL=1D0-PARJ(131)*PARJ(132)
57661 IF(MSTJ(102).GE.2) THEN
57662 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
57663 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
57664 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
57665 VE=4D0*PARU(102)-1D0
57666 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
57667 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
57672 C...Loop over different flavours: charge, velocity.
57677 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
57678 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
57681 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
57682 QF=KCHG(KFLC,1)/3D0
57684 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
57686 C...Calculate R and sum of charges for QED or QFD case.
57687 RQQ=RQQ+3D0*QF**2*POLL
57688 IF(MSTJ(102).LE.1) THEN
57689 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
57691 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
57692 RQV=RQV-6D0*QF*VF*SF1I
57693 RVA=RVA+3D0*(VF**2+1D0)*SF1W
57694 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
57695 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
57699 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
57701 C...Calculate cross-section, including QCD corrections.
57704 PARJ(143)=RTOT*RQCD
57705 PARJ(144)=PARJ(143)
57706 PARJ(145)=PARJ(141)*86.8D0/ECM**2
57707 PARJ(146)=PARJ(142)*86.8D0/ECM**2
57708 PARJ(147)=PARJ(143)*86.8D0/ECM**2
57709 PARJ(148)=PARJ(147)
57710 PARJ(157)=RSUM*RQCD
57714 IF(MSTJ(107).LE.0) RETURN
57716 C...Virtual cross-section.
57718 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
57719 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
57720 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
57721 &1.526D0*LOG(ECM**2/0.932D0)
57723 C...Soft and hard radiative cross-section in QED case.
57724 IF(MSTJ(102).LE.1) THEN
57725 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
57726 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
57727 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
57729 C...Soft and hard radiative cross-section in QFD case.
57731 SZM=1D0-(PARJ(123)/ECM)**2
57732 SZW=PARJ(123)*PARJ(124)/ECM**2
57733 PARJ(161)=-RQQ/RSUM
57734 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
57735 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
57736 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
57737 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
57738 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
57739 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
57740 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
57741 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
57742 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
57743 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
57744 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
57745 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
57746 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
57749 C...Total cross-section and fraction of hard photon events.
57750 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
57751 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
57752 PARJ(144)=PARJ(157)
57753 PARJ(148)=PARJ(144)*86.8D0/ECM**2
57759 C*********************************************************************
57762 C...Generates initial state photon radiation.
57764 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
57766 C...Double precision and integer declarations.
57767 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57768 IMPLICIT INTEGER(I-N)
57769 INTEGER PYK,PYCHGE,PYCOMP
57771 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57774 C...Function: cumulative hard photon spectrum in QFD case.
57775 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
57776 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
57778 C...Determine whether radiative photon or not.
57781 IF(PARJ(160).LT.PYR(0)) RETURN
57784 C...Photon energy range. Find photon momentum in QED case.
57786 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
57787 IF(MSTJ(102).LE.1) THEN
57788 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
57789 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
57791 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
57793 SZM=1D0-(PARJ(123)/ECM)**2
57794 SZW=PARJ(123)*PARJ(124)/ECM**2
57797 FXKD=1D-4*(FXKU-FXKL)
57798 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
57803 IF(FXKV.GT.FXKR) THEN
57810 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
57811 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
57815 C...Photon polar and azimuthal angle.
57816 PME=2D0*(PYMASS(11)/ECM)**2
57817 120 CTHM=PME*(2D0/PME)**PYR(0)
57818 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
57819 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
57821 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
57822 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
57823 THEK=PYANGL(CTHE,STHE)
57824 PHIK=PARU(2)*PYR(0)
57826 C...Rotation angle for hadronic system.
57828 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
57830 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
57831 &(2D0-XK*(1D0-SGN*CTHE)))
57836 C*********************************************************************
57839 C...Selects flavour for produced qqbar pair.
57841 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
57843 C...Double precision and integer declarations.
57844 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57845 IMPLICIT INTEGER(I-N)
57846 INTEGER PYK,PYCHGE,PYCOMP
57848 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57849 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57850 SAVE /PYDAT1/,/PYDAT2/
57852 C...Calculate maximum weight in QED or QFD case.
57853 IF(MSTJ(102).LE.1) THEN
57856 POLL=1D0-PARJ(131)*PARJ(132)
57857 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
57858 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
57859 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
57860 VE=4D0*PARU(102)-1D0
57861 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
57862 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
57863 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
57864 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
57865 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
57869 C...Choose flavour. Gives charge and velocity.
57872 IF(NTRY.GT.100) THEN
57873 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
57878 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
57881 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
57882 QF=KCHG(KFLC,1)/3D0
57884 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
57886 C...Calculate weight in QED or QFD case.
57887 IF(MSTJ(102).LE.1) THEN
57889 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
57891 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
57892 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
57893 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
57895 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
57898 C...Weighting or new event (radiative photon). Cross-section update.
57899 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
57900 PARJ(158)=PARJ(158)+1D0
57901 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
57902 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
57903 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
57904 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
57905 PARJ(148)=PARJ(144)*86.8D0/ECM**2
57910 C*********************************************************************
57913 C...Selects number of jets in matrix element approach.
57915 SUBROUTINE PYXJET(ECM,NJET,CUT)
57917 C...Double precision and integer declarations.
57918 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57919 IMPLICIT INTEGER(I-N)
57920 INTEGER PYK,PYCHGE,PYCOMP
57922 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57924 C...Local array and data.
57926 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
57928 C...Trivial result for two-jets only, including parton shower.
57929 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
57932 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
57933 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
57935 IF(MSTJ(109).EQ.2) CF=1D0
57936 IF(MSTJ(111).EQ.0) THEN
57939 ELSEIF(MSTU(111).EQ.0) THEN
57940 PARJ(169)=MIN(1D0,PARJ(129))
57941 Q2=PARJ(169)*ECM**2
57942 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
57943 & ((33D0-2D0*MSTU(112))*PARU(111)))))
57944 Q2R=PARJ(168)*ECM**2
57946 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
57947 Q2=PARJ(169)*ECM**2
57948 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
57949 & (2D0*PARU(112)/ECM)**2))
57950 Q2R=PARJ(168)*ECM**2
57953 C...alpha_strong for R and R itself.
57954 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
57955 IF(IABS(MSTJ(101)).EQ.1) THEN
57957 ELSEIF(MSTJ(109).EQ.0) THEN
57958 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
57959 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
57960 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
57962 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
57965 C...alpha_strong for jet rate. Initial value for y cut.
57966 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
57967 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
57968 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
57969 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
57970 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
57972 C...Parametrization of first order three-jet cross-section.
57973 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
57976 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
57977 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
57978 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
57979 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
57980 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
57984 C...Parametrization of second order three-jet cross-section.
57985 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
57986 & CUT.GE.0.25D0) THEN
57988 ELSEIF(MSTJ(110).LE.1) THEN
57989 CT=LOG(1D0/CUT-2D0)
57990 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
57991 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
57993 C...Interpolation in second/first order ratio for Zhu parametrization.
57994 ELSEIF(MSTJ(110).EQ.2) THEN
57997 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
58003 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
58005 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
58008 C...Shift in second order three-jet cross-section with optimized Q^2.
58009 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
58010 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
58011 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
58013 C...Parametrization of second order four-jet cross-section.
58014 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
58017 CT=LOG(1D0/CUT-5D0)
58018 IF(CUT.LE.0.018D0) THEN
58019 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
58020 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
58022 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
58023 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
58025 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
58026 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
58027 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
58028 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
58029 & 0.002093D0*CT**3)
58030 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
58032 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
58033 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
58036 C...If negative three-jet rate, change y' optimization parameter.
58037 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
58038 & PARJ(169).LT.0.99D0) THEN
58039 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
58040 Q2=PARJ(169)*ECM**2
58041 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
58045 C...If too high cross-section, use harder cuts, or fail.
58046 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
58047 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
58048 & PARJ(169).LT.0.99D0) THEN
58049 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
58050 Q2=PARJ(169)*ECM**2
58051 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
58053 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
58055 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
58057 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
58058 & PARJ(154))**(-1D0/3D0)
58059 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
58063 C...Scalar gluon (first order only).
58065 ALSPI=PYALPS(ECM**2)/PARU(1)
58066 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
58068 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
58069 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
58074 C...Select number of jets.
58076 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
58078 ELSEIF(MSTJ(101).LE.0) THEN
58079 NJET=MIN(4,2-MSTJ(101))
58083 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
58084 IF(PARJ(154).GT.RNJ) NJET=4
58090 C*********************************************************************
58093 C...Selects the kinematical variables of three-jet events.
58095 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
58097 C...Double precision and integer declarations.
58098 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58099 IMPLICIT INTEGER(I-N)
58100 INTEGER PYK,PYCHGE,PYCOMP
58102 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58105 DIMENSION ZHUP(5,12)
58107 C...Coefficients of Zhu second order parametrization.
58108 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
58109 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
58110 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
58111 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
58112 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
58113 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
58114 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
58115 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
58116 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
58117 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
58118 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
58120 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
58121 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
58124 C...Event type. Mass effect factors and other common constants.
58128 QME=(2D0*PMQ/ECM)**2
58129 IF(MSTJ(109).NE.1) THEN
58131 CUTD=LOG(1D0/CUT-2D0)
58132 IF(MSTJ(109).EQ.0) THEN
58136 WTMX=MIN(20D0,37D0-6D0*CUTD)
58137 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
58145 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
58146 ALS2PI=PARU(118)/PARU(2)
58148 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
58149 & LOG(PARJ(169))*ALS2PI
58150 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
58152 C...Choose three-jet events in allowed region.
58154 110 Y13L=CUTL+CUTD*PYR(0)
58155 Y23L=CUTL+CUTD*PYR(0)
58159 IF(Y12.LE.CUT) GOTO 110
58160 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
58162 C...Second order corrections.
58163 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
58168 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
58169 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
58170 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
58171 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
58172 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
58173 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
58174 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
58175 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
58176 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
58177 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
58178 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
58179 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
58180 & TR*(2D0*CUTL/3D0-10D0/9D0)+
58181 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
58182 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
58183 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
58184 & Y13*Y23)/(Y12+Y13)**2)/WT1+
58185 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
58186 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
58187 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
58188 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
58189 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
58190 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
58191 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
58192 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
58193 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
58194 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
58196 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
58197 C...Second order corrections; Zhu parametrization of ERT.
58202 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
58206 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
58207 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
58208 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
58209 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
58212 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
58213 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
58214 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
58215 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
58217 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
58218 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
58219 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
58220 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
58221 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
58223 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
58224 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
58225 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
58228 C...Impose mass cuts (gives two jets). For fixed jet number new try.
58232 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
58233 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
58234 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
58235 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
58236 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
58238 C...Scalar gluon model (first order only, no mass effects).
58241 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
58242 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
58243 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
58244 X1=1D0-0.5D0*(X3+YD)
58245 X2=1D0-0.5D0*(X3-YD)
58246 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
58247 IF(MSTJ(102).GE.2) THEN
58248 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
58249 & X3**2*PYR(0)) NJET=2
58251 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
58257 C*********************************************************************
58260 C...Selects the kinematical variables of four-jet events.
58262 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
58264 C...Double precision and integer declarations.
58265 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58266 IMPLICIT INTEGER(I-N)
58267 INTEGER PYK,PYCHGE,PYCOMP
58269 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58272 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
58274 C...Common constants. Colour factors for QCD and Abelian gluon theory.
58276 QME=(2D0*PMQ/ECM)**2
58277 CT=LOG(1D0/CUT-5D0)
58278 IF(MSTJ(109).EQ.0) THEN
58288 C...Choice of process (qqbargg or qqbarqqbar).
58291 IF(PARJ(155).GT.PYR(0)) IT=2
58292 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
58293 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
58294 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
58295 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
58298 C...Sample the five kinematical variables (for qqgg preweighted in y34).
58299 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
58300 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
58301 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
58302 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
58303 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
58305 CP=COS(PARU(1)*PYR(0))
58308 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
58309 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
58310 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
58312 Y12=1D0-Y134-Y23-Y24
58313 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
58317 C...Calculate matrix elements for qqgg or qqqq process.
58322 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
58323 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
58324 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
58325 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
58326 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
58327 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
58328 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
58329 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
58330 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
58331 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
58332 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
58333 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
58334 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
58335 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
58336 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
58337 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
58338 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
58339 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
58340 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
58341 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
58342 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
58343 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
58344 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
58345 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
58346 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
58347 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
58348 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
58349 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
58350 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
58351 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
58352 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
58353 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
58354 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
58355 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
58356 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
58357 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
58358 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
58359 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
58360 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
58361 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
58362 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
58365 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
58366 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
58367 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
58368 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
58369 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
58370 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
58371 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
58372 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
58373 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
58374 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
58375 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
58376 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
58377 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
58378 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
58379 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
58380 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
58381 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
58382 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
58385 C...Permutations of momenta in matrix element. Weighting.
58386 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
58397 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
58408 IF(IC.LE.3) GOTO 120
58409 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
58412 C...qqgg events: string configuration and event type.
58414 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
58415 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
58416 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
58417 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
58418 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
58419 IF(ID.EQ.2) GOTO 130
58420 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
58421 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
58422 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
58423 IF(ID.EQ.2) GOTO 130
58426 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
58427 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
58430 C...Mass cuts. Kinematical variables out.
58431 IF(Y12.LE.CUT+QME) NJET=2
58432 IF(NJET.EQ.2) GOTO 150
58433 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
58434 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
58435 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
58437 X12=(1D0-Q12)*Y13+Q12*Y23
58439 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
58441 C...qqbarqqbar events: string configuration, choose new flavour.
58444 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
58445 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
58446 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
58447 IF(WTR.LT.WTD(4)) ID=4
58448 IF(ID.GE.2) GOTO 130
58451 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
58452 140 KFLN=1+INT(5D0*PYR(0))
58453 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
58454 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
58455 IF(KFLN.GT.MSTJ(104)) NJET=2
58457 QMEN=(2D0*PMQN/ECM)**2
58459 C...Mass cuts. Kinematical variables out.
58460 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
58461 IF(NJET.EQ.2) GOTO 150
58462 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
58463 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
58464 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
58465 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
58466 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
58467 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
58470 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
58472 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
58473 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
58474 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
58476 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
58481 C*********************************************************************
58484 C...Gives the angular orientation of events.
58486 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
58488 C...Double precision and integer declarations.
58489 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58490 IMPLICIT INTEGER(I-N)
58491 INTEGER PYK,PYCHGE,PYCOMP
58493 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58494 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58495 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58496 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58498 C...Charge. Factors depending on polarization for QED case.
58500 POLL=1D0-PARJ(131)*PARJ(132)
58501 POLD=PARJ(132)-PARJ(131)
58502 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
58508 C...Factors depending on flavour, energy and polarization for QFD case.
58510 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
58511 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
58512 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
58514 VE=4D0*PARU(102)-1D0
58516 VF=AF-4D0*QF*PARU(102)
58517 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
58518 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
58519 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
58520 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
58521 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
58522 & SFW*SFF**2*(VE**2-AE**2))
58523 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
58527 C...Mass factor. Differential cross-sections for two-jet events.
58530 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
58531 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
58533 SIGU=4D0*SQRT(1D0-QME)
58534 SIGL=2D0*QME*SQRT(1D0-QME)
58540 C...Kinematical variables. Reduce four-jet event to three-jet one.
58543 X1=2D0*P(NC+1,4)/ECM
58544 X2=2D0*P(NC+3,4)/ECM
58546 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
58547 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
58548 X1=2D0*P(NC+1,4)/ECMR
58549 X2=2D0*P(NC+4,4)/ECMR
58552 C...Differential cross-sections for three-jet (or reduced four-jet).
58553 XQ=(1D0-X1)/(1D0-X2)
58554 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
58555 ST12=SQRT(1D0-CT12**2)
58556 IF(MSTJ(109).NE.1) THEN
58557 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
58558 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
58559 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
58560 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
58562 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
58563 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
58564 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
58565 SIGA=X2**2*ST12/SQ2
58566 SIGP=2D0*(X1**2-X2**2*CT12)
58568 C...Differential cross-sect for scalar gluons (no mass effects).
58572 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
58573 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
58574 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
58575 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
58576 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
58577 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
58578 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
58579 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
58580 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
58581 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
58582 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
58586 C...Upper bounds for differential cross-section.
58591 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
58592 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
58593 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
58594 &2D0*HF2A*ABS(SIGP)
58596 C...Generate angular orientation according to differential cross-sect.
58597 100 CHI=PARU(2)*PYR(0)
58598 CTHE=2D0*PYR(0)-1D0
58606 C2PHI=COS(2D0*(PHI-PARJ(134)))
58607 S2PHI=SIN(2D0*(PHI-PARJ(134)))
58608 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
58609 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
58610 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
58611 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
58612 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
58613 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
58614 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
58615 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
58620 C*********************************************************************
58623 C...Generates Upsilon and toponium decays into three gluons
58624 C...or two gluons and a photon.
58626 SUBROUTINE PYONIA(KFL,ECM)
58628 C...Double precision and integer declarations.
58629 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58630 IMPLICIT INTEGER(I-N)
58631 INTEGER PYK,PYCHGE,PYCOMP
58633 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58634 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58635 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58636 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58638 C...Printout. Check input parameters.
58639 IF(MSTU(12).GE.1) CALL PYLIST(0)
58640 IF(KFL.LT.0.OR.KFL.GT.8) THEN
58641 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
58642 IF(MSTU(21).GE.1) RETURN
58644 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
58645 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
58646 IF(MSTU(21).GE.1) RETURN
58649 C...Initial e+e- and onium state (optional).
58651 IF(MSTJ(115).GE.2) THEN
58653 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
58655 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
58659 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
58665 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
58671 C...Choose x1 and x2 according to matrix element.
58676 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
58677 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
58680 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
58681 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
58683 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
58684 MSTU(111)=MSTJ(108)
58685 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
58687 PARU(112)=PARJ(121)
58688 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
58690 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
58691 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
58694 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
58695 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
58697 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
58698 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
58701 ECMC=SQRT(1D0-X1)*ECM
58702 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
58707 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
58708 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
58709 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
58710 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
58712 IF(ECMC.LT.4D0*PARJ(127)) THEN
58716 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
58722 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
58725 C...Differential cross-sections. Upper limit for cross-section.
58726 IF(MSTJ(106).EQ.1) THEN
58728 HF1=1D0-PARJ(131)*PARJ(132)
58730 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
58731 ST13=SQRT(1D0-CT13**2)
58732 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
58733 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
58735 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
58736 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
58737 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
58739 C...Angular orientation of event.
58740 120 CHI=PARU(2)*PYR(0)
58741 CTHE=2D0*PYR(0)-1D0
58749 C2PHI=COS(2D0*(PHI-PARJ(134)))
58750 S2PHI=SIN(2D0*(PHI-PARJ(134)))
58751 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
58752 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
58753 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
58754 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
58755 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
58756 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
58757 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
58758 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
58761 C...Generate parton shower. Rearrange along strings and check.
58762 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
58763 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
58765 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
58766 IF(MSTJ(105).GE.0) MSTU(28)=0
58769 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
58772 C...Generate fragmentation. Information for PYTABU:
58773 IF(MSTJ(105).EQ.1) CALL PYEXEC
58774 MSTU(161)=110*KFLC+3
58780 C*********************************************************************
58783 C...Books a histogram.
58785 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
58787 C...Double precision declaration.
58788 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58789 IMPLICIT INTEGER(I-N)
58791 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58793 C...Local character variables.
58794 CHARACTER TITLE*(*), TITFX*60
58796 C...Check that input is sensible. Find initial address in memory.
58797 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
58798 &'(PYBOOK:) not allowed histogram number')
58799 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
58800 &'(PYBOOK:) not allowed number of bins')
58801 IF(XL.GE.XU) CALL PYERRM(28,
58802 &'(PYBOOK:) x limits in wrong order')
58804 IHIST(4)=IHIST(4)+28+NX
58805 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
58806 &'(PYBOOK:) out of histogram space')
58809 C...Store histogram size and reset contents.
58813 BIN(IS+4)=(XU-XL)/NX
58816 C...Store title by conversion to integer to double precision.
58819 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
58820 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
58826 C*********************************************************************
58829 C...Fills entry in histogram.
58831 SUBROUTINE PYFILL(ID,X,W)
58833 C...Double precision declaration.
58834 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58835 IMPLICIT INTEGER(I-N)
58837 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58840 C...Find initial address in memory. Increase number of entries.
58841 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
58842 &'(PYFILL:) not allowed histogram number')
58844 IF(IS.EQ.0) CALL PYERRM(28,
58845 &'(PYFILL:) filling unbooked histogram')
58846 BIN(IS+5)=BIN(IS+5)+1D0
58848 C...Find bin in x, including under/overflow, and fill.
58849 IF(X.LT.BIN(IS+2)) THEN
58850 BIN(IS+6)=BIN(IS+6)+W
58851 ELSEIF(X.GE.BIN(IS+3)) THEN
58852 BIN(IS+8)=BIN(IS+8)+W
58854 BIN(IS+7)=BIN(IS+7)+W
58855 IX=(X-BIN(IS+2))/BIN(IS+4)
58856 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
58857 BIN(IS+9+IX)=BIN(IS+9+IX)+W
58863 C*********************************************************************
58866 C...Multiplies histogram contents by factor.
58868 SUBROUTINE PYFACT(ID,F)
58870 C...Double precision declaration.
58871 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58872 IMPLICIT INTEGER(I-N)
58874 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58877 C...Find initial address in memory. Multiply all contents bins.
58878 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
58879 &'(PYFACT:) not allowed histogram number')
58881 IF(IS.EQ.0) CALL PYERRM(28,
58882 &'(PYFACT:) scaling unbooked histogram')
58883 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
58890 C*********************************************************************
58893 C...Performs operations between histograms.
58895 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
58897 C...Double precision declaration.
58898 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58899 IMPLICIT INTEGER(I-N)
58901 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
58903 C...Character variable.
58906 C...Find initial addresses in memory, and histogram size.
58907 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
58908 &'(PYFACT:) not allowed histogram number')
58910 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
58911 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
58912 NX=NINT(BIN(IS3+1))
58913 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
58915 C...Update info on number of histogram entries.
58916 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
58917 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
58918 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
58919 BIN(IS3+5)=BIN(IS1+5)
58922 C...Operations on pair of histograms: addition, subtraction,
58923 C...multiplication, division.
58924 IF(OPER.EQ.'+') THEN
58926 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
58928 ELSEIF(OPER.EQ.'-') THEN
58930 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
58932 ELSEIF(OPER.EQ.'*') THEN
58934 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
58936 ELSEIF(OPER.EQ.'/') THEN
58939 IF(ABS(FA2).LE.1D-20) THEN
58942 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
58946 C...Operations on single histogram: multiplication+addition,
58947 C...square root+addition, logarithm+addition.
58948 ELSEIF(OPER.EQ.'A') THEN
58950 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
58952 ELSEIF(OPER.EQ.'S') THEN
58954 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
58956 ELSEIF(OPER.EQ.'L') THEN
58959 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
58960 & ZMIN=0.8D0*BIN(IS1+IX)
58963 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
58966 C...Operation on two or three histograms: average and
58967 C...standard deviation.
58968 ELSEIF(OPER.EQ.'M') THEN
58970 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
58973 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
58976 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
58979 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
58983 BIN(IS1+IX)=F1*BIN(IS1+IX)
58990 C*********************************************************************
58993 C...Prints and resets all histograms.
58997 C...Double precision declaration.
58998 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58999 IMPLICIT INTEGER(I-N)
59001 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
59004 C...Loop over histograms, print and reset used ones.
59005 DO 100 ID=1,IHIST(1)
59007 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
59016 C*********************************************************************
59019 C...Prints a histogram (but does not reset it).
59021 SUBROUTINE PYPLOT(ID)
59023 C...Double precision declaration.
59024 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59025 IMPLICIT INTEGER(I-N)
59027 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59028 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
59029 SAVE /PYDAT1/,/PYBINS/
59030 C...Local arrays and character variables.
59031 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
59032 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
59034 C...Steps in histogram scale. Character sequence.
59035 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
59036 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
59038 C...Find initial address in memory; skip if empty histogram.
59039 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
59042 IF(NINT(BIN(IS+5)).LE.0) THEN
59043 WRITE(MSTU(11),5000) ID
59047 C...Number of histogram lines and x bins.
59051 C...Extract title by conversion from double precision via integer.
59053 IEQ=NINT(BIN(IS+8+NX+IT))
59054 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
59055 & //CHAR(MOD(IEQ,256))
59058 C...Find time; print title.
59060 IF(IDATI(1).GT.0) THEN
59061 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
59063 WRITE(MSTU(11),5200) ID, TITLE
59066 C...Find minimum and maximum bin content.
59069 DO 110 IX=IS+10,IS+8+NX
59070 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
59071 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
59074 C...Determine scale and step size for y axis.
59075 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
59076 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
59077 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
59078 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
59079 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
59080 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
59083 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
59087 C...Convert bin contents to integer form; fractional fill in top row.
59089 CTA=ABS(BIN(IS+8+IX))/DY
59090 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
59091 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
59093 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
59094 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
59096 C...Print histogram row by row.
59097 DO 150 IR=IRMA,IRMI,-1
59098 IF(IR.EQ.0) GOTO 150
59101 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
59102 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
59104 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
59107 C...Print sign and value of bin contents.
59108 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
59111 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
59112 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
59114 WRITE(MSTU(11),5400) OUT
59117 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
59119 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
59122 C...Print sign and value of lower bin edge.
59123 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
59127 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
59128 & OUT(IX:IX)=CHA(11)
59129 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
59131 WRITE(MSTU(11),5600) OUT
59134 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
59136 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
59140 C...Calculate and print statistics.
59145 CTA=ABS(BIN(IS+8+IX))
59146 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
59149 CXXSUM=CXXSUM+CTA*X**2
59151 XMEAN=CXSUM/MAX(CSUM,1D-20)
59152 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
59153 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
59154 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
59156 C...Formats for output.
59157 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
59158 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
59160 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
59161 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
59162 5400 FORMAT(/8X,'Contents',3X,A100)
59163 5500 FORMAT(9X,'*10**',I2,3X,A100)
59164 5600 FORMAT(/8X,'Low edge',3X,A100)
59165 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
59166 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
59167 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
59172 C*********************************************************************
59175 C...Resets bin contents of a histogram.
59177 SUBROUTINE PYNULL(ID)
59179 C...Double precision declaration.
59180 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59181 IMPLICIT INTEGER(I-N)
59183 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
59186 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
59189 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
59196 C*********************************************************************
59199 C...Dumps histogram contents on file for reading by other program.
59200 C...Can also read back own dump.
59202 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
59204 C...Double precision declaration.
59205 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59206 IMPLICIT INTEGER(I-N)
59208 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
59210 C...Local arrays and character variables.
59211 DIMENSION IHI(*),ISS(100),VAL(5)
59212 CHARACTER TITLE*60,FORMAT*13
59214 C...Dump all histograms that have been booked,
59215 C...including titles and ranges, one after the other.
59216 IF(MDUMP.EQ.1) THEN
59218 C...Loop over histograms and find which are wanted and booked.
59233 C...Write title, histogram size, filling statistics.
59236 IEQ=NINT(BIN(IS+8+NX+IT))
59237 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
59238 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
59240 WRITE(LFN,5100) ID,TITLE
59241 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
59242 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
59246 C...Write histogram contents, in groups of five.
59247 DO 120 IXG=1,(NX+4)/5
59251 VAL(IXV)=BIN(IS+8+IX)
59256 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
59259 C...Go to next histogram; finish.
59260 ELSEIF(NHI.GT.0) THEN
59261 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
59265 C...Read back in histograms dumped MDUMP=1.
59266 ELSEIF(MDUMP.EQ.2) THEN
59268 C...Read histogram number, title and range, and book.
59269 140 READ(LFN,5100,END=170) ID,TITLE
59270 READ(LFN,5200) NX,XL,XU
59271 CALL PYBOOK(ID,TITLE,NX,XL,XU)
59274 C...Read filling statistics.
59275 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
59276 BIN(IS+5)=DBLE(NENTRY)
59278 C...Read histogram contents, in groups of five.
59279 DO 160 IXG=1,(NX+4)/5
59280 READ(LFN,5400) (VAL(IXV),IXV=1,5)
59283 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
59287 C...Go to next histogram; finish.
59291 C...Write histogram contents in column format,
59292 C...convenient e.g. for GNUPLOT input.
59293 ELSEIF(MDUMP.EQ.3) THEN
59295 C...Find addresses to wanted histograms.
59309 IF(IS.NE.0.AND.NSS.LT.100) THEN
59312 ELSEIF(NSS.GE.100) THEN
59313 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
59314 ELSEIF(NHI.GT.0) THEN
59315 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
59319 C...Check that they have common number of x bins. Fix format.
59320 NX=NINT(BIN(ISS(1)+1))
59322 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
59323 CALL PYERRM(8,'(PYDUMP:) different number of bins')
59327 FORMAT='(1P,000E12.4)'
59328 WRITE(FORMAT(5:7),'(I3)') NSS+1
59330 C...Write histogram contents; first column x values.
59332 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
59333 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
59338 C...Formats for output.
59339 5100 FORMAT(I5,5X,A60)
59340 5200 FORMAT(I5,1P,2D12.4)
59341 5300 FORMAT(I12,1P,3D12.4)
59342 5400 FORMAT(1P,5D12.4)
59347 C*********************************************************************
59350 C...Dummy routine, which the user can replace in order to make cuts on
59351 C...the kinematics on the parton level before the matrix elements are
59352 C...evaluated and the event is generated. The cross-section estimates
59353 C...will automatically take these cuts into account, so the given
59354 C...values are for the allowed phase space region only. MCUT=0 means
59355 C...that the event has passed the cuts, MCUT=1 that it has failed.
59357 SUBROUTINE PYKCUT(MCUT)
59359 C...Double precision and integer declarations.
59360 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59361 IMPLICIT INTEGER(I-N)
59362 INTEGER PYK,PYCHGE,PYCOMP
59364 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59365 COMMON/PYINT1/MINT(400),VINT(400)
59366 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
59367 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
59369 C...Set default value (accepting event) for MCUT.
59372 C...Read out subprocess number.
59376 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
59380 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
59382 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
59384 C...Calculate x_1, x_2, x_F.
59385 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
59386 X1=SQRT(TAU)*EXP(YST)
59387 X2=SQRT(TAU)*EXP(-YST)
59389 X1=SQRT(TAUP)*EXP(YST)
59390 X2=SQRT(TAUP)*EXP(-YST)
59394 C...Calculate shat, that, uhat, p_T^2.
59400 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
59401 RPTS=4D0*VINT(71)**2/SHAT
59402 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
59405 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
59406 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
59407 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
59408 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
59410 C...Decisions by user to be put here.
59412 C...Stop program if this routine is ever called.
59413 C...You should not copy these lines to your own routine.
59414 WRITE(MSTU(11),5000)
59415 IF(PYR(0).LT.10D0) STOP
59417 C...Format for error printout.
59418 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
59419 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
59420 &1X,'Execution stopped!')
59425 C*********************************************************************
59428 C...Dummy routine, which the user can replace in order to multiply the
59429 C...standard PYTHIA differential cross-section by a process- and
59430 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
59431 C...to generation of weighted events, with weight 1/WTXS, while for
59432 C...MSTP(142)=2 it corresponds to a modification of the underlying
59435 SUBROUTINE PYEVWT(WTXS)
59437 C...Double precision and integer declarations.
59438 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59439 IMPLICIT INTEGER(I-N)
59440 INTEGER PYK,PYCHGE,PYCOMP
59442 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59443 COMMON/PYINT1/MINT(400),VINT(400)
59444 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
59445 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
59447 C...Set default weight for WTXS.
59450 C...Read out subprocess number.
59454 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
59458 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
59460 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
59462 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
59471 C...Modifications by user to be put here.
59473 C...Stop program if this routine is ever called.
59474 C...You should not copy these lines to your own routine.
59475 WRITE(MSTU(11),5000)
59476 IF(PYR(0).LT.10D0) STOP
59478 C...Format for error printout.
59479 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
59480 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
59481 &1X,'Execution stopped!')
59486 C*********************************************************************
59489 C...Dummy routine, to be replaced by a user implementing external
59490 C...processes. Is supposed to fill the HEPRUP commonblock with info
59491 C...on incoming beams and allowed processes.
59495 C...Double precision and integer declarations.
59496 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59497 IMPLICIT INTEGER(I-N)
59499 C...User process initialization commonblock.
59501 PARAMETER (MAXPUP=100)
59502 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
59503 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
59504 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
59505 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
59512 C*********************************************************************
59515 C...Dummy routine, to be replaced by a user implementing external
59516 C...processes. Depending on cross section model chosen, it either has
59517 C...to generate a process of the type IDPRUP requested, or pick a type
59518 C...itself and generate this event. The event is to be stored in the
59519 C...HEPEUP commonblock, including (often) an event weight.
59523 C...Double precision and integer declarations.
59524 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59525 IMPLICIT INTEGER(I-N)
59527 C...User process event common block.
59529 PARAMETER (MAXNUP=500)
59530 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
59531 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
59532 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
59533 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
59534 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
59540 C*********************************************************************
59542 C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
59544 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
59545 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59546 IMPLICIT INTEGER(I-N)
59547 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
59550 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59553 C...Stop program if this routine is ever called.
59554 WRITE(MSTU(11),5000)
59555 IF(PYR(0).LT.10D0) STOP
59557 C...Format for error printout.
59558 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
59559 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
59560 &1X,'Execution stopped!')
59565 C*********************************************************************
59568 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
59571 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59572 IMPLICIT INTEGER(I-N)
59573 CHARACTER*40 VISAJE
59576 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59579 C...Assign default value.
59582 C...Stop program if this routine is ever called.
59583 WRITE(MSTU(11),5000)
59584 IF(PYR(0).LT.10D0) STOP
59586 C...Format for error printout.
59587 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
59588 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
59589 &1X,'Execution stopped!')
59594 C*********************************************************************
59597 C...Dummy routine, to be replaced by user, to handle the decay of a
59598 C...polarized tau lepton.
59600 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
59601 C...IORIG is the position where the mother of the tau is stored;
59602 C... is 0 when the mother is not stored.
59603 C...KFORIG is the flavour of the mother of the tau;
59604 C... is 0 when the mother is not known.
59605 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
59606 C... e.g. in B hadron semileptonic decays the W propagator
59607 C... is not explicitly stored but the W code is still unambiguous.
59609 C...NDECAY is the number of decay products in the current tau decay.
59610 C...These decay products should be added to the /PYJETS/ common block,
59611 C...in positions N+1 through N+NDECAY. For each product I you must
59612 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
59613 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
59615 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
59617 C...Double precision and integer declarations.
59618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59619 IMPLICIT INTEGER(I-N)
59620 INTEGER PYK,PYCHGE,PYCOMP
59622 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59623 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59624 SAVE /PYJETS/,/PYDAT1/
59626 C...Stop program if this routine is ever called.
59627 C...You should not copy these lines to your own routine.
59628 NDECAY=ITAU+IORIG+KFORIG
59629 WRITE(MSTU(11),5000)
59630 IF(PYR(0).LT.10D0) STOP
59632 C...Format for error printout.
59633 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
59634 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
59635 &1X,'Execution stopped!')
59640 C*********************************************************************
59643 C...Finds current date and time.
59644 C...Since this task is not standardized in Fortran 77, the routine
59645 C...is dummy, to be replaced by the user. Examples are given for
59646 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
59647 C...you do not have access to suitable routines.
59649 SUBROUTINE PYTIME(IDATI)
59651 C...Double precision and integer declarations.
59652 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59653 IMPLICIT INTEGER(I-N)
59654 INTEGER PYK,PYCHGE,PYCOMP
59657 INTEGER IDATI(6),IDTEMP(3)
59659 C...Example 0: if you do not have suitable routines.
59664 C...Example 1: Fortran 90 routine.
59666 C CALL DATE_AND_TIME(VALUES=IVAL)
59674 C...Example 2: DEC Fortran 77. AIX.
59675 C CALL IDATE(IMON,IDAY,IYEAR)
59679 C CALL ITIME(IHOUR,IMIN,ISEC)
59684 C...Example 3: DEC Fortran, IRIX, IRIX64.
59685 C CALL IDATE(IMON,IDAY,IYEAR)
59693 C READ(ATIME(1:2),'(I2)') IHOUR
59694 C READ(ATIME(4:5),'(I2)') IMIN
59695 C READ(ATIME(7:8),'(I2)') ISEC
59700 C...Example 4: GNU LINUX libU77, SunOS.
59701 c CALL IDATE(IDTEMP)
59702 c IDATI(1)=IDTEMP(3)
59703 c IDATI(2)=IDTEMP(2)
59704 c IDATI(3)=IDTEMP(1)
59705 c CALL ITIME(IDTEMP)
59706 c IDATI(4)=IDTEMP(1)
59707 c IDATI(5)=IDTEMP(2)
59708 c IDATI(6)=IDTEMP(3)
59710 C...Common code to ensure right century.
59711 IDATI(1)=2000+MOD(IDATI(1),100)
git://git.uio.no / u / mrichter / AliRoot.git / blob